Tcl Source Code

Changes On Branch tip-660
Login

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

Changes In Branch tip-660 Excluding Merge-Ins

This is equivalent to a diff from 883464ea32 to 0bf637b9dc

2023-04-21
17:17
Merge pre-TIP 660 changes from trunk. check-in: a6a4d93dd6 user: dgp tags: dgp-refactor
16:49
Merge pre-TIP 660 changes from trunk. check-in: b1c433a972 user: dgp tags: novem
2023-04-20
16:53
Merge 9.0 check-in: aa3e7e529f user: jan.nijtmans tags: tip-626
2023-04-19
12:15
Merge trunk [883464ea32]. check-in: b5d4c2af53 user: pooryorick tags: trunk-encodingdefaultstrict
03:36
TIP 660 accepted. check-in: 1842599320 user: apnadkarni tags: trunk, main
02:32
Pick up lreplace.test and lseq.test from tip-660-with-trunk-testcases Closed-Leaf check-in: 0bf637b9dc user: apnadkarni tags: tip-660
02:00
Merge trunk check-in: 5ad7c7b96d user: apnadkarni tags: tip-660
2023-04-18
22:35
In DoReadChars() reset CHANNEL_ENCODING_ERROR instead of CHANNEL_BLOCKED. check-in: 883464ea32 user: pooryorick tags: trunk, main
22:00
Fix for [25cdcb7e8fb381fb]: Incomplete utf-8 sequence followed by eofchar results in failed asserti... check-in: a02c5b9f8b user: pooryorick tags: trunk, main

Changes to doc/AddErrInfo.3.

50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
.AP "const char" *message in
For \fBTcl_AddErrorInfo\fR,
this is a conventional C string to append to the \fB\-errorinfo\fR return option.
For \fBTcl_AddObjErrorInfo\fR,
this points to the first byte of an array of \fIlength\fR bytes
containing a string to append to the \fB\-errorinfo\fR return option.
This byte array may contain embedded null bytes
unless \fIlength\fR is TCL_INDEX_NONE.
.AP Tcl_Obj *objPtr in
A message to be appended to the \fB\-errorinfo\fR return option
in the form of a Tcl_Obj value.
.AP size_t length in
The number of bytes to copy from \fImessage\fR when
appending to the \fB\-errorinfo\fR return option.
If TCL_INDEX_NONE, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
The \fB\-errorcode\fR return option will be set to this value.
.AP "const char" *element in
String to record as one element of the \fB\-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP int lineNum
The line number of a script where an error occurred.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP size_t commandLength in
Number of bytes in command; TCL_INDEX_NONE means use all bytes up to first null byte
.BE
.SH DESCRIPTION
.PP
The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR
routines expose the same capabilities as the \fBreturn\fR and
\fBcatch\fR commands, respectively, in the form of a C interface.
.PP







|



|


|














|
|







50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
.AP "const char" *message in
For \fBTcl_AddErrorInfo\fR,
this is a conventional C string to append to the \fB\-errorinfo\fR return option.
For \fBTcl_AddObjErrorInfo\fR,
this points to the first byte of an array of \fIlength\fR bytes
containing a string to append to the \fB\-errorinfo\fR return option.
This byte array may contain embedded null bytes
unless \fIlength\fR is negative.
.AP Tcl_Obj *objPtr in
A message to be appended to the \fB\-errorinfo\fR return option
in the form of a Tcl_Obj value.
.AP Tcl_Size length in
The number of bytes to copy from \fImessage\fR when
appending to the \fB\-errorinfo\fR return option.
If negative, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
The \fB\-errorcode\fR return option will be set to this value.
.AP "const char" *element in
String to record as one element of the \fB\-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP int lineNum
The line number of a script where an error occurred.
.AP "const char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "const char" *command in
Pointer to first character in command that generated the error
.AP Tcl_Size commandLength in
Number of bytes in command; a negative value means use all bytes up to first null byte
.BE
.SH DESCRIPTION
.PP
The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR
routines expose the same capabilities as the \fBreturn\fR and
\fBcatch\fR commands, respectively, in the form of a C interface.
.PP
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
\fBTcl_AddObjErrorInfo\fR is nearly identical
to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR
argument.  This allows the \fImessage\fR string to contain
embedded null bytes.  This is essentially never a good idea.
If the \fImessage\fR needs to contain the null character \fBU+0000\fR,
Tcl's usual internal encoding rules should be used to avoid
the need for a null byte.  If the \fBTcl_AddObjErrorInfo\fR
interface is used at all, it should be with a TCL_INDEX_NONE \fIlength\fR value.
.PP
The procedure \fBTcl_SetObjErrorCode\fR is used to set the
\fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR
built up by the caller.
\fBTcl_SetObjErrorCode\fR is typically invoked just
before returning an error. If an error is
returned without calling \fBTcl_SetObjErrorCode\fR or







|







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
\fBTcl_AddObjErrorInfo\fR is nearly identical
to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR
argument.  This allows the \fImessage\fR string to contain
embedded null bytes.  This is essentially never a good idea.
If the \fImessage\fR needs to contain the null character \fBU+0000\fR,
Tcl's usual internal encoding rules should be used to avoid
the need for a null byte.  If the \fBTcl_AddObjErrorInfo\fR
interface is used at all, it should be with a negative \fIlength\fR value.
.PP
The procedure \fBTcl_SetObjErrorCode\fR is used to set the
\fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR
built up by the caller.
\fBTcl_SetObjErrorCode\fR is typically invoked just
before returning an error. If an error is
returned without calling \fBTcl_SetObjErrorCode\fR or

Changes to doc/ByteArrObj.3.

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
unsigned char *
\fBTcl_SetByteArrayLength\fR(\fIobjPtr, numBytes\fR)
.SH ARGUMENTS
.AS "const unsigned char" *numBytesPtr in/out
.AP "const unsigned char" *bytes in
The array of bytes used to initialize or set a byte-array value. May be NULL
even if \fInumBytes\fR is non-zero.
.AP size_t numBytes in
The number of bytes in the array.
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be
overwritten by a byte-array value.  For \fBTcl_GetBytesFromObj\fR,
\fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points
to the value from which to extract an array of bytes.
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
.AP "size_t \&| int" *numBytesPtr out
Points to space where the number of bytes in the array may be written.
Caller may pass NULL when it does not need this information.
.BE

.SH DESCRIPTION
.PP
These routines are used to create, modify, store, transfer, and retrieve







|








|







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
unsigned char *
\fBTcl_SetByteArrayLength\fR(\fIobjPtr, numBytes\fR)
.SH ARGUMENTS
.AS "const unsigned char" *numBytesPtr in/out
.AP "const unsigned char" *bytes in
The array of bytes used to initialize or set a byte-array value. May be NULL
even if \fInumBytes\fR is non-zero.
.AP Tcl_Size numBytes in
The number of bytes in the array.
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be
overwritten by a byte-array value.  For \fBTcl_GetBytesFromObj\fR,
\fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points
to the value from which to extract an array of bytes.
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
.AP "Tcl_Size \&| int" *numBytesPtr out
Points to space where the number of bytes in the array may be written.
Caller may pass NULL when it does not need this information.
.BE

.SH DESCRIPTION
.PP
These routines are used to create, modify, store, transfer, and retrieve
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
has not been disturbed.  The pointer may be used to overwrite the byte
contents of the internal representation, so long as the value is unshared
and any string representation is invalidated.
.PP
On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR
write the number of bytes in the byte-array value of \fIobjPtr\fR
to the space pointed to by \fInumBytesPtr\fR.  This space may be of type
\fBsize_t\fR or of type \fBint\fR.  It is recommended that callers provide
a \fBsize_t\fR space for this purpose.  If the caller provides only
an \fBint\fR space and the number of bytes in the byte-array value of
\fIobjPtr\fR is greater than \fBINT_MAX\fR, the routine will fail due
to being unable to correctly report the byte-array size to the caller.
The ability to provide an \fBint\fR space is best considered a migration
aid for codebases constrained to continue operating with Tcl releases
older than 8.7.
.PP







|
|







130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
has not been disturbed.  The pointer may be used to overwrite the byte
contents of the internal representation, so long as the value is unshared
and any string representation is invalidated.
.PP
On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR
write the number of bytes in the byte-array value of \fIobjPtr\fR
to the space pointed to by \fInumBytesPtr\fR.  This space may be of type
\fBTcl_Size\fR or of type \fBint\fR.  It is recommended that callers provide
a \fBTcl_Size\fR space for this purpose.  If the caller provides only
an \fBint\fR space and the number of bytes in the byte-array value of
\fIobjPtr\fR is greater than \fBINT_MAX\fR, the routine will fail due
to being unable to correctly report the byte-array size to the caller.
The ability to provide an \fBint\fR space is best considered a migration
aid for codebases constrained to continue operating with Tcl releases
older than 8.7.
.PP

Changes to doc/Class.3.

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
.AP "const char" *name in
The name of the object to create, or NULL if a new unused name is to be
automatically selected.
.AP "const char" *nsName in
The name of the namespace to create for the object's private use, or NULL if a
new unused name is to be automatically selected. The namespace must not
already exist.
.AP size_t objc in
The number of elements in the \fIobjv\fR array.
.AP "Tcl_Obj *const" *objv in
The arguments to the command to create the instance of the class.
.AP size_t skip in
The number of arguments at the start of the argument array, \fIobjv\fR, that
are not arguments to any constructors. This allows the generation of correct
error messages even when complicated calling patterns are used (e.g., via the
\fBnext\fR command).
.AP Tcl_ObjectMetadataType *metaTypePtr in
The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or
retrieved with \fBTcl_ClassGetMetadata\fR.







|



|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
.AP "const char" *name in
The name of the object to create, or NULL if a new unused name is to be
automatically selected.
.AP "const char" *nsName in
The name of the namespace to create for the object's private use, or NULL if a
new unused name is to be automatically selected. The namespace must not
already exist.
.AP Tcl_Size objc in
The number of elements in the \fIobjv\fR array.
.AP "Tcl_Obj *const" *objv in
The arguments to the command to create the instance of the class.
.AP Tcl_Size skip in
The number of arguments at the start of the argument array, \fIobjv\fR, that
are not arguments to any constructors. This allows the generation of correct
error messages even when complicated calling patterns are used (e.g., via the
\fBnext\fR command).
.AP Tcl_ObjectMetadataType *metaTypePtr in
The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or
retrieved with \fBTcl_ClassGetMetadata\fR.

Changes to doc/Concat.3.

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
.nf
\fB#include <tcl.h>\fR
.sp
const char *
\fBTcl_Concat\fR(\fIargc, argv\fR)
.SH ARGUMENTS
.AS "const char *const" argv[]
.AP size_t argc in
Number of strings.
.AP "const char *const" argv[] in
Array of strings to concatenate.  Must have \fIargc\fR entries.
.BE

.SH DESCRIPTION
.PP







|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
.nf
\fB#include <tcl.h>\fR
.sp
const char *
\fBTcl_Concat\fR(\fIargc, argv\fR)
.SH ARGUMENTS
.AS "const char *const" argv[]
.AP Tcl_Size argc in
Number of strings.
.AP "const char *const" argv[] in
Array of strings to concatenate.  Must have \fIargc\fR entries.
.BE

.SH DESCRIPTION
.PP

Changes to doc/CrtAlias.3.

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
below).
.AP "const char" *childCmd in
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
.AP "const char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP size_t argc in
Count of additional arguments to pass to the alias command.
.AP "const char *const" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP size_t objc in
Count of additional value arguments to pass to the aliased command.
.AP Tcl_Obj **objv in
Vector of Tcl_Obj structures, the additional value arguments to pass to
the aliased command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target







|




|







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
below).
.AP "const char" *childCmd in
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
.AP "const char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP Tcl_Size argc in
Count of additional arguments to pass to the alias command.
.AP "const char *const" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP Tcl_Size objc in
Count of additional value arguments to pass to the aliased command.
.AP Tcl_Obj **objv in
Vector of Tcl_Obj structures, the additional value arguments to pass to
the aliased command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target

Changes to doc/CrtChannel.3.

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
The channel to operate on.
.AP int direction in
\fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR
means the output handle is wanted.
.AP void **handlePtr out
Points to the location where the desired OS-specific handle should be
stored.
.AP size_t size in
The size, in bytes, of buffers to allocate in this channel.
.AP int mask in
An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR
and \fBTCL_EXCEPTION\fR that indicates events that have occurred on
this channel.
.AP Tcl_Interp *interp in
Current interpreter. (can be NULL)







|







137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
The channel to operate on.
.AP int direction in
\fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR
means the output handle is wanted.
.AP void **handlePtr out
Points to the location where the desired OS-specific handle should be
stored.
.AP Tcl_Size size in
The size, in bytes, of buffers to allocate in this channel.
.AP int mask in
An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR
and \fBTCL_EXCEPTION\fR that indicates events that have occurred on
this channel.
.AP Tcl_Interp *interp in
Current interpreter. (can be NULL)

Changes to doc/CrtObjCmd.3.

183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
\fBTcl_CreateObjCommand2\fR does the same as \fBTcl_CreateObjCommand\fR,
except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR.
.PP
.CS
typedef int \fBTcl_ObjCmdProc2\fR(
        void *\fIclientData\fR,
        Tcl_Interp *\fIinterp\fR,
        size_t \fIobjc\fR,
        Tcl_Obj *const \fIobjv\fR[]);
.CE
.PP
\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
Once the call completes, attempts to invoke \fIcmdName\fR in
\fIinterp\fR will result in errors.
If \fIcmdName\fR is not bound as a command in \fIinterp\fR then







|







183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
\fBTcl_CreateObjCommand2\fR does the same as \fBTcl_CreateObjCommand\fR,
except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR.
.PP
.CS
typedef int \fBTcl_ObjCmdProc2\fR(
        void *\fIclientData\fR,
        Tcl_Interp *\fIinterp\fR,
        ptrdiff_t \fIobjc\fR,
        Tcl_Obj *const \fIobjv\fR[]);
.CE
.PP
\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
Once the call completes, attempts to invoke \fIcmdName\fR in
\fIinterp\fR will result in errors.
If \fIcmdName\fR is not bound as a command in \fIinterp\fR then

Changes to doc/CrtTrace.3.

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
\fBTcl_CreateObjTrace2\fR(\fIinterp, level, flags, objProc2, clientData, deleteProc\fR)
.sp
\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
.SH ARGUMENTS
.AS Tcl_CmdObjTraceDeleteProc *deleteProc
.AP Tcl_Interp *interp in
Interpreter containing command to be traced or untraced.
.AP size_t level in
Only commands at or below this nesting level will be traced unless
0 is specified.  1 means
top-level commands only, 2 means top-level commands or those that are
invoked as immediate consequences of executing top-level commands
(procedure bodies, bracketed commands, etc.) and so on.
A value of 0 means that commands at any level are traced.
.AP int flags in







|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
\fBTcl_CreateObjTrace2\fR(\fIinterp, level, flags, objProc2, clientData, deleteProc\fR)
.sp
\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
.SH ARGUMENTS
.AS Tcl_CmdObjTraceDeleteProc *deleteProc
.AP Tcl_Interp *interp in
Interpreter containing command to be traced or untraced.
.AP Tcl_Size level in
Only commands at or below this nesting level will be traced unless
0 is specified.  1 means
top-level commands only, 2 means top-level commands or those that are
invoked as immediate consequences of executing top-level commands
(procedure bodies, bracketed commands, etc.) and so on.
A value of 0 means that commands at any level are traced.
.AP int flags in
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
\fIobjProc2\fR should have arguments and result that match the type,
\fBTcl_CmdObjTraceProc2\fR:
.PP
.CS
typedef int \fBTcl_CmdObjTraceProc2\fR(
        \fBvoid *\fR \fIclientData\fR,
        \fBTcl_Interp\fR* \fIinterp\fR,
        size_t \fIlevel\fR,
        const char *\fIcommand\fR,
        \fBTcl_Command\fR \fIcommandToken\fR,
        size_t \fIobjc\fR,
        \fBTcl_Obj\fR *const \fIobjv\fR[]);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters are copies of the
corresponding arguments given to \fBTcl_CreateTrace\fR.
\fIclientData\fR typically points to an application-specific data
structure that describes what to do when \fIobjProc\fR is invoked.  The







|


|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
\fIobjProc2\fR should have arguments and result that match the type,
\fBTcl_CmdObjTraceProc2\fR:
.PP
.CS
typedef int \fBTcl_CmdObjTraceProc2\fR(
        \fBvoid *\fR \fIclientData\fR,
        \fBTcl_Interp\fR* \fIinterp\fR,
        ptrdiff_t \fIlevel\fR,
        const char *\fIcommand\fR,
        \fBTcl_Command\fR \fIcommandToken\fR,
        ptrdiff_t \fIobjc\fR,
        \fBTcl_Obj\fR *const \fIobjv\fR[]);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters are copies of the
corresponding arguments given to \fBTcl_CreateTrace\fR.
\fIclientData\fR typically points to an application-specific data
structure that describes what to do when \fIobjProc\fR is invoked.  The

Changes to doc/DString.3.

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
char *
\fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR)
.sp
\fBTcl_DStringStartSublist\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringEndSublist\fR(\fIdsPtr\fR)
.sp
size_t
\fBTcl_DStringLength\fR(\fIdsPtr\fR)
.sp
char *
\fBTcl_DStringValue\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR)
.sp







|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
char *
\fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR)
.sp
\fBTcl_DStringStartSublist\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringEndSublist\fR(\fIdsPtr\fR)
.sp
Tcl_Size
\fBTcl_DStringLength\fR(\fIdsPtr\fR)
.sp
char *
\fBTcl_DStringValue\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR)
.sp
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
.AS Tcl_DString newLength in/out
.AP Tcl_DString *dsPtr in/out
Pointer to structure that is used to manage a dynamic string.
.AP "const char" *bytes in
Pointer to characters to append to dynamic string.
.AP "const char" *element in
Pointer to characters to append as list element to dynamic string.
.AP size_t length in
Number of bytes from \fIbytes\fR to add to dynamic string.  If TCL_INDEX_NONE,
add all characters up to null terminating character.
.AP size_t newLength in
New length for dynamic string, not including null terminating
character.
.AP Tcl_Interp *interp in/out
Interpreter whose result is to be set from or moved to the
dynamic string.
.BE








|
|

|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
.AS Tcl_DString newLength in/out
.AP Tcl_DString *dsPtr in/out
Pointer to structure that is used to manage a dynamic string.
.AP "const char" *bytes in
Pointer to characters to append to dynamic string.
.AP "const char" *element in
Pointer to characters to append as list element to dynamic string.
.AP Tcl_Size length in
Number of bytes from \fIbytes\fR to add to dynamic string.  If negative,
add all characters up to null terminating character.
.AP Tcl_Size newLength in
New length for dynamic string, not including null terminating
character.
.AP Tcl_Interp *interp in/out
Interpreter whose result is to be set from or moved to the
dynamic string.
.BE

Changes to doc/DetachPids.3.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
.sp
\fBTcl_ReapDetachedProcs\fR()
.sp
Tcl_Pid
\fBTcl_WaitPid\fR(\fIpid, statusPtr, options\fR)
.SH ARGUMENTS
.AS Tcl_Pid *statusPtr out
.AP size_t numPids in
Number of process ids contained in the array pointed to by \fIpidPtr\fR.
.AP int *pidPtr in
Address of array containing \fInumPids\fR process ids.
.AP Tcl_Pid pid in
The id of the process (pipe) to wait for.
.AP int *statusPtr out
The result of waiting on a process (pipe). Either 0 or ECHILD.







|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
.sp
\fBTcl_ReapDetachedProcs\fR()
.sp
Tcl_Pid
\fBTcl_WaitPid\fR(\fIpid, statusPtr, options\fR)
.SH ARGUMENTS
.AS Tcl_Pid *statusPtr out
.AP Tcl_Size numPids in
Number of process ids contained in the array pointed to by \fIpidPtr\fR.
.AP int *pidPtr in
Address of array containing \fInumPids\fR process ids.
.AP Tcl_Pid pid in
The id of the process (pipe) to wait for.
.AP int *statusPtr out
The result of waiting on a process (pipe). Either 0 or ECHILD.

Changes to doc/DictObj.3.

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
dictionary value (or sub-value, in the case of
\fBTcl_DictObjPutKeyList\fR.)
.AP Tcl_Obj **valuePtrPtr out
Points to a variable that will have the value from a key/value pair
placed within it.  For \fBTcl_DictObjFirst\fR and
\fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is
not interested in the value.
.AP "size_t \&| int" *sizePtr out
Points to a variable that will have the number of key/value pairs
contained within the dictionary placed within it.
.AP Tcl_DictSearch *searchPtr in/out
Pointer to record to use to keep track of progress in enumerating all
key/value pairs in a dictionary.  The contents of the record will be
initialized by the call to \fBTcl_DictObjFirst\fR.  If the enumerating
is to be terminated before all values in the dictionary have been
returned, the search record \fImust\fR be passed to
\fBTcl_DictObjDone\fR to enable the internal locks to be released.
.AP int *donePtr out
Points to a variable that will have a non-zero value written into it
when the enumeration of the key/value pairs in a dictionary has
completed, and a zero otherwise.
.AP size_t keyc in
Indicates the number of keys that will be supplied in the \fIkeyv\fR
array.
.AP "Tcl_Obj *const" *keyv in
Array of \fIkeyc\fR pointers to values that
\fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will
use to locate the key/value pair to manipulate within the
sub-dictionaries of the main dictionary value passed to them.







|













|







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
dictionary value (or sub-value, in the case of
\fBTcl_DictObjPutKeyList\fR.)
.AP Tcl_Obj **valuePtrPtr out
Points to a variable that will have the value from a key/value pair
placed within it.  For \fBTcl_DictObjFirst\fR and
\fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is
not interested in the value.
.AP "Tcl_Size \&| int" *sizePtr out
Points to a variable that will have the number of key/value pairs
contained within the dictionary placed within it.
.AP Tcl_DictSearch *searchPtr in/out
Pointer to record to use to keep track of progress in enumerating all
key/value pairs in a dictionary.  The contents of the record will be
initialized by the call to \fBTcl_DictObjFirst\fR.  If the enumerating
is to be terminated before all values in the dictionary have been
returned, the search record \fImust\fR be passed to
\fBTcl_DictObjDone\fR to enable the internal locks to be released.
.AP int *donePtr out
Points to a variable that will have a non-zero value written into it
when the enumeration of the key/value pairs in a dictionary has
completed, and a zero otherwise.
.AP Tcl_Size keyc in
Indicates the number of keys that will be supplied in the \fIkeyv\fR
array.
.AP "Tcl_Obj *const" *keyv in
Array of \fIkeyc\fR pointers to values that
\fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will
use to locate the key/value pair to manipulate within the
sub-dictionaries of the main dictionary value passed to them.

Changes to doc/Encoding.3.

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
.sp
int
\fBTcl_GetEncodingFromObj\fR(\fIinterp, objPtr, encodingPtr\fR)
.sp
char *
\fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
size_t
\fBTcl_ExternalToUtfDStringEx\fR(\fIinterp, encoding, src, srcLen, flags, dstPtr, errorIdxPtr\fR)
.sp
char *
\fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
size_t
\fBTcl_UtfToExternalDStringEx\fR(\fIinterp, encoding, src, srcLen, flags, dstPtr, errorIdxPtr\fR)
.sp
int
\fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
                  dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
int
\fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
                  dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
const char *
\fBTcl_GetEncodingName\fR(\fIencoding\fR)
.sp
size_t
\fBTcl_GetEncodingNulLength\fR(\fIencoding\fR)
.sp
int
\fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR)
.sp
const char *
\fBTcl_GetEncodingNameFromEnvironment\fR(\fIbufPtr\fR)







|





|













|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
.sp
int
\fBTcl_GetEncodingFromObj\fR(\fIinterp, objPtr, encodingPtr\fR)
.sp
char *
\fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
int
\fBTcl_ExternalToUtfDStringEx\fR(\fIinterp, encoding, src, srcLen, flags, dstPtr, errorIdxPtr\fR)
.sp
char *
\fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
int
\fBTcl_UtfToExternalDStringEx\fR(\fIinterp, encoding, src, srcLen, flags, dstPtr, errorIdxPtr\fR)
.sp
int
\fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
                  dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
int
\fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
                  dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
const char *
\fBTcl_GetEncodingName\fR(\fIencoding\fR)
.sp
Tcl_Size
\fBTcl_GetEncodingNulLength\fR(\fIencoding\fR)
.sp
int
\fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR)
.sp
const char *
\fBTcl_GetEncodingNameFromEnvironment\fR(\fIbufPtr\fR)
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
.AP "const char" *src in
For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the
specified encoding that are to be converted to UTF-8.  For the
\fBTcl_UtfToExternal\fR function, an array of
UTF-8 characters to be converted to the specified encoding.
.AP "const TCHAR" *tsrc in
An array of Windows TCHAR characters to convert to UTF-8.
.AP size_t srcLen in
Length of \fIsrc\fR or \fItsrc\fR in bytes.  If the length is negative, the
encoding-specific length of the string is used.
.AP Tcl_DString *dstPtr out
Pointer to an uninitialized or free \fBTcl_DString\fR in which the converted
result will be stored.
.AP int flags in
This is a bit mask passed in to control the operation of the encoding functions.







|







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
.AP "const char" *src in
For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the
specified encoding that are to be converted to UTF-8.  For the
\fBTcl_UtfToExternal\fR function, an array of
UTF-8 characters to be converted to the specified encoding.
.AP "const TCHAR" *tsrc in
An array of Windows TCHAR characters to convert to UTF-8.
.AP Tcl_Size srcLen in
Length of \fIsrc\fR or \fItsrc\fR in bytes.  If the length is negative, the
encoding-specific length of the string is used.
.AP Tcl_DString *dstPtr out
Pointer to an uninitialized or free \fBTcl_DString\fR in which the converted
result will be stored.
.AP int flags in
This is a bit mask passed in to control the operation of the encoding functions.
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
.CS
typedef struct Tcl_EncodingType {
    const char *\fIencodingName\fR;
    Tcl_EncodingConvertProc *\fItoUtfProc\fR;
    Tcl_EncodingConvertProc *\fIfromUtfProc\fR;
    Tcl_EncodingFreeProc *\fIfreeProc\fR;
    void *\fIclientData\fR;
    size_t \fInullSize\fR;
} \fBTcl_EncodingType\fR;
.CE
.PP
The \fIencodingName\fR provides a string name for the encoding, by
which it can be referred in other procedures such as
\fBTcl_GetEncoding\fR.  The \fItoUtfProc\fR refers to a callback
procedure to invoke to convert text from this encoding into UTF-8.







|







343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
.CS
typedef struct Tcl_EncodingType {
    const char *\fIencodingName\fR;
    Tcl_EncodingConvertProc *\fItoUtfProc\fR;
    Tcl_EncodingConvertProc *\fIfromUtfProc\fR;
    Tcl_EncodingFreeProc *\fIfreeProc\fR;
    void *\fIclientData\fR;
    Tcl_Size \fInullSize\fR;
} \fBTcl_EncodingType\fR;
.CE
.PP
The \fIencodingName\fR provides a string name for the encoding, by
which it can be referred in other procedures such as
\fBTcl_GetEncoding\fR.  The \fItoUtfProc\fR refers to a callback
procedure to invoke to convert text from this encoding into UTF-8.

Changes to doc/Eval.3.

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
.AP Tcl_Obj *objPtr in
A Tcl value containing the script to execute.
.AP int flags in
OR'ed combination of flag bits that specify additional options.
\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported.
.AP "const char" *fileName in
Name of a file containing a Tcl script.
.AP size_t objc in
The number of values in the array pointed to by \fIobjv\fR;
this is also the number of words in the command.
.AP Tcl_Obj **objv in
Points to an array of pointers to values; each value holds the
value of a single word in the command to execute.
.AP int numBytes in
The number of bytes in \fIscript\fR, not including any







|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
.AP Tcl_Obj *objPtr in
A Tcl value containing the script to execute.
.AP int flags in
OR'ed combination of flag bits that specify additional options.
\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported.
.AP "const char" *fileName in
Name of a file containing a Tcl script.
.AP Tcl_Size objc in
The number of values in the array pointed to by \fIobjv\fR;
this is also the number of words in the command.
.AP Tcl_Obj **objv in
Points to an array of pointers to values; each value holds the
value of a single word in the command to execute.
.AP int numBytes in
The number of bytes in \fIscript\fR, not including any

Changes to doc/FileSystem.3.

216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
The first of two path values to compare. The value may be converted
to \fBpath\fR type.
.AP Tcl_Obj *secondPtr in
The second of two path values to compare. The value may be converted
to \fBpath\fR type.
.AP Tcl_Obj *listObj in
The list of path elements to operate on with a \fBjoin\fR operation.
.AP size_t elements in
The number of elements in the \fIlistObj\fR which should
be joined together. If TCL_INDEX_NONE, then all elements are joined.
.AP Tcl_Obj **errorPtr out
In the case of an error, filled with a value containing the name of
the file which caused an error in the various copy/rename operations.
.AP int index in
The index of the attribute in question.
.AP Tcl_Obj *objPtr in
The value to set in the operation.







|

|







216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
The first of two path values to compare. The value may be converted
to \fBpath\fR type.
.AP Tcl_Obj *secondPtr in
The second of two path values to compare. The value may be converted
to \fBpath\fR type.
.AP Tcl_Obj *listObj in
The list of path elements to operate on with a \fBjoin\fR operation.
.AP Tcl_Size elements in
The number of elements in the \fIlistObj\fR which should
be joined together. If negative, then all elements are joined.
.AP Tcl_Obj **errorPtr out
In the case of an error, filled with a value containing the name of
the file which caused an error in the various copy/rename operations.
.AP int index in
The index of the attribute in question.
.AP Tcl_Obj *objPtr in
The value to set in the operation.
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
used to set those values for a given file.
.AP "const char" *modeString in
Specifies how the file is to be accessed. May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644. If a new file is created, these
permissions will be set on the created file.
.AP "size_t \&| int" *lenPtr out
If non-NULL, filled with the number of elements in the split path.
.AP Tcl_Obj *basePtr in
The base path on to which to join the given elements. May be NULL.
.AP size_t objc in
The number of elements in \fIobjv\fR.
.AP "Tcl_Obj *const" objv[] in
The elements to join to the given base path.
.AP Tcl_Obj *linkNamePtr in
The name of the link to be created or read.
.AP Tcl_Obj *toPtr in
What the link called \fIlinkNamePtr\fR should be linked to, or NULL if







|



|







265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
used to set those values for a given file.
.AP "const char" *modeString in
Specifies how the file is to be accessed. May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644. If a new file is created, these
permissions will be set on the created file.
.AP "ptrdiff_t \&| int" *lenPtr out
If non-NULL, filled with the number of elements in the split path.
.AP Tcl_Obj *basePtr in
The base path on to which to join the given elements. May be NULL.
.AP Tcl_Size objc in
The number of elements in \fIobjv\fR.
.AP "Tcl_Obj *const" objv[] in
The elements to join to the given base path.
.AP Tcl_Obj *linkNamePtr in
The name of the link to be created or read.
.AP Tcl_Obj *toPtr in
What the link called \fIlinkNamePtr\fR should be linked to, or NULL if
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
.SS "THE TCL_FILESYSTEM STRUCTURE"
.PP
The \fBTcl_Filesystem\fR structure contains the following fields:
.PP
.CS
typedef struct Tcl_Filesystem {
    const char *\fItypeName\fR;
    size_t \fIstructureLength\fR;
    Tcl_FSVersion \fIversion\fR;
    Tcl_FSPathInFilesystemProc *\fIpathInFilesystemProc\fR;
    Tcl_FSDupInternalRepProc *\fIdupInternalRepProc\fR;
    Tcl_FSFreeInternalRepProc *\fIfreeInternalRepProc\fR;
    Tcl_FSInternalToNormalizedProc *\fIinternalToNormalizedProc\fR;
    Tcl_FSCreateInternalRepProc *\fIcreateInternalRepProc\fR;
    Tcl_FSNormalizePathProc *\fInormalizePathProc\fR;







|







834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
.SS "THE TCL_FILESYSTEM STRUCTURE"
.PP
The \fBTcl_Filesystem\fR structure contains the following fields:
.PP
.CS
typedef struct Tcl_Filesystem {
    const char *\fItypeName\fR;
    Tcl_Size \fIstructureLength\fR;
    Tcl_FSVersion \fIversion\fR;
    Tcl_FSPathInFilesystemProc *\fIpathInFilesystemProc\fR;
    Tcl_FSDupInternalRepProc *\fIdupInternalRepProc\fR;
    Tcl_FSFreeInternalRepProc *\fIfreeInternalRepProc\fR;
    Tcl_FSInternalToNormalizedProc *\fIinternalToNormalizedProc\fR;
    Tcl_FSCreateInternalRepProc *\fIcreateInternalRepProc\fR;
    Tcl_FSNormalizePathProc *\fInormalizePathProc\fR;

Changes to doc/IntObj.3.

39
40
41
42
43
44
45



46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
.sp
int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
.sp
int
\fBTcl_GetWideUIntFromObj\fR(\fIinterp, objPtr, uwidePtr\fR)
.sp



.sp
\fB#include <tclTomMath.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewBignumObj\fR(\fIbigValue\fR)
.sp
\fBTcl_SetBignumObj\fR(\fIobjPtr, bigValue\fR)
.sp
int
\fBTcl_GetBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR)
.sp
int
\fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR)
.sp
int
\fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR)
.SH ARGUMENTS
.AS Tcl_WideInt doubleValue in/out
.AP size_t endValue in
\fBTcl_GetIntForIndex\fR will return this when the input value is "end".
.AP int intValue in
Integer value used to initialize or set a Tcl value.
.AP long longValue in
Long integer value used to initialize or set a Tcl value.
.AP Tcl_WideInt wideValue in
Wide integer value used to initialize or set a Tcl value.







>
>
>


















|







39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
.sp
int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
.sp
int
\fBTcl_GetWideUIntFromObj\fR(\fIinterp, objPtr, uwidePtr\fR)
.sp
int
\fBTcl_GetSizeIntFromObj\fR(\fIinterp, objPtr, sizePtr\fR)
.sp
.sp
\fB#include <tclTomMath.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewBignumObj\fR(\fIbigValue\fR)
.sp
\fBTcl_SetBignumObj\fR(\fIobjPtr, bigValue\fR)
.sp
int
\fBTcl_GetBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR)
.sp
int
\fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR)
.sp
int
\fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR)
.SH ARGUMENTS
.AS Tcl_WideInt doubleValue in/out
.AP Tcl_Size endValue in
\fBTcl_GetIntForIndex\fR will return this when the input value is "end".
.AP int intValue in
Integer value used to initialize or set a Tcl value.
.AP long longValue in
Long integer value used to initialize or set a Tcl value.
.AP Tcl_WideInt wideValue in
Wide integer value used to initialize or set a Tcl value.
79
80
81
82
83
84
85
86
87
88
89
90
91


92
93
94
95
96
97
98
.AP Tcl_Interp *interp in/out
When non-NULL, an error message is left here when integral value
retrieval fails.
.AP int *intPtr out
Points to place to store the integer value retrieved from \fIobjPtr\fR.
.AP long *longPtr out
Points to place to store the long integer value retrieved from \fIobjPtr\fR.
.AP size_t *indexPtr out
Points to place to store the size_t value retrieved from \fIobjPtr\fR.
.AP Tcl_WideInt *widePtr out
Points to place to store the wide integer value retrieved from \fIobjPtr\fR.
.AP Tcl_WideUInt *uwidePtr out
Points to place to store the unsigned wide integer value retrieved from \fIobjPtr\fR.


.AP mp_int *bigValue in/out
Points to a multi-precision integer structure declared by the LibTomMath
library.
.AP double doubleValue in
Double value from which the integer part is determined and
used to initialize a multi-precision integer value.
.BE







|
|




>
>







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
.AP Tcl_Interp *interp in/out
When non-NULL, an error message is left here when integral value
retrieval fails.
.AP int *intPtr out
Points to place to store the integer value retrieved from \fIobjPtr\fR.
.AP long *longPtr out
Points to place to store the long integer value retrieved from \fIobjPtr\fR.
.AP Tcl_Size *indexPtr out
Points to place to store the Tcl_Size value retrieved from \fIobjPtr\fR.
.AP Tcl_WideInt *widePtr out
Points to place to store the wide integer value retrieved from \fIobjPtr\fR.
.AP Tcl_WideUInt *uwidePtr out
Points to place to store the unsigned wide integer value retrieved from \fIobjPtr\fR.
.AP Tcl_Size *sizePtr out
Points to place to store the \fBTcl_Size\fR integer value retrieved from \fIobjPtr\fR.
.AP mp_int *bigValue in/out
Points to a multi-precision integer structure declared by the LibTomMath
library.
.AP double doubleValue in
Double value from which the integer part is determined and
used to initialize a multi-precision integer value.
.BE
134
135
136
137
138
139
140
141

142
143
144
145
146
147
148
\fIobjPtr\fR does not hold an index value.  If the attempt fails,
then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL,
an error message is left in \fIinterp\fR.  The \fBTcl_ObjType\fR
of \fIobjPtr\fR may be changed to make subsequent calls to the
same routine more efficient.
.PP
The \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR,
\fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and

\fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral
value of the appropriate type from the Tcl value \fIobjPtr\fR.  If the
attempt succeeds, then \fBTCL_OK\fR is returned, and the value is
written to the storage provided by the caller.  The attempt might
fail if \fIobjPtr\fR does not hold an integral value, or if the
value exceeds the range of the target type.  If the attempt fails,
then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL,







|
>







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
\fIobjPtr\fR does not hold an index value.  If the attempt fails,
then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL,
an error message is left in \fIinterp\fR.  The \fBTcl_ObjType\fR
of \fIobjPtr\fR may be changed to make subsequent calls to the
same routine more efficient.
.PP
The \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR,
\fBTcl_GetWideIntFromObj\fR, \fBTcl_GetSizeIntFromObj\fR,
\fBTcl_GetBignumFromObj\fR, and
\fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral
value of the appropriate type from the Tcl value \fIobjPtr\fR.  If the
attempt succeeds, then \fBTCL_OK\fR is returned, and the value is
written to the storage provided by the caller.  The attempt might
fail if \fIobjPtr\fR does not hold an integral value, or if the
value exceeds the range of the target type.  If the attempt fails,
then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL,

Changes to doc/Limit.3.

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
.AS Tcl_LimitHandlerDeleteProc commandLimit in/out
.AP Tcl_Interp *interp in
Interpreter that the limit being managed applies to or that will have
its limits checked.
.AP int type in
The type of limit that the operation refers to.  This must be either
\fBTCL_LIMIT_COMMANDS\fR or \fBTCL_LIMIT_TIME\fR.
.AP size_t commandLimit in
The maximum number of commands (as reported by \fBinfo cmdcount\fR)
that may be executed in the interpreter.
.AP Tcl_Time *timeLimitPtr in/out
A pointer to a structure that will either have the new time limit read
from (\fBTcl_LimitSetTime\fR) or the current time limit written to
(\fBTcl_LimitGetTime\fR).
.AP int granularity in







|







61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
.AS Tcl_LimitHandlerDeleteProc commandLimit in/out
.AP Tcl_Interp *interp in
Interpreter that the limit being managed applies to or that will have
its limits checked.
.AP int type in
The type of limit that the operation refers to.  This must be either
\fBTCL_LIMIT_COMMANDS\fR or \fBTCL_LIMIT_TIME\fR.
.AP Tcl_Size commandLimit in
The maximum number of commands (as reported by \fBinfo cmdcount\fR)
that may be executed in the interpreter.
.AP Tcl_Time *timeLimitPtr in/out
A pointer to a structure that will either have the new time limit read
from (\fBTcl_LimitSetTime\fR) or the current time limit written to
(\fBTcl_LimitGetTime\fR).
.AP int granularity in

Changes to doc/LinkVar.3.

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and
\fBTCL_LINK_BINARY\fR may be used.
.VE "TIP 312"
.sp
All the above for both functions may be
optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl
variable read-only.
.AP size_t size in
.VS "TIP 312"
The number of elements in the C array. Must be greater than zero.
.VE "TIP 312"
.BE
.SH DESCRIPTION
.PP
\fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable







|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and
\fBTCL_LINK_BINARY\fR may be used.
.VE "TIP 312"
.sp
All the above for both functions may be
optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl
variable read-only.
.AP Tcl_Size size in
.VS "TIP 312"
The number of elements in the C array. Must be greater than zero.
.VE "TIP 312"
.BE
.SH DESCRIPTION
.PP
\fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable

Changes to doc/ListObj.3.

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
an attempt will be made to convert it to one.
.AP Tcl_Obj *objPtr in
For \fBTcl_ListObjAppendElement\fR,
points to the Tcl value that will be appended to \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
this points to the Tcl value that will be converted to a list value
containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR.
.AP "size_t \&| int" *objcPtr in
Points to location where \fBTcl_ListObjGetElements\fR
stores the number of element values in \fIlistPtr\fR.
.AP Tcl_Obj ***objvPtr out
A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array
of pointers to the element values of \fIlistPtr\fR.
.AP size_t objc in
The number of Tcl values that \fBTcl_NewListObj\fR
will insert into a new list value,
and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
the number of Tcl values to insert into \fIobjPtr\fR.
.AP "Tcl_Obj *const" objv[] in
An array of pointers to values.
\fBTcl_NewListObj\fR will insert these values into a new list value
and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR.
Each value will become a separate list element.
.AP "size_t \&| int" *lengthPtr out
Points to location where \fBTcl_ListObjLength\fR
stores the length of the list.
.AP size_t index in
Index of the list element that \fBTcl_ListObjIndex\fR
is to return.
The first element has index 0.
.AP Tcl_Obj **objPtrPtr out
Points to place where \fBTcl_ListObjIndex\fR is to store
a pointer to the resulting list element value.
.AP size_t first in
Index of the starting list element that \fBTcl_ListObjReplace\fR
is to replace.
The list's first element has index 0.
.AP size_t count in
The number of elements that \fBTcl_ListObjReplace\fR
is to replace.
.BE

.SH DESCRIPTION
.PP
Tcl list values have an internal representation that supports







|





|










|


|






|



|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
an attempt will be made to convert it to one.
.AP Tcl_Obj *objPtr in
For \fBTcl_ListObjAppendElement\fR,
points to the Tcl value that will be appended to \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
this points to the Tcl value that will be converted to a list value
containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR.
.AP "ptrdiff_t \&| int" *objcPtr in
Points to location where \fBTcl_ListObjGetElements\fR
stores the number of element values in \fIlistPtr\fR.
.AP Tcl_Obj ***objvPtr out
A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array
of pointers to the element values of \fIlistPtr\fR.
.AP Tcl_Size objc in
The number of Tcl values that \fBTcl_NewListObj\fR
will insert into a new list value,
and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
the number of Tcl values to insert into \fIobjPtr\fR.
.AP "Tcl_Obj *const" objv[] in
An array of pointers to values.
\fBTcl_NewListObj\fR will insert these values into a new list value
and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR.
Each value will become a separate list element.
.AP "ptrdiff_t \&| int" *lengthPtr out
Points to location where \fBTcl_ListObjLength\fR
stores the length of the list.
.AP Tcl_Size index in
Index of the list element that \fBTcl_ListObjIndex\fR
is to return.
The first element has index 0.
.AP Tcl_Obj **objPtrPtr out
Points to place where \fBTcl_ListObjIndex\fR is to store
a pointer to the resulting list element value.
.AP Tcl_Size first in
Index of the starting list element that \fBTcl_ListObjReplace\fR
is to replace.
The list's first element has index 0.
.AP Tcl_Size count in
The number of elements that \fBTcl_ListObjReplace\fR
is to replace.
.BE

.SH DESCRIPTION
.PP
Tcl list values have an internal representation that supports
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
in the address \fIobjPtrPtr\fR.
If \fIlistPtr\fR does not already refer to a list value,
\fBTcl_ListObjIndex\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
If the index is out of range,
that is, \fIindex\fR is TCL_INDEX_NONE or
greater than or equal to the number of elements in the list,
\fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR
and returns \fBTCL_OK\fR.
Otherwise it returns \fBTCL_OK\fR after storing the element's
value pointer.
The reference count for the list element is not incremented;
the caller must do that if it needs to retain a pointer to the element.
.PP
\fBTcl_ListObjReplace\fR replaces zero or more elements
of the list referenced by \fIlistPtr\fR
with the \fIobjc\fR values in the array referenced by \fIobjv\fR.
If \fIlistPtr\fR does not point to a list value,
\fBTcl_ListObjReplace\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise, it returns \fBTCL_OK\fR after replacing the values.
If \fIobjv\fR is NULL, no new elements are added.
If the argument \fIfirst\fR is zero or TCL_INDEX_NONE,
it refers to the first element.
If \fIfirst\fR is greater than or equal to the
number of elements in the list, then no elements are deleted;
the new elements are appended to the list.
\fIcount\fR gives the number of elements to replace.
If \fIcount\fR is zero or TCL_INDEX_NONE then no elements are deleted;
the new elements are simply inserted before the one
designated by \fIfirst\fR.
\fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's
old string representation.
The reference counts of any elements inserted from \fIobjv\fR
are incremented since the resulting list now refers to them.
Similarly, the reference counts for any replaced values are decremented.







|


















|





|







180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
in the address \fIobjPtrPtr\fR.
If \fIlistPtr\fR does not already refer to a list value,
\fBTcl_ListObjIndex\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
If the index is out of range,
that is, \fIindex\fR is negative or
greater than or equal to the number of elements in the list,
\fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR
and returns \fBTCL_OK\fR.
Otherwise it returns \fBTCL_OK\fR after storing the element's
value pointer.
The reference count for the list element is not incremented;
the caller must do that if it needs to retain a pointer to the element.
.PP
\fBTcl_ListObjReplace\fR replaces zero or more elements
of the list referenced by \fIlistPtr\fR
with the \fIobjc\fR values in the array referenced by \fIobjv\fR.
If \fIlistPtr\fR does not point to a list value,
\fBTcl_ListObjReplace\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise, it returns \fBTCL_OK\fR after replacing the values.
If \fIobjv\fR is NULL, no new elements are added.
If the argument \fIfirst\fR is zero or negative,
it refers to the first element.
If \fIfirst\fR is greater than or equal to the
number of elements in the list, then no elements are deleted;
the new elements are appended to the list.
\fIcount\fR gives the number of elements to replace.
If \fIcount\fR is zero or negative then no elements are deleted;
the new elements are simply inserted before the one
designated by \fIfirst\fR.
\fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's
old string representation.
The reference counts of any elements inserted from \fIobjv\fR
are incremented since the resulting list now refers to them.
Similarly, the reference counts for any replaced values are decremented.

Changes to doc/Method.3.

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
.sp
Tcl_Method
\fBTcl_ObjectContextMethod\fR(\fIcontext\fR)
.sp
Tcl_Object
\fBTcl_ObjectContextObject\fR(\fIcontext\fR)
.sp
size_t
\fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR)
.SH ARGUMENTS
.AS void *clientData in
.AP Tcl_Interp *interp in/out
The interpreter holding the object or class to create or update a method in.
.AP Tcl_Object object in
The object to create the method in.







|







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
.sp
Tcl_Method
\fBTcl_ObjectContextMethod\fR(\fIcontext\fR)
.sp
Tcl_Object
\fBTcl_ObjectContextObject\fR(\fIcontext\fR)
.sp
Tcl_Size
\fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR)
.SH ARGUMENTS
.AS void *clientData in
.AP Tcl_Interp *interp in/out
The interpreter holding the object or class to create or update a method in.
.AP Tcl_Object object in
The object to create the method in.
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
when the method was created. If NULL, the \fIclientData\fR value will not be
retrieved.
.AP Tcl_Method method in
A reference to a method to query.
.AP Tcl_ObjectContext context in
A reference to a method-call context. Note that client code \fImust not\fR
retain a reference to a context.
.AP size_t objc in
The number of arguments to pass to the method implementation.
.AP "Tcl_Obj *const" *objv in
An array of arguments to pass to the method implementation.
.AP size_t skip in
The number of arguments passed to the method implementation that do not
represent "real" arguments.
.BE
.SH DESCRIPTION
.PP
A method is an operation carried out on an object that is associated with the
object. Every method must be attached to either an object or a class; methods







|



|







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
when the method was created. If NULL, the \fIclientData\fR value will not be
retrieved.
.AP Tcl_Method method in
A reference to a method to query.
.AP Tcl_ObjectContext context in
A reference to a method-call context. Note that client code \fImust not\fR
retain a reference to a context.
.AP Tcl_Size objc in
The number of arguments to pass to the method implementation.
.AP "Tcl_Obj *const" *objv in
An array of arguments to pass to the method implementation.
.AP Tcl_Size skip in
The number of arguments passed to the method implementation that do not
represent "real" arguments.
.BE
.SH DESCRIPTION
.PP
A method is an operation carried out on an object that is associated with the
object. Every method must be attached to either an object or a class; methods

Changes to doc/NRE.3.

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Called instead of \fIproc2\fR when a trampoline is already in use.
.AP void *clientData in
Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR
and \fIobjProc\fR.
.AP Tcl_CmdDeleteProc *deleteProc in/out
Called before \fIcmdName\fR is deleted from the interpreter, allowing for
command-specific cleanup. May be NULL.
.AP size_t objc in
Number of items in \fIobjv\fR.
.AP Tcl_Obj **objv in
Words in the command.
.AP Tcl_Obj *objPtr in
A script or expression to evaluate.
.AP int flags in
As described for \fITcl_EvalObjv\fR.







|







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Called instead of \fIproc2\fR when a trampoline is already in use.
.AP void *clientData in
Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR
and \fIobjProc\fR.
.AP Tcl_CmdDeleteProc *deleteProc in/out
Called before \fIcmdName\fR is deleted from the interpreter, allowing for
command-specific cleanup. May be NULL.
.AP Tcl_Size objc in
Number of items in \fIobjv\fR.
.AP Tcl_Obj **objv in
Words in the command.
.AP Tcl_Obj *objPtr in
A script or expression to evaluate.
.AP int flags in
As described for \fITcl_EvalObjv\fR.

Changes to doc/Number.3.

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
.SH ARGUMENTS
.AS Tcl_Interp clientDataPtr out
.AP Tcl_Interp *interp out
When non-NULL, error information is recorded here when the value is not
in any of the numeric formats recognized by Tcl.
.AP "const char" *bytes in
Points to first byte of the string value to be examined.
.AP size_t numBytes in
The number of bytes, starting at \fIbytes\fR, that should be examined.
If the value \fBTCL_INDEX_NONE\fR is provided, then all bytes should
be examined until the first \fBNUL\fR byte terminates examination.
.AP "void *" *clientDataPtr out
Points to space where a pointer value may be written through which a numeric
value is available to read.
.AP int *typePtr out
Points to space where a value may be written reporting what type of
numeric storage is available to read.







|

|







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
.SH ARGUMENTS
.AS Tcl_Interp clientDataPtr out
.AP Tcl_Interp *interp out
When non-NULL, error information is recorded here when the value is not
in any of the numeric formats recognized by Tcl.
.AP "const char" *bytes in
Points to first byte of the string value to be examined.
.AP Tcl_Size numBytes in
The number of bytes, starting at \fIbytes\fR, that should be examined.
If \fBnumBytes\fR is negative, then all bytes should
be examined until the first \fBNUL\fR byte terminates examination.
.AP "void *" *clientDataPtr out
Points to space where a pointer value may be written through which a numeric
value is available to read.
.AP int *typePtr out
Points to space where a value may be written reporting what type of
numeric storage is available to read.
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
multiple-precision integer library, included with Tcl.
.PP
The routines \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR perform
the same function.  They differ only in how the arguments present the Tcl
value to be examined.  \fBTcl_GetNumber\fR accepts a counted string
value in the arguments \fIbytes\fR and \fInumBytes\fR (or a
\fBNUL\fR-terminated string value when \fInumBytes\fR is
\fBTCL_INDEX_NONE\fR).  \fBTcl_GetNumberFromObj\fR accepts the Tcl value
in \fIobjPtr\fR.
.PP
Both routines examine the Tcl value and determine whether Tcl recognizes
it as a number.  If not, both routines return \fBTCL_ERROR\fR and (when
\fIinterp\fR is not NULL) record an error message and error code
in \fIinterp\fR.
.PP







|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
multiple-precision integer library, included with Tcl.
.PP
The routines \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR perform
the same function.  They differ only in how the arguments present the Tcl
value to be examined.  \fBTcl_GetNumber\fR accepts a counted string
value in the arguments \fIbytes\fR and \fInumBytes\fR (or a
\fBNUL\fR-terminated string value when \fInumBytes\fR is
negative).  \fBTcl_GetNumberFromObj\fR accepts the Tcl value
in \fIobjPtr\fR.
.PP
Both routines examine the Tcl value and determine whether Tcl recognizes
it as a number.  If not, both routines return \fBTCL_ERROR\fR and (when
\fIinterp\fR is not NULL) record an error message and error code
in \fIinterp\fR.
.PP

Changes to doc/Object.3.

107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
    size_t \fIrefCount\fR;
    char *\fIbytes\fR;
    size_t \fIlength\fR;
    const Tcl_ObjType *\fItypePtr\fR;
    union {
        long \fIlongValue\fR;
        double \fIdoubleValue\fR;
        void *\fIotherValuePtr\fR;
        Tcl_WideInt \fIwideValue\fR;
        struct {







|

|







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
    Tcl_Size \fIrefCount\fR;
    char *\fIbytes\fR;
    Tcl_Size \fIlength\fR;
    const Tcl_ObjType *\fItypePtr\fR;
    union {
        long \fIlongValue\fR;
        double \fIdoubleValue\fR;
        void *\fIotherValuePtr\fR;
        Tcl_WideInt \fIwideValue\fR;
        struct {

Changes to doc/OpenFileChnl.3.

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
.sp
int
\fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR)
.sp
int
\fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR)
.sp
size_t
\fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR)
.sp
size_t
\fBTcl_Gets\fR(\fIchannel, lineRead\fR)
.sp
size_t
\fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR)
.sp
size_t
\fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR)
.sp
size_t
\fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR)
.sp
size_t
\fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR)
.sp
size_t
\fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR)
.sp
size_t
\fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR)
.sp
int
\fBTcl_Eof\fR(\fIchannel\fR)
.sp
int
\fBTcl_Flush\fR(\fIchannel\fR)







|


|


|


|


|


|


|


|







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
.sp
int
\fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR)
.sp
int
\fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR)
.sp
Tcl_Size
\fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR)
.sp
Tcl_Size
\fBTcl_Gets\fR(\fIchannel, lineRead\fR)
.sp
Tcl_Size
\fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR)
.sp
Tcl_Size
\fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR)
.sp
Tcl_Size
\fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR)
.sp
Tcl_Size
\fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR)
.sp
Tcl_Size
\fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR)
.sp
Tcl_Size
\fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR)
.sp
int
\fBTcl_Eof\fR(\fIchannel\fR)
.sp
int
\fBTcl_Flush\fR(\fIchannel\fR)
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
The name of a local or network file.
.AP "const char" *mode in
Specifies how the file is to be accessed.  May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644.  If a new file is created, these
permissions will be set on the created file.
.AP size_t argc in
The number of elements in \fIargv\fR.
.AP "const char" **argv in
Arguments for constructing a command pipeline.  These values have the same
meaning as the non-switch arguments to the Tcl \fBexec\fR command.
.AP int flags in
Specifies the disposition of the stdio handles in pipeline: OR-ed
combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, and







|







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
The name of a local or network file.
.AP "const char" *mode in
Specifies how the file is to be accessed.  May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644.  If a new file is created, these
permissions will be set on the created file.
.AP Tcl_Size argc in
The number of elements in \fIargv\fR.
.AP "const char" **argv in
Arguments for constructing a command pipeline.  These values have the same
meaning as the non-switch arguments to the Tcl \fBexec\fR command.
.AP int flags in
Specifies the disposition of the stdio handles in pipeline: OR-ed
combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, and
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
The pattern to match on, passed to Tcl_StringMatch, or NULL.
.AP Tcl_Channel channel in
A Tcl channel for input or output.  Must have been the return value
from a procedure such as \fBTcl_OpenFileChannel\fR.
.AP Tcl_Obj *readObjPtr in/out
A pointer to a Tcl value in which to store the characters read from the
channel.
.AP size_t charsToRead in
The number of characters to read from the channel.  If the channel's encoding
is \fBbinary\fR, this is equivalent to the number of bytes to read from the
channel.
.AP int appendFlag in
If non-zero, data read from the channel will be appended to the value.
Otherwise, the data will replace the existing contents of the value.
.AP char *readBuf out
A buffer in which to store the bytes read from the channel.
.AP size_t bytesToRead in
The number of bytes to read from the channel.  The buffer \fIreadBuf\fR must
be large enough to hold this many bytes.
.AP Tcl_Obj *lineObjPtr in/out
A pointer to a Tcl value in which to store the line read from the
channel.  The line read will be appended to the current value of the
value.
.AP Tcl_DString *lineRead in/out
A pointer to a Tcl dynamic string in which to store the line read from the
channel.  Must have been initialized by the caller.  The line read will be
appended to any data already in the dynamic string.
.AP "const char" *input in
The input to add to a channel buffer.
.AP size_t inputLen in
Length of the input
.AP int addAtEnd in
Flag indicating whether the input should be added to the end or
beginning of the channel buffer.
.AP Tcl_Obj *writeObjPtr in
A pointer to a Tcl value whose contents will be output to the channel.
.AP "const char" *charBuf in
A buffer containing the characters to output to the channel.
.AP "const char" *byteBuf in
A buffer containing the bytes to output to the channel.
.AP size_t bytesToWrite in
The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and
output to the channel.
.AP "long long" offset in
How far to move the access point in the channel at which the next input or
output operation will be applied, measured in bytes from the position
given by \fIseekMode\fR.  May be either positive or negative.
.AP int seekMode in







|








|












|










|







150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
The pattern to match on, passed to Tcl_StringMatch, or NULL.
.AP Tcl_Channel channel in
A Tcl channel for input or output.  Must have been the return value
from a procedure such as \fBTcl_OpenFileChannel\fR.
.AP Tcl_Obj *readObjPtr in/out
A pointer to a Tcl value in which to store the characters read from the
channel.
.AP Tcl_Size charsToRead in
The number of characters to read from the channel.  If the channel's encoding
is \fBbinary\fR, this is equivalent to the number of bytes to read from the
channel.
.AP int appendFlag in
If non-zero, data read from the channel will be appended to the value.
Otherwise, the data will replace the existing contents of the value.
.AP char *readBuf out
A buffer in which to store the bytes read from the channel.
.AP Tcl_Size bytesToRead in
The number of bytes to read from the channel.  The buffer \fIreadBuf\fR must
be large enough to hold this many bytes.
.AP Tcl_Obj *lineObjPtr in/out
A pointer to a Tcl value in which to store the line read from the
channel.  The line read will be appended to the current value of the
value.
.AP Tcl_DString *lineRead in/out
A pointer to a Tcl dynamic string in which to store the line read from the
channel.  Must have been initialized by the caller.  The line read will be
appended to any data already in the dynamic string.
.AP "const char" *input in
The input to add to a channel buffer.
.AP Tcl_Size inputLen in
Length of the input
.AP int addAtEnd in
Flag indicating whether the input should be added to the end or
beginning of the channel buffer.
.AP Tcl_Obj *writeObjPtr in
A pointer to a Tcl value whose contents will be output to the channel.
.AP "const char" *charBuf in
A buffer containing the characters to output to the channel.
.AP "const char" *byteBuf in
A buffer containing the bytes to output to the channel.
.AP Tcl_Size bytesToWrite in
The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and
output to the channel.
.AP "long long" offset in
How far to move the access point in the channel at which the next input or
output operation will be applied, measured in bytes from the position
given by \fIseekMode\fR.  May be either positive or negative.
.AP int seekMode in
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
.SH "TCL_READCHARS AND TCL_READ"
.PP
\fBTcl_ReadChars\fR consumes bytes from \fIchannel\fR, converting the bytes
to UTF-8 based on the channel's encoding and storing the produced data in
\fIreadObjPtr\fR's string representation.  The return value of
\fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR,
that were stored in \fIreadObjPtr\fR.  If an error occurs while reading, the
return value is TCL_INDEX_NONE and \fBTcl_ReadChars\fR records a POSIX error code that
can be retrieved with \fBTcl_GetErrno\fR.
.PP
Setting \fIcharsToRead\fR to TCL_INDEX_NONE will cause the command to read
all characters currently available (non-blocking) or everything until
eof (blocking mode).
.PP
The return value may be smaller than the value to read, indicating that less
data than requested was available.  This is called a \fIshort read\fR.  In
blocking mode, this can only happen on an end-of-file.  In nonblocking mode,
a short read can also occur if there is not enough input currently







|


|







402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
.SH "TCL_READCHARS AND TCL_READ"
.PP
\fBTcl_ReadChars\fR consumes bytes from \fIchannel\fR, converting the bytes
to UTF-8 based on the channel's encoding and storing the produced data in
\fIreadObjPtr\fR's string representation.  The return value of
\fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR,
that were stored in \fIreadObjPtr\fR.  If an error occurs while reading, the
return value is -1 and \fBTcl_ReadChars\fR records a POSIX error code that
can be retrieved with \fBTcl_GetErrno\fR.
.PP
Setting \fIcharsToRead\fR to -1 will cause the command to read
all characters currently available (non-blocking) or everything until
eof (blocking mode).
.PP
The return value may be smaller than the value to read, indicating that less
data than requested was available.  This is called a \fIshort read\fR.  In
blocking mode, this can only happen on an end-of-file.  In nonblocking mode,
a short read can also occur if there is not enough input currently
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
channel is treated as an individual Unicode character.  All of the
characters of the line except for the terminating end-of-line character(s)
are appended to \fIlineObjPtr\fR's string representation.  The end-of-line
character(s) are read and discarded.
.PP
If a line was successfully read, the return value is greater than or equal
to zero and indicates the number of bytes stored in \fIlineObjPtr\fR.  If an
error occurs, \fBTcl_GetsObj\fR returns TCL_INDEX_NONE and records a POSIX error code
that can be retrieved with \fBTcl_GetErrno\fR.  \fBTcl_GetsObj\fR also
returns TCL_INDEX_NONE if the end of the file is reached; the \fBTcl_Eof\fR procedure
can be used to distinguish an error from an end-of-file condition.
.PP
If the channel is in nonblocking mode, the return value can also be TCL_INDEX_NONE
if no data was available or the data that was available did not contain an
end-of-line character.  When TCL_INDEX_NONE is returned, the \fBTcl_InputBlocked\fR
procedure may be invoked to determine if the channel is blocked because
of input unavailability.
.PP
\fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting
characters are appended to the dynamic string given by
\fIlineRead\fR rather than a Tcl value.
.SH "TCL_UNGETS"
.PP
\fBTcl_Ungets\fR is used to add data to the input queue of a channel,
at either the head or tail of the queue.  The pointer \fIinput\fR points
to the data that is to be added.  The length of the input to add is given
by \fIinputLen\fR.  A non-zero value of \fIaddAtEnd\fR indicates that the
data is to be added at the end of queue; otherwise it will be added at the
head of the queue.  If \fIchannel\fR has a
.QW sticky
EOF set, no data will be
added to the input queue.  \fBTcl_Ungets\fR returns \fIinputLen\fR or
TCL_INDEX_NONE if an error occurs.
.SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE"
.PP
\fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at
\fIcharBuf\fR.  The UTF-8 characters in the buffer are converted to the
channel's encoding and queued for output to \fIchannel\fR.  If
\fIbytesToWrite\fR is negative, \fBTcl_WriteChars\fR expects \fIcharBuf\fR
to be null-terminated and it outputs everything up to the null.
.PP
Data queued for output may not appear on the output device immediately, due
to internal buffering.  If the data should appear immediately, call
\fBTcl_Flush\fR after the call to \fBTcl_WriteChars\fR, or set the
\fB\-buffering\fR option on the channel to \fBnone\fR.  If you wish the data
to appear as soon as a complete line is accepted for output, set the
\fB\-buffering\fR option on the channel to \fBline\fR mode.
.PP
The return value of \fBTcl_WriteChars\fR is a count of how many bytes were
accepted for output to the channel.  This is either TCL_INDEX_NONE to
indicate that an error occurred or another number greater than
zero to indicate success.  If an error occurs, \fBTcl_WriteChars\fR records
a POSIX error code that may be retrieved with \fBTcl_GetErrno\fR.
.PP
Newline characters in the output data are translated to platform-specific
end-of-line sequences according to the \fB\-translation\fR option for the
channel.  This is done even if the channel has no encoding.







|

|


|

|

















|
















|







467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
channel is treated as an individual Unicode character.  All of the
characters of the line except for the terminating end-of-line character(s)
are appended to \fIlineObjPtr\fR's string representation.  The end-of-line
character(s) are read and discarded.
.PP
If a line was successfully read, the return value is greater than or equal
to zero and indicates the number of bytes stored in \fIlineObjPtr\fR.  If an
error occurs, \fBTcl_GetsObj\fR returns -1 and records a POSIX error code
that can be retrieved with \fBTcl_GetErrno\fR.  \fBTcl_GetsObj\fR also
returns -1 if the end of the file is reached; the \fBTcl_Eof\fR procedure
can be used to distinguish an error from an end-of-file condition.
.PP
If the channel is in nonblocking mode, the return value can also be -1
if no data was available or the data that was available did not contain an
end-of-line character.  When -1 is returned, the \fBTcl_InputBlocked\fR
procedure may be invoked to determine if the channel is blocked because
of input unavailability.
.PP
\fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting
characters are appended to the dynamic string given by
\fIlineRead\fR rather than a Tcl value.
.SH "TCL_UNGETS"
.PP
\fBTcl_Ungets\fR is used to add data to the input queue of a channel,
at either the head or tail of the queue.  The pointer \fIinput\fR points
to the data that is to be added.  The length of the input to add is given
by \fIinputLen\fR.  A non-zero value of \fIaddAtEnd\fR indicates that the
data is to be added at the end of queue; otherwise it will be added at the
head of the queue.  If \fIchannel\fR has a
.QW sticky
EOF set, no data will be
added to the input queue.  \fBTcl_Ungets\fR returns \fIinputLen\fR or
-1 if an error occurs.
.SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE"
.PP
\fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at
\fIcharBuf\fR.  The UTF-8 characters in the buffer are converted to the
channel's encoding and queued for output to \fIchannel\fR.  If
\fIbytesToWrite\fR is negative, \fBTcl_WriteChars\fR expects \fIcharBuf\fR
to be null-terminated and it outputs everything up to the null.
.PP
Data queued for output may not appear on the output device immediately, due
to internal buffering.  If the data should appear immediately, call
\fBTcl_Flush\fR after the call to \fBTcl_WriteChars\fR, or set the
\fB\-buffering\fR option on the channel to \fBnone\fR.  If you wish the data
to appear as soon as a complete line is accepted for output, set the
\fB\-buffering\fR option on the channel to \fBline\fR mode.
.PP
The return value of \fBTcl_WriteChars\fR is a count of how many bytes were
accepted for output to the channel.  This is either -1 to
indicate that an error occurred or another number greater than
zero to indicate success.  If an error occurs, \fBTcl_WriteChars\fR records
a POSIX error code that may be retrieved with \fBTcl_GetErrno\fR.
.PP
Newline characters in the output data are translated to platform-specific
end-of-line sequences according to the \fB\-translation\fR option for the
channel.  This is done even if the channel has no encoding.

Changes to doc/ParseArgs.3.

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
\fBTcl_ParseArgsObjv\fR(\fIinterp, argTable, objcPtr, objv, remObjv\fR)
.SH ARGUMENTS
.AS "const Tcl_ArgvInfo" ***remObjv in/out
.AP Tcl_Interp *interp out
Where to store error messages.
.AP "const Tcl_ArgvInfo" *argTable in
Pointer to array of option descriptors.
.AP "size_t \&| int" *objcPtr in/out
A pointer to variable holding number of arguments in \fIobjv\fR. Will be
modified to hold number of arguments left in the unprocessed argument list
stored in \fIremObjv\fR.
.AP "Tcl_Obj *const" *objv in
The array of arguments to be parsed.
.AP Tcl_Obj ***remObjv out
Pointer to a variable that will hold the array of unprocessed arguments.







|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
\fBTcl_ParseArgsObjv\fR(\fIinterp, argTable, objcPtr, objv, remObjv\fR)
.SH ARGUMENTS
.AS "const Tcl_ArgvInfo" ***remObjv in/out
.AP Tcl_Interp *interp out
Where to store error messages.
.AP "const Tcl_ArgvInfo" *argTable in
Pointer to array of option descriptors.
.AP "Tcl_Size \&| int" *objcPtr in/out
A pointer to variable holding number of arguments in \fIobjv\fR. Will be
modified to hold number of arguments left in the unprocessed argument list
stored in \fIremObjv\fR.
.AP "Tcl_Obj *const" *objv in
The array of arguments to be parsed.
.AP Tcl_Obj ***remObjv out
Pointer to a variable that will hold the array of unprocessed arguments.

Changes to doc/ParseCmd.3.

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
For procedures other than \fBTcl_FreeParse\fR and
\fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating
the script and also is used for error reporting; must not be NULL.
.AP "const char" *start in
Pointer to first character in string to parse.
.AP size_t numBytes in
Number of bytes in string to parse, not including any terminating null
character.  If less than 0 then the script consists of all characters
following \fIstart\fR up to the first null character.
.AP int nested in
Non-zero means that the script is part of a command substitution so an
unquoted close bracket should be treated as a command terminator.  If zero,
close brackets have no special meaning.







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
For procedures other than \fBTcl_FreeParse\fR and
\fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating
the script and also is used for error reporting; must not be NULL.
.AP "const char" *start in
Pointer to first character in string to parse.
.AP Tcl_Size numBytes in
Number of bytes in string to parse, not including any terminating null
character.  If less than 0 then the script consists of all characters
following \fIstart\fR up to the first null character.
.AP int nested in
Non-zero means that the script is part of a command substitution so an
unquoted close bracket should be treated as a command terminator.  If zero,
close brackets have no special meaning.
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR
return parse information in two data structures, Tcl_Parse and Tcl_Token:
.PP
.CS
typedef struct Tcl_Parse {
    const char *\fIcommentStart\fR;
    size_t \fIcommentSize\fR;
    const char *\fIcommandStart\fR;
    size_t \fIcommandSize\fR;
    size_t \fInumWords\fR;
    Tcl_Token *\fItokenPtr\fR;
    size_t \fInumTokens\fR;
    ...
} \fBTcl_Parse\fR;

typedef struct Tcl_Token {
    int \fItype\fR;
    const char *\fIstart\fR;
    size_t \fIsize\fR;
    size_t \fInumComponents\fR;
} \fBTcl_Token\fR;
.CE
.PP
The first five fields of a Tcl_Parse structure
are filled in only by \fBTcl_ParseCommand\fR.
These fields are not used by the other parsing procedures.
.PP







|

|
|

|






|
|







192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR
return parse information in two data structures, Tcl_Parse and Tcl_Token:
.PP
.CS
typedef struct Tcl_Parse {
    const char *\fIcommentStart\fR;
    Tcl_Size \fIcommentSize\fR;
    const char *\fIcommandStart\fR;
    Tcl_Size \fIcommandSize\fR;
    Tcl_Size \fInumWords\fR;
    Tcl_Token *\fItokenPtr\fR;
    Tcl_Size \fInumTokens\fR;
    ...
} \fBTcl_Parse\fR;

typedef struct Tcl_Token {
    int \fItype\fR;
    const char *\fIstart\fR;
    Tcl_Size \fIsize\fR;
    Tcl_Size \fInumComponents\fR;
} \fBTcl_Token\fR;
.CE
.PP
The first five fields of a Tcl_Parse structure
are filled in only by \fBTcl_ParseCommand\fR.
These fields are not used by the other parsing procedures.
.PP

Changes to doc/PkgRequire.3.

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
.AP "const void" *clientData in
Arbitrary value to be associated with the package.
.AP void *clientDataPtr out
Pointer to place to store the value associated with the matching
package. It is only changed if the pointer is not NULL and the
function completed successfully. The storage can be any pointer
type with the same size as a void pointer.
.AP size_t objc in
Number of requirements.
.AP Tcl_Obj* objv[] in
Array of requirements.
.BE
.SH DESCRIPTION
.PP
These procedures provide C-level interfaces to Tcl's package and







|







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
.AP "const void" *clientData in
Arbitrary value to be associated with the package.
.AP void *clientDataPtr out
Pointer to place to store the value associated with the matching
package. It is only changed if the pointer is not NULL and the
function completed successfully. The storage can be any pointer
type with the same size as a void pointer.
.AP Tcl_Size objc in
Number of requirements.
.AP Tcl_Obj* objv[] in
Array of requirements.
.BE
.SH DESCRIPTION
.PP
These procedures provide C-level interfaces to Tcl's package and

Changes to doc/RegExp.3.

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
.AP "const char" *start in
If \fItext\fR is just a portion of some other string, this argument
identifies the beginning of the larger string.
If it is not the same as \fItext\fR, then no
.QW \fB^\fR
matches will be allowed.
.AP size_t index in
Specifies which range is desired:  0 means the range of the entire
match, 1 or greater means the range that matched a parenthesized
sub-expression.
.AP "const char" **startPtr out
The address of the first character in the range is stored here, or
NULL if there is no such range.
.AP "const char" **endPtr out
The address of the character just after the last one in the range
is stored here, or NULL if there is no such range.
.AP int cflags in
OR-ed combination of the compilation flags \fBTCL_REG_ADVANCED\fR,
\fBTCL_REG_EXTENDED\fR, \fBTCL_REG_BASIC\fR, \fBTCL_REG_EXPANDED\fR,
\fBTCL_REG_QUOTE\fR, \fBTCL_REG_NOCASE\fR, \fBTCL_REG_NEWLINE\fR,
\fBTCL_REG_NLSTOP\fR, \fBTCL_REG_NLANCH\fR, \fBTCL_REG_NOSUB\fR, and
\fBTCL_REG_CANMATCH\fR. See below for more information.
.AP size_t offset in
The character offset into the text where matching should begin.
The value of the offset has no impact on \fB^\fR matches.  This
behavior is controlled by \fIeflags\fR.
.AP size_t nmatches in
The number of matching subexpressions that should be remembered for
later use.  If this value is 0, then no subexpression match
information will be computed.  If the value is TCL_INDEX_NONE, then
all of the matching subexpressions will be remembered.  Any other
value will be taken as the maximum number of subexpressions to
remember.
.AP int eflags in
OR-ed combination of the execution flags \fBTCL_REG_NOTBOL\fR and
\fBTCL_REG_NOTEOL\fR. See below for more information.
.AP Tcl_RegExpInfo *infoPtr out







|















|



|


|







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
.AP "const char" *start in
If \fItext\fR is just a portion of some other string, this argument
identifies the beginning of the larger string.
If it is not the same as \fItext\fR, then no
.QW \fB^\fR
matches will be allowed.
.AP Tcl_Size index in
Specifies which range is desired:  0 means the range of the entire
match, 1 or greater means the range that matched a parenthesized
sub-expression.
.AP "const char" **startPtr out
The address of the first character in the range is stored here, or
NULL if there is no such range.
.AP "const char" **endPtr out
The address of the character just after the last one in the range
is stored here, or NULL if there is no such range.
.AP int cflags in
OR-ed combination of the compilation flags \fBTCL_REG_ADVANCED\fR,
\fBTCL_REG_EXTENDED\fR, \fBTCL_REG_BASIC\fR, \fBTCL_REG_EXPANDED\fR,
\fBTCL_REG_QUOTE\fR, \fBTCL_REG_NOCASE\fR, \fBTCL_REG_NEWLINE\fR,
\fBTCL_REG_NLSTOP\fR, \fBTCL_REG_NLANCH\fR, \fBTCL_REG_NOSUB\fR, and
\fBTCL_REG_CANMATCH\fR. See below for more information.
.AP Tcl_Size offset in
The character offset into the text where matching should begin.
The value of the offset has no impact on \fB^\fR matches.  This
behavior is controlled by \fIeflags\fR.
.AP Tcl_Size nmatches in
The number of matching subexpressions that should be remembered for
later use.  If this value is 0, then no subexpression match
information will be computed.  If the value is negative, then
all of the matching subexpressions will be remembered.  Any other
value will be taken as the maximum number of subexpressions to
remember.
.AP int eflags in
OR-ed combination of the execution flags \fBTCL_REG_NOTBOL\fR and
\fBTCL_REG_NOTEOL\fR. See below for more information.
.AP Tcl_RegExpInfo *infoPtr out
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
\fBTcl_RegExpGetInfo\fR retrieves information about the last match
performed with a given regular expression \fIregexp\fR.  The
\fIinfoPtr\fR argument contains a pointer to a structure that is
defined as follows:
.PP
.CS
typedef struct Tcl_RegExpInfo {
    size_t \fInsubs\fR;
    Tcl_RegExpIndices *\fImatches\fR;
    size_t \fIextendStart\fR;
} \fBTcl_RegExpInfo\fR;
.CE
.PP
The \fInsubs\fR field contains a count of the number of parenthesized
subexpressions within the regular expression.  If the \fBTCL_REG_NOSUB\fR
was used, then this value will be zero.  The \fImatches\fR field
points to an array of \fInsubs\fR+1 values that indicate the bounds of each
subexpression matched.  The first element in the array refers to the
range matched by the entire regular expression, and subsequent elements
refer to the parenthesized subexpressions in the order that they
appear in the pattern.  Each element is a structure that is defined as
follows:
.PP
.CS
typedef struct Tcl_RegExpIndices {
    size_t \fIstart\fR;
    size_t \fIend\fR;
} \fBTcl_RegExpIndices\fR;
.CE
.PP
The \fIstart\fR and \fIend\fR values are Unicode character indices
relative to the offset location within \fIobjPtr\fR where matching began.
The \fIstart\fR index identifies the first character of the matched
subexpression.  The \fIend\fR index identifies the first character







|

|















|
|







333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
\fBTcl_RegExpGetInfo\fR retrieves information about the last match
performed with a given regular expression \fIregexp\fR.  The
\fIinfoPtr\fR argument contains a pointer to a structure that is
defined as follows:
.PP
.CS
typedef struct Tcl_RegExpInfo {
    Tcl_Size \fInsubs\fR;
    Tcl_RegExpIndices *\fImatches\fR;
    Tcl_Size \fIextendStart\fR;
} \fBTcl_RegExpInfo\fR;
.CE
.PP
The \fInsubs\fR field contains a count of the number of parenthesized
subexpressions within the regular expression.  If the \fBTCL_REG_NOSUB\fR
was used, then this value will be zero.  The \fImatches\fR field
points to an array of \fInsubs\fR+1 values that indicate the bounds of each
subexpression matched.  The first element in the array refers to the
range matched by the entire regular expression, and subsequent elements
refer to the parenthesized subexpressions in the order that they
appear in the pattern.  Each element is a structure that is defined as
follows:
.PP
.CS
typedef struct Tcl_RegExpIndices {
    Tcl_Size \fIstart\fR;
    Tcl_Size \fIend\fR;
} \fBTcl_RegExpIndices\fR;
.CE
.PP
The \fIstart\fR and \fIend\fR values are Unicode character indices
relative to the offset location within \fIobjPtr\fR where matching began.
The \fIstart\fR index identifies the first character of the matched
subexpression.  The \fIend\fR index identifies the first character

Changes to doc/SetRecLmt.3.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
.BS
.SH NAME
Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
size_t
\fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Interpreter whose recursion limit is to be set.
Must be greater than zero.
.AP size_t depth in
New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR.
.BE

.SH DESCRIPTION
.PP
At any given time Tcl enforces a limit on the number of recursive
calls that may be active for \fBTcl_Eval\fR and related procedures







|






|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
.BS
.SH NAME
Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Size
\fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Interpreter whose recursion limit is to be set.
Must be greater than zero.
.AP Tcl_Size depth in
New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR.
.BE

.SH DESCRIPTION
.PP
At any given time Tcl enforces a limit on the number of recursive
calls that may be active for \fBTcl_Eval\fR and related procedures

Changes to doc/SplitList.3.

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
.sp
int
\fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR)
.sp
char *
\fBTcl_Merge\fR(\fIargc, argv\fR)
.sp
size_t
\fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR)
.sp
size_t
\fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR)
.sp
size_t
\fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR)
.sp
size_t
\fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR)
.SH ARGUMENTS
.AS "const char *const" ***argvPtr out
.AP Tcl_Interp *interp out
Interpreter to use for error reporting.  If NULL, then no error message
is left.
.AP "const char" *list in
Pointer to a string with proper list structure.
.AP "size_t \&| int" *argcPtr out
Filled in with number of elements in \fIlist\fR.
.AP "const char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIlist\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP size_t argc in
Number of elements in \fIargv\fR.
.AP "const char *const" *argv in
Array of strings to merge together into a single list.
Each string will become a separate element of the list.
.AP "const char" *src in
String that is to become an element of a list.
.AP int *flagsPtr in
Pointer to word to fill in with information about \fIsrc\fR.
The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR.
.AP size_t length in
Number of bytes in string \fIsrc\fR.
.AP char *dst in
Place to copy converted list element.  Must contain enough characters
to hold converted string.
.AP int flags in
Information about \fIsrc\fR. Must be value returned by previous
call to \fBTcl_ScanElement\fR, possibly OR-ed







|


|


|


|








|






|









|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
.sp
int
\fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR)
.sp
char *
\fBTcl_Merge\fR(\fIargc, argv\fR)
.sp
Tcl_Size
\fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR)
.sp
Tcl_Size
\fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR)
.sp
Tcl_Size
\fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR)
.sp
Tcl_Size
\fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR)
.SH ARGUMENTS
.AS "const char *const" ***argvPtr out
.AP Tcl_Interp *interp out
Interpreter to use for error reporting.  If NULL, then no error message
is left.
.AP "const char" *list in
Pointer to a string with proper list structure.
.AP "Tcl_Size \&| int" *argcPtr out
Filled in with number of elements in \fIlist\fR.
.AP "const char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIlist\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP Tcl_Size argc in
Number of elements in \fIargv\fR.
.AP "const char *const" *argv in
Array of strings to merge together into a single list.
Each string will become a separate element of the list.
.AP "const char" *src in
String that is to become an element of a list.
.AP int *flagsPtr in
Pointer to word to fill in with information about \fIsrc\fR.
The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR.
.AP Tcl_Size length in
Number of bytes in string \fIsrc\fR.
.AP char *dst in
Place to copy converted list element.  Must contain enough characters
to hold converted string.
.AP int flags in
Information about \fIsrc\fR. Must be value returned by previous
call to \fBTcl_ScanElement\fR, possibly OR-ed
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
addition to the array of pointers, it
also holds copies of all the list elements.  It is the caller's
responsibility to free up all of this storage.
For example, suppose that you have called \fBTcl_SplitList\fR with
the following code:
.PP
.CS
size_t argc;
int code;
char *string;
char **argv;
\&...
code = \fBTcl_SplitList\fR(interp, string, &argc, &argv);
.CE
.PP







|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
addition to the array of pointers, it
also holds copies of all the list elements.  It is the caller's
responsibility to free up all of this storage.
For example, suppose that you have called \fBTcl_SplitList\fR with
the following code:
.PP
.CS
Tcl_Size argc;
int code;
char *string;
char **argv;
\&...
code = \fBTcl_SplitList\fR(interp, string, &argc, &argv);
.CE
.PP

Changes to doc/SplitPath.3.

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Tcl_PathType
\fBTcl_GetPathType\fR(\fIpath\fR)
.SH ARGUMENTS
.AS "const char *const" ***argvPtr in/out
.AP "const char" *path in
File path in a form appropriate for the current platform (see the
\fBfilename\fR manual entry for acceptable forms for path names).
.AP "size_t \&| int" *argcPtr out
Filled in with number of path elements in \fIpath\fR.
.AP "const char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIpath\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP size_t argc in
Number of elements in \fIargv\fR.
.AP "const char *const" *argv in
Array of path elements to merge together into a single path.
.AP Tcl_DString *resultPtr in/out
A pointer to an initialized \fBTcl_DString\fR to which the result of
\fBTcl_JoinPath\fR will be appended.
.BE







|






|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Tcl_PathType
\fBTcl_GetPathType\fR(\fIpath\fR)
.SH ARGUMENTS
.AS "const char *const" ***argvPtr in/out
.AP "const char" *path in
File path in a form appropriate for the current platform (see the
\fBfilename\fR manual entry for acceptable forms for path names).
.AP "Tcl_Size \&| int" *argcPtr out
Filled in with number of path elements in \fIpath\fR.
.AP "const char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIpath\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP Tcl_Size argc in
Number of elements in \fIargv\fR.
.AP "const char *const" *argv in
Array of path elements to merge together into a single path.
.AP Tcl_DString *resultPtr in/out
A pointer to an initialized \fBTcl_DString\fR to which the result of
\fBTcl_JoinPath\fR will be appended.
.BE
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
dynamically allocated; in addition to the array of pointers, it also
holds copies of all the path elements.  It is the caller's
responsibility to free all of this storage.
For example, suppose that you have called \fBTcl_SplitPath\fR with the
following code:
.PP
.CS
size_t argc;
char *path;
char **argv;
\&...
Tcl_SplitPath(string, &argc, &argv);
.CE
.PP
Then you should eventually free the storage with a call like the







|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
dynamically allocated; in addition to the array of pointers, it also
holds copies of all the path elements.  It is the caller's
responsibility to free all of this storage.
For example, suppose that you have called \fBTcl_SplitPath\fR with the
following code:
.PP
.CS
Tcl_Size argc;
char *path;
char **argv;
\&...
Tcl_SplitPath(string, &argc, &argv);
.CE
.PP
Then you should eventually free the storage with a call like the

Changes to doc/StringObj.3.

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
.sp
Tcl_UniChar *
\fBTcl_GetUnicode\fR(\fIobjPtr\fR)
.sp
int
\fBTcl_GetUniChar\fR(\fIobjPtr, index\fR)
.sp
size_t
\fBTcl_GetCharLength\fR(\fIobjPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetRange\fR(\fIobjPtr, first, last\fR)
.sp
void
\fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR)







|







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
.sp
Tcl_UniChar *
\fBTcl_GetUnicode\fR(\fIobjPtr\fR)
.sp
int
\fBTcl_GetUniChar\fR(\fIobjPtr, index\fR)
.sp
Tcl_Size
\fBTcl_GetCharLength\fR(\fIobjPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetRange\fR(\fIobjPtr, first, last\fR)
.sp
void
\fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR)
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *appendObjPtr in/out
.AP "const char" *bytes in
Points to the first byte of an array of UTF-8-encoded bytes
used to set or append to a string value.
This byte array may contain embedded null characters
unless \fInumChars\fR is \fBTCL_INDEX_NONE\fR.  (Applications needing null bytes
should represent them as the two-byte sequence \fI\e300\e200\fR, use
\fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if
the string is a collection of uninterpreted bytes.)
.AP size_t length in
The number of bytes to copy from \fIbytes\fR when
initializing, setting, or appending to a string value.
If \fBTCL_INDEX_NONE\fR, all bytes up to the first null are used.
.AP "const Tcl_UniChar" *unicode in
Points to the first byte of an array of Unicode characters
used to set or append to a string value.
This byte array may contain embedded null characters
unless \fInumChars\fR is \fBTCL_INDEX_NONE\fR.
.AP size_t numChars in
The number of Unicode characters to copy from \fIunicode\fR when
initializing, setting, or appending to a string value.
If \fBTCL_INDEX_NONE\fR, all characters up to the first null character are used.
.AP size_t index in
The index of the Unicode character to return.
.AP size_t first in
The index of the first Unicode character in the Unicode range to be
returned as a new value. If \fBTCL_INDEX_NONE\fR, behave the same as if the
value was 0.
.AP size_t last in
The index of the last Unicode character in the Unicode range to be
returned as a new value. If \fBTCL_INDEX_NONE\fR, take all characters up to
the last one available.
.AP Tcl_Obj *objPtr in/out
Points to a value to manipulate.
.AP Tcl_Obj *appendObjPtr in
The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR.
.AP "size_t \&| int" *lengthPtr out
The location where \fBTcl_GetStringFromObj\fR will store the length
of a value's string representation. May be (int *)NULL when not used.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP size_t limit in
Maximum number of bytes to be appended.
.AP "const char" *ellipsis in
Suffix to append when the limit leads to string truncation.
If NULL is passed then the suffix
.QW "..."
is used.
.AP "const char" *format in
Format control string including % conversion specifiers.
.AP size_t objc in
The number of elements to format or concatenate.
.AP Tcl_Obj *objv[] in
The array of values to format or concatenate.
.AP size_t newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.BE
.SH DESCRIPTION
.PP
The procedures described in this manual entry allow Tcl values to
be manipulated as string values.  They use the internal representation







|



|


|




|
|


|
|

|

|

|

|





|







|








|



|







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *appendObjPtr in/out
.AP "const char" *bytes in
Points to the first byte of an array of UTF-8-encoded bytes
used to set or append to a string value.
This byte array may contain embedded null characters
unless \fInumChars\fR is negative.  (Applications needing null bytes
should represent them as the two-byte sequence \fI\e300\e200\fR, use
\fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if
the string is a collection of uninterpreted bytes.)
.AP Tcl_Size length in
The number of bytes to copy from \fIbytes\fR when
initializing, setting, or appending to a string value.
If negative, all bytes up to the first null are used.
.AP "const Tcl_UniChar" *unicode in
Points to the first byte of an array of Unicode characters
used to set or append to a string value.
This byte array may contain embedded null characters
unless \fInumChars\fR is negative.
.AP Tcl_Size numChars in
The number of Unicode characters to copy from \fIunicode\fR when
initializing, setting, or appending to a string value.
If negative, all characters up to the first null character are used.
.AP Tcl_Size index in
The index of the Unicode character to return.
.AP Tcl_Size first in
The index of the first Unicode character in the Unicode range to be
returned as a new value. If negative, behave the same as if the
value was 0.
.AP Tcl_Size last in
The index of the last Unicode character in the Unicode range to be
returned as a new value. If negative, take all characters up to
the last one available.
.AP Tcl_Obj *objPtr in/out
Points to a value to manipulate.
.AP Tcl_Obj *appendObjPtr in
The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR.
.AP "ptrdiff_t \&| int" *lengthPtr out
The location where \fBTcl_GetStringFromObj\fR will store the length
of a value's string representation. May be (int *)NULL when not used.
.AP "const char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP Tcl_Size limit in
Maximum number of bytes to be appended.
.AP "const char" *ellipsis in
Suffix to append when the limit leads to string truncation.
If NULL is passed then the suffix
.QW "..."
is used.
.AP "const char" *format in
Format control string including % conversion specifiers.
.AP Tcl_Size objc in
The number of elements to format or concatenate.
.AP Tcl_Obj *objv[] in
The array of values to format or concatenate.
.AP Tcl_Size newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.BE
.SH DESCRIPTION
.PP
The procedures described in this manual entry allow Tcl values to
be manipulated as string values.  They use the internal representation
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
value's Unicode representation. If the index is out of range or
it references a low surrogate preceded by a high surrogate, it returns -1;
.PP
\fBTcl_GetRange\fR returns a newly created value comprised of the
characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's
Unicode representation.  If the value's Unicode representation
is invalid, the Unicode representation is regenerated from the value's
string representation.  If \fIfirst\fR == TCL_INDEX_NONE, then the returned
string starts at the beginning of the value. If \fIlast\fR == TCL_INDEX_NONE,
then the returned string ends at the end of the value.
.PP
\fBTcl_GetCharLength\fR returns the number of characters (as opposed
to bytes) in the string value.
.PP
\fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and
\fIlength\fR to the string representation of the value specified by







|
|







209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
value's Unicode representation. If the index is out of range or
it references a low surrogate preceded by a high surrogate, it returns -1;
.PP
\fBTcl_GetRange\fR returns a newly created value comprised of the
characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's
Unicode representation.  If the value's Unicode representation
is invalid, the Unicode representation is regenerated from the value's
string representation.  If \fIfirst\fR is negative, then the returned
string starts at the beginning of the value. If \fIlast\fR negative,
then the returned string ends at the end of the value.
.PP
\fBTcl_GetCharLength\fR returns the number of characters (as opposed
to bytes) in the string value.
.PP
\fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and
\fIlength\fR to the string representation of the value specified by
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
end result should be kept short enough to be read.
Bytes from \fIbytes\fR are appended to \fIobjPtr\fR, but no more
than \fIlimit\fR bytes total are to be appended. If the limit prevents
all \fIlength\fR bytes that are available from being appended, then the
appending is done so that the last bytes appended are from the
string \fIellipsis\fR. This allows for an indication of the truncation
to be left in the string.
When \fIlength\fR is \fBTCL_INDEX_NONE\fR, all bytes up to the first zero byte are appended,
subject to the limit. When \fIellipsis\fR is NULL, the default
string \fB...\fR is used. When \fIellipsis\fR is non-NULL, it must point
to a zero-byte-terminated string in Tcl's internal UTF encoding.
The number of bytes appended can be less than the lesser
of \fIlength\fR and \fIlimit\fR when appending fewer
bytes is necessary to append only whole multi-byte characters.
.PP







|







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
end result should be kept short enough to be read.
Bytes from \fIbytes\fR are appended to \fIobjPtr\fR, but no more
than \fIlimit\fR bytes total are to be appended. If the limit prevents
all \fIlength\fR bytes that are available from being appended, then the
appending is done so that the last bytes appended are from the
string \fIellipsis\fR. This allows for an indication of the truncation
to be left in the string.
When \fIlength\fR is negative, all bytes up to the first zero byte are appended,
subject to the limit. When \fIellipsis\fR is NULL, the default
string \fB...\fR is used. When \fIellipsis\fR is non-NULL, it must point
to a zero-byte-terminated string in Tcl's internal UTF encoding.
The number of bytes appended can be less than the lesser
of \fIlength\fR and \fIlimit\fR when appending fewer
bytes is necessary to append only whole multi-byte characters.
.PP
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
functionality is needed.
.PP
\fBTcl_ObjPrintf\fR serves as a replacement for the common sequence
.PP
.CS
char buf[SOME_SUITABLE_LENGTH];
sprintf(buf, format, ...);
\fBTcl_NewStringObj\fR(buf, \fBTCL_INDEX_NONE\fR);
.CE
.PP
but with greater convenience and no need to
determine \fBSOME_SUITABLE_LENGTH\fR. The formatting is done with the same
core formatting engine used by \fBTcl_Format\fR.  This means the set of
supported conversion specifiers is that of the \fBformat\fR command and
not that of the \fBsprintf\fR routine where the two sets differ. When a







|







302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
functionality is needed.
.PP
\fBTcl_ObjPrintf\fR serves as a replacement for the common sequence
.PP
.CS
char buf[SOME_SUITABLE_LENGTH];
sprintf(buf, format, ...);
\fBTcl_NewStringObj\fR(buf, -1);
.CE
.PP
but with greater convenience and no need to
determine \fBSOME_SUITABLE_LENGTH\fR. The formatting is done with the same
core formatting engine used by \fBTcl_Format\fR.  This means the set of
supported conversion specifiers is that of the \fBformat\fR command and
not that of the \fBsprintf\fR routine where the two sets differ. When a

Changes to doc/TclZlib.3.

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this
dictionary.
.AP "unsigned int" initValue in
The initial value for the checksum algorithm.
.AP "unsigned char" *bytes in
An array of bytes to run the checksum algorithm over, or NULL to get the
recommended initial value for the checksum algorithm.
.AP size_t length in
The number of bytes in the array.
.AP int mode in
What mode to operate the stream in. Should be either
\fBTCL_ZLIB_STREAM_DEFLATE\fR for a compressing stream or
\fBTCL_ZLIB_STREAM_INFLATE\fR for a decompressing stream.
.AP Tcl_ZlibStream *zshandlePtr out
A pointer to a variable in which to write the abstract token for the stream
upon successful creation.
.AP Tcl_ZlibStream zshandle in
The abstract token for the stream to operate on.
.AP int flush in
Whether and how to flush the stream after writing the data to it. Must be one
of: \fBTCL_ZLIB_NO_FLUSH\fR if no flushing is to be done, \fBTCL_ZLIB_FLUSH\fR
if the currently compressed data must be made available for access using
\fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put
into a state where the decompressor can recover from on corruption, or
\fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any
trailer demanded by the format is written.
.AP size_t count in
The maximum number of bytes to get from the stream, or TCL_INDEX_NONE to get
all remaining bytes from the stream's buffers.
.AP Tcl_Obj *compDict in
A byte array value that is the compression dictionary to use with the stream.
Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this
only ever be used with streams that were created with their \fIformat\fR set
to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to
indicate whether a compression dictionary was present other than to fail on







|


















|
|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this
dictionary.
.AP "unsigned int" initValue in
The initial value for the checksum algorithm.
.AP "unsigned char" *bytes in
An array of bytes to run the checksum algorithm over, or NULL to get the
recommended initial value for the checksum algorithm.
.AP Tcl_Size length in
The number of bytes in the array.
.AP int mode in
What mode to operate the stream in. Should be either
\fBTCL_ZLIB_STREAM_DEFLATE\fR for a compressing stream or
\fBTCL_ZLIB_STREAM_INFLATE\fR for a decompressing stream.
.AP Tcl_ZlibStream *zshandlePtr out
A pointer to a variable in which to write the abstract token for the stream
upon successful creation.
.AP Tcl_ZlibStream zshandle in
The abstract token for the stream to operate on.
.AP int flush in
Whether and how to flush the stream after writing the data to it. Must be one
of: \fBTCL_ZLIB_NO_FLUSH\fR if no flushing is to be done, \fBTCL_ZLIB_FLUSH\fR
if the currently compressed data must be made available for access using
\fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put
into a state where the decompressor can recover from on corruption, or
\fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any
trailer demanded by the format is written.
.AP Tcl_Size count in
The maximum number of bytes to get from the stream, or -1 to get
all remaining bytes from the stream's buffers.
.AP Tcl_Obj *compDict in
A byte array value that is the compression dictionary to use with the stream.
Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this
only ever be used with streams that were created with their \fIformat\fR set
to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to
indicate whether a compression dictionary was present other than to fail on

Changes to doc/Tcl_Main.3.

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
.sp
Tcl_Obj *
\fBTcl_GetStartupScript\fR(\fIencodingPtr\fR)
.sp
\fBTcl_SetMainLoop\fR(\fImainLoopProc\fR)
.SH ARGUMENTS
.AS Tcl_MainLoopProc *mainLoopProc
.AP size_t argc in
Number of elements in \fIargv\fR.
.AP char *argv[] in
Array of strings containing command-line arguments. On Windows, when
using -DUNICODE, the parameter type changes to wchar_t *.
.AP char *charargv[] in
As argv, but does not change type to wchar_t.
.AP char *wideargv[] in







|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
.sp
Tcl_Obj *
\fBTcl_GetStartupScript\fR(\fIencodingPtr\fR)
.sp
\fBTcl_SetMainLoop\fR(\fImainLoopProc\fR)
.SH ARGUMENTS
.AS Tcl_MainLoopProc *mainLoopProc
.AP Tcl_Size argc in
Number of elements in \fIargv\fR.
.AP char *argv[] in
Array of strings containing command-line arguments. On Windows, when
using -DUNICODE, the parameter type changes to wchar_t *.
.AP char *charargv[] in
As argv, but does not change type to wchar_t.
.AP char *wideargv[] in

Changes to doc/ToUpper.3.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
.sp
int
\fBTcl_UniCharToLower\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharToTitle\fR(\fIch\fR)
.sp
size_t
\fBTcl_UtfToUpper\fR(\fIstr\fR)
.sp
size_t
\fBTcl_UtfToLower\fR(\fIstr\fR)
.sp
size_t
\fBTcl_UtfToTitle\fR(\fIstr\fR)
.SH ARGUMENTS
.AS char *str in/out
.AP int ch in
The Unicode character to be converted.
.AP char *str in/out
Pointer to UTF-8 string to be converted in place.







|


|


|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
.sp
int
\fBTcl_UniCharToLower\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharToTitle\fR(\fIch\fR)
.sp
Tcl_Size
\fBTcl_UtfToUpper\fR(\fIstr\fR)
.sp
Tcl_Size
\fBTcl_UtfToLower\fR(\fIstr\fR)
.sp
Tcl_Size
\fBTcl_UtfToTitle\fR(\fIstr\fR)
.SH ARGUMENTS
.AS char *str in/out
.AP int ch in
The Unicode character to be converted.
.AP char *str in/out
Pointer to UTF-8 string to be converted in place.

Changes to doc/Utf.3.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, Tcl_WCharLen, Tcl_Char16Len, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
typedef ... \fBTcl_UniChar\fR;
.sp
size_t
\fBTcl_UniCharToUtf\fR(\fIch, buf\fR)
.sp
size_t
\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR)
.sp
size_t
\fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR)
.sp
size_t
\fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR)
.sp
char *
\fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR)
.sp
char *
\fBTcl_Char16ToUtfDString\fR(\fIuStr, uniLength, dsPtr\fR)







|


|


|


|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, Tcl_WCharLen, Tcl_Char16Len, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
typedef ... \fBTcl_UniChar\fR;
.sp
Tcl_Size
\fBTcl_UniCharToUtf\fR(\fIch, buf\fR)
.sp
Tcl_Size
\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR)
.sp
Tcl_Size
\fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR)
.sp
Tcl_Size
\fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR)
.sp
char *
\fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR)
.sp
char *
\fBTcl_Char16ToUtfDString\fR(\fIuStr, uniLength, dsPtr\fR)
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
.sp
int
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
.sp
const char *
\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR)
.sp
size_t
\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *uniPattern in/out
.AP char *buf out
Buffer in which the UTF-8 representation of the Tcl_UniChar is stored.  At most
4 bytes are stored in the buffer.
.AP int ch in







|







89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
.sp
int
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
.sp
const char *
\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR)
.sp
Tcl_Size
\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR)
.SH ARGUMENTS
.AS "const Tcl_UniChar" *uniPattern in/out
.AP char *buf out
Buffer in which the UTF-8 representation of the Tcl_UniChar is stored.  At most
4 bytes are stored in the buffer.
.AP int ch in
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
A null-terminated wchar_t string.
.AP "const unsigned short" *utf16s in
A null-terminated utf-16 string.
.AP "const unsigned short" *utf16t in
A null-terminated utf-16 string.
.AP "const unsigned short" *utf16Pattern in
A null-terminated utf-16 string.
.AP size_t length in
The length of the UTF-8 string in bytes (not UTF-8 characters).  If
TCL_INDEX_NONE, all bytes up to the first null byte are used.
.AP size_t uniLength in
The length of the Unicode string in characters.
.AP "Tcl_DString" *dsPtr in/out
A pointer to a previously initialized \fBTcl_DString\fR.
.AP "const char" *start in
Pointer to the beginning of a UTF-8 string.
.AP size_t index in
The index of a character (not byte) in the UTF-8 string.
.AP int *readPtr out
If non-NULL, filled with the number of bytes in the backslash sequence,
including the backslash character.
.AP char *dst out
Buffer in which the bytes represented by the backslash sequence are stored.
At most 4 bytes are stored in the buffer.







|

|
|





|







128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
A null-terminated wchar_t string.
.AP "const unsigned short" *utf16s in
A null-terminated utf-16 string.
.AP "const unsigned short" *utf16t in
A null-terminated utf-16 string.
.AP "const unsigned short" *utf16Pattern in
A null-terminated utf-16 string.
.AP Tcl_Size length in
The length of the UTF-8 string in bytes (not UTF-8 characters).  If
negative, all bytes up to the first null byte are used.
.AP Tcl_Size uniLength in
The length of the Unicode string in characters.
.AP "Tcl_DString" *dsPtr in/out
A pointer to a previously initialized \fBTcl_DString\fR.
.AP "const char" *start in
Pointer to the beginning of a UTF-8 string.
.AP Tcl_Size index in
The index of a character (not byte) in the UTF-8 string.
.AP int *readPtr out
If non-NULL, filled with the number of bytes in the backslash sequence,
including the backslash character.
.AP char *dst out
Buffer in which the bytes represented by the backslash sequence are stored.
At most 4 bytes are stored in the buffer.
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
does not guarantee that the UTF-8 string is properly formed.  This routine
is used by procedures that are operating on a byte at a time and need to
know if a full Unicode character has been seen.
.PP
\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings.  It
returns the number of Tcl_UniChars that are represented by the UTF-8 string
\fIsrc\fR.  The length of the source string is \fIlength\fR bytes.  If the
length is TCL_INDEX_NONE, all bytes up to the first null byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings.  It
returns a pointer to the first occurrence of the Unicode character \fIch\fR
in the null-terminated UTF-8 string \fIsrc\fR.  The null terminator is
considered part of the UTF-8 string.
.PP
\fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings.  It







|







250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
does not guarantee that the UTF-8 string is properly formed.  This routine
is used by procedures that are operating on a byte at a time and need to
know if a full Unicode character has been seen.
.PP
\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings.  It
returns the number of Tcl_UniChars that are represented by the UTF-8 string
\fIsrc\fR.  The length of the source string is \fIlength\fR bytes.  If the
length is negative, all bytes up to the first null byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings.  It
returns a pointer to the first occurrence of the Unicode character \fIch\fR
in the null-terminated UTF-8 string \fIsrc\fR.  The null terminator is
considered part of the UTF-8 string.
.PP
\fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings.  It
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte
\fIsrc[-5]\fR.
.PP
\fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the
Pascal Ord() function.  It returns the Unicode character represented at the
specified character (not byte) \fIindex\fR in the UTF-8 string
\fIsrc\fR.  The source string must contain at least \fIindex\fR
characters.  If \fIindex\fR is TCL_INDEX_NONE or \fIindex\fR points
to the second half of a surrogate pair, it returns -1.
.PP
\fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not
byte) \fIindex\fR in the UTF-8 string \fIsrc\fR.  The source string must
contain at least \fIindex\fR characters.  This is equivalent to calling
\fBTcl_UtfToUniChar\fR \fIindex\fR times.  If \fIindex\fR is TCL_INDEX_NONE,
the return pointer points to the first character in the source string.
.PP
\fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl
commands.  It parses a backslash sequence and stores the properly formed
UTF-8 character represented by the backslash sequence in the output
buffer \fIdst\fR.  At most 4 bytes are stored in the buffer.
\fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number







|





|







295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte
\fIsrc[-5]\fR.
.PP
\fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the
Pascal Ord() function.  It returns the Unicode character represented at the
specified character (not byte) \fIindex\fR in the UTF-8 string
\fIsrc\fR.  The source string must contain at least \fIindex\fR
characters.  If \fIindex\fR is negative or \fIindex\fR points
to the second half of a surrogate pair, it returns -1.
.PP
\fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not
byte) \fIindex\fR in the UTF-8 string \fIsrc\fR.  The source string must
contain at least \fIindex\fR characters.  This is equivalent to calling
\fBTcl_UtfToUniChar\fR \fIindex\fR times.  If \fIindex\fR is negative,
the return pointer points to the first character in the source string.
.PP
\fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl
commands.  It parses a backslash sequence and stores the properly formed
UTF-8 character represented by the backslash sequence in the output
buffer \fIdst\fR.  At most 4 bytes are stored in the buffer.
\fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number

Changes to doc/WrongNumArgs.3.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
.sp
\fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR)
.SH ARGUMENTS
.AS "Tcl_Obj *const" *message
.AP Tcl_Interp interp in
Interpreter in which error will be reported: error message gets stored
in its result value.
.AP size_t objc in
Number of leading arguments from \fIobjv\fR to include in error
message.
.AP "Tcl_Obj *const" objv[] in
Arguments to command that had the wrong number of arguments.
.AP "const char" *message in
Additional error information to print after leading arguments
from \fIobjv\fR.  This typically gives the acceptable syntax







|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
.sp
\fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR)
.SH ARGUMENTS
.AS "Tcl_Obj *const" *message
.AP Tcl_Interp interp in
Interpreter in which error will be reported: error message gets stored
in its result value.
.AP Tcl_Size objc in
Number of leading arguments from \fIobjv\fR to include in error
message.
.AP "Tcl_Obj *const" objv[] in
Arguments to command that had the wrong number of arguments.
.AP "const char" *message in
Additional error information to print after leading arguments
from \fIobjv\fR.  This typically gives the acceptable syntax

Changes to generic/tcl.decls.

2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
# TIP #568
declare 649 {
    unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    int *numBytesPtr)
}
declare 650 {
    unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    size_t *numBytesPtr)
}

# TIP #481
declare 651 {
    char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
}
declare 652 {
    Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
}
# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 653 {
    unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr)
}

# TIP #575
declare 654 {
    int Tcl_UtfCharComplete(const char *src, Tcl_Size length)
}
declare 655 {







|




|


|



|







2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
# TIP #568
declare 649 {
    unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    int *numBytesPtr)
}
declare 650 {
    unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    Tcl_Size *numBytesPtr)
}

# TIP #481
declare 651 {
    char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr)
}
declare 652 {
    Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr)
}
# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 653 {
    unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, Tcl_Size *numBytesPtr)
}

# TIP #575
declare 654 {
    int Tcl_UtfCharComplete(const char *src, Tcl_Size length)
}
declare 655 {
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
declare 660 {
    int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber)
}

# TIP #616
declare 661 {
    int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
	    size_t *objcPtr, Tcl_Obj ***objvPtr)
}
declare 662 {
    int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
	    size_t *lengthPtr)
}
declare 663 {
    int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr)
}
declare 664 {
    int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr,
	    const char ***argvPtr)
}
declare 665 {
    void Tcl_SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr)
}
declare 666 {
    Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr)
}
declare 667 {
    int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
	    size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
}

# TIP #617
declare 668 {
    Tcl_Size Tcl_UniCharLen(const int *uniStr)
}
declare 669 {







|



|


|


|



|


|



|







2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
declare 660 {
    int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber)
}

# TIP #616
declare 661 {
    int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
	    Tcl_Size *objcPtr, Tcl_Obj ***objvPtr)
}
declare 662 {
    int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
	    Tcl_Size *lengthPtr)
}
declare 663 {
    int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr)
}
declare 664 {
    int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr,
	    const char ***argvPtr)
}
declare 665 {
    void Tcl_SplitPath(const char *path, Tcl_Size *argcPtr, const char ***argvPtr)
}
declare 666 {
    Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr)
}
declare 667 {
    int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
	    Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
}

# TIP #617
declare 668 {
    Tcl_Size Tcl_UniCharLen(const int *uniStr)
}
declare 669 {
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
    Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
	    const char *cmdName, Tcl_ObjCmdProc2 *proc,
	    Tcl_ObjCmdProc2 *nreProc2, void *clientData,
	    Tcl_CmdDeleteProc *deleteProc)
}
declare 679 {
    int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
	    void *clientData, size_t objc, Tcl_Obj *const objv[])
}

# TIP #638.
declare 680 {
    int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    void **clientDataPtr, int *typePtr)
}
declare 681 {
    int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, size_t numBytes,
	    void **clientDataPtr, int *typePtr)
}

# TIP #220.
declare 682 {
    int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode)
}







|








|







2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
    Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
	    const char *cmdName, Tcl_ObjCmdProc2 *proc,
	    Tcl_ObjCmdProc2 *nreProc2, void *clientData,
	    Tcl_CmdDeleteProc *deleteProc)
}
declare 679 {
    int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
	    void *clientData, ptrdiff_t objc, Tcl_Obj *const objv[])
}

# TIP #638.
declare 680 {
    int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    void **clientDataPtr, int *typePtr)
}
declare 681 {
    int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes,
	    void **clientDataPtr, int *typePtr)
}

# TIP #220.
declare 682 {
    int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode)
}
2621
2622
2623
2624
2625
2626
2627






2628
2629
2630
2631
2632
2633
2634
	    Tcl_WideUInt *uwidePtr)
}

# TIP 651
declare 685 {
    Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
}







# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #

declare 688 {
    void TclUnusedStubEntry(void)
}








>
>
>
>
>
>







2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
	    Tcl_WideUInt *uwidePtr)
}

# TIP 651
declare 685 {
    Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
}

# TIP 660
declare 686 {
    int Tcl_GetSizeIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    Tcl_Size *sizePtr)
}

# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #

declare 688 {
    void TclUnusedStubEntry(void)
}

Changes to generic/tcl.h.

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
#define Tcl_DoubleAsWide(val)	((Tcl_WideInt)((double)(val)))

#if TCL_MAJOR_VERSION < 9
    typedef int Tcl_Size;
#   define TCL_SIZE_MODIFIER ""
#   define TCL_SIZE_MAX INT_MAX
#else
    typedef size_t Tcl_Size;
#   define TCL_SIZE_MAX PTRDIFF_MAX
#   define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#endif /* TCL_MAJOR_VERSION */

#ifdef _WIN32
#   if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T)
	typedef struct __stat64 Tcl_StatBuf;







|







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
#define Tcl_DoubleAsWide(val)	((Tcl_WideInt)((double)(val)))

#if TCL_MAJOR_VERSION < 9
    typedef int Tcl_Size;
#   define TCL_SIZE_MODIFIER ""
#   define TCL_SIZE_MAX INT_MAX
#else
    typedef ptrdiff_t Tcl_Size;
#   define TCL_SIZE_MAX PTRDIFF_MAX
#   define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#endif /* TCL_MAJOR_VERSION */

#ifdef _WIN32
#   if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T)
	typedef struct __stat64 Tcl_StatBuf;
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp,
	int level, char *command, Tcl_CmdProc *proc,
	void *cmdClientData, int argc, const char *argv[]);
typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp,
	int level, const char *command, Tcl_Command commandInfo, int objc,
	struct Tcl_Obj *const *objv);
typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp,
	size_t level, const char *command, Tcl_Command commandInfo, size_t objc,
	struct Tcl_Obj *const *objv);
typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData);
typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
	struct Tcl_Obj *dupPtr);
typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src,
	int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst,
	int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr);







|







557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp,
	int level, char *command, Tcl_CmdProc *proc,
	void *cmdClientData, int argc, const char *argv[]);
typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp,
	int level, const char *command, Tcl_Command commandInfo, int objc,
	struct Tcl_Obj *const *objv);
typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp,
	ptrdiff_t level, const char *command, Tcl_Command commandInfo, ptrdiff_t objc,
	struct Tcl_Obj *const *objv);
typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData);
typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
	struct Tcl_Obj *dupPtr);
typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src,
	int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst,
	int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr);
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
typedef void (Tcl_IdleProc) (void *clientData);
typedef void (Tcl_InterpDeleteProc) (void *clientData,
	Tcl_Interp *interp);
typedef void (Tcl_NamespaceDeleteProc) (void *clientData);
typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp,
	int objc, struct Tcl_Obj *const *objv);
typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp,
	size_t objc, struct Tcl_Obj *const *objv);
typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp);
typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags);
typedef void (Tcl_PanicProc) (const char *format, ...);
typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan,
	char *address, int port);
typedef void (Tcl_TimerProc) (void *clientData);
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);







|







582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
typedef void (Tcl_IdleProc) (void *clientData);
typedef void (Tcl_InterpDeleteProc) (void *clientData,
	Tcl_Interp *interp);
typedef void (Tcl_NamespaceDeleteProc) (void *clientData);
typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp,
	int objc, struct Tcl_Obj *const *objv);
typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp,
	ptrdiff_t objc, struct Tcl_Obj *const *objv);
typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp);
typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags);
typedef void (Tcl_PanicProc) (const char *format, ...);
typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan,
	char *address, int port);
typedef void (Tcl_TimerProc) (void *clientData);
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
#endif
#if defined(_WIN32) && defined(UNICODE)
#ifndef USE_TCL_STUBS
#   define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
#endif
#   define Tcl_MainEx Tcl_MainExW
    EXTERN TCL_NORETURN void Tcl_MainExW(size_t argc, wchar_t **argv,
	    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8)
#define Tcl_SetPanicProc(panicProc) \
    TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc))
#define Tcl_InitSubsystems() \
    TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))())
#define Tcl_FindExecutable(argv0) \
    TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0))
#define TclZipfs_AppHook(argcp, argvp) \
	TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp))
#define Tcl_MainExW(argc, argv, appInitProc, interp) \
	(void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
	TclStubCall((void *)4))(argc, argv, appInitProc, interp)
#if !defined(_WIN32) || !defined(UNICODE)
#define Tcl_MainEx(argc, argv, appInitProc, interp) \
	(void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
	TclStubCall((void *)5))(argc, argv, appInitProc, interp)
#endif
#define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \







|












|







2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
#endif
#if defined(_WIN32) && defined(UNICODE)
#ifndef USE_TCL_STUBS
#   define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
#endif
#   define Tcl_MainEx Tcl_MainExW
    EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv,
	    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8)
#define Tcl_SetPanicProc(panicProc) \
    TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc))
#define Tcl_InitSubsystems() \
    TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))())
#define Tcl_FindExecutable(argv0) \
    TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0))
#define TclZipfs_AppHook(argcp, argvp) \
	TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp))
#define Tcl_MainExW(argc, argv, appInitProc, interp) \
	(void)((const char *(*)(Tcl_Size, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
	TclStubCall((void *)4))(argc, argv, appInitProc, interp)
#if !defined(_WIN32) || !defined(UNICODE)
#define Tcl_MainEx(argc, argv, appInitProc, interp) \
	(void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
	TclStubCall((void *)5))(argc, argv, appInitProc, interp)
#endif
#define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \

Changes to generic/tclArithSeries.c.

353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
	    dend = end;
	}
    }

    if (TCL_MAJOR_VERSION < 9 && len > ListSizeT_MAX) {
	Tcl_SetObjResult(
	    interp,
	    Tcl_NewStringObj("max length of a Tcl list exceeded", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	return TCL_ERROR;
    }

    if (arithSeriesObj) {
	*arithSeriesObj = (useDoubles)
	    ? NewArithSeriesDbl(dstart, dend, dstep, len)







|







353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
	    dend = end;
	}
    }

    if (TCL_MAJOR_VERSION < 9 && len > ListSizeT_MAX) {
	Tcl_SetObjResult(
	    interp,
	    Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	return TCL_ERROR;
    }

    if (arithSeriesObj) {
	*arithSeriesObj = (useDoubles)
	    ? NewArithSeriesDbl(dstart, dend, dstep, len)
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
	Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
    }
    arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj);
    if (index < 0 || (Tcl_Size)index >= arithSeriesRepPtr->len) {
	if (interp) {
	    Tcl_SetObjResult(interp,
		    Tcl_ObjPrintf("index %" TCL_LL_MODIFIER "d is out of bounds 0 to %"
			    TCL_Z_MODIFIER "d", index, (arithSeriesRepPtr->len-1)));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	}
	return NULL;
    }
    /* List[i] = Start + (Step * index) */
    if (arithSeriesRepPtr->isDouble) {
	return Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index));







|







440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
	Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
    }
    arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj);
    if (index < 0 || (Tcl_Size)index >= arithSeriesRepPtr->len) {
	if (interp) {
	    Tcl_SetObjResult(interp,
		    Tcl_ObjPrintf("index %" TCL_LL_MODIFIER "d is out of bounds 0 to %"
			    TCL_LL_MODIFIER "d", index, (arithSeriesRepPtr->len-1)));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	}
	return NULL;
    }
    /* List[i] = Start + (Step * index) */
    if (arithSeriesRepPtr->isDouble) {
	return Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
	    } else {
		/* Construct the elements array */
		objv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * objc);
		if (objv == NULL) {
		    if (interp) {
			Tcl_SetObjResult(
			    interp,
			    Tcl_NewStringObj("max length of a Tcl list exceeded", TCL_INDEX_NONE));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
		    }
		    return TCL_ERROR;
		}
		arithSeriesRepPtr->elements = objv;
		for (i = 0; i < objc; i++) {
		    objv[i] = TclArithSeriesObjIndex(interp, objPtr, i);







|







861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
	    } else {
		/* Construct the elements array */
		objv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * objc);
		if (objv == NULL) {
		    if (interp) {
			Tcl_SetObjResult(
			    interp,
			    Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
		    }
		    return TCL_ERROR;
		}
		arithSeriesRepPtr->elements = objv;
		for (i = 0; i < objc; i++) {
		    objv[i] = TclArithSeriesObjIndex(interp, objPtr, i);

Changes to generic/tclArithSeries.h.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

/*
 * The structure used for the ArithSeries internal representation.
 * Note that the len can in theory be always computed by start,end,step
 * but it's faster to cache it inside the internal representation.
 */
typedef struct {
    Tcl_Size len;
    Tcl_Obj **elements;
    int isDouble;
    Tcl_WideInt start;
    Tcl_WideInt end;
    Tcl_WideInt step;
} ArithSeries;
typedef struct {
    Tcl_Size len;
    Tcl_Obj **elements;
    int isDouble;
    double start;
    double end;
    double step;
} ArithSeriesDbl;








|







|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

/*
 * The structure used for the ArithSeries internal representation.
 * Note that the len can in theory be always computed by start,end,step
 * but it's faster to cache it inside the internal representation.
 */
typedef struct {
    Tcl_WideInt len;
    Tcl_Obj **elements;
    int isDouble;
    Tcl_WideInt start;
    Tcl_WideInt end;
    Tcl_WideInt step;
} ArithSeries;
typedef struct {
    Tcl_WideInt len;
    Tcl_Obj **elements;
    int isDouble;
    double start;
    double end;
    double step;
} ArithSeriesDbl;

Changes to generic/tclAssembly.c.

218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
typedef struct AssemblyEnv {
    CompileEnv* envPtr;		/* Compilation environment being used for code
				 * generation */
    Tcl_Parse* parsePtr;	/* Parse of the current line of source */
    Tcl_HashTable labelHash;	/* Hash table whose keys are labels and whose
				 * values are 'label' objects storing the code
				 * offsets of the labels. */
    size_t cmdLine;		/* Current line number within the assembly
				 * code */
    int* clNext;		/* Invisible continuation line for
				 * [info frame] */
    BasicBlock* head_bb;	/* First basic block in the code */
    BasicBlock* curr_bb;	/* Current basic block */
    int maxDepth;		/* Maximum stack depth encountered */
    int curCatchDepth;		/* Current depth of catches */







|







218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
typedef struct AssemblyEnv {
    CompileEnv* envPtr;		/* Compilation environment being used for code
				 * generation */
    Tcl_Parse* parsePtr;	/* Parse of the current line of source */
    Tcl_HashTable labelHash;	/* Hash table whose keys are labels and whose
				 * values are 'label' objects storing the code
				 * offsets of the labels. */
    Tcl_Size cmdLine;	/* Current line number within the assembly
				 * code */
    int* clNext;		/* Invisible continuation line for
				 * [info frame] */
    BasicBlock* head_bb;	/* First basic block in the code */
    BasicBlock* curr_bb;	/* Current basic block */
    int maxDepth;		/* Maximum stack depth encountered */
    int curCatchDepth;		/* Current depth of catches */
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
    Tcl_Obj* instNameObj;	/* Name of the instruction */
    int tblIdx;			/* Index in TalInstructionTable of the
				 * instruction */
    TalInstType instType;	/* Type of the instruction */
    Tcl_Obj* operand1Obj = NULL;
				/* First operand to the instruction */
    const char* operand1;	/* String rep of the operand */
    size_t operand1Len;		/* String length of the operand */
    int opnd;			/* Integer representation of an operand */
    int litIndex;		/* Literal pool index of a constant */
    size_t localVar;		/* LVT index of a local variable */
    int flags;			/* Flags for a basic block */
    JumptableInfo* jtPtr;	/* Pointer to a jumptable */
    int infoIndex;		/* Index of the jumptable in auxdata */
    int status = TCL_ERROR;	/* Return value from this function */

    /*
     * Make sure that the instruction name is known at compile time.







|


|







1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
    Tcl_Obj* instNameObj;	/* Name of the instruction */
    int tblIdx;			/* Index in TalInstructionTable of the
				 * instruction */
    TalInstType instType;	/* Type of the instruction */
    Tcl_Obj* operand1Obj = NULL;
				/* First operand to the instruction */
    const char* operand1;	/* String rep of the operand */
    Tcl_Size operand1Len;	/* String length of the operand */
    int opnd;			/* Integer representation of an operand */
    int litIndex;		/* Literal pool index of a constant */
    Tcl_Size localVar;	/* LVT index of a local variable */
    int flags;			/* Flags for a basic block */
    JumptableInfo* jtPtr;	/* Pointer to a jumptable */
    int infoIndex;		/* Index of the jumptable in auxdata */
    int status = TCL_ERROR;	/* Return value from this function */

    /*
     * Make sure that the instruction name is known at compile time.
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
	    goto cleanup;
	}
	if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_CLOCK_READ:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	if (opnd < 0 || opnd > 3) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("operand must be [0..3]", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL);
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_CONCAT1:







|
















|







1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
	    goto cleanup;
	}
	if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_CLOCK_READ:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	if (opnd < 0 || opnd > 3) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("operand must be [0..3]", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL);
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_CONCAT1:
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_DICT_UNSET:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_END_CATCH:







|
















|







1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_DICT_UNSET:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_END_CATCH:
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	if (opnd < 2) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("operand must be >=2", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
	    }
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_LVT:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE) {
	    goto cleanup;
	}
	BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0);
	break;

    case ASSEM_LVT1:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE || CheckOneByte(interp, localVar)) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
	break;

    case ASSEM_LVT1_SINT1:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE || CheckOneByte(interp, localVar)
		|| GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckSignedOneByte(interp, opnd)) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
	TclEmitInt1(opnd, envPtr);
	break;

    case ASSEM_LVT4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0);
	break;

    case ASSEM_OVER:
	if (parsePtr->numWords != 2) {







|













|











|











|














|







1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	if (opnd < 2) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("operand must be >=2", -1));
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
	    }
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_LVT:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0) {
	    goto cleanup;
	}
	BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0);
	break;

    case ASSEM_LVT1:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0 || CheckOneByte(interp, localVar)) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
	break;

    case ASSEM_LVT1_SINT1:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0 || CheckOneByte(interp, localVar)
		|| GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckSignedOneByte(interp, opnd)) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
	TclEmitInt1(opnd, envPtr);
	break;

    case ASSEM_LVT4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0);
	break;

    case ASSEM_OVER:
	if (parsePtr->numWords != 2) {
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar == TCL_INDEX_NONE) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0);
	TclEmitInt4(localVar, envPtr);
	break;

    default:







|







1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
	if (localVar < 0) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0);
	TclEmitInt4(localVar, envPtr);
	break;

    default:
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
 */

static int
CreateMirrorJumpTable(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
    Tcl_Obj* jumps)		/* List of alternating keywords and labels */
{
    size_t objc;			/* Number of elements in the 'jumps' list */
    Tcl_Obj** objv;		/* Pointers to the elements in the list */
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */
    JumptableInfo* jtPtr;
    Tcl_HashTable* jtHashPtr;	/* Hashtable in the JumptableInfo */
    Tcl_HashEntry* hashEntry;	/* Entry for a key in the hashtable */
    int isNew;			/* Flag==1 if the key is not yet in the
				 * table. */
    size_t i;

    if (TclListObjLengthM(interp, jumps, &objc) != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc % 2 != 0) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(







|












|







1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
 */

static int
CreateMirrorJumpTable(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
    Tcl_Obj* jumps)		/* List of alternating keywords and labels */
{
    Tcl_Size objc;			/* Number of elements in the 'jumps' list */
    Tcl_Obj** objv;		/* Pointers to the elements in the list */
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */
    JumptableInfo* jtPtr;
    Tcl_HashTable* jtHashPtr;	/* Hashtable in the JumptableInfo */
    Tcl_HashEntry* hashEntry;	/* Entry for a key in the hashtable */
    int isNew;			/* Flag==1 if the key is not yet in the
				 * table. */
    Tcl_Size i;

    if (TclListObjLengthM(interp, jumps, &objc) != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc % 2 != 0) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
    Tcl_Obj* operandObj;

    TclNewObj(operandObj);
    if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
	Tcl_DecrRefCount(operandObj);
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "assembly code may not contain substitutions", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL);
	}
	return TCL_ERROR;
    }
    *tokenPtrPtr = TokenAfter(*tokenPtrPtr);
    Tcl_IncrRefCount(operandObj);
    *operandObjPtr = operandObj;







|







2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
    Tcl_Obj* operandObj;

    TclNewObj(operandObj);
    if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
	Tcl_DecrRefCount(operandObj);
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "assembly code may not contain substitutions", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL);
	}
	return TCL_ERROR;
    }
    *tokenPtrPtr = TokenAfter(*tokenPtrPtr);
    Tcl_IncrRefCount(operandObj);
    *operandObjPtr = operandObj;
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Token* tokenPtr = *tokenPtrPtr;
				/* INOUT: Pointer to the next token in the
				 * source code. */
    Tcl_Obj* varNameObj;	/* Name of the variable */
    const char* varNameStr;
    size_t varNameLen;
    size_t localVar;		/* Index of the variable in the LVT */

    if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
	return TCL_INDEX_NONE;
    }
    varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
    if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
	Tcl_DecrRefCount(varNameObj);
	return TCL_INDEX_NONE;
    }
    localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
    Tcl_DecrRefCount(varNameObj);
    if (localVar == TCL_INDEX_NONE) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "cannot use this instruction to create a variable"
		    " in a non-proc context", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
	}
	return TCL_INDEX_NONE;
    }
    *tokenPtrPtr = TokenAfter(tokenPtr);
    return localVar;
}







|
|











|



|







2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Token* tokenPtr = *tokenPtrPtr;
				/* INOUT: Pointer to the next token in the
				 * source code. */
    Tcl_Obj* varNameObj;	/* Name of the variable */
    const char* varNameStr;
    Tcl_Size varNameLen;
    Tcl_Size localVar;		/* Index of the variable in the LVT */

    if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
	return TCL_INDEX_NONE;
    }
    varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
    if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
	Tcl_DecrRefCount(varNameObj);
	return TCL_INDEX_NONE;
    }
    localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
    Tcl_DecrRefCount(varNameObj);
    if (localVar < 0) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "cannot use this instruction to create a variable"
		    " in a non-proc context", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
	}
	return TCL_INDEX_NONE;
    }
    *tokenPtrPtr = TokenAfter(tokenPtr);
    return localVar;
}
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
CheckOneByte(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value < 0 || value > 0xFF) {
	result = Tcl_NewStringObj("operand does not fit in one byte", TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}








|







2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
CheckOneByte(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value < 0 || value > 0xFF) {
	result = Tcl_NewStringObj("operand does not fit in one byte", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
CheckSignedOneByte(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value > 0x7F || value < -0x80) {
	result = Tcl_NewStringObj("operand does not fit in one byte", TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}








|







2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
CheckSignedOneByte(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value > 0x7F || value < -0x80) {
	result = Tcl_NewStringObj("operand does not fit in one byte", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
CheckNonNegative(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value < 0) {
	result = Tcl_NewStringObj("operand must be nonnegative", TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}








|







2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
CheckNonNegative(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value < 0) {
	result = Tcl_NewStringObj("operand must be nonnegative", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
CheckStrictlyPositive(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value <= 0) {
	result = Tcl_NewStringObj("operand must be positive", TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}








|







2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
CheckStrictlyPositive(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value <= 0) {
	result = Tcl_NewStringObj("operand must be positive", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331

static int
CheckStack(
    AssemblyEnv* assemEnvPtr)	/* Assembly environment */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    size_t maxDepth;		/* Maximum stack depth overall */

    /*
     * Checking the head block will check all the other blocks recursively.
     */

    assemEnvPtr->maxDepth = 0;
    if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL,







|







3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331

static int
CheckStack(
    AssemblyEnv* assemEnvPtr)	/* Assembly environment */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Size maxDepth;		/* Maximum stack depth overall */

    /*
     * Checking the head block will check all the other blocks recursively.
     */

    assemEnvPtr->maxDepth = 0;
    if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL,
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
	 */

	if (blockPtr->initialStackDepth == initialStackDepth) {
	    return TCL_OK;
	}
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "inconsistent stack depths on two execution paths", TCL_INDEX_NONE));

	    /*
	     * TODO - add execution trace of both paths
	     */

	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);







|







3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
	 */

	if (blockPtr->initialStackDepth == initialStackDepth) {
	    return TCL_OK;
	}
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "inconsistent stack depths on two execution paths", -1));

	    /*
	     * TODO - add execution trace of both paths
	     */

	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
    /*
     * Calculate minimum stack depth, and flag an error if the block
     * underflows the stack.
     */

    if (initialStackDepth + blockPtr->minStackDepth < 0) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
	    AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	}
	return TCL_ERROR;
    }

    /*
     * Make sure that the block doesn't try to pop below the stack level of an
     * enclosing catch.
     */

    if (blockPtr->enclosingCatch != 0 &&
	    initialStackDepth + blockPtr->minStackDepth
	    < (blockPtr->enclosingCatch->initialStackDepth
		+ blockPtr->enclosingCatch->finalStackDepth)) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "code pops stack below level of enclosing catch", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", TCL_INDEX_NONE);
	    AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	}
	return TCL_ERROR;
    }

    /*







|


















|
|







3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
    /*
     * Calculate minimum stack depth, and flag an error if the block
     * underflows the stack.
     */

    if (initialStackDepth + blockPtr->minStackDepth < 0) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
	    AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	}
	return TCL_ERROR;
    }

    /*
     * Make sure that the block doesn't try to pop below the stack level of an
     * enclosing catch.
     */

    if (blockPtr->enclosingCatch != 0 &&
	    initialStackDepth + blockPtr->minStackDepth
	    < (blockPtr->enclosingCatch->initialStackDepth
		+ blockPtr->enclosingCatch->finalStackDepth)) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "code pops stack below level of enclosing catch", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1);
	    AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	}
	return TCL_ERROR;
    }

    /*
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744

    if (bbPtr->catchState == BBCS_UNKNOWN) {
	bbPtr->enclosingCatch = enclosing;
    } else if (bbPtr->enclosingCatch != enclosing) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "execution reaches an instruction in inconsistent "
		    "exception contexts", TCL_INDEX_NONE));
	    Tcl_SetErrorLine(interp, bbPtr->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL);
	}
	return TCL_ERROR;
    }
    if (state > bbPtr->catchState) {
	bbPtr->catchState = state;







|







3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744

    if (bbPtr->catchState == BBCS_UNKNOWN) {
	bbPtr->enclosingCatch = enclosing;
    } else if (bbPtr->enclosingCatch != enclosing) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "execution reaches an instruction in inconsistent "
		    "exception contexts", -1));
	    Tcl_SetErrorLine(interp, bbPtr->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL);
	}
	return TCL_ERROR;
    }
    if (state > bbPtr->catchState) {
	bbPtr->catchState = state;
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
	 * If the block ends a catch, the state for the successor is whatever
	 * the state was on entry to the catch.
	 */

	if (enclosing == NULL) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"endCatch without a corresponding beginCatch", TCL_INDEX_NONE));
		Tcl_SetErrorLine(interp, bbPtr->startLine);
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL);
	    }
	    return TCL_ERROR;
	}
	fallThruEnclosing = enclosing->enclosingCatch;
	fallThruState = enclosing->catchState;







|







3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
	 * If the block ends a catch, the state for the successor is whatever
	 * the state was on entry to the catch.
	 */

	if (enclosing == NULL) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"endCatch without a corresponding beginCatch", -1));
		Tcl_SetErrorLine(interp, bbPtr->startLine);
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL);
	    }
	    return TCL_ERROR;
	}
	fallThruEnclosing = enclosing->enclosingCatch;
	fallThruState = enclosing->catchState;
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */

    if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "catch still active on exit from assembly code", TCL_INDEX_NONE));
	    Tcl_SetErrorLine(interp,
		    assemEnvPtr->curr_bb->enclosingCatch->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;







|







3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */

    if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "catch still active on exit from assembly code", -1));
	    Tcl_SetErrorLine(interp,
		    assemEnvPtr->curr_bb->enclosingCatch->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;

Changes to generic/tclBasic.c.

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103

typedef struct {
    Tcl_Interp *interp;		/* Interp this struct belongs to. */
    Tcl_AsyncHandler async;	/* Async handler token for script
				 * cancellation. */
    char *result;		/* The script cancellation result or NULL for
				 * a default result. */
    size_t length;		/* Length of the above error message. */
    void *clientData;		/* Not used. */
    int flags;			/* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(cancelLock);








|







89
90
91
92
93
94
95
96
97
98
99
100
101
102
103

typedef struct {
    Tcl_Interp *interp;		/* Interp this struct belongs to. */
    Tcl_AsyncHandler async;	/* Async handler token for script
				 * cancellation. */
    char *result;		/* The script cancellation result or NULL for
				 * a default result. */
    Tcl_Size length;		/* Length of the above error message. */
    void *clientData;		/* Not used. */
    int flags;			/* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(cancelLock);

216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */

#define CORO_ACTIVATE_YIELD    NULL
#define CORO_ACTIVATE_YIELDM   INT2PTR(1)

#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL     ((size_t)-1)
#define COROUTINE_ARGUMENTS_ARBITRARY           ((size_t)-2)

/*
 * The following structure define the commands in the Tcl core.
 */

typedef struct {
    const char *name;		/* Name of object-based command. */







|
|







216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */

#define CORO_ACTIVATE_YIELD    NULL
#define CORO_ACTIVATE_YIELDM   INT2PTR(1)

#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL     (-1)
#define COROUTINE_ARGUMENTS_ARBITRARY           (-2)

/*
 * The following structure define the commands in the Tcl core.
 */

typedef struct {
    const char *name;		/* Name of object-based command. */
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
 *----------------------------------------------------------------------
 */

static int
buildInfoObjCmd2(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    size_t objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    if (objc - 1 > 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?option?");
	return TCL_ERROR;
    }
    if (objc == 2) {
	size_t len;
	const char *arg = Tcl_GetStringFromObj(objv[1], &len);
	if (len == 7 && !strcmp(arg, "version")) {
	    char buf[80];
	    const char *p = strchr((char *)clientData, '.');
	    if (p) {
		const char *q = strchr(p+1, '.');
		const char *r = strchr(p+1, '+');







|


|




|







609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
 *----------------------------------------------------------------------
 */

static int
buildInfoObjCmd2(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?option?");
	return TCL_ERROR;
    }
    if (objc == 2) {
	Tcl_Size len;
	const char *arg = Tcl_GetStringFromObj(objv[1], &len);
	if (len == 7 && !strcmp(arg, "version")) {
	    char buf[80];
	    const char *p = strchr((char *)clientData, '.');
	    if (p) {
		const char *q = strchr(p+1, '.');
		const char *r = strchr(p+1, '+');
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
static int
buildInfoObjCmd(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return buildInfoObjCmd2(clientData, interp, (size_t)objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateInterp --
 *







|







698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
static int
buildInfoObjCmd(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return buildInfoObjCmd2(clientData, interp, objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateInterp --
 *
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
    Tcl_Interp *interp)		/* Interpreter to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *hTablePtr;
    ResolverScheme *resPtr, *nextResPtr;
    size_t i;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
	 * unless we are exiting.
     */

    if ((iPtr->numLevels > 0) && !TclInExit()) {







|







1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
    Tcl_Interp *interp)		/* Interpreter to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *hTablePtr;
    ResolverScheme *resPtr, *nextResPtr;
    Tcl_Size i;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
	 * unless we are exiting.
     */

    if ((iPtr->numLevels > 0) && !TclInExit()) {
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
     * the source, in order to avoid potential confusion, lets prevent "::" in
     * the token too. - dl
     */

    if (strstr(hiddenCmdToken, "::") != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot use namespace qualifiers in hidden command"
		" token (rename)", TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
	return TCL_ERROR;
    }

    /*
     * Find the command to hide. An error is returned if cmdName can't be
     * found. Look up the command only from the global namespace. Full path of







|







2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
     * the source, in order to avoid potential confusion, lets prevent "::" in
     * the token too. - dl
     */

    if (strstr(hiddenCmdToken, "::") != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot use namespace qualifiers in hidden command"
		" token (rename)", -1));
        Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
	return TCL_ERROR;
    }

    /*
     * Find the command to hide. An error is returned if cmdName can't be
     * found. Look up the command only from the global namespace. Full path of
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
    int objc,
    Tcl_Obj * const *objv)
{
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
    if (objc < 0) {
	objc = -1;
    }
    return info->proc(info->clientData, interp, (size_t)objc, objv);
}

static void cmdWrapperDeleteProc(void *clientData) {
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;

    clientData = info->deleteData;
    Tcl_CmdDeleteProc *deleteProc = info->deleteProc;







|







2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
    int objc,
    Tcl_Obj * const *objv)
{
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
    if (objc < 0) {
	objc = -1;
    }
    return info->proc(info->clientData, interp, objc, objv);
}

static void cmdWrapperDeleteProc(void *clientData) {
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;

    clientData = info->deleteData;
    Tcl_CmdDeleteProc *deleteProc = info->deleteProc;
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
     * The trace function needs to get a fully qualified name for old and new
     * commands [Tcl bug #651271], or else there's no way for the trace
     * function to get the namespace from which the old command is being
     * renamed!
     */

    Tcl_DStringInit(&newFullName);
    Tcl_DStringAppend(&newFullName, newNsPtr->fullName, TCL_INDEX_NONE);
    if (newNsPtr != iPtr->globalNsPtr) {
	TclDStringAppendLiteral(&newFullName, "::");
    }
    Tcl_DStringAppend(&newFullName, newTail, TCL_INDEX_NONE);
    cmdPtr->refCount++;
    CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
	    Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
    Tcl_DStringFree(&newFullName);

    /*
     * The new command name is okay, so remove the command from its current







|



|







3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
     * The trace function needs to get a fully qualified name for old and new
     * commands [Tcl bug #651271], or else there's no way for the trace
     * function to get the namespace from which the old command is being
     * renamed!
     */

    Tcl_DStringInit(&newFullName);
    Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
    if (newNsPtr != iPtr->globalNsPtr) {
	TclDStringAppendLiteral(&newFullName, "::");
    }
    Tcl_DStringAppend(&newFullName, newTail, -1);
    cmdPtr->refCount++;
    CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
	    Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
    Tcl_DStringFree(&newFullName);

    /*
     * The new command name is okay, so remove the command from its current
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
 *----------------------------------------------------------------------
 */

static int
invokeObj2Command(
    void *clientData,	/* Points to command's Command structure. */
    Tcl_Interp *interp,		/* Current interpreter. */
    size_t objc,		/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int result;
    Command *cmdPtr = (Command *) clientData;

    if (objc > INT_MAX) {
	objc = TCL_INDEX_NONE;
    }
    if (cmdPtr->objProc != NULL) {
	result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
    } else {
	result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
		cmdPtr->objClientData, objc, objv);
    }
    return result;
}

static int cmdWrapper2Proc(void *clientData,
    Tcl_Interp *interp,
    size_t objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr = (Command *)clientData;
    return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
}

int







|






|












|







3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
 *----------------------------------------------------------------------
 */

static int
invokeObj2Command(
    void *clientData,	/* Points to command's Command structure. */
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int result;
    Command *cmdPtr = (Command *) clientData;

    if (objc > INT_MAX) {
	objc = TCL_INDEX_NONE; /* TODO - why? Should error, not truncate */
    }
    if (cmdPtr->objProc != NULL) {
	result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
    } else {
	result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
		cmdPtr->objClientData, objc, objv);
    }
    return result;
}

static int cmdWrapper2Proc(void *clientData,
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr = (Command *)clientData;
    return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
}

int
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
    /*
     * Add the full name of the containing namespace, followed by the "::"
     * separator, and the command name.
     */

    if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
	if (cmdPtr->nsPtr != NULL) {
	    Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, TCL_INDEX_NONE);
	    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
		Tcl_AppendToObj(objPtr, "::", 2);
	    }
	}
	if (cmdPtr->hPtr != NULL) {
	    name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
	    Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *







|






|







3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
    /*
     * Add the full name of the containing namespace, followed by the "::"
     * separator, and the command name.
     */

    if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
	if (cmdPtr->nsPtr != NULL) {
	    Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
	    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
		Tcl_AppendToObj(objPtr, "::", 2);
	    }
	}
	if (cmdPtr->hPtr != NULL) {
	    name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
	    Tcl_AppendToObj(objPtr, name, -1);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071

    /*
     * If the interpreter has been deleted, return an error.
     */

    if (iPtr->flags & DELETED) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to call eval in deleted interpreter", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "IDELETE",
		"attempt to call eval in deleted interpreter", NULL);
	return TCL_ERROR;
    }

    if (iPtr->execEnvPtr->rewind) {
	return TCL_ERROR;







|







4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071

    /*
     * If the interpreter has been deleted, return an error.
     */

    if (iPtr->flags & DELETED) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to call eval in deleted interpreter", -1));
	Tcl_SetErrorCode(interp, "TCL", "IDELETE",
		"attempt to call eval in deleted interpreter", NULL);
	return TCL_ERROR;
    }

    if (iPtr->execEnvPtr->rewind) {
	return TCL_ERROR;
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
     */

    if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
	return TCL_OK;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "too many nested evaluations (infinite loop?)", TCL_INDEX_NONE));
    Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *







|







4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
     */

    if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
	return TCL_OK;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "too many nested evaluations (infinite loop?)", -1));
    Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
    /*
     * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
     * interp's result; otherwise, we leave it alone.
     */

    if (flags & TCL_LEAVE_ERR_MSG) {
        const char *id, *message = NULL;
        size_t length;

        /*
         * Setup errorCode variables so that we can differentiate between
         * being canceled and unwound.
         */

        if (iPtr->asyncCancelMsg != NULL) {







|







4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
    /*
     * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
     * interp's result; otherwise, we leave it alone.
     */

    if (flags & TCL_LEAVE_ERR_MSG) {
        const char *id, *message = NULL;
        Tcl_Size length;

        /*
         * Setup errorCode variables so that we can differentiate between
         * being canceled and unwound.
         */

        if (iPtr->asyncCancelMsg != NULL) {
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
        } else {
            id = "ICANCEL";
            if (length == 0) {
                message = "eval canceled";
            }
        }

        Tcl_SetObjResult(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
    }

    /*
     * Return TCL_ERROR to the caller (not necessarily just the Tcl core
     * itself) that indicates further processing of the script or command in
     * progress should halt gracefully and as soon as possible.







|







4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
        } else {
            id = "ICANCEL";
            if (length == 0) {
                message = "eval canceled";
            }
        }

        Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1));
        Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
    }

    /*
     * Return TCL_ERROR to the caller (not necessarily just the Tcl core
     * itself) that indicates further processing of the script or command in
     * progress should halt gracefully and as soon as possible.
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
 *----------------------------------------------------------------------
 */

int
Tcl_EvalObjv(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */
    size_t objc,			/* Number of words in command. */
    Tcl_Obj *const objv[],	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags)			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
				 * TCL_EVAL_NOERR are currently supported. */
{
    int result;
    NRE_callback *rootPtr = TOP_CB(interp);

    result = TclNREvalObjv(interp, objc, objv, flags, NULL);
    return TclNRRunCallbacks(interp, result, rootPtr);
}

int
TclNREvalObjv(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */
    size_t objc,			/* Number of words in command. */
    Tcl_Obj *const objv[],	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags,			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
				 * TCL_EVAL_NOERR are currently supported. */
    Command *cmdPtr)		/* NULL if the Command is to be looked up







|


















|







4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
 *----------------------------------------------------------------------
 */

int
Tcl_EvalObjv(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */
    Tcl_Size objc,		/* Number of words in command. */
    Tcl_Obj *const objv[],	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags)			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
				 * TCL_EVAL_NOERR are currently supported. */
{
    int result;
    NRE_callback *rootPtr = TOP_CB(interp);

    result = TclNREvalObjv(interp, objc, objv, flags, NULL);
    return TclNRRunCallbacks(interp, result, rootPtr);
}

int
TclNREvalObjv(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */
    Tcl_Size objc,		/* Number of words in command. */
    Tcl_Obj *const objv[],	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags,			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
				 * TCL_EVAL_NOERR are currently supported. */
    Command *cmdPtr)		/* NULL if the Command is to be looked up
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr;
    const char *cmdString;
    size_t cmdLen;
    int objc = PTR2INT(data[0]);
    Tcl_Obj **objv = (Tcl_Obj **)data[1];

    if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	/*
	 * If there was an error, a command string will be needed for the
	 * error log: get it out of the itemPtr. The details depend on the







|







4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr;
    const char *cmdString;
    Tcl_Size cmdLen;
    int objc = PTR2INT(data[0]);
    Tcl_Obj **objv = (Tcl_Obj **)data[1];

    if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	/*
	 * If there was an error, a command string will be needed for the
	 * error log: get it out of the itemPtr. The details depend on the
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[],
    Namespace *lookupNsPtr)
{
    Command * cmdPtr;
    Interp *iPtr = (Interp *) interp;
    size_t i, newObjc, handlerObjc;
    Tcl_Obj **newObjv, **handlerObjv;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered
				 * unknown command handler for the current
				 * namespace (TIP 181). */
    Namespace *savedNsPtr = NULL;








|







4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[],
    Namespace *lookupNsPtr)
{
    Command * cmdPtr;
    Interp *iPtr = (Interp *) interp;
    Tcl_Size i, newObjc, handlerObjc;
    Tcl_Obj **newObjv, **handlerObjv;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered
				 * unknown command handler for the current
				 * namespace (TIP 181). */
    Namespace *savedNsPtr = NULL;

4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
    Command **cmdPtrPtr,
    Tcl_Obj *commandPtr,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr = *cmdPtrPtr;
    size_t length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
    int traceCode = TCL_OK;
    const char *command = Tcl_GetStringFromObj(commandPtr, &length);

    /*
     * Call trace functions.
     * Execute any command or execution traces. Note that we bump up the
     * command's reference count for the duration of the calling of the







|







4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
    Command **cmdPtrPtr,
    Tcl_Obj *commandPtr,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr = *cmdPtrPtr;
    Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
    int traceCode = TCL_OK;
    const char *command = Tcl_GetStringFromObj(commandPtr, &length);

    /*
     * Call trace functions.
     * Execute any command or execution traces. Note that we bump up the
     * command's reference count for the duration of the calling of the
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
{
    Interp *iPtr = (Interp *) interp;
    int traceCode = TCL_OK;
    int objc = PTR2INT(data[0]);
    Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
    Command *cmdPtr = (Command *)data[2];
    Tcl_Obj **objv = (Tcl_Obj **)data[3];
    size_t length;
    const char *command = Tcl_GetStringFromObj(commandPtr, &length);

    if (!(cmdPtr->flags & CMD_DYING)) {
	if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
	    traceCode = TclCheckExecutionTraces(interp, command, length,
		    cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
	}







|







5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
{
    Interp *iPtr = (Interp *) interp;
    int traceCode = TCL_OK;
    int objc = PTR2INT(data[0]);
    Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
    Command *cmdPtr = (Command *)data[2];
    Tcl_Obj **objv = (Tcl_Obj **)data[3];
    Tcl_Size length;
    const char *command = Tcl_GetStringFromObj(commandPtr, &length);

    if (!(cmdPtr->flags & CMD_DYING)) {
	if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
	    traceCode = TclCheckExecutionTraces(interp, command, length,
		    cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
	}
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
int
Tcl_EvalTokensStandard(
    Tcl_Interp *interp,		/* Interpreter in which to lookup variables,
				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    size_t count)			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
{
    return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
	    NULL, NULL);
}

/*







|







5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
int
Tcl_EvalTokensStandard(
    Tcl_Interp *interp,		/* Interpreter in which to lookup variables,
				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    Tcl_Size count)			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
{
    return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
	    NULL, NULL);
}

/*
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
 */

int
Tcl_EvalEx(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * script. Also used for error reporting. */
    const char *script,		/* First character of script to evaluate. */
    size_t numBytes,		/* Number of bytes in script. If -1, the
				 * script consists of all bytes up to the
				 * first null character. */
    int flags)			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL is currently supported. */
{
    return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
}

int
TclEvalEx(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * script. Also used for error reporting. */
    const char *script,		/* First character of script to evaluate. */
    size_t numBytes,		/* Number of bytes in script. If -1, the
				 * script consists of all bytes up to the
				 * first NUL character. */
    int flags,			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL is currently supported. */
    size_t line,			/* The line the script starts on. */
    int *clNextOuter,		/* Information about an outer context for */
    const char *outerScript)	/* continuation line data. This is set only in
				 * TclSubstTokens(), to properly handle
				 * [...]-nested commands. The 'outerScript'
				 * refers to the most-outer script containing
				 * the embedded command, which is referred to
				 * by 'script'. The 'clNextOuter' refers to







|














|





|







5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
 */

int
Tcl_EvalEx(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * script. Also used for error reporting. */
    const char *script,		/* First character of script to evaluate. */
    Tcl_Size numBytes,		/* Number of bytes in script. If -1, the
				 * script consists of all bytes up to the
				 * first null character. */
    int flags)			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL is currently supported. */
{
    return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
}

int
TclEvalEx(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * script. Also used for error reporting. */
    const char *script,		/* First character of script to evaluate. */
    Tcl_Size numBytes,		/* Number of bytes in script. If -1, the
				 * script consists of all bytes up to the
				 * first NUL character. */
    int flags,			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL is currently supported. */
    Tcl_Size line,		/* The line the script starts on. */
    int *clNextOuter,		/* Information about an outer context for */
    const char *outerScript)	/* continuation line data. This is set only in
				 * TclSubstTokens(), to properly handle
				 * [...]-nested commands. The 'outerScript'
				 * refers to the most-outer script containing
				 * the embedded command, which is referred to
				 * by 'script'. The 'clNextOuter' refers to
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
    Interp *iPtr = (Interp *) interp;
    const char *p, *next;
    const unsigned int minObjs = 20;
    Tcl_Obj **objv, **objvSpace;
    int *expand, *lines, *lineSpace;
    Tcl_Token *tokenPtr;
    int bytesLeft, expandRequested, code = TCL_OK;
    size_t commandLength;
    CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
				 * TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
    int gotParse = 0;
    TCL_HASH_TYPE i, objectsUsed = 0;
				/* These variables keep track of how much
				 * state has been allocated while evaluating







|







5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
    Interp *iPtr = (Interp *) interp;
    const char *p, *next;
    const unsigned int minObjs = 20;
    Tcl_Obj **objv, **objvSpace;
    int *expand, *lines, *lineSpace;
    Tcl_Token *tokenPtr;
    int bytesLeft, expandRequested, code = TCL_OK;
    Tcl_Size commandLength;
    CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
				 * TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
    int gotParse = 0;
    TCL_HASH_TYPE i, objectsUsed = 0;
				/* These variables keep track of how much
				 * state has been allocated while evaluating
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
	if (clNextOuter) {
	    clNext = clNextOuter;
	} else {
	    clNext = &iPtr->scriptCLLocPtr->loc[0];
	}
    }

    if (numBytes == TCL_INDEX_NONE) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);

    savedVarFramePtr = iPtr->varFramePtr;
    if (flags & TCL_EVAL_GLOBAL) {
	iPtr->varFramePtr = iPtr->rootFramePtr;







|







5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
	if (clNextOuter) {
	    clNext = clNextOuter;
	} else {
	    clNext = &iPtr->scriptCLLocPtr->loc[0];
	}
    }

    if (numBytes < 0) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);

    savedVarFramePtr = iPtr->varFramePtr;
    if (flags & TCL_EVAL_GLOBAL) {
	iPtr->varFramePtr = iPtr->rootFramePtr;
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
	    /*
	     * TIP #280. Track lines within the words of the current
	     * command. We use a separate pointer into the table of
	     * continuation line locations to not lose our position for the
	     * per-command parsing.
	     */

	    size_t wordLine = line;
	    const char *wordStart = parsePtr->commandStart;
	    int *wordCLNext = clNext;
	    unsigned int objectsNeeded = 0;
	    unsigned int numWords = parsePtr->numWords;

	    /*
	     * Generate an array of objects for the words of the command.







|







5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
	    /*
	     * TIP #280. Track lines within the words of the current
	     * command. We use a separate pointer into the table of
	     * continuation line locations to not lose our position for the
	     * per-command parsing.
	     */

	    Tcl_Size wordLine = line;
	    const char *wordStart = parsePtr->commandStart;
	    int *wordCLNext = clNext;
	    unsigned int objectsNeeded = 0;
	    unsigned int numWords = parsePtr->numWords;

	    /*
	     * Generate an array of objects for the words of the command.
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374

		if (code != TCL_OK) {
		    break;
		}
		objv[objectsUsed] = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    size_t numElements;

		    code = TclListObjLengthM(interp, objv[objectsUsed],
			    &numElements);
		    if (code == TCL_ERROR) {
			/*
			 * Attempt to expand a non-list.
			 */







|







5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374

		if (code != TCL_OK) {
		    break;
		}
		objv[objectsUsed] = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    Tcl_Size numElements;

		    code = TclListObjLengthM(interp, objv[objectsUsed],
			    &numElements);
		    if (code == TCL_ERROR) {
			/*
			 * Attempt to expand a non-list.
			 */
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
			    (Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *));
		    lines = lineSpace = (int *)Tcl_Alloc(objectsNeeded * sizeof(int));
		}

		objectsUsed = 0;
		while (wordIdx--) {
		    if (expand[wordIdx]) {
			size_t numElements;
			Tcl_Obj **elements, *temp = copy[wordIdx];

			TclListObjGetElementsM(NULL, temp, &numElements,
				&elements);
			objectsUsed += numElements;
			while (numElements--) {
			    lines[objIdx] = -1;







|







5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
			    (Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *));
		    lines = lineSpace = (int *)Tcl_Alloc(objectsNeeded * sizeof(int));
		}

		objectsUsed = 0;
		while (wordIdx--) {
		    if (expand[wordIdx]) {
			Tcl_Size numElements;
			Tcl_Obj **elements, *temp = copy[wordIdx];

			TclListObjGetElementsM(NULL, temp, &numElements,
				&elements);
			objectsUsed += numElements;
			while (numElements--) {
			    lines[objIdx] = -1;
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclAdvanceLines(
    size_t *line,
    const char *start,
    const char *end)
{
    const char *p;

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







|







5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclAdvanceLines(
    Tcl_Size *line,
    const char *start,
    const char *end)
{
    const char *p;

    for (p = start; p < end; p++) {
	if (*p == '\n') {
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclAdvanceContinuations(
    size_t *line,
    int **clNextPtrPtr,
    int loc)
{
    /*
     * Track the invisible continuation lines embedded in a script, if any.
     * Here they are just spaces (already). They were removed by
     * TclSubstTokens via TclParseBackslash.







|







5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclAdvanceContinuations(
    Tcl_Size *line,
    int **clNextPtrPtr,
    int loc)
{
    /*
     * Track the invisible continuation lines embedded in a script, if any.
     * Here they are just spaces (already). They were removed by
     * TclSubstTokens via TclParseBackslash.
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
TclArgumentBCEnter(
    Tcl_Interp *interp,
    Tcl_Obj *objv[],
    int objc,
    void *codePtr,
    CmdFrame *cfPtr,
    int cmd,
    size_t pc)
{
    ExtCmdLoc *eclPtr;
    int word;
    ECL *ePtr;
    CFWordBC *lastPtr = NULL;
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hePtr =







|







5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
TclArgumentBCEnter(
    Tcl_Interp *interp,
    Tcl_Obj *objv[],
    int objc,
    void *codePtr,
    CmdFrame *cfPtr,
    int cmd,
    Tcl_Size pc)
{
    ExtCmdLoc *eclPtr;
    int word;
    ECL *ePtr;
    CFWordBC *lastPtr = NULL;
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hePtr =
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
     * ensemble dispatch.  Ensemble subcommands that lead to script
     * evaluation are not supposed to get compiled, because a command
     * such as [info level] in the script can expose some of the dispatch
     * shenanigans.  This means that we don't have to tend to the
     * housekeeping, and can escape now.
     */

    if (ePtr->nline != (size_t)objc) {
        return;
    }

    /*
     * Having disposed of the ensemble cases, we can state...
     * A few truths ...
     * (1) ePtr->nline == objc







|







5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
     * ensemble dispatch.  Ensemble subcommands that lead to script
     * evaluation are not supposed to get compiled, because a command
     * such as [info level] in the script can expose some of the dispatch
     * shenanigans.  This means that we don't have to tend to the
     * housekeeping, and can escape now.
     */

    if (ePtr->nline != objc) {
        return;
    }

    /*
     * Having disposed of the ensemble cases, we can state...
     * A few truths ...
     * (1) ePtr->nline == objc
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
     * This function consists of three independent blocks for: direct
     * evaluation of canonical lists, compilation and bytecode execution and
     * finally direct evaluation. Precisely one of these blocks will be run.
     */

    if (TclListObjIsCanonical(objPtr)) {
	CmdFrame *eoFramePtr = NULL;
	size_t objc;
	Tcl_Obj *listPtr, **objv;

	/*
	 * Canonical List Optimization:  In this case, we
	 * can safely use Tcl_EvalObjv instead and get an appreciable
	 * improvement in execution speed. This is because it allows us to
	 * avoid a setFromAny step that would just pack everything into a







|







6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
     * This function consists of three independent blocks for: direct
     * evaluation of canonical lists, compilation and bytecode execution and
     * finally direct evaluation. Precisely one of these blocks will be run.
     */

    if (TclListObjIsCanonical(objPtr)) {
	CmdFrame *eoFramePtr = NULL;
	Tcl_Size objc;
	Tcl_Obj *listPtr, **objv;

	/*
	 * Canonical List Optimization:  In this case, we
	 * can safely use Tcl_EvalObjv instead and get an appreciable
	 * improvement in execution speed. This is because it allows us to
	 * avoid a setFromAny step that would just pack everything into a
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
	/*
	 * We're not supposed to use the compiler or byte-code
	 * interpreter. Let Tcl_EvalEx evaluate the command directly (and
	 * probably more slowly).
	 */

	const char *script;
	size_t numSrcBytes;

	/*
	 * Now we check if we have data about invisible continuation lines for
	 * the script, and make it available to the direct script parser and
	 * evaluator we are about to call, if so.
	 *
	 * It may be possible that the script Tcl_Obj* can be free'd while the







|







6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
	/*
	 * We're not supposed to use the compiler or byte-code
	 * interpreter. Let Tcl_EvalEx evaluate the command directly (and
	 * probably more slowly).
	 */

	const char *script;
	Tcl_Size numSrcBytes;

	/*
	 * Now we check if we have data about invisible continuation lines for
	 * the script, and make it available to the direct script parser and
	 * evaluator we are about to call, if so.
	 *
	 * It may be possible that the script Tcl_Obj* can be free'd while the
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286

    if (iPtr->numLevels == 0) {
	if (result == TCL_RETURN) {
	    result = TclUpdateReturnInfo(iPtr);
	}
	if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
	    const char *script;
	    size_t numSrcBytes;

	    ProcessUnexpectedResult(interp, result);
	    result = TCL_ERROR;
	    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
	    Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
	}








|







6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286

    if (iPtr->numLevels == 0) {
	if (result == TCL_RETURN) {
	    result = TclUpdateReturnInfo(iPtr);
	}
	if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
	    const char *script;
	    Tcl_Size numSrcBytes;

	    ProcessUnexpectedResult(interp, result);
	    result = TCL_ERROR;
	    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
	    Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
	}

6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
    int returnCode)		/* The unexpected result code. */
{
    char buf[TCL_INTEGER_SPACE];

    Tcl_ResetResult(interp);
    if (returnCode == TCL_BREAK) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"invoked \"break\" outside of a loop", TCL_INDEX_NONE));
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"invoked \"continue\" outside of a loop", TCL_INDEX_NONE));
    } else {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"command returned bad code: %d", returnCode));
    }
    snprintf(buf, sizeof(buf), "%d", returnCode);
    Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL);
}







|


|







6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
    int returnCode)		/* The unexpected result code. */
{
    char buf[TCL_INTEGER_SPACE];

    Tcl_ResetResult(interp);
    if (returnCode == TCL_BREAK) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"invoked \"break\" outside of a loop", -1));
    } else if (returnCode == TCL_CONTINUE) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"invoked \"continue\" outside of a loop", -1));
    } else {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"command returned bad code: %d", returnCode));
    }
    snprintf(buf, sizeof(buf), "%d", returnCode);
    Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL);
}
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
    if (*exprstring == '\0') {
	/*
	 * Legacy compatibility - return 0 for the zero-length string.
	 */

	*ptr = 0;
    } else {
	exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprLongObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
    }
    return result;
}








|







6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
    if (*exprstring == '\0') {
	/*
	 * Legacy compatibility - return 0 for the zero-length string.
	 */

	*ptr = 0;
    } else {
	exprPtr = Tcl_NewStringObj(exprstring, -1);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprLongObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
    }
    return result;
}

6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
    if (*exprstring == '\0') {
	/*
	 * Legacy compatibility - return 0 for the zero-length string.
	 */

	*ptr = 0.0;
    } else {
	exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
				/* Discard the expression object. */
    }
    return result;
}







|







6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
    if (*exprstring == '\0') {
	/*
	 * Legacy compatibility - return 0 for the zero-length string.
	 */

	*ptr = 0.0;
    } else {
	exprPtr = Tcl_NewStringObj(exprstring, -1);
	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
				/* Discard the expression object. */
    }
    return result;
}
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
	 * An empty string. Just set the result boolean to 0 (false).
	 */

	*ptr = 0;
	return TCL_OK;
    } else {
	int result;
	Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);

	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
	return result;
    }
}







|







6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
	 * An empty string. Just set the result boolean to 0 (false).
	 */

	*ptr = 0;
	return TCL_OK;
    } else {
	int result;
	Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1);

	Tcl_IncrRefCount(exprPtr);
	result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
	Tcl_DecrRefCount(exprPtr);
	return result;
    }
}
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
				 * or TCL_INVOKE_NO_TRACEBACK. */
{
    if (interp == NULL) {
	return TCL_ERROR;
    }
    if ((objc < 1) || (objv == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "illegal argument vector", TCL_INDEX_NONE));
	return TCL_ERROR;
    }
    if ((flags & TCL_INVOKE_HIDDEN) == 0) {
	Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
    }
    return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}







|







6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
				 * or TCL_INVOKE_NO_TRACEBACK. */
{
    if (interp == NULL) {
	return TCL_ERROR;
    }
    if ((objc < 1) || (objv == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "illegal argument vector", -1));
	return TCL_ERROR;
    }
    if ((flags & TCL_INVOKE_HIDDEN) == 0) {
	Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
    }
    return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
    if (expr[0] == '\0') {
	/*
	 * An empty string. Just set the interpreter's result to 0.
	 */

	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
    } else {
	Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, TCL_INDEX_NONE);

	Tcl_IncrRefCount(exprObj);
	code = Tcl_ExprObj(interp, exprObj, &resultPtr);
	Tcl_DecrRefCount(exprObj);
	if (code == TCL_OK) {
	    Tcl_SetObjResult(interp, resultPtr);
	    Tcl_DecrRefCount(resultPtr);







|







6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
    if (expr[0] == '\0') {
	/*
	 * An empty string. Just set the interpreter's result to 0.
	 */

	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
    } else {
	Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);

	Tcl_IncrRefCount(exprObj);
	code = Tcl_ExprObj(interp, exprObj, &resultPtr);
	Tcl_DecrRefCount(exprObj);
	if (code == TCL_OK) {
	    Tcl_SetObjResult(interp, resultPtr);
	    Tcl_DecrRefCount(resultPtr);
6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
6820

void
Tcl_AppendObjToErrorInfo(
    Tcl_Interp *interp,		/* Interpreter to which error information
				 * pertains. */
    Tcl_Obj *objPtr)		/* Message to record. */
{
    size_t length;
    const char *message = Tcl_GetStringFromObj(objPtr, &length);
    Interp *iPtr = (Interp *) interp;

    Tcl_IncrRefCount(objPtr);

    /*
     * If we are just starting to log an error, errorInfo is initialized from







|







6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
6820

void
Tcl_AppendObjToErrorInfo(
    Tcl_Interp *interp,		/* Interpreter to which error information
				 * pertains. */
    Tcl_Obj *objPtr)		/* Message to record. */
{
    Tcl_Size length;
    const char *message = Tcl_GetStringFromObj(objPtr, &length);
    Interp *iPtr = (Interp *) interp;

    Tcl_IncrRefCount(objPtr);

    /*
     * If we are just starting to log an error, errorInfo is initialized from
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899

    Tcl_DStringInit(&buf);
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	Tcl_DStringAppend(&buf, string, TCL_INDEX_NONE);
    }

    result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), TCL_INDEX_NONE, 0);
    Tcl_DStringFree(&buf);
    return result;
}

/*
 *----------------------------------------------------------------------
 *







|


|







6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899

    Tcl_DStringInit(&buf);
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	Tcl_DStringAppend(&buf, string, -1);
    }

    result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
    Tcl_DStringFree(&buf);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

size_t
Tcl_SetRecursionLimit(
    Tcl_Interp *interp,		/* Interpreter whose nesting limit is to be
				 * set. */
    size_t depth)			/* New value for maximimum depth. */
{
    Interp *iPtr = (Interp *) interp;
    size_t old;

    old = iPtr->maxNestingDepth;
    if (depth + 1 > 1) {
	iPtr->maxNestingDepth = depth;
    }
    return old;
}

/*
 *----------------------------------------------------------------------







|



|


|


|







6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_SetRecursionLimit(
    Tcl_Interp *interp,		/* Interpreter whose nesting limit is to be
				 * set. */
    Tcl_Size depth)		/* New value for maximimum depth. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Size old;

    old = iPtr->maxNestingDepth;
    if (depth > 0) {
	iPtr->maxNestingDepth = depth;
    }
    return old;
}

/*
 *----------------------------------------------------------------------
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
	}
	Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
    }
    return TCL_OK;

  negarg:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
            "square root of negative argument", TCL_INDEX_NONE));
    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
	    "domain error: argument not in valid range", NULL);
    return TCL_ERROR;
}

static int
ExprSqrtFunc(







|







7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
	}
	Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
    }
    return TCL_OK;

  negarg:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
            "square root of negative argument", -1));
    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
	    "domain error: argument not in valid range", NULL);
    return TCL_ERROR;
}

static int
ExprSqrtFunc(
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
    if (type == TCL_NUMBER_INT) {
	Tcl_WideInt l = *((const Tcl_WideInt *) ptr);

	if (l > 0) {
	    goto unChanged;
	} else if (l == 0) {
	    if (TclHasStringRep(objv[1])) {
		size_t numBytes;
		const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);

		while (numBytes) {
		    if (*bytes == '-') {
			Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
			return TCL_OK;
		    }







|







7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
    if (type == TCL_NUMBER_INT) {
	Tcl_WideInt l = *((const Tcl_WideInt *) ptr);

	if (l > 0) {
	    goto unChanged;
	} else if (l == 0) {
	    if (TclHasStringRep(objv[1])) {
		Tcl_Size numBytes;
		const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);

		while (numBytes) {
		    if (*bytes == '-') {
			Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
			return TCL_OK;
		    }
8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
 */

int
Tcl_NRCallObjProc(
    Tcl_Interp *interp,
    Tcl_ObjCmdProc *objProc,
    void *clientData,
    size_t objc,
    Tcl_Obj *const objv[])
{
    NRE_callback *rootPtr = TOP_CB(interp);

    TclNRAddCallback(interp, Dispatch, objProc, clientData,
	    INT2PTR(objc), objv);
    return TclNRRunCallbacks(interp, TCL_OK, rootPtr);







|







8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
 */

int
Tcl_NRCallObjProc(
    Tcl_Interp *interp,
    Tcl_ObjCmdProc *objProc,
    void *clientData,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    NRE_callback *rootPtr = TOP_CB(interp);

    TclNRAddCallback(interp, Dispatch, objProc, clientData,
	    INT2PTR(objc), objv);
    return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
    clientData = info->clientData;
    Tcl_ObjCmdProc2 *proc = info->proc;
    Tcl_Free(info);
    if (objc < 0) {
	objc = -1;
    }
    return proc(clientData, interp, (size_t)objc, objv);
}

int
Tcl_NRCallObjProc2(
    Tcl_Interp *interp,
    Tcl_ObjCmdProc2 *objProc,
    void *clientData,
    size_t objc,
    Tcl_Obj *const objv[])
{
    if (objc > INT_MAX) {
	Tcl_WrongNumArgs(interp, 1, objv, "?args?");
	return TCL_ERROR;
    }








|







|







8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
    clientData = info->clientData;
    Tcl_ObjCmdProc2 *proc = info->proc;
    Tcl_Free(info);
    if (objc < 0) {
	objc = -1;
    }
    return proc(clientData, interp, (Tcl_Size)objc, objv);
}

int
Tcl_NRCallObjProc2(
    Tcl_Interp *interp,
    Tcl_ObjCmdProc2 *objProc,
    void *clientData,
    ptrdiff_t objc,
    Tcl_Obj *const objv[])
{
    if (objc > INT_MAX) {
	Tcl_WrongNumArgs(interp, 1, objv, "?args?");
	return TCL_ERROR;
    }

8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
    int objc,
    Tcl_Obj *const objv[])
{
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
    if (objc < 0) {
	objc = -1;
    }
    return info->nreProc(info->clientData, interp, (size_t)objc, objv);
}

Tcl_Command
Tcl_NRCreateCommand2(
    Tcl_Interp *interp,		/* Token for command interpreter (returned by
				 * previous call to Tcl_CreateInterp). */
    const char *cmdName,	/* Name of command. If it contains namespace







|







8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
    int objc,
    Tcl_Obj *const objv[])
{
    CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
    if (objc < 0) {
	objc = -1;
    }
    return info->nreProc(info->clientData, interp, objc, objv);
}

Tcl_Command
Tcl_NRCreateCommand2(
    Tcl_Interp *interp,		/* Token for command interpreter (returned by
				 * previous call to Tcl_CreateInterp). */
    const char *cmdName,	/* Name of command. If it contains namespace
8653
8654
8655
8656
8657
8658
8659
8660
8661
8662
8663
8664
8665
8666
8667
8668
8669
8670
8671
8672
8673
8674
8675
8676
8677
8678
8679
8680
8681
8682
    return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
}

int
Tcl_NREvalObjv(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */
    size_t objc,			/* Number of words in command. */
    Tcl_Obj *const objv[],	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags)			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
				 * TCL_EVAL_NOERR are currently supported. */
{
    return TclNREvalObjv(interp, objc, objv, flags, NULL);
}

int
Tcl_NRCmdSwap(
    Tcl_Interp *interp,
    Tcl_Command cmd,
    size_t objc,
    Tcl_Obj *const objv[],
    int flags)
{
    return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR,
	    (Command *) cmd);
}








|














|







8653
8654
8655
8656
8657
8658
8659
8660
8661
8662
8663
8664
8665
8666
8667
8668
8669
8670
8671
8672
8673
8674
8675
8676
8677
8678
8679
8680
8681
8682
    return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
}

int
Tcl_NREvalObjv(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the
				 * command. Also used for error reporting. */
    Tcl_Size objc,			/* Number of words in command. */
    Tcl_Obj *const objv[],	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags)			/* Collection of OR-ed bits that control the
				 * evaluation of the script. Only
				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
				 * TCL_EVAL_NOERR are currently supported. */
{
    return TclNREvalObjv(interp, objc, objv, flags, NULL);
}

int
Tcl_NRCmdSwap(
    Tcl_Interp *interp,
    Tcl_Command cmd,
    Tcl_Size objc,
    Tcl_Obj *const objv[],
    int flags)
{
    return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR,
	    (Command *) cmd);
}

8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
8815
8816
    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
	return TCL_ERROR;
    }

    if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "tailcall can only be called from a proc, lambda or method", TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
	return TCL_ERROR;
    }

    /*
     * Invocation without args just clears a scheduled tailcall; invocation
     * with an argument replaces any previously scheduled tailcall.







|







8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
8815
8816
    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
	return TCL_ERROR;
    }

    if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "tailcall can only be called from a proc, lambda or method", -1));
        Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
	return TCL_ERROR;
    }

    /*
     * Invocation without args just clears a scheduled tailcall; invocation
     * with an argument replaces any previously scheduled tailcall.
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
8846
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;

        /*
         * The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled.
         */

        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
        listPtr = Tcl_NewListObj(objc, objv);
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
    return TCL_RETURN;
}







|







8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
8846
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;

        /*
         * The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled.
         */

        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        listPtr = Tcl_NewListObj(objc, objv);
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
    return TCL_RETURN;
}
8860
8861
8862
8863
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873
8874
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
    Tcl_Namespace *nsPtr;
    size_t objc;
    Tcl_Obj **objv;

    TclListObjGetElementsM(interp, listPtr, &objc, &objv);
    nsObjPtr = objv[0];

    if (result == TCL_OK) {
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);







|







8860
8861
8862
8863
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873
8874
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
    Tcl_Namespace *nsPtr;
    Tcl_Size objc;
    Tcl_Obj **objv;

    TclListObjGetElementsM(interp, listPtr, &objc, &objv);
    nsObjPtr = objv[0];

    if (result == TCL_OK) {
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
	return TCL_ERROR;
    }

    if (!corPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "yield can only be called in a coroutine", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
	return TCL_ERROR;
    }

    if (objc == 2) {
	Tcl_SetObjResult(interp, objv[1]);
    }







|







8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
	return TCL_ERROR;
    }

    if (!corPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "yield can only be called in a coroutine", -1));
	Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
	return TCL_ERROR;
    }

    if (objc == 2) {
	Tcl_SetObjResult(interp, objv[1]);
    }
8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
	return TCL_ERROR;
    }

    if (!corPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "yieldto can only be called in a coroutine", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
	return TCL_ERROR;
    }

    if (((Namespace *) nsPtr)->flags & NS_DYING) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"yieldto called in deleted namespace", TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
		NULL);
        return TCL_ERROR;
    }

    /*
     * Add the tailcall in the caller env, then just yield.
     *
     * This is essentially code from TclNRTailcallObjCmd
     */

    listPtr = Tcl_NewListObj(objc, objv);
    nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
    TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

    /*
     * Add the callback in the caller's env, then instruct TEBC to yield.
     */

    iPtr->execEnvPtr = corPtr->callerEEPtr;







|






|












|







8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
	return TCL_ERROR;
    }

    if (!corPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "yieldto can only be called in a coroutine", -1));
	Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
	return TCL_ERROR;
    }

    if (((Namespace *) nsPtr)->flags & NS_DYING) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"yieldto called in deleted namespace", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
		NULL);
        return TCL_ERROR;
    }

    /*
     * Add the tailcall in the caller env, then just yield.
     *
     * This is essentially code from TclNRTailcallObjCmd
     */

    listPtr = Tcl_NewListObj(objc, objv);
    nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
    TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

    /*
     * Add the callback in the caller's env, then instruct TEBC to yield.
     */

    iPtr->execEnvPtr = corPtr->callerEEPtr;
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222

        /*
         * Record the stackLevel at which the resume is happening, then swap
         * the interp's environment to make it suitable to run this coroutine.
         */

        corPtr->stackLevel = &corPtr;
        size_t numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = iPtr->numLevels;

        SAVE_CONTEXT(corPtr->caller);
        corPtr->callerEEPtr = iPtr->execEnvPtr;
        RESTORE_CONTEXT(corPtr->running);
        iPtr->execEnvPtr = corPtr->eePtr;
        iPtr->numLevels += numLevels;







|







9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222

        /*
         * Record the stackLevel at which the resume is happening, then swap
         * the interp's environment to make it suitable to run this coroutine.
         */

        corPtr->stackLevel = &corPtr;
        Tcl_Size numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = iPtr->numLevels;

        SAVE_CONTEXT(corPtr->caller);
        corPtr->callerEEPtr = iPtr->execEnvPtr;
        RESTORE_CONTEXT(corPtr->running);
        iPtr->execEnvPtr = corPtr->eePtr;
        iPtr->numLevels += numLevels;
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
		    }
		}
	    }
	    iPtr->execEnvPtr = corPtr->eePtr;


            Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "cannot yield: C stack busy", TCL_INDEX_NONE));
            Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
                    NULL);
            return TCL_ERROR;
        }

        void *type = data[1];
        if (type == CORO_ACTIVATE_YIELD) {
            corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
        } else if (type == CORO_ACTIVATE_YIELDM) {
            corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY;
        } else {
            Tcl_Panic("Yield received an option which is not implemented");
        }

	corPtr->yieldPtr = NULL;
        corPtr->stackLevel = NULL;

        size_t numLevels = iPtr->numLevels;
        iPtr->numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;

        iPtr->execEnvPtr = corPtr->callerEEPtr;
    }

    return TCL_OK;







|

















|







9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
		    }
		}
	    }
	    iPtr->execEnvPtr = corPtr->eePtr;


            Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "cannot yield: C stack busy", -1));
            Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
                    NULL);
            return TCL_ERROR;
        }

        void *type = data[1];
        if (type == CORO_ACTIVATE_YIELD) {
            corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
        } else if (type == CORO_ACTIVATE_YIELDM) {
            corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY;
        } else {
            Tcl_Panic("Yield received an option which is not implemented");
        }

	corPtr->yieldPtr = NULL;
        corPtr->stackLevel = NULL;

        Tcl_Size numLevels = iPtr->numLevels;
        iPtr->numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;

        iPtr->execEnvPtr = corPtr->callerEEPtr;
    }

    return TCL_OK;
9284
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298

static int
TclNREvalList(
    void *data[],
    Tcl_Interp *interp,
    TCL_UNUSED(int) /*result*/)
{
    size_t objc;
    Tcl_Obj **objv;
    Tcl_Obj *listPtr = (Tcl_Obj *)data[0];

    Tcl_IncrRefCount(listPtr);

    TclMarkTailcall(interp);
    TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);







|







9284
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298

static int
TclNREvalList(
    void *data[],
    Tcl_Interp *interp,
    TCL_UNUSED(int) /*result*/)
{
    Tcl_Size objc;
    Tcl_Obj **objv;
    Tcl_Obj *listPtr = (Tcl_Obj *)data[0];

    Tcl_IncrRefCount(listPtr);

    TclMarkTailcall(interp);
    TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347
9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
    /*
     * Look up the coroutine.
     */

    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only get coroutine type of a coroutine", TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objv[1]), NULL);
        return TCL_ERROR;
    }

    /*
     * An active coroutine is "active". Can't tell what it might do in the
     * future.
     */

    corPtr = (CoroutineData *)cmdPtr->objClientData;
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("active", TCL_INDEX_NONE));
        return TCL_OK;
    }

    /*
     * Inactive coroutines are classified by the (effective) command used to
     * suspend them, which matters when you're injecting a probe.
     */

    switch (corPtr->nargs) {
    case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", TCL_INDEX_NONE));
        return TCL_OK;
    case COROUTINE_ARGUMENTS_ARBITRARY:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", TCL_INDEX_NONE));
        return TCL_OK;
    default:
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "unknown coroutine type", TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
        return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------







|












|










|


|



|







9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347
9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
    /*
     * Look up the coroutine.
     */

    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only get coroutine type of a coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objv[1]), NULL);
        return TCL_ERROR;
    }

    /*
     * An active coroutine is "active". Can't tell what it might do in the
     * future.
     */

    corPtr = (CoroutineData *)cmdPtr->objClientData;
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
        return TCL_OK;
    }

    /*
     * Inactive coroutines are classified by the (effective) command used to
     * suspend them, which matters when you're injecting a probe.
     */

    switch (corPtr->nargs) {
    case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
        return TCL_OK;
    case COROUTINE_ARGUMENTS_ARBITRARY:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
        return TCL_OK;
    default:
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "unknown coroutine type", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
        return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
9388
9389
9390
9391
9392
9393
9394
9395
9396
9397
9398
9399
9400
9401
9402
    /*
     * How to get a coroutine from its handle.
     */

    Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);

    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objPtr), NULL);
        return NULL;
    }
    return (CoroutineData *)cmdPtr->objClientData;
}








|







9388
9389
9390
9391
9392
9393
9394
9395
9396
9397
9398
9399
9400
9401
9402
    /*
     * How to get a coroutine from its handle.
     */

    Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);

    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objPtr), NULL);
        return NULL;
    }
    return (CoroutineData *)cmdPtr->objClientData;
}

9422
9423
9424
9425
9426
9427
9428
9429
9430
9431
9432
9433
9434
9435
9436
    corPtr = GetCoroutineFromObj(interp, objv[1],
            "can only inject a command into a coroutine");
    if (!corPtr) {
        return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a suspended coroutine", TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed.







|







9422
9423
9424
9425
9426
9427
9428
9429
9430
9431
9432
9433
9434
9435
9436
    corPtr = GetCoroutineFromObj(interp, objv[1],
            "can only inject a command into a coroutine");
    if (!corPtr) {
        return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a suspended coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed.
9500
9501
9502
9503
9504
9505
9506
9507
9508
9509
9510
9511
9512
9513
9514

    /*
     * Record the stackLevel at which the resume is happening, then swap
     * the interp's environment to make it suitable to run this coroutine.
     */

    corPtr->stackLevel = &corPtr;
    size_t numLevels = corPtr->auxNumLevels;
    corPtr->auxNumLevels = iPtr->numLevels;

    /*
     * Do the actual stack swap.
     */

    SAVE_CONTEXT(corPtr->caller);







|







9500
9501
9502
9503
9504
9505
9506
9507
9508
9509
9510
9511
9512
9513
9514

    /*
     * Record the stackLevel at which the resume is happening, then swap
     * the interp's environment to make it suitable to run this coroutine.
     */

    corPtr->stackLevel = &corPtr;
    Tcl_Size numLevels = corPtr->auxNumLevels;
    corPtr->auxNumLevels = iPtr->numLevels;

    /*
     * Do the actual stack swap.
     */

    SAVE_CONTEXT(corPtr->caller);
9544
9545
9546
9547
9548
9549
9550
9551
9552
9553
9554
9555
9556
9557
9558
9559
9560
InjectHandler(
    void *data[],
    Tcl_Interp *interp,
    TCL_UNUSED(int) /*result*/)
{
    CoroutineData *corPtr = (CoroutineData *)data[0];
    Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
    size_t nargs = PTR2INT(data[2]);
    void *isProbe = data[3];
    size_t objc;
    Tcl_Obj **objv;

    if (!isProbe) {
	/*
	 * If this is [coroinject], add the extra arguments now.
	 */








|

|







9544
9545
9546
9547
9548
9549
9550
9551
9552
9553
9554
9555
9556
9557
9558
9559
9560
InjectHandler(
    void *data[],
    Tcl_Interp *interp,
    TCL_UNUSED(int) /*result*/)
{
    CoroutineData *corPtr = (CoroutineData *)data[0];
    Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
    Tcl_Size nargs = PTR2INT(data[2]);
    void *isProbe = data[3];
    Tcl_Size objc;
    Tcl_Obj **objv;

    if (!isProbe) {
	/*
	 * If this is [coroinject], add the extra arguments now.
	 */

9591
9592
9593
9594
9595
9596
9597
9598
9599
9600
9601
9602
9603
9604
9605
InjectHandlerPostCall(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    CoroutineData *corPtr = (CoroutineData *)data[0];
    Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
    size_t nargs = PTR2INT(data[2]);
    void *isProbe = data[3];

    /*
     * Delete the command words for what we just executed.
     */

    Tcl_DecrRefCount(listPtr);







|







9591
9592
9593
9594
9595
9596
9597
9598
9599
9600
9601
9602
9603
9604
9605
InjectHandlerPostCall(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    CoroutineData *corPtr = (CoroutineData *)data[0];
    Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
    Tcl_Size nargs = PTR2INT(data[2]);
    void *isProbe = data[3];

    /*
     * Delete the command words for what we just executed.
     */

    Tcl_DecrRefCount(listPtr);
9614
9615
9616
9617
9618
9619
9620
9621
9622
9623
9624
9625
9626
9627
9628
    if (isProbe) {
        if (result == TCL_ERROR) {
            Tcl_AddErrorInfo(interp,
                    "\n    (injected coroutine probe command)");
        }
        corPtr->nargs = nargs;
        corPtr->stackLevel = NULL;
        size_t numLevels = iPtr->numLevels;
        iPtr->numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
        iPtr->execEnvPtr = corPtr->callerEEPtr;
    }
    return result;
}








|







9614
9615
9616
9617
9618
9619
9620
9621
9622
9623
9624
9625
9626
9627
9628
    if (isProbe) {
        if (result == TCL_ERROR) {
            Tcl_AddErrorInfo(interp,
                    "\n    (injected coroutine probe command)");
        }
        corPtr->nargs = nargs;
        corPtr->stackLevel = NULL;
        Tcl_Size numLevels = iPtr->numLevels;
        iPtr->numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
        iPtr->execEnvPtr = corPtr->callerEEPtr;
    }
    return result;
}

9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
9672
9673
    corPtr = GetCoroutineFromObj(interp, objv[1],
            "can only inject a command into a coroutine");
    if (!corPtr) {
        return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a suspended coroutine", TCL_INDEX_NONE));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed.







|







9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
9672
9673
    corPtr = GetCoroutineFromObj(interp, objv[1],
            "can only inject a command into a coroutine");
    if (!corPtr) {
        return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a suspended coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed.
9710
9711
9712
9713
9714
9715
9716
9717
9718
9719
9720
9721
9722
9723
9724
9725
9726
9727
            Tcl_SetObjResult(interp, objv[1]);
        } else if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
            return TCL_ERROR;
        }
        break;
    default:
        if (corPtr->nargs + 1 != (size_t)objc) {
            Tcl_SetObjResult(interp,
                    Tcl_NewStringObj("wrong coro nargs; how did we get here? "
                    "not implemented!", TCL_INDEX_NONE));
            Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
            return TCL_ERROR;
        }
        /* fallthrough */
    case COROUTINE_ARGUMENTS_ARBITRARY:
        if (objc > 1) {
            Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1));







|


|







9710
9711
9712
9713
9714
9715
9716
9717
9718
9719
9720
9721
9722
9723
9724
9725
9726
9727
            Tcl_SetObjResult(interp, objv[1]);
        } else if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
            return TCL_ERROR;
        }
        break;
    default:
        if (corPtr->nargs + 1 != objc) {
            Tcl_SetObjResult(interp,
                    Tcl_NewStringObj("wrong coro nargs; how did we get here? "
                    "not implemented!", -1));
            Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
            return TCL_ERROR;
        }
        /* fallthrough */
    case COROUTINE_ARGUMENTS_ARBITRARY:
        if (objc > 1) {
            Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1));

Changes to generic/tclBinary.c.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
#include <assert.h>

/*
 * The following constants are used by GetFormatSpec to indicate various
 * special conditions in the parsing of a format specifier.
 */

#define BINARY_ALL ((size_t)-1)		/* Use all elements in the argument. */
#define BINARY_NOCOUNT ((size_t)-2)	/* No count was specified in format. */

/*
 * The following flags may be OR'ed together and returned by GetFormatSpec
 */

#define BINARY_SIGNED 0		/* Field to be read as signed data */
#define BINARY_UNSIGNED 1	/* Field to be read as unsigned data */







|
|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
#include <assert.h>

/*
 * The following constants are used by GetFormatSpec to indicate various
 * special conditions in the parsing of a format specifier.
 */

#define BINARY_ALL -1		/* Use all elements in the argument. */
#define BINARY_NOCOUNT -2	/* No count was specified in format. */

/*
 * The following flags may be OR'ed together and returned by GetFormatSpec
 */

#define BINARY_SIGNED 0		/* Field to be read as signed data */
#define BINARY_UNSIGNED 1	/* Field to be read as unsigned data */
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74

static void		DupProperByteArrayInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static int		FormatNumber(Tcl_Interp *interp, int type,
			    Tcl_Obj *src, unsigned char **cursorPtr);
static void		FreeProperByteArrayInternalRep(Tcl_Obj *objPtr);
static int		GetFormatSpec(const char **formatPtr, char *cmdPtr,
			    size_t *countPtr, int *flagsPtr);
static Tcl_Obj *	ScanNumber(unsigned char *buffer, int type,
			    int flags, Tcl_HashTable **numberCachePtr);
static int		SetByteArrayFromAny(Tcl_Interp *interp, size_t limit,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    size_t length, int type);
/* Binary ensemble commands */







|


|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74

static void		DupProperByteArrayInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static int		FormatNumber(Tcl_Interp *interp, int type,
			    Tcl_Obj *src, unsigned char **cursorPtr);
static void		FreeProperByteArrayInternalRep(Tcl_Obj *objPtr);
static int		GetFormatSpec(const char **formatPtr, char *cmdPtr,
			    Tcl_Size *countPtr, int *flagsPtr);
static Tcl_Obj *	ScanNumber(unsigned char *buffer, int type,
			    int flags, Tcl_HashTable **numberCachePtr);
static int		SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Size limit,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    size_t length, int type);
/* Binary ensemble commands */
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

186
187

188
189
190
191
192
193
194
195
 * The following structure is the internal rep for a ByteArray object. Keeps
 * track of how much memory has been used and how much has been allocated for
 * the byte array to enable growing and shrinking of the ByteArray object with
 * fewer mallocs.
 */

typedef struct {
    size_t used;		/* The number of bytes used in the byte
				 * array. */
    size_t allocated;		/* The amount of space actually allocated
				 * minus 1 byte. */
    unsigned char bytes[TCLFLEXARRAY];	/* The array of bytes. The actual size of this
				 * field depends on the 'allocated' field
				 * above. */
} ByteArray;


#define BYTEARRAY_SIZE(len) \
	( (offsetof(ByteArray, bytes) + (len) < offsetof(ByteArray, bytes)) \

	? (Tcl_Panic("max size of a Tcl value exceeded"), 0) \
	: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
		(irPtr)->twoPtrValue.ptr1 = (baPtr)

int
TclIsPureByteArray(







|

|






>

<
>
|







170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

188
189
190
191
192
193
194
195
196
 * The following structure is the internal rep for a ByteArray object. Keeps
 * track of how much memory has been used and how much has been allocated for
 * the byte array to enable growing and shrinking of the ByteArray object with
 * fewer mallocs.
 */

typedef struct {
    Tcl_Size used;		/* The number of bytes used in the byte
				 * array. */
    Tcl_Size allocated;		/* The amount of space actually allocated
				 * minus 1 byte. */
    unsigned char bytes[TCLFLEXARRAY];	/* The array of bytes. The actual size of this
				 * field depends on the 'allocated' field
				 * above. */
} ByteArray;

#define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes))
#define BYTEARRAY_SIZE(len) \

        ( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
	? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \
	: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
		(irPtr)->twoPtrValue.ptr1 = (baPtr)

int
TclIsPureByteArray(
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

#undef Tcl_NewByteArrayObj

Tcl_Obj *
Tcl_NewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    size_t numBytes)		/* Number of bytes in the array */
{
#ifdef TCL_MEM_DEBUG
    return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0);
#else /* if not TCL_MEM_DEBUG */
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);







|







219
220
221
222
223
224
225
226
227
228
229
230
231
232
233

#undef Tcl_NewByteArrayObj

Tcl_Obj *
Tcl_NewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    Tcl_Size numBytes)		/* Number of bytes in the array */
{
#ifdef TCL_MEM_DEBUG
    return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0);
#else /* if not TCL_MEM_DEBUG */
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
 */

#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    size_t numBytes,		/* Number of bytes in the array */
    const char *file,		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{
    Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetByteArrayObj(objPtr, bytes, numBytes);
    return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    size_t numBytes,		/* Number of bytes in the array */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    return Tcl_NewByteArrayObj(bytes, numBytes);
}
#endif /* TCL_MEM_DEBUG */








|
















|







262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
 */

#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    Tcl_Size numBytes,		/* Number of bytes in the array */
    const char *file,		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{
    Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetByteArrayObj(objPtr, bytes, numBytes);
    return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewByteArrayObj(
    const unsigned char *bytes,	/* The array of bytes used to initialize the
				 * new object. */
    Tcl_Size numBytes,		/* Number of bytes in the array */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    return Tcl_NewByteArrayObj(bytes, numBytes);
}
#endif /* TCL_MEM_DEBUG */

309
310
311
312
313
314
315
316

317
318
319
320
321
322
323
324
325

326
327
328
329
330
331
332
 */

void
Tcl_SetByteArrayObj(
    Tcl_Obj *objPtr,		/* Object to initialize as a ByteArray. */
    const unsigned char *bytes,	/* The array of bytes to use as the new value.
				 * May be NULL even if numBytes > 0. */
    size_t numBytes)		/* Number of bytes in the array */

{
    ByteArray *byteArrayPtr;
    Tcl_ObjInternalRep ir;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
    }
    TclInvalidateStringRep(objPtr);


    byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes));
    byteArrayPtr->used = numBytes;
    byteArrayPtr->allocated = numBytes;

    if ((bytes != NULL) && (numBytes > 0)) {
	memcpy(byteArrayPtr->bytes, bytes, numBytes);
    }







|
>









>







310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
 */

void
Tcl_SetByteArrayObj(
    Tcl_Obj *objPtr,		/* Object to initialize as a ByteArray. */
    const unsigned char *bytes,	/* The array of bytes to use as the new value.
				 * May be NULL even if numBytes > 0. */
    Tcl_Size numBytes)		/* Number of bytes in the array.
				 * Must be >= 0 */
{
    ByteArray *byteArrayPtr;
    Tcl_ObjInternalRep ir;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
    }
    TclInvalidateStringRep(objPtr);

    assert(numBytes >= 0);
    byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes));
    byteArrayPtr->used = numBytes;
    byteArrayPtr->allocated = numBytes;

    if ((bytes != NULL) && (numBytes > 0)) {
	memcpy(byteArrayPtr->bytes, bytes, numBytes);
    }
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
 */

#undef Tcl_GetBytesFromObj
unsigned char *
Tcl_GetBytesFromObj(
    Tcl_Interp *interp,		/* For error reporting */
    Tcl_Obj *objPtr,		/* Value to extract from */
    size_t *numBytesPtr)	/* If non-NULL, write the number of bytes
				 * in the array here */
{
    ByteArray *baPtr;
    const Tcl_ObjInternalRep *irPtr
	    = TclFetchInternalRep(objPtr, &properByteArrayType);

    if (irPtr == NULL) {







|







356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
 */

#undef Tcl_GetBytesFromObj
unsigned char *
Tcl_GetBytesFromObj(
    Tcl_Interp *interp,		/* For error reporting */
    Tcl_Obj *objPtr,		/* Value to extract from */
    Tcl_Size *numBytesPtr)	/* If non-NULL, write the number of bytes
				 * in the array here */
{
    ByteArray *baPtr;
    const Tcl_ObjInternalRep *irPtr
	    = TclFetchInternalRep(objPtr, &properByteArrayType);

    if (irPtr == NULL) {
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
unsigned char *
TclGetBytesFromObj(
    Tcl_Interp *interp,		/* For error reporting */
    Tcl_Obj *objPtr,		/* Value to extract from */
    int *numBytesPtr)		/* If non-NULL, write the number of bytes
				 * in the array here */
{
    size_t numBytes = 0;
    unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes);

    if (bytes && numBytesPtr) {
	if (numBytes > INT_MAX) {
	    /* Caller asked for numBytes to be written to an int, but the
	     * value is outside the int range. */

	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"byte sequence length exceeds INT_MAX", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", NULL);
	    }
	    return NULL;
	} else {
	    *numBytesPtr = (int) numBytes;
	}
    }







|









|







385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
unsigned char *
TclGetBytesFromObj(
    Tcl_Interp *interp,		/* For error reporting */
    Tcl_Obj *objPtr,		/* Value to extract from */
    int *numBytesPtr)		/* If non-NULL, write the number of bytes
				 * in the array here */
{
    Tcl_Size numBytes = 0;
    unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes);

    if (bytes && numBytesPtr) {
	if (numBytes > INT_MAX) {
	    /* Caller asked for numBytes to be written to an int, but the
	     * value is outside the int range. */

	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"byte sequence length exceeds INT_MAX", -1));
		Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", NULL);
	    }
	    return NULL;
	} else {
	    *numBytesPtr = (int) numBytes;
	}
    }
429
430
431
432
433
434
435
436

437
438
439
440

441
442
443
444
445
446
447
 *
 *----------------------------------------------------------------------
 */

unsigned char *
Tcl_SetByteArrayLength(
    Tcl_Obj *objPtr,		/* The ByteArray object. */
    size_t numBytes)		/* Number of bytes in resized array */

{
    ByteArray *byteArrayPtr;
    Tcl_ObjInternalRep *irPtr;


    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
    }

    irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
    if (irPtr == NULL) {
	if (TCL_ERROR == SetByteArrayFromAny(NULL, numBytes, objPtr)) {







|
>




>







432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
 *
 *----------------------------------------------------------------------
 */

unsigned char *
Tcl_SetByteArrayLength(
    Tcl_Obj *objPtr,		/* The ByteArray object. */
    Tcl_Size numBytes)		/* Number of bytes in resized array
                                 * Must be >= 0 */
{
    ByteArray *byteArrayPtr;
    Tcl_ObjInternalRep *irPtr;

    assert(numBytes >= 0);
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
    }

    irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
    if (irPtr == NULL) {
	if (TCL_ERROR == SetByteArrayFromAny(NULL, numBytes, objPtr)) {
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506

/*
 *----------------------------------------------------------------------
 *
 * MakeByteArray --
 *
 *	Generate a ByteArray internal rep from the string rep of objPtr.
 *	The generated byte sequence may have no more than limit bytes. The
 *	value of TCL_INDEX_NONE for limit indicates no limit imposed. If
 *	boolean argument demandProper is true, then no byte sequence should
 *	be output to the caller (write NULL instead). When no bytes sequence
 *	is output and interp is not NULL, leave an error message and error
 *	code in interp explaining why a proper byte sequence could not be
 *	made.
 *
 * Results:
 *	Returns a boolean indicating whether the bytes generated (up to
 *	limit bytes) are a proper representation of (a limited prefix of)
 *	the string. Writes a pointer to the generated ByteArray to
 *	*byteArrayPtrPtr. If not NULL it needs to be released with Tcl_Free().
 *
 *----------------------------------------------------------------------
 */

static int
MakeByteArray(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    size_t limit,
    int demandProper,
    ByteArray **byteArrayPtrPtr)
{
    size_t length;
    const char *src = Tcl_GetStringFromObj(objPtr, &length);
    size_t numBytes
	    = (limit != TCL_INDEX_NONE && limit < length) ? limit : length;
    ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes));
    unsigned char *dst = byteArrayPtr->bytes;
    unsigned char *dstEnd = dst + numBytes;
    const char *srcEnd = src + length;
    int proper = 1;

    for (; src < srcEnd && dst < dstEnd; ) {







|
|



















|



|

<
|







469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502

503
504
505
506
507
508
509
510

/*
 *----------------------------------------------------------------------
 *
 * MakeByteArray --
 *
 *	Generate a ByteArray internal rep from the string rep of objPtr.
 *	The generated byte sequence may have no more than limit bytes.
 *	A negative value for limit indicates no limit imposed. If
 *	boolean argument demandProper is true, then no byte sequence should
 *	be output to the caller (write NULL instead). When no bytes sequence
 *	is output and interp is not NULL, leave an error message and error
 *	code in interp explaining why a proper byte sequence could not be
 *	made.
 *
 * Results:
 *	Returns a boolean indicating whether the bytes generated (up to
 *	limit bytes) are a proper representation of (a limited prefix of)
 *	the string. Writes a pointer to the generated ByteArray to
 *	*byteArrayPtrPtr. If not NULL it needs to be released with Tcl_Free().
 *
 *----------------------------------------------------------------------
 */

static int
MakeByteArray(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Size limit,
    int demandProper,
    ByteArray **byteArrayPtrPtr)
{
    Tcl_Size length;
    const char *src = Tcl_GetStringFromObj(objPtr, &length);

    Tcl_Size numBytes = (limit >= 0 && limit < length) ? limit : length;
    ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes));
    unsigned char *dst = byteArrayPtr->bytes;
    unsigned char *dstEnd = dst + numBytes;
    const char *srcEnd = src + length;
    int proper = 1;

    for (; src < srcEnd && dst < dstEnd; ) {
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
 *
 *----------------------------------------------------------------------
 */

static int
SetByteArrayFromAny(
    Tcl_Interp *interp,		/* For error reporting. */
    size_t limit,		/* Create no more than this many bytes */
    Tcl_Obj *objPtr)		/* The object to convert to type ByteArray. */
{
    ByteArray *byteArrayPtr;
    Tcl_ObjInternalRep ir;

    if (0 == MakeByteArray(interp, objPtr, limit, 1, &byteArrayPtr)) {
	return TCL_ERROR;







|







571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
 *
 *----------------------------------------------------------------------
 */

static int
SetByteArrayFromAny(
    Tcl_Interp *interp,		/* For error reporting. */
    Tcl_Size limit,		/* Create no more than this many bytes */
    Tcl_Obj *objPtr)		/* The object to convert to type ByteArray. */
{
    ByteArray *byteArrayPtr;
    Tcl_ObjInternalRep ir;

    if (0 == MakeByteArray(interp, objPtr, limit, 1, &byteArrayPtr)) {
	return TCL_ERROR;
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
 */

static void
DupProperByteArrayInternalRep(
    Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr)		/* Object with internal rep to set. */
{
    size_t length;
    ByteArray *srcArrayPtr, *copyArrayPtr;
    Tcl_ObjInternalRep ir;

    srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType));
    length = srcArrayPtr->used;

    copyArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length));







|







632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
 */

static void
DupProperByteArrayInternalRep(
    Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
    Tcl_Obj *copyPtr)		/* Object with internal rep to set. */
{
    Tcl_Size length;
    ByteArray *srcArrayPtr, *copyArrayPtr;
    Tcl_ObjInternalRep ir;

    srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType));
    length = srcArrayPtr->used;

    copyArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length));
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
UpdateStringOfByteArray(
    Tcl_Obj *objPtr)		/* ByteArray object whose string rep to
				 * update. */
{
    const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
    ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr);
    unsigned char *src = byteArrayPtr->bytes;
    size_t i, length = byteArrayPtr->used;
    size_t size = length;

    /*
     * How much space will string rep need?
     */

    for (i = 0; i < length; i++) {
	if ((src[i] == 0) || (src[i] > 127)) {







|
|







673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
UpdateStringOfByteArray(
    Tcl_Obj *objPtr)		/* ByteArray object whose string rep to
				 * update. */
{
    const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
    ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr);
    unsigned char *src = byteArrayPtr->bytes;
    Tcl_Size i, length = byteArrayPtr->used;
    Tcl_Size size = length;

    /*
     * How much space will string rep need?
     */

    for (i = 0; i < length; i++) {
	if ((src[i] == 0) || (src[i] > 127)) {
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
 *----------------------------------------------------------------------
 */

void
TclAppendBytesToByteArray(
    Tcl_Obj *objPtr,
    const unsigned char *bytes,
    size_t len)
{
    ByteArray *byteArrayPtr;
    size_t needed;
    Tcl_ObjInternalRep *irPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
    }
    if (len == TCL_INDEX_NONE) {
	Tcl_Panic("%s must be called with definite number of bytes to append",
		"TclAppendBytesToByteArray");
    }
    if (len == 0) {
	/*
	 * Append zero bytes is a no-op.
	 */







|


|





|







723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
 *----------------------------------------------------------------------
 */

void
TclAppendBytesToByteArray(
    Tcl_Obj *objPtr,
    const unsigned char *bytes,
    Tcl_Size len)
{
    ByteArray *byteArrayPtr;
    Tcl_Size needed;
    Tcl_ObjInternalRep *irPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
    }
    if (len < 0) {
	Tcl_Panic("%s must be called with definite number of bytes to append",
		"TclAppendBytesToByteArray");
    }
    if (len == 0) {
	/*
	 * Append zero bytes is a no-op.
	 */
753
754
755
756
757
758
759
760
761
762
763
764

765
766
767
768
769
770
771
772
773
774

775
776
777
778

779
780
781


782
783
784
785
786
787
788
789
790
791
792
793
794
    }
    byteArrayPtr = GET_BYTEARRAY(irPtr);

    /*
     * If we need to, resize the allocated space in the byte array.
     */

    needed = byteArrayPtr->used + len;
    if (needed < byteArrayPtr->used) {
	/* Wrapped around SIZE_MAX!! */
	Tcl_Panic("max size of a Tcl value exceeded");
    }

    if (needed > byteArrayPtr->allocated) {
	ByteArray *ptr = NULL;

        /*
	 * Try to allocate double the total space that is needed.
	 */

	size_t attempt = 2 * needed;

	/* Protection just in case we wrapped around SIZE_MAX */

	if (attempt >= needed) {
	    ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr,
		    BYTEARRAY_SIZE(attempt));
	}

	if (ptr == NULL) {
	    /*
	     * Try to allocate double the increment that is needed (plus).


	     */

	    attempt = needed + len + TCL_MIN_GROWTH;
	    if (attempt >= needed) {
		ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr,
			BYTEARRAY_SIZE(attempt));
	    }
	}
	if (ptr == NULL) {
	    /*
	     * Last chance: Try to allocate exactly what is needed.
	     */








<
|
|
|

>







|
|
|
>
|



>


|
>
>

|
|
<
|
|







757
758
759
760
761
762
763

764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792

793
794
795
796
797
798
799
800
801
    }
    byteArrayPtr = GET_BYTEARRAY(irPtr);

    /*
     * If we need to, resize the allocated space in the byte array.
     */


    if ((BYTEARRAY_MAX_LEN - byteArrayPtr->used) < len) {
	/* Will wrap around !! */
	Tcl_Panic("max size of a byte array exceeded");
    }
    needed = byteArrayPtr->used + len;
    if (needed > byteArrayPtr->allocated) {
	ByteArray *ptr = NULL;

        /*
	 * Try to allocate double the total space that is needed.
	 */

	Tcl_Size attempt;
	
	/* Make sure we do not wrap when doubling */
	if (needed <= (BYTEARRAY_MAX_LEN - needed)) {
	    attempt = 2 * needed;
	    ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr,
		    BYTEARRAY_SIZE(attempt));
	}

	if (ptr == NULL) {
	    /*
	     * Try to allocate double the increment that is needed.
	     * (Originally TCL_MIN_GROWTH was added as well but that would
	     * need one more separate overflow check so forget it.)
	     */
	    if (len <= (BYTEARRAY_MAX_LEN - needed)) {
		attempt = needed + len;

		ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr,
						      BYTEARRAY_SIZE(attempt));
	    }
	}
	if (ptr == NULL) {
	    /*
	     * Last chance: Try to allocate exactly what is needed.
	     */

859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int arg;			/* Index of next argument to consume. */
    int value = 0;		/* Current integer value to be packed.
				 * Initialized to avoid compiler warning. */
    char cmd;			/* Current format character. */
    size_t count;			/* Count associated with current format
				 * character. */
    int flags;			/* Format field flags */
    const char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    unsigned char *maxPos;	/* Greatest position within result buffer that
				 * cursor has visited.*/
    const char *errorString;
    const char *errorValue, *str;
    size_t offset, size, length;

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

    /*







|











|







866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int arg;			/* Index of next argument to consume. */
    int value = 0;		/* Current integer value to be packed.
				 * Initialized to avoid compiler warning. */
    char cmd;			/* Current format character. */
    Tcl_Size count;			/* Count associated with current format
				 * character. */
    int flags;			/* Format field flags */
    const char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    unsigned char *maxPos;	/* Greatest position within result buffer that
				 * cursor has visited.*/
    const char *errorString;
    const char *errorValue, *str;
    Tcl_Size offset, size, length;

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

    /*
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
	     * non-list value.
	     */

	    if (count == BINARY_NOCOUNT) {
		arg++;
		count = 1;
	    } else {
		size_t listc;
		Tcl_Obj **listv;

		/*
		 * The macro evals its args more than once: avoid arg++
		 */

		if (TclListObjLengthM(interp, objv[arg], &listc







|







976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
	     * non-list value.
	     */

	    if (count == BINARY_NOCOUNT) {
		arg++;
		count = 1;
	    } else {
		Tcl_Size listc;
		Tcl_Obj **listv;

		/*
		 * The macro evals its args more than once: avoid arg++
		 */

		if (TclListObjLengthM(interp, objv[arg], &listc
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
	    }
	    offset += count*size;
	    break;

	case 'x':
	    if (count == BINARY_ALL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot use \"*\" in format string with \"x\"", TCL_INDEX_NONE));
		return TCL_ERROR;
	    } else if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    offset += count;
	    break;
	case 'X':







|







1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
	    }
	    offset += count*size;
	    break;

	case 'x':
	    if (count == BINARY_ALL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot use \"*\" in format string with \"x\"", -1));
		return TCL_ERROR;
	    } else if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    offset += count;
	    break;
	case 'X':
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
	case 'W':
	case 'r':
	case 'R':
	case 'd':
	case 'q':
	case 'Q':
	case 'f': {
	    size_t listc, i;
	    Tcl_Obj **listv;

	    if (count == BINARY_NOCOUNT) {
		/*
		 * Note that we are casting away the const-ness of objv, but
		 * this is safe since we aren't going to modify the array.
		 */







|







1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
	case 'W':
	case 'r':
	case 'R':
	case 'd':
	case 'q':
	case 'Q':
	case 'f': {
	    Tcl_Size listc, i;
	    Tcl_Obj **listv;

	    if (count == BINARY_NOCOUNT) {
		/*
		 * Note that we are casting away the const-ness of objv, but
		 * this is safe since we aren't going to modify the array.
		 */
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
	case 'X':
	    if (cursor > maxPos) {
		maxPos = cursor;
	    }
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    if ((count == BINARY_ALL) || (count > (size_t)(cursor - buffer))) {
		cursor = buffer;
	    } else {
		cursor -= count;
	    }
	    break;
	case '@':
	    if (cursor > maxPos) {







|







1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
	case 'X':
	    if (cursor > maxPos) {
		maxPos = cursor;
	    }
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
		cursor = buffer;
	    } else {
		cursor -= count;
	    }
	    break;
	case '@':
	    if (cursor > maxPos) {
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad field specifier \"%s\"", buf));
	return TCL_ERROR;
    }

 error:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, TCL_INDEX_NONE));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryScanCmd --







|







1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad field specifier \"%s\"", buf));
	return TCL_ERROR;
    }

 error:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryScanCmd --
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int arg;			/* Index of next argument to consume. */
    int value = 0;		/* Current integer value to be packed.
				 * Initialized to avoid compiler warning. */
    char cmd;			/* Current format character. */
    size_t count;			/* Count associated with current format
				 * character. */
    int flags;			/* Format field flags */
    const char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    const char *errorString;
    const char *str;
    size_t offset, size, length = 0, i;

    Tcl_Obj *valuePtr, *elementPtr;
    Tcl_HashTable numberCacheHash;
    Tcl_HashTable *numberCachePtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,







|








|







1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int arg;			/* Index of next argument to consume. */
    int value = 0;		/* Current integer value to be packed.
				 * Initialized to avoid compiler warning. */
    char cmd;			/* Current format character. */
    Tcl_Size count;			/* Count associated with current format
				 * character. */
    int flags;			/* Format field flags */
    const char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    const char *errorString;
    const char *str;
    Tcl_Size offset, size, length = 0, i;

    Tcl_Obj *valuePtr, *elementPtr;
    Tcl_HashTable numberCacheHash;
    Tcl_HashTable *numberCachePtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
	    }
	    if (count == BINARY_ALL) {
		count = (length - offset) * 8;
	    } else {
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (count > (size_t)(length - offset) * 8) {
		    goto done;
		}
	    }
	    src = buffer + offset;
	    TclNewObj(valuePtr);
	    Tcl_SetObjLength(valuePtr, count);
	    dest = TclGetString(valuePtr);







|







1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
	    }
	    if (count == BINARY_ALL) {
		count = (length - offset) * 8;
	    } else {
		if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (count > (length - offset) * 8) {
		    goto done;
		}
	    }
	    src = buffer + offset;
	    TclNewObj(valuePtr);
	    Tcl_SetObjLength(valuePtr, count);
	    dest = TclGetString(valuePtr);
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635

	scanNumber:
	    if (arg >= objc) {
		DeleteScanNumberCache(numberCachePtr);
		goto badIndex;
	    }
	    if (count == BINARY_NOCOUNT) {
		if (length < (size_t)size + offset) {
		    goto done;
		}
		valuePtr = ScanNumber(buffer+offset, cmd, flags,
			&numberCachePtr);
		offset += size;
	    } else {
		if (count == BINARY_ALL) {







|







1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642

	scanNumber:
	    if (arg >= objc) {
		DeleteScanNumberCache(numberCachePtr);
		goto badIndex;
	    }
	    if (count == BINARY_NOCOUNT) {
		if (length < size + offset) {
		    goto done;
		}
		valuePtr = ScanNumber(buffer+offset, cmd, flags,
			&numberCachePtr);
		offset += size;
	    } else {
		if (count == BINARY_ALL) {
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad field specifier \"%s\"", buf));
	return TCL_ERROR;
    }

 error:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, TCL_INDEX_NONE));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * GetFormatSpec --







|







1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad field specifier \"%s\"", buf));
	return TCL_ERROR;
    }

 error:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * GetFormatSpec --
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
 *----------------------------------------------------------------------
 */

static int
GetFormatSpec(
    const char **formatPtr,	/* Pointer to format string. */
    char *cmdPtr,		/* Pointer to location of command char. */
    size_t *countPtr,		/* Pointer to repeat count value. */
    int *flagsPtr)		/* Pointer to field flags */
{
    /*
     * Skip any leading blanks.
     */

    while (**formatPtr == ' ') {







|







1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
 *----------------------------------------------------------------------
 */

static int
GetFormatSpec(
    const char **formatPtr,	/* Pointer to format string. */
    char *cmdPtr,		/* Pointer to location of command char. */
    Tcl_Size *countPtr,		/* Pointer to repeat count value. */
    int *flagsPtr)		/* Pointer to field flags */
{
    /*
     * Skip any leading blanks.
     */

    while (**formatPtr == ' ') {
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data = NULL;
    unsigned char *cursor = NULL;
    size_t offset = 0, count = 0;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "data");
	return TCL_ERROR;
    }

    data = Tcl_GetBytesFromObj(interp, objv[1], &count);







|







2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data = NULL;
    unsigned char *cursor = NULL;
    Tcl_Size offset = 0, count = 0;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "data");
	return TCL_ERROR;
    }

    data = Tcl_GetBytesFromObj(interp, objv[1], &count);
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor, c;
    int i, index, value, pure = 1, strict = 0;
    size_t size, cut = 0, count = 0;
    int ucs4;
    enum {OPT_STRICT };
    static const char *const optStrings[] = { "-strict", NULL };

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
	return TCL_ERROR;







|







2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor, c;
    int i, index, value, pure = 1, strict = 0;
    Tcl_Size size, cut = 0, count = 0;
    int ucs4;
    enum {OPT_STRICT };
    static const char *const optStrings[] = { "-strict", NULL };

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
	return TCL_ERROR;
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj;
    unsigned char *data, *limit;
    int maxlen = 0;
    const char *wrapchar = "\n";
    size_t wrapcharlen = 1;
    int i, index, size, outindex = 0, purewrap = 1;
    size_t offset, count = 0;
    enum { OPT_MAXLEN, OPT_WRAPCHAR };
    static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };

    if (objc < 2 || objc % 2 != 0) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-maxlen len? ?-wrapchar char? data");
	return TCL_ERROR;
    }
    for (i = 1; i < objc - 1; i += 2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_MAXLEN:
	    if (Tcl_GetIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (maxlen < 0) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"line length out of range", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
			"LINE_LENGTH", NULL);
		return TCL_ERROR;
	    }
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = (const char *)Tcl_GetByteArrayFromObj(







|

|




















|







2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj;
    unsigned char *data, *limit;
    int maxlen = 0;
    const char *wrapchar = "\n";
    Tcl_Size wrapcharlen = 1;
    int i, index, size, outindex = 0, purewrap = 1;
    Tcl_Size offset, count = 0;
    enum { OPT_MAXLEN, OPT_WRAPCHAR };
    static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };

    if (objc < 2 || objc % 2 != 0) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-maxlen len? ?-wrapchar char? data");
	return TCL_ERROR;
    }
    for (i = 1; i < objc - 1; i += 2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_MAXLEN:
	    if (Tcl_GetIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (maxlen < 0) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"line length out of range", -1));
		Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
			"LINE_LENGTH", NULL);
		return TCL_ERROR;
	    }
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = (const char *)Tcl_GetByteArrayFromObj(
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
    Tcl_Obj *resultObj;
    unsigned char *data, *start, *cursor;
    int rawLength, i, bits, index;
    unsigned int n;
    int lineLength = 61;
    const unsigned char SingleNewline[] = { UCHAR('\n') };
    const unsigned char *wrapchar = SingleNewline;
    size_t j, offset, count = 0, wrapcharlen = sizeof(SingleNewline);
    enum { OPT_MAXLEN, OPT_WRAPCHAR };
    static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };

    if (objc < 2 || objc % 2 != 0) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-maxlen len? ?-wrapchar char? data");
	return TCL_ERROR;







|







2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
    Tcl_Obj *resultObj;
    unsigned char *data, *start, *cursor;
    int rawLength, i, bits, index;
    unsigned int n;
    int lineLength = 61;
    const unsigned char SingleNewline[] = { UCHAR('\n') };
    const unsigned char *wrapchar = SingleNewline;
    Tcl_Size j, offset, count = 0, wrapcharlen = sizeof(SingleNewline);
    enum { OPT_MAXLEN, OPT_WRAPCHAR };
    static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };

    if (objc < 2 || objc % 2 != 0) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-maxlen len? ?-wrapchar char? data");
	return TCL_ERROR;
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
	case OPT_MAXLEN:
	    if (Tcl_GetIntFromObj(interp, objv[i + 1],
		    &lineLength) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (lineLength < 5 || lineLength > 85) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"line length out of range", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
			"LINE_LENGTH", NULL);
		return TCL_ERROR;
	    }
	    lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = (const unsigned char *) Tcl_GetStringFromObj(
		    objv[i + 1], &wrapcharlen);
	    {
		const unsigned char *p = wrapchar;
		size_t numBytes = wrapcharlen;

		while (numBytes) {
		    switch (*p) {
			case '\t':
			case '\v':
			case '\f':
			case '\r':







|











|







2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
	case OPT_MAXLEN:
	    if (Tcl_GetIntFromObj(interp, objv[i + 1],
		    &lineLength) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (lineLength < 5 || lineLength > 85) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"line length out of range", -1));
		Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
			"LINE_LENGTH", NULL);
		return TCL_ERROR;
	    }
	    lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = (const unsigned char *) Tcl_GetStringFromObj(
		    objv[i + 1], &wrapcharlen);
	    {
		const unsigned char *p = wrapchar;
		Tcl_Size numBytes = wrapcharlen;

		while (numBytes) {
		    switch (*p) {
			case '\t':
			case '\v':
			case '\f':
			case '\r':
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor;
    int i, index, pure = 1, strict = 0, lineLen;
    size_t size, count = 0;
    unsigned char c;
    int ucs4;
    enum { OPT_STRICT };
    static const char *const optStrings[] = { "-strict", NULL };

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? data");







|







2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor;
    int i, index, pure = 1, strict = 0, lineLen;
    Tcl_Size size, count = 0;
    unsigned char c;
    int ucs4;
    enum { OPT_STRICT };
    static const char *const optStrings[] = { "-strict", NULL };

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend, c = '\0';
    unsigned char *begin = NULL;
    unsigned char *cursor = NULL;
    int pure = 1, strict = 0;
    int i, index, cut = 0;
    size_t size, count = 0;
    int ucs4;
    enum { OPT_STRICT };
    static const char *const optStrings[] = { "-strict", NULL };

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
	return TCL_ERROR;







|







3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend, c = '\0';
    unsigned char *begin = NULL;
    unsigned char *cursor = NULL;
    int pure = 1, strict = 0;
    int i, index, cut = 0;
    Tcl_Size size, count = 0;
    int ucs4;
    enum { OPT_STRICT };
    static const char *const optStrings[] = { "-strict", NULL };

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
	return TCL_ERROR;

Changes to generic/tclCkalloc.c.

185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
	    current_bytes_malloced,
	    maximum_malloc_packets,
	    maximum_bytes_malloced);
    if (flags == 0) {
	fprintf((FILE *)clientData, "%s", buf);
    } else {
	/* Assume objPtr to append to */
	Tcl_AppendToObj((Tcl_Obj *) clientData, buf, TCL_INDEX_NONE);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *







|







185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
	    current_bytes_malloced,
	    maximum_malloc_packets,
	    maximum_bytes_malloced);
    if (flags == 0) {
	fprintf((FILE *)clientData, "%s", buf);
    } else {
	/* Assume objPtr to append to */
	Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclClock.c.

139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
/*
 * Function prototypes for local procedures in this file:
 */

static int		ConvertUTCToLocal(Tcl_Interp *,
			    TclDateFields *, Tcl_Obj *, int);
static int		ConvertUTCToLocalUsingTable(Tcl_Interp *,
			    TclDateFields *, size_t, Tcl_Obj *const[]);
static int		ConvertUTCToLocalUsingC(Tcl_Interp *,
			    TclDateFields *, int);
static int		ConvertLocalToUTC(Tcl_Interp *,
			    TclDateFields *, Tcl_Obj *, int);
static int		ConvertLocalToUTCUsingTable(Tcl_Interp *,
			    TclDateFields *, size_t, Tcl_Obj *const[]);
static int		ConvertLocalToUTCUsingC(Tcl_Interp *,
			    TclDateFields *, int);
static Tcl_Obj *	LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
			    size_t, Tcl_Obj *const *);
static void		GetYearWeekDay(TclDateFields *, int);
static void		GetGregorianEraYearDay(TclDateFields *, int);
static void		GetMonthDay(TclDateFields *);
static void		GetJulianDayFromEraYearWeekDay(TclDateFields *, int);
static void		GetJulianDayFromEraYearMonthDay(TclDateFields *, int);
static int		IsGregorianLeapYear(TclDateFields *);
static int		WeekdayOnOrBefore(int, int);







|





|



|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
/*
 * Function prototypes for local procedures in this file:
 */

static int		ConvertUTCToLocal(Tcl_Interp *,
			    TclDateFields *, Tcl_Obj *, int);
static int		ConvertUTCToLocalUsingTable(Tcl_Interp *,
			    TclDateFields *, Tcl_Size, Tcl_Obj *const[]);
static int		ConvertUTCToLocalUsingC(Tcl_Interp *,
			    TclDateFields *, int);
static int		ConvertLocalToUTC(Tcl_Interp *,
			    TclDateFields *, Tcl_Obj *, int);
static int		ConvertLocalToUTCUsingTable(Tcl_Interp *,
			    TclDateFields *, Tcl_Size, Tcl_Obj *const[]);
static int		ConvertLocalToUTCUsingC(Tcl_Interp *,
			    TclDateFields *, int);
static Tcl_Obj *	LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
			    Tcl_Size, Tcl_Obj *const *);
static void		GetYearWeekDay(TclDateFields *, int);
static void		GetGregorianEraYearDay(TclDateFields *, int);
static void		GetMonthDay(TclDateFields *);
static void		GetJulianDayFromEraYearWeekDay(TclDateFields *, int);
static void		GetJulianDayFromEraYearMonthDay(TclDateFields *, int);
static int		IsGregorianLeapYear(TclDateFields *);
static int		WeekdayOnOrBefore(int, int);
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
static int
ConvertLocalToUTC(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Fields of the time */
    Tcl_Obj *tzdata,		/* Time zone data */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    size_t rowc;			/* Number of rows in tzdata */
    Tcl_Obj **rowv;		/* Pointers to the rows */

    /*
     * Unpack the tz data.
     */

    if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {







|







724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
static int
ConvertLocalToUTC(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Fields of the time */
    Tcl_Obj *tzdata,		/* Time zone data */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    Tcl_Size rowc;			/* Number of rows in tzdata */
    Tcl_Obj **rowv;		/* Pointers to the rows */

    /*
     * Unpack the tz data.
     */

    if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
 *----------------------------------------------------------------------
 */

static int
ConvertLocalToUTCUsingTable(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Time to convert, with 'seconds' filled in */
    size_t rowc,			/* Number of points at which time changes */
    Tcl_Obj *const rowv[])	/* Points at which time changes */
{
    Tcl_Obj *row;
    size_t cellc;
    Tcl_Obj **cellv;
    int have[8];
    int nHave = 0;
    int i;
    int found;

    /*







|



|







769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
 *----------------------------------------------------------------------
 */

static int
ConvertLocalToUTCUsingTable(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Time to convert, with 'seconds' filled in */
    Tcl_Size rowc,			/* Number of points at which time changes */
    Tcl_Obj *const rowv[])	/* Points at which time changes */
{
    Tcl_Obj *row;
    Tcl_Size cellc;
    Tcl_Obj **cellv;
    int have[8];
    int nHave = 0;
    int i;
    int found;

    /*
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
static int
ConvertUTCToLocal(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Fields of the time */
    Tcl_Obj *tzdata,		/* Time zone data */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    size_t rowc;			/* Number of rows in tzdata */
    Tcl_Obj **rowv;		/* Pointers to the rows */

    /*
     * Unpack the tz data.
     */

    if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {







|







927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
static int
ConvertUTCToLocal(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Fields of the time */
    Tcl_Obj *tzdata,		/* Time zone data */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    Tcl_Size rowc;			/* Number of rows in tzdata */
    Tcl_Obj **rowv;		/* Pointers to the rows */

    /*
     * Unpack the tz data.
     */

    if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
 *----------------------------------------------------------------------
 */

static int
ConvertUTCToLocalUsingTable(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Fields of the date */
    size_t rowc,			/* Number of rows in the conversion table
				 * (>= 1) */
    Tcl_Obj *const rowv[])	/* Rows of the conversion table */
{
    Tcl_Obj *row;		/* Row containing the current information */
    size_t cellc;			/* Count of cells in the row (must be 4) */
    Tcl_Obj **cellv;		/* Pointers to the cells */

    /*
     * Look up the nearest transition time.
     */

    row = LookupLastTransition(interp, fields->seconds, rowc, rowv);







|




|







972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
 *----------------------------------------------------------------------
 */

static int
ConvertUTCToLocalUsingTable(
    Tcl_Interp *interp,		/* Tcl interpreter */
    TclDateFields *fields,	/* Fields of the date */
    Tcl_Size rowc,			/* Number of rows in the conversion table
				 * (>= 1) */
    Tcl_Obj *const rowv[])	/* Rows of the conversion table */
{
    Tcl_Obj *row;		/* Row containing the current information */
    Tcl_Size cellc;			/* Count of cells in the row (must be 4) */
    Tcl_Obj **cellv;		/* Pointers to the cells */

    /*
     * Look up the nearest transition time.
     */

    row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
LookupLastTransition(
    Tcl_Interp *interp,		/* Interpreter for error messages */
    Tcl_WideInt tick,		/* Time from the epoch */
    size_t rowc,			/* Number of rows of tzdata */
    Tcl_Obj *const *rowv)	/* Rows in tzdata */
{
    size_t l;
    size_t u;
    Tcl_Obj *compObj;
    Tcl_WideInt compVal;

    /*
     * Examine the first row to make sure we're in bounds.
     */








|


|
|







1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
LookupLastTransition(
    Tcl_Interp *interp,		/* Interpreter for error messages */
    Tcl_WideInt tick,		/* Time from the epoch */
    Tcl_Size rowc,			/* Number of rows of tzdata */
    Tcl_Obj *const *rowv)	/* Rows in tzdata */
{
    Tcl_Size l;
    Tcl_Size u;
    Tcl_Obj *compObj;
    Tcl_WideInt compVal;

    /*
     * Examine the first row to make sure we're in bounds.
     */

Changes to generic/tclCmdAH.c.

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 */

struct ForeachState {
    Tcl_Obj *bodyPtr;		/* The script body of the command. */
    int bodyIdx;		/* The argument index of the body. */
    int j, maxj;		/* Number of loop iterations. */
    int numLists;		/* Count of value lists. */
    size_t *index;			/* Array of value list indices. */
    size_t *varcList;		/* # loop variables per list. */
    Tcl_Obj ***varvList;	/* Array of var name lists. */
    Tcl_Obj **vCopyList;	/* Copies of var name list arguments. */
    size_t *argcList;		/* Array of value list sizes. */
    Tcl_Obj ***argvList;	/* Array of value lists. */
    Tcl_Obj **aCopyList;	/* Copies of value list arguments. */
    Tcl_Obj *resultList;	/* List of result values from the loop body,
				 * or NULL if we're not collecting them
				 * ([lmap] vs [foreach]). */
};








|
|


|







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 */

struct ForeachState {
    Tcl_Obj *bodyPtr;		/* The script body of the command. */
    int bodyIdx;		/* The argument index of the body. */
    int j, maxj;		/* Number of loop iterations. */
    int numLists;		/* Count of value lists. */
    Tcl_Size *index;		/* Array of value list indices. */
    Tcl_Size *varcList; 	/* # loop variables per list. */
    Tcl_Obj ***varvList;	/* Array of var name lists. */
    Tcl_Obj **vCopyList;	/* Copies of var name list arguments. */
    Tcl_Size *argcList;		/* Array of value list sizes. */
    Tcl_Obj ***argvList;	/* Array of value lists. */
    Tcl_Obj **aCopyList;	/* Copies of value list arguments. */
    Tcl_Obj *resultList;	/* List of result values from the loop body,
				 * or NULL if we're not collecting them
				 * ([lmap] vs [foreach]). */
};

526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *data;		/* Byte array to convert */
    Tcl_DString ds;		/* Buffer to hold the string */
    Tcl_Encoding encoding;	/* Encoding to use */
    size_t length = 0;			/* Length of the byte array being converted */
    const char *bytesPtr;	/* Pointer to the first byte of the array */
    int flags;
    int result;
    Tcl_Obj *failVarObj;
    Tcl_Size errorLocation;

    if (EncodingConvertParseOptions(







|







526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *data;		/* Byte array to convert */
    Tcl_DString ds;		/* Buffer to hold the string */
    Tcl_Encoding encoding;	/* Encoding to use */
    Tcl_Size length = 0;			/* Length of the byte array being converted */
    const char *bytesPtr;	/* Pointer to the first byte of the array */
    int flags;
    int result;
    Tcl_Obj *failVarObj;
    Tcl_Size errorLocation;

    if (EncodingConvertParseOptions(
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *data;		/* String to convert */
    Tcl_DString ds;		/* Buffer to hold the byte array */
    Tcl_Encoding encoding;	/* Encoding to use */
    size_t length;			/* Length of the string being converted */
    const char *stringPtr;	/* Pointer to the first byte of the string */
    int result;
    int flags;
    Tcl_Obj *failVarObj;
    Tcl_Size errorLocation;

    if (EncodingConvertParseOptions(







|







626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *data;		/* String to convert */
    Tcl_DString ds;		/* Buffer to hold the byte array */
    Tcl_Encoding encoding;	/* Encoding to use */
    Tcl_Size length;			/* Length of the string being converted */
    const char *stringPtr;	/* Pointer to the first byte of the string */
    int result;
    int flags;
    Tcl_Obj *failVarObj;
    Tcl_Size errorLocation;

    if (EncodingConvertParseOptions(
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
{
    Tcl_Obj *res;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }
    res = Tcl_FSSplitPath(objv[1], (size_t *)NULL);
    if (res == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"could not read \"%s\": no such file or directory",
		TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
		NULL);
	return TCL_ERROR;







|







2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
{
    Tcl_Obj *res;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }
    res = Tcl_FSSplitPath(objv[1], NULL);
    if (res == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"could not read \"%s\": no such file or directory",
		TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
		NULL);
	return TCL_ERROR;
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
     *
     * The setting up of all of these pointers is moderately messy, but allows
     * the rest of this code to be simple and for us to use a single memory
     * allocation for better performance.
     */

    statePtr = (struct ForeachState *)TclStackAlloc(interp,
	    sizeof(struct ForeachState) + 3 * numLists * sizeof(size_t)
	    + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
    memset(statePtr, 0,
	    sizeof(struct ForeachState) + 3 * numLists * sizeof(size_t)
	    + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
    statePtr->varvList = (Tcl_Obj ***) (statePtr + 1);
    statePtr->argvList = statePtr->varvList + numLists;
    statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists);
    statePtr->aCopyList = statePtr->vCopyList + numLists;
    statePtr->index = (size_t *) (statePtr->aCopyList + numLists);
    statePtr->varcList = statePtr->index + numLists;
    statePtr->argcList = statePtr->varcList + numLists;

    statePtr->numLists = numLists;
    statePtr->bodyPtr = objv[objc - 1];
    statePtr->bodyIdx = objc - 1;








|


|





|







2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
     *
     * The setting up of all of these pointers is moderately messy, but allows
     * the rest of this code to be simple and for us to use a single memory
     * allocation for better performance.
     */

    statePtr = (struct ForeachState *)TclStackAlloc(interp,
	    sizeof(struct ForeachState) + 3 * numLists * sizeof(Tcl_Size)
	    + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
    memset(statePtr, 0,
	    sizeof(struct ForeachState) + 3 * numLists * sizeof(Tcl_Size)
	    + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
    statePtr->varvList = (Tcl_Obj ***) (statePtr + 1);
    statePtr->argvList = statePtr->varvList + numLists;
    statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists);
    statePtr->aCopyList = statePtr->vCopyList + numLists;
    statePtr->index = (Tcl_Size *) (statePtr->aCopyList + numLists);
    statePtr->varcList = statePtr->index + numLists;
    statePtr->argcList = statePtr->varcList + numLists;

    statePtr->numLists = numLists;
    statePtr->bodyPtr = objv[objc - 1];
    statePtr->bodyIdx = objc - 1;

2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956

static inline int
ForeachAssignments(
    Tcl_Interp *interp,
    struct ForeachState *statePtr)
{
    int i;
    size_t v, k;
    Tcl_Obj *valuePtr, *varValuePtr;

    for (i=0 ; i<statePtr->numLists ; i++) {
	int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType.objType);
	for (v=0 ; v<statePtr->varcList[i] ; v++) {
	    k = statePtr->index[i]++;
	    if (k < statePtr->argcList[i]) {







|







2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956

static inline int
ForeachAssignments(
    Tcl_Interp *interp,
    struct ForeachState *statePtr)
{
    int i;
    Tcl_Size v, k;
    Tcl_Obj *valuePtr, *varValuePtr;

    for (i=0 ; i<statePtr->numLists ; i++) {
	int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType.objType);
	for (v=0 ; v<statePtr->varcList[i] ; v++) {
	    k = statePtr->index[i]++;
	    if (k < statePtr->argcList[i]) {

Changes to generic/tclCmdIL.c.

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

/*
 * These function pointer types are used with the "lsearch" and "lsort"
 * commands to facilitate the "-nocase" option.
 */

typedef int (*SortStrCmpFn_t) (const char *, const char *);
typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);

/*
 * The "lsort" command needs to pass certain information down to the function
 * that compares two list elements, and the comparison function needs to pass
 * success or failure information back up to the top-level "lsort" command.
 * The following structure is used to pass this information.
 */







|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

/*
 * These function pointer types are used with the "lsearch" and "lsort"
 * commands to facilitate the "-nocase" option.
 */

typedef int (*SortStrCmpFn_t) (const char *, const char *);
typedef int (*SortMemCmpFn_t) (const void *, const void *, Tcl_Size);

/*
 * The "lsort" command needs to pass certain information down to the function
 * that compares two list elements, and the comparison function needs to pass
 * success or failure information back up to the top-level "lsort" command.
 * The following structure is used to pass this information.
 */
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
    int *indexv;		/* If the -index option was specified, this
				 * holds an encoding of the indexes contained
				 * in the list supplied as an argument to
				 * that option.
				 * NULL if no indexes supplied, and points to
				 * singleIndex field when only one
				 * supplied. */
    size_t indexc;			/* Number of indexes in indexv array. */
    int singleIndex;		/* Static space for common index case. */
    int unique;
    int numElements;
    Tcl_Interp *interp;		/* The interpreter in which the sort is being
				 * done. */
    int resultCode;		/* Completion code for the lsort command. If
				 * an error occurs during the sort this is







|







70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
    int *indexv;		/* If the -index option was specified, this
				 * holds an encoding of the indexes contained
				 * in the list supplied as an argument to
				 * that option.
				 * NULL if no indexes supplied, and points to
				 * singleIndex field when only one
				 * supplied. */
    Tcl_Size indexc;		/* Number of indexes in indexv array. */
    int singleIndex;		/* Static space for common index case. */
    int unique;
    int numElements;
    Tcl_Interp *interp;		/* The interpreter in which the sort is being
				 * done. */
    int resultCode;		/* Completion code for the lsort command. If
				 * an error occurs during the sort this is
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
     */

    listObjPtr = Tcl_NewListObj(0, NULL);
    for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
	    localPtr = localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_ListObjAppendElement(interp, listObjPtr,
		    Tcl_NewStringObj(localPtr->name, TCL_INDEX_NONE));
	}
    }
    Tcl_SetObjResult(interp, listObjPtr);
    return TCL_OK;
}

/*







|







500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
     */

    listObjPtr = Tcl_NewListObj(0, NULL);
    for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
	    localPtr = localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_ListObjAppendElement(interp, listObjPtr,
		    Tcl_NewStringObj(localPtr->name, -1));
	}
    }
    Tcl_SetObjResult(interp, listObjPtr);
    return TCL_OK;
}

/*
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    const char *name, *bytes;
    Proc *procPtr;
    size_t numBytes;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "procname");
	return TCL_ERROR;
    }

    name = TclGetString(objv[1]);







|







537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    const char *name, *bytes;
    Proc *procPtr;
    Tcl_Size numBytes;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "procname");
	return TCL_ERROR;
    }

    name = TclGetString(objv[1]);
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
    Tcl_HashSearch search;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
    Tcl_Command cmd;
    size_t i;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * commands.
     */

    if (objc == 1) {







|







647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
    Tcl_HashSearch search;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
    Tcl_Command cmd;
    Tcl_Size i;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * commands.
     */

    if (objc == 1) {
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
	if (entryPtr != NULL) {
	    if (specificNsInPattern) {
		cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
		elemObjPtr = Tcl_NewObj();
		Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
	    } else {
		cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
		elemObjPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE);
	    }
	    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    Tcl_SetObjResult(interp, listPtr);
	    return TCL_OK;
	}
	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    Tcl_HashTable *tablePtr = NULL;	/* Quell warning. */







|







712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
	if (entryPtr != NULL) {
	    if (specificNsInPattern) {
		cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
		elemObjPtr = Tcl_NewObj();
		Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
	    } else {
		cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
		elemObjPtr = Tcl_NewStringObj(cmdName, -1);
	    }
	    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    Tcl_SetObjResult(interp, listPtr);
	    return TCL_OK;
	}
	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    Tcl_HashTable *tablePtr = NULL;	/* Quell warning. */
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
	    if (entryPtr == NULL) {
		tablePtr = &globalNsPtr->cmdTable;
		entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
	    }
	    if (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(tablePtr, entryPtr);
		Tcl_ListObjAppendElement(interp, listPtr,
			Tcl_NewStringObj(cmdName, TCL_INDEX_NONE));
		Tcl_SetObjResult(interp, listPtr);
		return TCL_OK;
	    }
	}
    } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) {
	/*
	 * The pattern is non-trivial, but either there is no explicit path or







|







740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
	    if (entryPtr == NULL) {
		tablePtr = &globalNsPtr->cmdTable;
		entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
	    }
	    if (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(tablePtr, entryPtr);
		Tcl_ListObjAppendElement(interp, listPtr,
			Tcl_NewStringObj(cmdName, -1));
		Tcl_SetObjResult(interp, listPtr);
		return TCL_OK;
	    }
	}
    } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) {
	/*
	 * The pattern is non-trivial, but either there is no explicit path or
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
	    if ((simplePattern == NULL)
		    || Tcl_StringMatch(cmdName, simplePattern)) {
		if (specificNsInPattern) {
		    cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE);
		}
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*







|







762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
	    if ((simplePattern == NULL)
		    || Tcl_StringMatch(cmdName, simplePattern)) {
		if (specificNsInPattern) {
		    cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		}
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
			Tcl_ListObjAppendElement(interp, listPtr,
				Tcl_NewStringObj(cmdName, TCL_INDEX_NONE));
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}
    } else {
	/*







|







785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
			Tcl_ListObjAppendElement(interp, listPtr,
				Tcl_NewStringObj(cmdName, -1));
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}
    } else {
	/*
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
	Tcl_InitObjHashTable(&addedCommandsTable);

	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	while (entryPtr != NULL) {
	    cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
	    if ((simplePattern == NULL)
		    || Tcl_StringMatch(cmdName, simplePattern)) {
		elemObjPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE);
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		(void) Tcl_CreateHashEntry(&addedCommandsTable,
			elemObjPtr, &isNew);
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}








|







814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
	Tcl_InitObjHashTable(&addedCommandsTable);

	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	while (entryPtr != NULL) {
	    cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
	    if ((simplePattern == NULL)
		    || Tcl_StringMatch(cmdName, simplePattern)) {
		elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		(void) Tcl_CreateHashEntry(&addedCommandsTable,
			elemObjPtr, &isNew);
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
		foundGlobal = 1;
	    }
	    entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    elemObjPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE);
		    (void) Tcl_CreateHashEntry(&addedCommandsTable,
			    elemObjPtr, &isNew);
		    if (isNew) {
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    } else {
			TclDecrRefCount(elemObjPtr);
		    }







|







840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
		foundGlobal = 1;
	    }
	    entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		    (void) Tcl_CreateHashEntry(&addedCommandsTable,
			    elemObjPtr, &isNew);
		    if (isNew) {
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    } else {
			TclDecrRefCount(elemObjPtr);
		    }
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881

	if (!foundGlobal) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    elemObjPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE);
		    if (Tcl_FindHashEntry(&addedCommandsTable,
			    (char *) elemObjPtr) == NULL) {
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    } else {
			TclDecrRefCount(elemObjPtr);
		    }
		}







|







867
868
869
870
871
872
873
874
875
876
877
878
879
880
881

	if (!foundGlobal) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
	    while (entryPtr != NULL) {
		cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
		if ((simplePattern == NULL)
			|| Tcl_StringMatch(cmdName, simplePattern)) {
		    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		    if (Tcl_FindHashEntry(&addedCommandsTable,
			    (char *) elemObjPtr) == NULL) {
			Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		    } else {
			TclDecrRefCount(elemObjPtr);
		    }
		}
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
    switch (framePtr->type) {
    case TCL_LOCATION_EVAL:
	/*
	 * Evaluation, dynamic script. Type, line, cmd, the latter through
	 * str.
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], TCL_INDEX_NONE));
	if (framePtr->line) {
	    ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
	} else {
	    ADD_PAIR("line", Tcl_NewWideIntObj(1));
	}
	ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
	break;

    case TCL_LOCATION_PREBC:
	/*
	 * Precompiled. Result contains the type as signal, nothing else.
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], TCL_INDEX_NONE));
	break;

    case TCL_LOCATION_BC: {
	/*
	 * Execution of bytecode. Talk to the BC engine to fill out the frame.
	 */








|













|







1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
    switch (framePtr->type) {
    case TCL_LOCATION_EVAL:
	/*
	 * Evaluation, dynamic script. Type, line, cmd, the latter through
	 * str.
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
	if (framePtr->line) {
	    ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
	} else {
	    ADD_PAIR("line", Tcl_NewWideIntObj(1));
	}
	ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
	break;

    case TCL_LOCATION_PREBC:
	/*
	 * Precompiled. Result contains the type as signal, nothing else.
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
	break;

    case TCL_LOCATION_BC: {
	/*
	 * Execution of bytecode. Talk to the BC engine to fill out the frame.
	 */

1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
	TclGetSrcInfoForPc(fPtr);

	/*
	 * Now filled: cmd.str.(cmd,len), line
	 * Possibly modified: type, path!
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], TCL_INDEX_NONE));
	if (fPtr->line) {
	    ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0]));
	}

	if (fPtr->type == TCL_LOCATION_SOURCE) {
	    ADD_PAIR("file", fPtr->data.eval.path);








|







1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
	TclGetSrcInfoForPc(fPtr);

	/*
	 * Now filled: cmd.str.(cmd,len), line
	 * Possibly modified: type, path!
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1));
	if (fPtr->line) {
	    ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0]));
	}

	if (fPtr->type == TCL_LOCATION_SOURCE) {
	    ADD_PAIR("file", fPtr->data.eval.path);

1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
    }

    case TCL_LOCATION_SOURCE:
	/*
	 * Evaluation of a script file.
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], TCL_INDEX_NONE));
	ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
	ADD_PAIR("file", framePtr->data.eval.path);

	/*
	 * Refcount framePtr->data.eval.path goes up when lv is converted into
	 * the result list object.
	 */







|







1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
    }

    case TCL_LOCATION_SOURCE:
	/*
	 * Evaluation of a script file.
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
	ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
	ADD_PAIR("file", framePtr->data.eval.path);

	/*
	 * Refcount framePtr->data.eval.path goes up when lv is converted into
	 * the result list object.
	 */
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414

	    TclNewObj(procNameObj);
	    Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
		    procNameObj);
	    ADD_PAIR("proc", procNameObj);
	} else if (procPtr->cmdPtr->clientData) {
	    ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData;
	    size_t i;

	    /*
	     * This is a non-standard command. Luckily, it's told us how to
	     * render extra information about its frame.
	     */

	    for (i=0 ; i<efiPtr->length ; i++) {
		lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, TCL_INDEX_NONE);
		if (efiPtr->fields[i].proc) {
		    lv[lc++] =
			efiPtr->fields[i].proc(efiPtr->fields[i].clientData);
		} else {
		    lv[lc++] = (Tcl_Obj *)efiPtr->fields[i].clientData;
		}
	    }







|







|







1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414

	    TclNewObj(procNameObj);
	    Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
		    procNameObj);
	    ADD_PAIR("proc", procNameObj);
	} else if (procPtr->cmdPtr->clientData) {
	    ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData;
	    Tcl_Size i;

	    /*
	     * This is a non-standard command. Luckily, it's told us how to
	     * render extra information about its frame.
	     */

	    for (i=0 ; i<efiPtr->length ; i++) {
		lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1);
		if (efiPtr->fields[i].proc) {
		    lv[lc++] =
			efiPtr->fields[i].proc(efiPtr->fields[i].clientData);
		} else {
		    lv[lc++] = (Tcl_Obj *)efiPtr->fields[i].clientData;
		}
	    }
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
"		::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n"
"		    ::set cmd [::namespace tail $cmd]\n"
"		    ::if {$cmd ni $cmds} {\n"
"			::lappend cmds $cmd\n"
"		    }\n"
"		}\n"
"		::return $cmds\n"
"	    } [::namespace current]] ", TCL_INDEX_NONE);

    if (objc == 2) {
	Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1]));

	Tcl_AppendObjToObj(script, arg);
	Tcl_DecrRefCount(arg);
    }







|







1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
"		::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n"
"		    ::set cmd [::namespace tail $cmd]\n"
"		    ::if {$cmd ni $cmds} {\n"
"			::lappend cmds $cmd\n"
"		    }\n"
"		}\n"
"		::return $cmds\n"
"	    } [::namespace current]] ", -1);

    if (objc == 2) {
	Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1]));

	Tcl_AppendObjToObj(script, arg);
	Tcl_DecrRefCount(arg);
    }
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    name = Tcl_GetHostName();
    if (name) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(name, TCL_INDEX_NONE));
	return TCL_OK;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "unable to determine name of host", TCL_INDEX_NONE));
    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *







|




|







1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    name = Tcl_GetHostName();
    if (name) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
	return TCL_OK;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "unable to determine name of host", -1));
    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
    if (libDirName != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, TCL_INDEX_NONE));
	return TCL_OK;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "no library has been specified for Tcl", TCL_INDEX_NONE));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *







|




|







1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
    if (libDirName != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
	return TCL_OK;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "no library has been specified for Tcl", -1));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL,
	    (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
    if (patchlevel != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, TCL_INDEX_NONE));
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------







|







1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL,
	    (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
    if (patchlevel != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1));
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
	    } else {
	    simpleProcOK:
		if (specificNsInPattern) {
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
			    elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(simplePattern, TCL_INDEX_NONE);
		}
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    }
	}
    } else
#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
    {







|







1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
	    } else {
	    simpleProcOK:
		if (specificNsInPattern) {
		    elemObjPtr = Tcl_NewObj();
		    Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
			    elemObjPtr);
		} else {
		    elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
		}
		Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
	    }
	}
    } else
#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
    {
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
		} else {
		procOK:
		    if (specificNsInPattern) {
			elemObjPtr = Tcl_NewObj();
			Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
				elemObjPtr);
		    } else {
			elemObjPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE);
		    }
		    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		}
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}








|







1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
		} else {
		procOK:
		    if (specificNsInPattern) {
			elemObjPtr = Tcl_NewObj();
			Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
				elemObjPtr);
		    } else {
			elemObjPtr = Tcl_NewStringObj(cmdName, -1);
		    }
		    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		}
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
			cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
			realCmdPtr = (Command *) TclGetOriginalCommand(
				(Tcl_Command) cmdPtr);

			if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
				&& TclIsProc(realCmdPtr))) {
			    Tcl_ListObjAppendElement(interp, listPtr,
				    Tcl_NewStringObj(cmdName, TCL_INDEX_NONE));
			}
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}
#endif







|







1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
			cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
			realCmdPtr = (Command *) TclGetOriginalCommand(
				(Tcl_Command) cmdPtr);

			if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
				&& TclIsProc(realCmdPtr))) {
			    Tcl_ListObjAppendElement(interp, listPtr,
				    Tcl_NewStringObj(cmdName, -1));
			}
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}
#endif
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
{
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

#ifdef TCL_SHLIB_EXT
    Tcl_SetObjResult(interp, Tcl_NewStringObj(TCL_SHLIB_EXT, TCL_INDEX_NONE));
#endif
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
{
    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

#ifdef TCL_SHLIB_EXT
    Tcl_SetObjResult(interp, Tcl_NewStringObj(TCL_SHLIB_EXT, -1));
#endif
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
     */

    if (Tcl_IsSafe(interp)
	    && (((Command *) command)->objProc == TclAliasObjCmd)) {
	Tcl_AppendResult(interp, "native", NULL);
    } else {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj(TclGetCommandTypeName(command), TCL_INDEX_NONE));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
     */

    if (Tcl_IsSafe(interp)
	    && (((Command *) command)->objProc == TclAliasObjCmd)) {
	Tcl_AppendResult(interp, "native", NULL);
    } else {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj(TclGetCommandTypeName(command), -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
int
Tcl_JoinObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    size_t length, listLen;
    int isArithSeries = 0;
    Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
	return TCL_ERROR;
    }







|







2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
int
Tcl_JoinObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    Tcl_Size length, listLen;
    int isArithSeries = 0;
    Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
	return TCL_ERROR;
    }
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
    joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
    Tcl_IncrRefCount(joinObjPtr);

    (void) Tcl_GetStringFromObj(joinObjPtr, &length);
    if (length == 0) {
	resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
    } else {
	size_t i;

	resObjPtr = Tcl_NewObj();
	if (isArithSeries) {
	    Tcl_Obj *valueObj;
	    for (i = 0;  i < listLen;  i++) {
		if (i > 0) {








|







2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
    joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
    Tcl_IncrRefCount(joinObjPtr);

    (void) Tcl_GetStringFromObj(joinObjPtr, &length);
    if (length == 0) {
	resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
    } else {
	Tcl_Size i;

	resObjPtr = Tcl_NewObj();
	if (isArithSeries) {
	    Tcl_Obj *valueObj;
	    for (i = 0;  i < listLen;  i++) {
		if (i > 0) {

2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *listCopyPtr;
    Tcl_Obj **listObjv;		/* The contents of the list. */
    size_t listObjc;		/* The length of the list. */
    int code = TCL_OK;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
	return TCL_ERROR;
    }








|







2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *listCopyPtr;
    Tcl_Obj **listObjv;		/* The contents of the list. */
    Tcl_Size listObjc;		/* The length of the list. */
    int code = TCL_OK;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
	return TCL_ERROR;
    }

2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
Tcl_LinsertObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,		/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *listPtr;
    size_t len, index;
    int result;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
	return TCL_ERROR;
    }








|







2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
Tcl_LinsertObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,		/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *listPtr;
    Tcl_Size len, index;
    int result;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
	return TCL_ERROR;
    }

2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
     * appended to the list.
     */

    result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
    if (result != TCL_OK) {
	return result;
    }
    if (index + 1 > len + 1) {
	index = len;
    }

    /*
     * If the list object is unshared we can modify it directly. Otherwise we
     * create a copy to modify: this is "copy on write".
     */







|







2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
     * appended to the list.
     */

    result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
    if (result != TCL_OK) {
	return result;
    }
    if (index > len) {
	index = len;
    }

    /*
     * If the list object is unshared we can modify it directly. Otherwise we
     * create a copy to modify: this is "copy on write".
     */
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
Tcl_LlengthObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])
				/* Argument objects. */
{
    size_t listLen;
    int result;
    Tcl_Obj *objPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list");
	return TCL_ERROR;
    }







|







2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
Tcl_LlengthObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])
				/* Argument objects. */
{
    Tcl_Size listLen;
    int result;
    Tcl_Obj *objPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list");
	return TCL_ERROR;
    }
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
Tcl_LpopObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])
				/* Argument objects. */
{
    size_t listLen;
    int result;
    Tcl_Obj *elemPtr, *stored;
    Tcl_Obj *listPtr, **elemPtrs;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
	return TCL_ERROR;







|







2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
Tcl_LpopObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])
				/* Argument objects. */
{
    Tcl_Size listLen;
    int result;
    Tcl_Obj *elemPtr, *stored;
    Tcl_Obj *listPtr, **elemPtrs;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
	return TCL_ERROR;
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
     * TclLindexFlat adds a ref count which is handled.
     */

    if (objc == 2) {
	if (!listLen) {
	    /* empty list, throw the same error as with index "end" */
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"index \"end\" out of range", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
		"OUTOFRANGE", NULL);
	    return TCL_ERROR;
	}
	elemPtr = elemPtrs[listLen - 1];
	Tcl_IncrRefCount(elemPtr);
    } else {







|







2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
     * TclLindexFlat adds a ref count which is handled.
     */

    if (objc == 2) {
	if (!listLen) {
	    /* empty list, throw the same error as with index "end" */
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"index \"end\" out of range", -1));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
		"OUTOFRANGE", NULL);
	    return TCL_ERROR;
	}
	elemPtr = elemPtrs[listLen - 1];
	Tcl_IncrRefCount(elemPtr);
    } else {
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])
				/* Argument objects. */
{
    int result;
    size_t listLen, first, last;
    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
	return TCL_ERROR;
    }

    result = TclListObjLengthM(interp, objv[1], &listLen);
    if (result != TCL_OK) {







|







2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])
				/* Argument objects. */
{
    int result;
    Tcl_Size listLen, first, last;
    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
	return TCL_ERROR;
    }

    result = TclListObjLengthM(interp, objv[1], &listLen);
    if (result != TCL_OK) {
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
 */

static int
LremoveIndexCompare(
    const void *el1Ptr,
    const void *el2Ptr)
{
    size_t idx1 = *((const size_t *) el1Ptr);
    size_t idx2 = *((const size_t *) el2Ptr);

    /*
     * This will put the larger element first.
     */

    return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}

int
Tcl_LremoveObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, idxc, prevIdx, first, num;
    size_t *idxv, listLen;
    Tcl_Obj *listObj;

    /*
     * Parse the arguments.
     */

    if (objc < 2) {







|
|















|
|







2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
 */

static int
LremoveIndexCompare(
    const void *el1Ptr,
    const void *el2Ptr)
{
    Tcl_Size idx1 = *((const Tcl_Size *) el1Ptr);
    Tcl_Size idx2 = *((const Tcl_Size *) el2Ptr);

    /*
     * This will put the larger element first.
     */

    return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}

int
Tcl_LremoveObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size i, idxc, prevIdx, first, num;
    Tcl_Size *idxv, listLen;
    Tcl_Obj *listObj;

    /*
     * Parse the arguments.
     */

    if (objc < 2) {
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
    }

    idxc = objc - 2;
    if (idxc == 0) {
	Tcl_SetObjResult(interp, listObj);
	return TCL_OK;
    }
    idxv = (size_t *)Tcl_Alloc((objc - 2) * sizeof(size_t));
    for (i = 2; i < objc; i++) {
	if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
		&idxv[i - 2]) != TCL_OK) {
	    Tcl_Free(idxv);
	    return TCL_ERROR;
	}
    }

    /*
     * Sort the indices, large to small so that when we remove an index we
     * don't change the indices still to be processed.
     */

    if (idxc > 1) {
	qsort(idxv, idxc, sizeof(size_t), LremoveIndexCompare);
    }

    /*
     * Make our working copy, then do the actual removes piecemeal.
     */

    if (Tcl_IsShared(listObj)) {
	listObj = TclListObjCopy(NULL, listObj);
    }
    num = 0;
    first = listLen;
    for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
	int idx = idxv[i];

	/*
	 * Repeated index and sanity check.
	 */

	if (idx == prevIdx) {
	    continue;
	}
	prevIdx = idx;
	if (idx < 0 || idx >= (int)listLen) {
	    continue;
	}

	/*
	 * Coalesce adjacent removes to reduce the number of copies.
	 */








|














|












|









|







2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
    }

    idxc = objc - 2;
    if (idxc == 0) {
	Tcl_SetObjResult(interp, listObj);
	return TCL_OK;
    }
    idxv = (Tcl_Size *)Tcl_Alloc((objc - 2) * sizeof(*idxv));
    for (i = 2; i < objc; i++) {
	if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
		&idxv[i - 2]) != TCL_OK) {
	    Tcl_Free(idxv);
	    return TCL_ERROR;
	}
    }

    /*
     * Sort the indices, large to small so that when we remove an index we
     * don't change the indices still to be processed.
     */

    if (idxc > 1) {
	qsort(idxv, idxc, sizeof(*idxv), LremoveIndexCompare);
    }

    /*
     * Make our working copy, then do the actual removes piecemeal.
     */

    if (Tcl_IsShared(listObj)) {
	listObj = TclListObjCopy(NULL, listObj);
    }
    num = 0;
    first = listLen;
    for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
	Tcl_Size idx = idxv[i];

	/*
	 * Repeated index and sanity check.
	 */

	if (idx == prevIdx) {
	    continue;
	}
	prevIdx = idx;
	if (idx < 0 || idx >= listLen) {
	    continue;
	}

	/*
	 * Coalesce adjacent removes to reduce the number of copies.
	 */

2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
     */

    objc -= 2;
    objv += 2;

    /* Final sanity check. Do not exceed limits on max list length. */

    if (elementCount && (size_t)objc > LIST_MAX/elementCount) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", LIST_MAX));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	return TCL_ERROR;
    }
    totalElems = objc * elementCount;

    /*
     * Get an empty list object that is allocated large enough to hold each







|

|







2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
     */

    objc -= 2;
    objv += 2;

    /* Final sanity check. Do not exceed limits on max list length. */

    if (elementCount && objc > LIST_MAX/elementCount) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"max length of a Tcl list (%" TCL_SIZE_MODIFIER "d elements) exceeded", LIST_MAX));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	return TCL_ERROR;
    }
    totalElems = objc * elementCount;

    /*
     * Get an empty list object that is allocated large enough to hold each
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
Tcl_LreplaceObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *listPtr;
    size_t numToDelete, listLen, first, last;
    int result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"list first last ?element ...?");
	return TCL_ERROR;
    }







|







3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
Tcl_LreplaceObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *listPtr;
    Tcl_Size numToDelete, listLen, first, last;
    int result;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"list first last ?element ...?");
	return TCL_ERROR;
    }
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
    }

    result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first == TCL_INDEX_NONE) {
	first = 0;
    } else if (first > listLen) {
	first = listLen;
    }

    if (last + 1 > listLen) {
	last = listLen - 1;
    }
    if (first + 1 <= last + 1) {
	numToDelete = last - first + 1;
    } else {
	numToDelete = 0;
    }

    /*
     * If the list object is unshared we can modify it directly, otherwise we







|





|


|







3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
    }

    result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first < 0) {
	first = 0;
    } else if (first > listLen) {
	first = listLen;
    }

    if (last >= listLen) {
	last = listLen - 1;
    }
    if (first <= last) {
	numToDelete = last - first + 1;
    } else {
	numToDelete = 0;
    }

    /*
     * If the list object is unshared we can modify it directly, otherwise we
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
Tcl_LreverseObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    Tcl_Obj **elemv;
    size_t elemc, i, j;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list");
	return TCL_ERROR;
    }

    /*







|







3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
Tcl_LreverseObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    Tcl_Obj **elemv;
    Tcl_Size elemc, i, j;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "list");
	return TCL_ERROR;
    }

    /*
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    const char *bytes, *patternBytes;
    int match, index, result=TCL_OK, bisect;
    size_t i, length = 0, listc, elemLen, start, groupSize, groupOffset, lower, upper;
    int allocatedIndexVector = 0;
    int isIncreasing;
    Tcl_WideInt patWide, objWide, wide;
    int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
    double patDouble, objDouble;
    SortInfo sortInfo;
    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;







|







3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    const char *bytes, *patternBytes;
    int match, index, result=TCL_OK, bisect;
    Tcl_Size i, length = 0, listc, elemLen, start, groupSize, groupOffset, lower, upper;
    int allocatedIndexVector = 0;
    int isIncreasing;
    Tcl_WideInt patWide, objWide, wide;
    int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
    double patDouble, objDouble;
    SortInfo sortInfo;
    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
    sortInfo.indexc = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern");
	return TCL_ERROR;
    }

    for (i = 1; i < (size_t)objc-2; i++) {
	enum lsearchoptions idx;
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx)
		!= TCL_OK) {
	    result = TCL_ERROR;
	    goto done;
	}
	switch (idx) {







|







3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
    sortInfo.indexc = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern");
	return TCL_ERROR;
    }

    for (i = 1; i < objc-2; i++) {
	enum lsearchoptions idx;
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx)
		!= TCL_OK) {
	    result = TCL_ERROR;
	    goto done;
	}
	switch (idx) {
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
	     * because it will either be replaced or there will be an error.
	     */

	    if (startPtr != NULL) {
		Tcl_DecrRefCount(startPtr);
		startPtr = NULL;
	    }
	    if (i + 4 > (size_t)objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing starting index", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    i++;
	    if (objv[i] == objv[objc - 2]) {
		/*
		 * Take copy to prevent shimmering problems. Note that it does
		 * not matter if the index obj is also a component of the list
		 * being searched. We only need to copy where the list and the
		 * index are one-and-the-same.
		 */

		startPtr = Tcl_DuplicateObj(objv[i]);
	    } else {
		startPtr = objv[i];
	    }
	    Tcl_IncrRefCount(startPtr);
	    break;
	case LSEARCH_STRIDE:		/* -stride */
	    if (i + 4 > (size_t)objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-stride\" option must be "
			"followed by stride length", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) {
		result = TCL_ERROR;
		goto done;
	    }
	    if (wide < 1) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"stride length must be at least 1", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
			"BADSTRIDE", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    groupSize = wide;
	    i++;
	    break;
	case LSEARCH_INDEX: {		/* -index */
	    Tcl_Obj **indices;
	    size_t j;

	    if (allocatedIndexVector) {
		TclStackFree(interp, sortInfo.indexv);
		allocatedIndexVector = 0;
	    }
	    if (i + 4 > (size_t)objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }







|

|




















|


|










|










|





|







3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
	     * because it will either be replaced or there will be an error.
	     */

	    if (startPtr != NULL) {
		Tcl_DecrRefCount(startPtr);
		startPtr = NULL;
	    }
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing starting index", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    i++;
	    if (objv[i] == objv[objc - 2]) {
		/*
		 * Take copy to prevent shimmering problems. Note that it does
		 * not matter if the index obj is also a component of the list
		 * being searched. We only need to copy where the list and the
		 * index are one-and-the-same.
		 */

		startPtr = Tcl_DuplicateObj(objv[i]);
	    } else {
		startPtr = objv[i];
	    }
	    Tcl_IncrRefCount(startPtr);
	    break;
	case LSEARCH_STRIDE:		/* -stride */
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-stride\" option must be "
			"followed by stride length", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) {
		result = TCL_ERROR;
		goto done;
	    }
	    if (wide < 1) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"stride length must be at least 1", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
			"BADSTRIDE", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    groupSize = wide;
	    i++;
	    break;
	case LSEARCH_INDEX: {		/* -index */
	    Tcl_Obj **indices;
	    Tcl_Size j;

	    if (allocatedIndexVector) {
		TclStackFree(interp, sortInfo.indexv);
		allocatedIndexVector = 0;
	    }
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		result = TCL_ERROR;
		goto done;
	    }
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519

    /*
     * Subindices only make sense if asked for with -index option set.
     */

    if (returnSubindices && sortInfo.indexc==0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"-subindices cannot be used without -index option", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
		"BAD_OPTION_MIX", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if (bisect && (allMatches || negatedMatch)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"-bisect is not compatible with -all or -not", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
		"BAD_OPTION_MIX", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if (mode == REGEXP) {







|








|







3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519

    /*
     * Subindices only make sense if asked for with -index option set.
     */

    if (returnSubindices && sortInfo.indexc==0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"-subindices cannot be used without -index option", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
		"BAD_OPTION_MIX", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if (bisect && (allMatches || negatedMatch)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"-bisect is not compatible with -all or -not", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
		"BAD_OPTION_MIX", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if (mode == REGEXP) {
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
	if (sortInfo.indexc > 0) {
	    /*
	     * Use the first value in the list supplied to -index as the
	     * offset of the element within each group by which to sort.
	     */

	    groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
	    if (groupOffset >= groupSize) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"when used with \"-stride\", the leading \"-index\""
			" value must be within the group", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
			"BADINDEX", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    if (sortInfo.indexc == 1) {
		sortInfo.indexc = 0;







|


|







3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
	if (sortInfo.indexc > 0) {
	    /*
	     * Use the first value in the list supplied to -index as the
	     * offset of the element within each group by which to sort.
	     */

	    groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
	    if (groupOffset < 0 || groupOffset >= groupSize) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"when used with \"-stride\", the leading \"-index\""
			" value must be within the group", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
			"BADINDEX", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    if (sortInfo.indexc == 1) {
		sortInfo.indexc = 0;
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
	}

	/*
	 * If the search started past the end of the list, we just return a
	 * "did not match anything at all" result straight away. [Bug 1374778]
	 */

	if (start >= (size_t)listc) {
	    if (allMatches || inlineReturn) {
		Tcl_ResetResult(interp);
	    } else {
		TclNewIntObj(itemPtr, -1);
		Tcl_SetObjResult(interp, itemPtr);
	    }
	    goto done;







|







3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
	}

	/*
	 * If the search started past the end of the list, we just return a
	 * "did not match anything at all" result straight away. [Bug 1374778]
	 */

	if (start >= listc) {
	    if (allMatches || inlineReturn) {
		Tcl_ResetResult(interp);
	    } else {
		TclNewIntObj(itemPtr, -1);
		Tcl_SetObjResult(interp, itemPtr);
	    }
	    goto done;
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
		    Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
			    groupSize, &listv[i]);
		} else {
		    itemPtr = listv[i];
		    Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
		}
	    } else if (returnSubindices) {
		size_t j;

		TclNewIndexObj(itemPtr, i+groupOffset);
		for (j=0 ; j<sortInfo.indexc ; j++) {
		    Tcl_Obj *elObj;
		    size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc);
		    TclNewIndexObj(elObj, elValue);
		    Tcl_ListObjAppendElement(interp, itemPtr, elObj);







|







3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
		    Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
			    groupSize, &listv[i]);
		} else {
		    itemPtr = listv[i];
		    Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
		}
	    } else if (returnSubindices) {
		Tcl_Size j;

		TclNewIndexObj(itemPtr, i+groupOffset);
		for (j=0 ; j<sortInfo.indexc ; j++) {
		    Tcl_Obj *elObj;
		    size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc);
		    TclNewIndexObj(elObj, elValue);
		    Tcl_ListObjAppendElement(interp, itemPtr, elObj);
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
     * Return everything or a single value.
     */

    if (allMatches) {
	Tcl_SetObjResult(interp, listPtr);
    } else if (!inlineReturn) {
	if (returnSubindices) {
	    size_t j;

	    TclNewIndexObj(itemPtr, index+groupOffset);
	    for (j=0 ; j<sortInfo.indexc ; j++) {
		Tcl_Obj *elObj;
		size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc);
		TclNewIndexObj(elObj, elValue);
		Tcl_ListObjAppendElement(interp, itemPtr, elObj);







|







3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
     * Return everything or a single value.
     */

    if (allMatches) {
	Tcl_SetObjResult(interp, listPtr);
    } else if (!inlineReturn) {
	if (returnSubindices) {
	    Tcl_Size j;

	    TclNewIndexObj(itemPtr, index+groupOffset);
	    for (j=0 ; j<sortInfo.indexc ; j++) {
		Tcl_Obj *elObj;
		size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc);
		TclNewIndexObj(elObj, elValue);
		Tcl_ListObjAppendElement(interp, itemPtr, elObj);
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    int indices, nocase = 0, indexc;
    int sortMode = SORTMODE_ASCII;
    int group, allocatedIndexVector = 0;
    size_t j, idx, groupSize, groupOffset, length;
    Tcl_WideInt wide;
    Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
    size_t i, elmArrSize;
    SortElement *elementArray = NULL, *elementPtr;
    SortInfo sortInfo;		/* Information about this sort that needs to
				 * be passed to the comparison function. */
#   define MAXCALLOC 1024000
#   define NUM_LISTS 30
    SortElement *subList[NUM_LISTS+1];
				/* This array holds pointers to temporary







|


|







4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    int indices, nocase = 0, indexc;
    int sortMode = SORTMODE_ASCII;
    int group, allocatedIndexVector = 0;
    Tcl_Size j, idx, groupSize, groupOffset, length;
    Tcl_WideInt wide;
    Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
    Tcl_Size i, elmArrSize;
    SortElement *elementArray = NULL, *elementPtr;
    SortInfo sortInfo;		/* Information about this sort that needs to
				 * be passed to the comparison function. */
#   define MAXCALLOC 1024000
#   define NUM_LISTS 30
    SortElement *subList[NUM_LISTS+1];
				/* This array holds pointers to temporary
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
    sortInfo.resultCode = TCL_OK;
    cmdPtr = NULL;
    indices = 0;
    group = 0;
    groupSize = 1;
    groupOffset = 0;
    indexPtr = NULL;
    for (i = 1; i < (size_t)objc-1; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
		&index) != TCL_OK) {
	    sortInfo.resultCode = TCL_ERROR;
	    goto done;
	}
	switch (index) {
	case LSORT_ASCII:
	    sortInfo.sortMode = SORTMODE_ASCII;
	    break;
	case LSORT_COMMAND:
	    if (i + 2 == (size_t)objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-command\" option must be followed "
			"by comparison command", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    sortInfo.sortMode = SORTMODE_COMMAND;
	    cmdPtr = objv[i+1];
	    i++;
	    break;
	case LSORT_DECREASING:
	    sortInfo.isIncreasing = 0;
	    break;
	case LSORT_DICTIONARY:
	    sortInfo.sortMode = SORTMODE_DICTIONARY;
	    break;
	case LSORT_INCREASING:
	    sortInfo.isIncreasing = 1;
	    break;
	case LSORT_INDEX: {
	    size_t sortindex;
	    Tcl_Obj **indexv;

	    if (i + 2 == (size_t)objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }







|










|


|


















|


|







4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
    sortInfo.resultCode = TCL_OK;
    cmdPtr = NULL;
    indices = 0;
    group = 0;
    groupSize = 1;
    groupOffset = 0;
    indexPtr = NULL;
    for (i = 1; i < objc-1; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
		&index) != TCL_OK) {
	    sortInfo.resultCode = TCL_ERROR;
	    goto done;
	}
	switch (index) {
	case LSORT_ASCII:
	    sortInfo.sortMode = SORTMODE_ASCII;
	    break;
	case LSORT_COMMAND:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-command\" option must be followed "
			"by comparison command", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    sortInfo.sortMode = SORTMODE_COMMAND;
	    cmdPtr = objv[i+1];
	    i++;
	    break;
	case LSORT_DECREASING:
	    sortInfo.isIncreasing = 0;
	    break;
	case LSORT_DICTIONARY:
	    sortInfo.sortMode = SORTMODE_DICTIONARY;
	    break;
	case LSORT_INCREASING:
	    sortInfo.isIncreasing = 1;
	    break;
	case LSORT_INDEX: {
	    Tcl_Size sortindex;
	    Tcl_Obj **indexv;

	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
	case LSORT_UNIQUE:
	    sortInfo.unique = 1;
	    break;
	case LSORT_INDICES:
	    indices = 1;
	    break;
	case LSORT_STRIDE:
	    if (i + 2 == (size_t)objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-stride\" option must be "
			"followed by stride length", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) {
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (wide < 2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"stride length must be at least 2", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADSTRIDE", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    groupSize = wide;
	    group = 1;







|


|










|







4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
	case LSORT_UNIQUE:
	    sortInfo.unique = 1;
	    break;
	case LSORT_INDICES:
	    indices = 1;
	    break;
	case LSORT_STRIDE:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-stride\" option must be "
			"followed by stride length", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) {
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (wide < 2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"stride length must be at least 2", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADSTRIDE", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    groupSize = wide;
	    group = 1;
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
	if (sortInfo.indexc > 0) {
	    /*
	     * Use the first value in the list supplied to -index as the
	     * offset of the element within each group by which to sort.
	     */

	    groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
	    if (groupOffset >= groupSize) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"when used with \"-stride\", the leading \"-index\""
			" value must be within the group", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADINDEX", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (sortInfo.indexc == 1) {
		sortInfo.indexc = 0;







|


|







4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
	if (sortInfo.indexc > 0) {
	    /*
	     * Use the first value in the list supplied to -index as the
	     * offset of the element within each group by which to sort.
	     */

	    groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
	    if (groupOffset < 0 || groupOffset >= groupSize) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"when used with \"-stride\", the leading \"-index\""
			" value must be within the group", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADINDEX", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (sortInfo.indexc == 1) {
		sortInfo.indexc = 0;
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    Tcl_Obj *listPtr;		/* Pointer to the list being altered. */
    Tcl_Obj *finalValuePtr;	/* Value finally assigned to the variable. */
    int createdNewObj;
    int result;
    size_t first;
    size_t last;
    size_t listLen;
    size_t numToDelete;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"listVar first last ?element ...?");
	return TCL_ERROR;
    }








|
|
|
|







5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    Tcl_Obj *listPtr;		/* Pointer to the list being altered. */
    Tcl_Obj *finalValuePtr;	/* Value finally assigned to the variable. */
    int createdNewObj;
    int result;
    Tcl_Size first;
    Tcl_Size last;
    Tcl_Size listLen;
    Tcl_Size numToDelete;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"listVar first last ?element ...?");
	return TCL_ERROR;
    }

5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
    }

    result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first == TCL_INDEX_NONE) {
	first = 0;
    } else if (first > listLen) {
	first = listLen;
    }

    /* The +1 in comparisons are necessitated by indices being unsigned */
    if ((last + 1) > listLen) {
	last = listLen - 1;
    }
    if ((first + 1) <= (last + 1)) {
	numToDelete = last - first + 1;
    } else {
	numToDelete = 0;
    }

    if (Tcl_IsShared(listPtr)) {
	listPtr = TclListObjCopy(NULL, listPtr);







|






|


|







5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
    }

    result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first < 0) {
	first = 0;
    } else if (first > listLen) {
	first = listLen;
    }

    /* The +1 in comparisons are necessitated by indices being unsigned */
    if (last >= listLen) {
	last = listLen - 1;
    }
    if (first <= last) {
	numToDelete = last - first + 1;
    } else {
	numToDelete = 0;
    }

    if (Tcl_IsShared(listPtr)) {
	listPtr = TclListObjCopy(NULL, listPtr);
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
	double a, b;

	a = elemPtr1->collationKey.doubleValue;
	b = elemPtr2->collationKey.doubleValue;
	order = ((a >= b) - (a <= b));
    } else {
	Tcl_Obj **objv, *paramObjv[2];
	size_t objc;
	Tcl_Obj *objPtr1, *objPtr2;

	if (infoPtr->resultCode != TCL_OK) {
	    /*
	     * Once an error has occurred, skip any future comparisons so as
	     * to preserve the error message in sortInterp->result.
	     */







|







5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
	double a, b;

	a = elemPtr1->collationKey.doubleValue;
	b = elemPtr2->collationKey.doubleValue;
	order = ((a >= b) - (a <= b));
    } else {
	Tcl_Obj **objv, *paramObjv[2];
	Tcl_Size objc;
	Tcl_Obj *objPtr1, *objPtr2;

	if (infoPtr->resultCode != TCL_OK) {
	    /*
	     * Once an error has occurred, skip any future comparisons so as
	     * to preserve the error message in sortInterp->result.
	     */
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
	/*
	 * Parse the result of the command.
	 */

	if (TclGetIntFromObj(infoPtr->interp,
		Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
	    Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
		    "-compare command returned non-integer result", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
		    "COMPARISONFAILED", NULL);
	    infoPtr->resultCode = TCL_ERROR;
	    return 0;
	}
    }
    if (!infoPtr->isIncreasing) {







|







5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
	/*
	 * Parse the result of the command.
	 */

	if (TclGetIntFromObj(infoPtr->interp,
		Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
	    Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
		    "-compare command returned non-integer result", -1));
	    Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
		    "COMPARISONFAILED", NULL);
	    infoPtr->resultCode = TCL_ERROR;
	    return 0;
	}
    }
    if (!infoPtr->isIncreasing) {
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516

static Tcl_Obj *
SelectObjFromSublist(
    Tcl_Obj *objPtr,		/* Obj to select sublist from. */
    SortInfo *infoPtr)		/* Information passed from the top-level
				 * "lsearch" or "lsort" command. */
{
    size_t i;

    /*
     * Quick check for case when no "-index" option is there.
     */

    if (infoPtr->indexc == 0) {
	return objPtr;
    }

    /*
     * Iterate over the indices, traversing through the nested sublists as we
     * go.
     */

    for (i=0 ; i<infoPtr->indexc ; i++) {
	size_t listLen;
	int index;
	Tcl_Obj *currentObj;

	if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}

	index = TclIndexDecode(infoPtr->indexv[i], listLen - 1);

	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {
	    if (index == (int)TCL_INDEX_NONE) {
		index = TCL_INDEX_END - infoPtr->indexv[i];
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element end-%d missing from sublist \"%s\"",
			index, TclGetString(objPtr)));
	    } else {
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element %d missing from sublist \"%s\"",







|















|
















|







5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516

static Tcl_Obj *
SelectObjFromSublist(
    Tcl_Obj *objPtr,		/* Obj to select sublist from. */
    SortInfo *infoPtr)		/* Information passed from the top-level
				 * "lsearch" or "lsort" command. */
{
    Tcl_Size i;

    /*
     * Quick check for case when no "-index" option is there.
     */

    if (infoPtr->indexc == 0) {
	return objPtr;
    }

    /*
     * Iterate over the indices, traversing through the nested sublists as we
     * go.
     */

    for (i=0 ; i<infoPtr->indexc ; i++) {
	Tcl_Size listLen;
	int index;
	Tcl_Obj *currentObj;

	if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}

	index = TclIndexDecode(infoPtr->indexv[i], listLen - 1);

	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {
	    if (index == TCL_INDEX_NONE) {
		index = TCL_INDEX_END - infoPtr->indexv[i];
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element end-%d missing from sublist \"%s\"",
			index, TclGetString(objPtr)));
	    } else {
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element %d missing from sublist \"%s\"",

Changes to generic/tclCmdMZ.c.

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
int
Tcl_RegexpObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t offset, stringLength, matchLength, cflags, eflags;
    int i, indices, match, about, all, doinline, numMatchesSaved;
    Tcl_RegExp regExpr;
    Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
    Tcl_RegExpInfo info;
    static const char *const options[] = {
	"-all",		"-about",	"-indices",	"-inline",
	"-expanded",	"-line",	"-linestop",	"-lineanchor",







|







124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
int
Tcl_RegexpObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size offset, stringLength, matchLength, cflags, eflags;
    int i, indices, match, about, all, doinline, numMatchesSaved;
    Tcl_RegExp regExpr;
    Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
    Tcl_RegExpInfo info;
    static const char *const options[] = {
	"-all",		"-about",	"-indices",	"-inline",
	"-expanded",	"-line",	"-linestop",	"-lineanchor",
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
	case REGEXP_LINESTOP:
	    cflags |= TCL_REG_NLSTOP;
	    break;
	case REGEXP_LINEANCHOR:
	    cflags |= TCL_REG_NLANCH;
	    break;
	case REGEXP_START: {
	    size_t temp;
	    if (++i >= objc) {
		goto endOfForLoop;
	    }
	    if (TclGetIntForIndexM(interp, objv[i], (size_t)WIDE_MAX - 1, &temp) != TCL_OK) {
		goto optionError;
	    }
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
	    }
	    startIndex = objv[i];
	    Tcl_IncrRefCount(startIndex);







|



|







187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
	case REGEXP_LINESTOP:
	    cflags |= TCL_REG_NLSTOP;
	    break;
	case REGEXP_LINEANCHOR:
	    cflags |= TCL_REG_NLANCH;
	    break;
	case REGEXP_START: {
	    Tcl_Size temp;
	    if (++i >= objc) {
		goto endOfForLoop;
	    }
	    if (TclGetIntForIndexM(interp, objv[i], TCL_SIZE_MAX - 1, &temp) != TCL_OK) {
		goto optionError;
	    }
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
	    }
	    startIndex = objv[i];
	    Tcl_IncrRefCount(startIndex);
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
    /*
     * Check if the user requested -inline, but specified match variables; a
     * no-no.
     */

    if (doinline && ((objc - 2) != 0)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"regexp match variables not allowed when using -inline", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP",
		"MIX_VAR_INLINE", NULL);
	goto optionError;
    }

    /*
     * Handle the odd about case separately.







|







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
    /*
     * Check if the user requested -inline, but specified match variables; a
     * no-no.
     */

    if (doinline && ((objc - 2) != 0)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"regexp match variables not allowed when using -inline", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP",
		"MIX_VAR_INLINE", NULL);
	goto optionError;
    }

    /*
     * Handle the odd about case separately.
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

    objPtr = objv[1];
    stringLength = Tcl_GetCharLength(objPtr);

    if (startIndex) {
	TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
	Tcl_DecrRefCount(startIndex);
	if (offset == TCL_INDEX_NONE) {
	    offset = TCL_INDEX_START;
	}
    }

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
	return TCL_ERROR;







|







257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

    objPtr = objv[1];
    stringLength = Tcl_GetCharLength(objPtr);

    if (startIndex) {
	TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
	Tcl_DecrRefCount(startIndex);
	if (offset < 0) {
	    offset = TCL_INDEX_START;
	}
    }

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
	return TCL_ERROR;
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
	 * considered the start of the line. If for example the pattern {^} is
	 * passed and -start is positive, then the pattern will not match the
	 * start of the string unless the previous character is a newline.
	 */

	if (offset == TCL_INDEX_START) {
	    eflags = 0;
	} else if (offset + 1 > stringLength + 1) {
	    eflags = TCL_REG_NOTBOL;
	} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
	    eflags = 0;
	} else {
	    eflags = TCL_REG_NOTBOL;
	}








|







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
	 * considered the start of the line. If for example the pattern {^} is
	 * passed and -start is positive, then the pattern will not match the
	 * start of the string unless the previous character is a newline.
	 */

	if (offset == TCL_INDEX_START) {
	    eflags = 0;
	} else if (offset > stringLength) {
	    eflags = TCL_REG_NOTBOL;
	} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
	    eflags = 0;
	} else {
	    eflags = TCL_REG_NOTBOL;
	}

360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
		resultPtr = Tcl_NewObj();
	    }
	}
	for (i = 0; i < objc; i++) {
	    Tcl_Obj *newPtr;

	    if (indices) {
		size_t start, end;
		Tcl_Obj *objs[2];

		/*
		 * Only adjust the match area if there was a match for that
		 * area. (Scriptics Bug 4391/SF Bug #219232)
		 */

		if (i <= (int)info.nsubs && info.matches[i].start != TCL_INDEX_NONE) {
		    start = offset + info.matches[i].start;
		    end = offset + info.matches[i].end;

		    /*
		     * Adjust index so it refers to the last character in the
		     * match instead of the first character after the match.
		     */

		    if (end + 1 >= offset + 1) {
			end--;
		    }
		} else {
		    start = TCL_INDEX_NONE;
		    end = TCL_INDEX_NONE;
		}

		TclNewIndexObj(objs[0], start);
		TclNewIndexObj(objs[1], end);

		newPtr = Tcl_NewListObj(2, objs);
	    } else {
		if ((i <= (int)info.nsubs) && (info.matches[i].end + 1 > 1)) {
		    newPtr = Tcl_GetRange(objPtr,
			    offset + info.matches[i].start,
			    offset + info.matches[i].end - 1);
		} else {
		    newPtr = Tcl_NewObj();
		}
	    }







|







|








|












|







360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
		resultPtr = Tcl_NewObj();
	    }
	}
	for (i = 0; i < objc; i++) {
	    Tcl_Obj *newPtr;

	    if (indices) {
		Tcl_Size start, end;
		Tcl_Obj *objs[2];

		/*
		 * Only adjust the match area if there was a match for that
		 * area. (Scriptics Bug 4391/SF Bug #219232)
		 */

		if (i <= (int)info.nsubs && info.matches[i].start >= 0) {
		    start = offset + info.matches[i].start;
		    end = offset + info.matches[i].end;

		    /*
		     * Adjust index so it refers to the last character in the
		     * match instead of the first character after the match.
		     */

		    if (end >= offset) {
			end--;
		    }
		} else {
		    start = TCL_INDEX_NONE;
		    end = TCL_INDEX_NONE;
		}

		TclNewIndexObj(objs[0], start);
		TclNewIndexObj(objs[1], end);

		newPtr = Tcl_NewListObj(2, objs);
	    } else {
		if ((i <= (int)info.nsubs) && (info.matches[i].end > 0)) {
		    newPtr = Tcl_GetRange(objPtr,
			    offset + info.matches[i].start,
			    offset + info.matches[i].end - 1);
		} else {
		    newPtr = Tcl_NewObj();
		}
	    }
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
	 * these cases we always want to bump the index up one.
	 */

	if (matchLength == 0) {
	    offset++;
	}
	all++;
	if (offset + 1 >= stringLength + 1) {
	    break;
	}
    }

    /*
     * Set the interpreter's object result to an integer object with value 1
     * if -all wasn't specified, otherwise it's all-1 (the number of times







|







440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
	 * these cases we always want to bump the index up one.
	 */

	if (matchLength == 0) {
	    offset++;
	}
	all++;
	if (offset >= stringLength) {
	    break;
	}
    }

    /*
     * Set the interpreter's object result to an integer object with value 1
     * if -all wasn't specified, otherwise it's all-1 (the number of times
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
Tcl_RegsubObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int result, cflags, all, match, command;
    size_t idx, wlen, wsublen = 0, offset, numMatches, numParts;
    size_t start, end, subStart, subEnd;
    Tcl_RegExp regExpr;
    Tcl_RegExpInfo info;
    Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
    Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;

    static const char *const options[] = {
	"-all",		"-command",	"-expanded",	"-line",







|
|







484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
Tcl_RegsubObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int result, cflags, all, match, command;
    Tcl_Size idx, wlen, wsublen = 0, offset, numMatches, numParts;
    Tcl_Size start, end, subStart, subEnd;
    Tcl_RegExp regExpr;
    Tcl_RegExpInfo info;
    Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
    Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;

    static const char *const options[] = {
	"-all",		"-command",	"-expanded",	"-line",
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522

    cflags = TCL_REG_ADVANCED;
    all = 0;
    offset = TCL_INDEX_START;
    command = 0;
    resultPtr = NULL;

    for (idx = 1; idx < (size_t)objc; idx++) {
	const char *name;

	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option",







|







508
509
510
511
512
513
514
515
516
517
518
519
520
521
522

    cflags = TCL_REG_ADVANCED;
    all = 0;
    offset = TCL_INDEX_START;
    command = 0;
    resultPtr = NULL;

    for (idx = 1; idx < objc; idx++) {
	const char *name;

	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option",
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
	case REGSUB_LINESTOP:
	    cflags |= TCL_REG_NLSTOP;
	    break;
	case REGSUB_LINEANCHOR:
	    cflags |= TCL_REG_NLANCH;
	    break;
	case REGSUB_START: {
	    size_t temp;
	    if (++idx >= (size_t)objc) {
		goto endOfForLoop;
	    }
	    if (TclGetIntForIndexM(interp, objv[idx], (size_t)WIDE_MAX - 1, &temp) != TCL_OK) {
		goto optionError;
	    }
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
	    }
	    startIndex = objv[idx];
	    Tcl_IncrRefCount(startIndex);
	    break;
	}
	case REGSUB_LAST:
	    idx++;
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if ((size_t)objc < idx + 3 || (size_t)objc > idx + 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-option ...? exp string subSpec ?varName?");
    optionError:
	if (startIndex) {
	    Tcl_DecrRefCount(startIndex);
	}
	return TCL_ERROR;
    }

    objc -= idx;
    objv += idx;

    if (startIndex) {
	size_t stringLength = Tcl_GetCharLength(objv[1]);

	TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
	Tcl_DecrRefCount(startIndex);
	if (offset == TCL_INDEX_NONE) {
	    offset = TCL_INDEX_START;
	}
    }

    if (all && (offset == TCL_INDEX_START) && (command == 0)
	    && (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
	    && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
	/*
	 * This is a simple one pair string map situation. We make use of a
	 * slightly modified version of the one pair STR_MAP code.
	 */

	size_t slen;
	int nocase, wsrclc;
	int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,size_t);
	Tcl_UniChar *p;

	numMatches = 0;
	nocase = (cflags & TCL_REG_NOCASE);
	strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp;







|
|


|
















|













|



|
|



|







|







542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
	case REGSUB_LINESTOP:
	    cflags |= TCL_REG_NLSTOP;
	    break;
	case REGSUB_LINEANCHOR:
	    cflags |= TCL_REG_NLANCH;
	    break;
	case REGSUB_START: {
	    Tcl_Size temp;
	    if (++idx >= objc) {
		goto endOfForLoop;
	    }
	    if (TclGetIntForIndexM(interp, objv[idx], TCL_SIZE_MAX - 1, &temp) != TCL_OK) {
		goto optionError;
	    }
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
	    }
	    startIndex = objv[idx];
	    Tcl_IncrRefCount(startIndex);
	    break;
	}
	case REGSUB_LAST:
	    idx++;
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if (objc < idx + 3 || objc > idx + 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-option ...? exp string subSpec ?varName?");
    optionError:
	if (startIndex) {
	    Tcl_DecrRefCount(startIndex);
	}
	return TCL_ERROR;
    }

    objc -= idx;
    objv += idx;

    if (startIndex) {
	Tcl_Size stringLength = Tcl_GetCharLength(objv[1]);

	TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
	Tcl_DecrRefCount(startIndex);
	if (offset < 0) {
	    offset = 0;
	}
    }

    if (all && (offset == 0) && (command == 0)
	    && (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
	    && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
	/*
	 * This is a simple one pair string map situation. We make use of a
	 * slightly modified version of the one pair STR_MAP code.
	 */

	Tcl_Size slen;
	int nocase, wsrclc;
	int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,size_t);
	Tcl_UniChar *p;

	numMatches = 0;
	nocase = (cflags & TCL_REG_NOCASE);
	strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp;
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
	 * arguments to the subSpec to form a command, that is then executed
	 * and the result used as the string to substitute in. Actually,
	 * everything is passed through Tcl_EvalObjv, as that's much faster.
	 */

	if (command) {
	    Tcl_Obj **args = NULL, **parts;
	    size_t numArgs;

	    TclListObjGetElementsM(interp, subPtr, &numParts, &parts);
	    numArgs = numParts + info.nsubs + 1;
	    args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs);
	    memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);

	    for (idx = 0 ; idx <= info.nsubs ; idx++) {
		subStart = info.matches[idx].start;
		subEnd = info.matches[idx].end;
		if ((subStart != TCL_INDEX_NONE) && (subEnd != TCL_INDEX_NONE)) {
		    args[idx + numParts] = Tcl_NewUnicodeObj(
			    wstring + offset + subStart, subEnd - subStart);
		} else {
		    args[idx + numParts] = Tcl_NewObj();
		}
		Tcl_IncrRefCount(args[idx + numParts]);
	    }







|









|







770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
	 * arguments to the subSpec to form a command, that is then executed
	 * and the result used as the string to substitute in. Actually,
	 * everything is passed through Tcl_EvalObjv, as that's much faster.
	 */

	if (command) {
	    Tcl_Obj **args = NULL, **parts;
	    Tcl_Size numArgs;

	    TclListObjGetElementsM(interp, subPtr, &numParts, &parts);
	    numArgs = numParts + info.nsubs + 1;
	    args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs);
	    memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);

	    for (idx = 0 ; idx <= info.nsubs ; idx++) {
		subStart = info.matches[idx].start;
		subEnd = info.matches[idx].end;
		if ((subStart >= 0) && (subEnd >= 0)) {
		    args[idx + numParts] = Tcl_NewUnicodeObj(
			    wstring + offset + subStart, subEnd - subStart);
		} else {
		    args[idx + numParts] = Tcl_NewObj();
		}
		Tcl_IncrRefCount(args[idx + numParts]);
	    }
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
		Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
			wsrc - wfirstChar);
	    }

	    if (idx <= info.nsubs) {
		subStart = info.matches[idx].start;
		subEnd = info.matches[idx].end;
		if ((subStart != TCL_INDEX_NONE) && (subEnd != TCL_INDEX_NONE)) {
		    Tcl_AppendUnicodeToObj(resultPtr,
			    wstring + offset + subStart, subEnd - subStart);
		}
	    }

	    if (*wsrc == '\\') {
		wsrc++;







|







884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
		Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
			wsrc - wfirstChar);
	    }

	    if (idx <= info.nsubs) {
		subStart = info.matches[idx].start;
		subEnd = info.matches[idx].end;
		if ((subStart >= 0) && (subEnd >= 0)) {
		    Tcl_AppendUnicodeToObj(resultPtr,
			    wstring + offset + subStart, subEnd - subStart);
		}
	    }

	    if (*wsrc == '\\') {
		wsrc++;
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int ch = 0;
    int len;
    const char *splitChars;
    const char *stringPtr;
    const char *end;
    size_t splitCharLen, stringLen;
    Tcl_Obj *listPtr, *objPtr;

    if (objc == 2) {
	splitChars = " \n\t\r";
	splitCharLen = 4;
    } else if (objc == 3) {
	splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);







|







1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int ch = 0;
    int len;
    const char *splitChars;
    const char *stringPtr;
    const char *end;
    Tcl_Size splitCharLen, stringLen;
    Tcl_Obj *listPtr, *objPtr;

    if (objc == 2) {
	splitChars = " \n\t\r";
	splitCharLen = 4;
    } else if (objc == 3) {
	splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	    stringPtr = p + 1;
	}
	TclNewStringObj(objPtr, stringPtr, end - stringPtr);
	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    } else {
	const char *element, *p, *splitEnd;
	size_t splitLen;
	int splitChar;

	/*
	 * Normal case: split on any of a given set of characters. Discard
	 * instances of the split characters.
	 */








|







1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	    stringPtr = p + 1;
	}
	TclNewStringObj(objPtr, stringPtr, end - stringPtr);
	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    } else {
	const char *element, *p, *splitEnd;
	Tcl_Size splitLen;
	int splitChar;

	/*
	 * Normal case: split on any of a given set of characters. Discard
	 * instances of the split characters.
	 */

1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
static int
StringFirstCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t start = TCL_INDEX_START;

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"needleString haystackString ?startIndex?");
	return TCL_ERROR;
    }

    if (objc == 4) {
	size_t end = Tcl_GetCharLength(objv[2]) - 1;

	if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) {
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start));
    return TCL_OK;







|








|







1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
static int
StringFirstCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size start = TCL_INDEX_START;

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"needleString haystackString ?startIndex?");
	return TCL_ERROR;
    }

    if (objc == 4) {
	Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1;

	if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) {
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start));
    return TCL_OK;
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
static int
StringLastCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t last = TCL_INDEX_END;

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"needleString haystackString ?lastIndex?");
	return TCL_ERROR;
    }

    if (objc == 4) {
	size_t end = Tcl_GetCharLength(objv[2]) - 1;

	if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) {
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, TclStringLast(objv[1], objv[2], last));
    return TCL_OK;







|








|







1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
static int
StringLastCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size last = TCL_SIZE_MAX;

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"needleString haystackString ?lastIndex?");
	return TCL_ERROR;
    }

    if (objc == 4) {
	Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1;

	if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) {
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, TclStringLast(objv[1], objv[2], last));
    return TCL_OK;
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
static int
StringIndexCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t index, end;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
	return TCL_ERROR;
    }

    /*
     * Get the char length to calculate what 'end' means.
     */

    end = Tcl_GetCharLength(objv[1]) - 1;
    if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    if ((index != TCL_INDEX_NONE) && (index + 1 <= end + 1)) {
	int ch = Tcl_GetUniChar(objv[1], index);

	if (ch == -1) {
	    return TCL_OK;
	}

	/*







|















|







1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
static int
StringIndexCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size index, end;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
	return TCL_ERROR;
    }

    /*
     * Get the char length to calculate what 'end' means.
     */

    end = Tcl_GetCharLength(objv[1]) - 1;
    if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    if ((index >= 0) && (index <= end)) {
	int ch = Tcl_GetUniChar(objv[1], index);

	if (ch == -1) {
	    return TCL_OK;
	}

	/*
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
static int
StringInsertCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[])	/* Argument objects */
{
    size_t length;		/* String length */
    size_t index;		/* Insert index */
    Tcl_Obj *outObj;		/* Output object */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string index insertString");
	return TCL_ERROR;
    }

    length = Tcl_GetCharLength(objv[1]);
    if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    if (index == TCL_INDEX_NONE) {
	index = TCL_INDEX_START;
    }
    if (index > length) {
	index = length;
    }

    outObj = TclStringReplace(interp, objv[1], index, 0, objv[3],







|
|












|







1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
static int
StringInsertCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[])	/* Argument objects */
{
    Tcl_Size length;		/* String length */
    Tcl_Size index;		/* Insert index */
    Tcl_Obj *outObj;		/* Output object */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string index insertString");
	return TCL_ERROR;
    }

    length = Tcl_GetCharLength(objv[1]);
    if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    if (index < 0) {
	index = TCL_INDEX_START;
    }
    if (index > length) {
	index = length;
    }

    outObj = TclStringReplace(interp, objv[1], index, 0, objv[3],
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *end, *stop;
    int (*chcomp)(int) = NULL;	/* The UniChar comparison function. */
    int i, result = 1, strict = 0;
    size_t failat = 0, length1, length2, length3;
    Tcl_Obj *objPtr, *failVarObj = NULL;
    Tcl_WideInt w;

    static const char *const isClasses[] = {
	"alnum",	"alpha",	"ascii",	"control",
	"boolean",	"dict",		"digit",	"double",
	"entier",	"false",	"graph",	"integer",







|







1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *end, *stop;
    int (*chcomp)(int) = NULL;	/* The UniChar comparison function. */
    int i, result = 1, strict = 0;
    Tcl_Size failat = 0, length1, length2, length3;
    Tcl_Obj *objPtr, *failVarObj = NULL;
    Tcl_WideInt w;

    static const char *const isClasses[] = {
	"alnum",	"alpha",	"ascii",	"control",
	"boolean",	"dict",		"digit",	"double",
	"entier",	"false",	"graph",	"integer",
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
	}
	break;
    case STR_IS_CONTROL:
	chcomp = Tcl_UniCharIsControl;
	break;
    case STR_IS_DICT: {
	int dresult;
	size_t dsize;

	dresult = Tcl_DictObjSize(interp, objPtr, &dsize);
	Tcl_ResetResult(interp);
	result = (dresult == TCL_OK) ? 1 : 0;
	if (dresult != TCL_OK && failVarObj != NULL) {
	    /*
	     * Need to figure out where the list parsing failed, which is
	     * fairly expensive. This is adapted from the core of
	     * SetDictFromAny().
	     */

	    const char *elemStart, *nextElem;
	    int lenRemain;
	    size_t elemSize;
	    const char *p;

	    string1 = Tcl_GetStringFromObj(objPtr, &length1);
	    end = string1 + length1;
	    failat = -1;
	    for (p=string1, lenRemain=length1; lenRemain > 0;
		    p=nextElem, lenRemain=end-nextElem) {







|












|
<







1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646

1647
1648
1649
1650
1651
1652
1653
	}
	break;
    case STR_IS_CONTROL:
	chcomp = Tcl_UniCharIsControl;
	break;
    case STR_IS_DICT: {
	int dresult;
	Tcl_Size dsize;

	dresult = Tcl_DictObjSize(interp, objPtr, &dsize);
	Tcl_ResetResult(interp);
	result = (dresult == TCL_OK) ? 1 : 0;
	if (dresult != TCL_OK && failVarObj != NULL) {
	    /*
	     * Need to figure out where the list parsing failed, which is
	     * fairly expensive. This is adapted from the core of
	     * SetDictFromAny().
	     */

	    const char *elemStart, *nextElem;
	    Tcl_Size lenRemain, elemSize;

	    const char *p;

	    string1 = Tcl_GetStringFromObj(objPtr, &length1);
	    end = string1 + length1;
	    failat = -1;
	    for (p=string1, lenRemain=length1; lenRemain > 0;
		    p=nextElem, lenRemain=end-nextElem) {
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
	    /*
	     * Need to figure out where the list parsing failed, which is
	     * fairly expensive. This is adapted from the core of
	     * SetListFromAny().
	     */

	    const char *elemStart, *nextElem;
	    size_t lenRemain;
	    size_t elemSize;
	    const char *p;

	    string1 = Tcl_GetStringFromObj(objPtr, &length1);
	    end = string1 + length1;
	    failat = -1;
	    for (p=string1, lenRemain=length1; lenRemain > 0;
		    p=nextElem, lenRemain=end-nextElem) {







|
|







1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
	    /*
	     * Need to figure out where the list parsing failed, which is
	     * fairly expensive. This is adapted from the core of
	     * SetListFromAny().
	     */

	    const char *elemStart, *nextElem;
	    Tcl_Size lenRemain;
	    Tcl_Size elemSize;
	    const char *p;

	    string1 = Tcl_GetStringFromObj(objPtr, &length1);
	    end = string1 + length1;
	    failat = -1;
	    for (p=string1, lenRemain=length1; lenRemain > 0;
		    p=nextElem, lenRemain=end-nextElem) {
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
static int
StringMapCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t length1, length2,  mapElemc, index;
    int nocase = 0, mapWithDict = 0, copySource = 0;
    Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
    Tcl_UniChar *ustring1, *ustring2, *p, *end;
    int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, size_t);

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");







|







1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
static int
StringMapCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size length1, length2,  mapElemc, index;
    int nocase = 0, mapWithDict = 0, copySource = 0;
    Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
    Tcl_UniChar *ustring1, *ustring2, *p, *end;
    int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, size_t);

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
    /*
     * This test is tricky, but has to be that way or you get other strange
     * inconsistencies (see test string-10.20.1 for illustration why!)
     */

    if (!TclHasStringRep(objv[objc-2])
	    && TclHasInternalRep(objv[objc-2], &tclDictType)) {
	size_t i;
	int done;
	Tcl_DictSearch search;

	/*
	 * We know the type exactly, so all dict operations will succeed for
	 * sure. This shortens this code quite a bit.
	 */







|







1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
    /*
     * This test is tricky, but has to be that way or you get other strange
     * inconsistencies (see test string-10.20.1 for illustration why!)
     */

    if (!TclHasStringRep(objv[objc-2])
	    && TclHasInternalRep(objv[objc-2], &tclDictType)) {
	Tcl_Size i;
	int done;
	Tcl_DictSearch search;

	/*
	 * We know the type exactly, so all dict operations will succeed for
	 * sure. This shortens this code quite a bit.
	 */
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
	Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
		mapElemv+1, &done);
	for (index=2 ; index<mapElemc ; index+=2) {
	    Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
	}
	Tcl_DictObjDone(&search);
    } else {
	size_t i;
	if (TclListObjGetElementsM(interp, objv[objc-2], &i,
		&mapElemv) != TCL_OK) {
	    return TCL_ERROR;
	}
	mapElemc = i;
	if (mapElemc == 0) {
	    /*
	     * empty charMap, just return whatever string was given.
	     */

	    Tcl_SetObjResult(interp, objv[objc-1]);
	    return TCL_OK;
	} else if (mapElemc & 1) {
	    /*
	     * The charMap must be an even number of key/value items.
	     */

	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("char map list unbalanced", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP",
		    "UNBALANCED", NULL);
	    return TCL_ERROR;
	}
    }

    /*







|


















|







2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
	Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
		mapElemv+1, &done);
	for (index=2 ; index<mapElemc ; index+=2) {
	    Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
	}
	Tcl_DictObjDone(&search);
    } else {
	Tcl_Size i;
	if (TclListObjGetElementsM(interp, objv[objc-2], &i,
		&mapElemv) != TCL_OK) {
	    return TCL_ERROR;
	}
	mapElemc = i;
	if (mapElemc == 0) {
	    /*
	     * empty charMap, just return whatever string was given.
	     */

	    Tcl_SetObjResult(interp, objv[objc-1]);
	    return TCL_OK;
	} else if (mapElemc & 1) {
	    /*
	     * The charMap must be an even number of key/value items.
	     */

	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("char map list unbalanced", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP",
		    "UNBALANCED", NULL);
	    return TCL_ERROR;
	}
    }

    /*
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
	/*
	 * Special case for one map pair which avoids the extra for loop and
	 * extra calls to get Unicode data. The algorithm is otherwise
	 * identical to the multi-pair case. This will be >30% faster on
	 * larger strings.
	 */

	size_t mapLen;
	int u2lc;
	Tcl_UniChar *mapString;

	ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
	p = ustring1;
	if ((length2 > length1) || (length2 == 0)) {
	    /*







|







2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
	/*
	 * Special case for one map pair which avoids the extra for loop and
	 * extra calls to get Unicode data. The algorithm is otherwise
	 * identical to the multi-pair case. This will be >30% faster on
	 * larger strings.
	 */

	Tcl_Size mapLen;
	int u2lc;
	Tcl_UniChar *mapString;

	ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
	p = ustring1;
	if ((length2 > length1) || (length2 == 0)) {
	    /*
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146

		    Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
		}
	    }
	}
    } else {
	Tcl_UniChar **mapStrings;
	size_t *mapLens;
	int *u2lc = 0;

	/*
	 * Precompute pointers to the Unicode string and length. This saves us
	 * repeated function calls later, significantly speeding up the
	 * algorithm. We only need the lowercase first char in the nocase
	 * case.
	 */

	mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*sizeof(Tcl_UniChar *)*2);
	mapLens = (size_t *)TclStackAlloc(interp, mapElemc * sizeof(size_t) * 2);
	if (nocase) {
	    u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int));
	}
	for (index = 0; index < mapElemc; index++) {
	    mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
		    mapLens+index);
	    if (nocase && ((index % 2) == 0)) {







|










|







2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145

		    Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
		}
	    }
	}
    } else {
	Tcl_UniChar **mapStrings;
	Tcl_Size *mapLens;
	int *u2lc = 0;

	/*
	 * Precompute pointers to the Unicode string and length. This saves us
	 * repeated function calls later, significantly speeding up the
	 * algorithm. We only need the lowercase first char in the nocase
	 * case.
	 */

	mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*sizeof(Tcl_UniChar *)*2);
	mapLens = (Tcl_Size *)TclStackAlloc(interp, mapElemc * sizeof(Tcl_Size) * 2);
	if (nocase) {
	    u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int));
	}
	for (index = 0; index < mapElemc; index++) {
	    mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
		    mapLens+index);
	    if (nocase && ((index % 2) == 0)) {
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
		 */

		ustring2 = mapStrings[index];
		length2 = mapLens[index];
		if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase &&
			(Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) &&
			/* Restrict max compare length. */
			((size_t)(end-ustring1) >= length2) && ((length2 == 1) ||
			!strCmpFn(ustring2, ustring1, length2))) {
		    if (p != ustring1) {
			/*
			 * Put the skipped chars onto the result first.
			 */

			Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);







|







2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
		 */

		ustring2 = mapStrings[index];
		length2 = mapLens[index];
		if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase &&
			(Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) &&
			/* Restrict max compare length. */
			((end-ustring1) >= length2) && ((length2 == 1) ||
			!strCmpFn(ustring2, ustring1, length2))) {
		    if (p != ustring1) {
			/*
			 * Put the skipped chars onto the result first.
			 */

			Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
	return TCL_ERROR;
    }

    if (objc == 4) {
	size_t length;
	const char *string = Tcl_GetStringFromObj(objv[1], &length);

	if ((length > 1) &&
	    strncmp(string, "-nocase", length) == 0) {
	    nocase = TCL_MATCH_NOCASE;
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(







|







2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
	return TCL_ERROR;
    }

    if (objc == 4) {
	Tcl_Size length;
	const char *string = Tcl_GetStringFromObj(objv[1], &length);

	if ((length > 1) &&
	    strncmp(string, "-nocase", length) == 0) {
	    nocase = TCL_MATCH_NOCASE;
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
static int
StringRangeCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t first, last, end;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string first last");
	return TCL_ERROR;
    }

    /*
     * Get the length in actual characters; Then reduce it by one because
     * 'end' refers to the last character, not one past it.
     */

    end = Tcl_GetCharLength(objv[1]) - 1;

    if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
	    TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
	return TCL_ERROR;
    }

    if (last != TCL_INDEX_NONE) {
	Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|


















|







2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
static int
StringRangeCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size first, last, end;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string first last");
	return TCL_ERROR;
    }

    /*
     * Get the length in actual characters; Then reduce it by one because
     * 'end' refers to the last character, not one past it.
     */

    end = Tcl_GetCharLength(objv[1]) - 1;

    if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
	    TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
	return TCL_ERROR;
    }

    if (last >= 0) {
	Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
static int
StringRplcCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	size_t first, last, end;

    if (objc < 4 || objc > 5) {
	Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
	return TCL_ERROR;
    }

    end = Tcl_GetCharLength(objv[1]) - 1;

    if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
	    TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * The following test screens out most empty substrings as candidates for
     * replacement. When they are detected, no replacement is done, and the
     * result is the original string.
     */

    if ((last == TCL_INDEX_NONE) ||	/* Range ends before start of string */
	    (first + 1 > end + 1) ||	/* Range begins after end of string */
	    (last + 1 < first + 1)) {	/* Range begins after it starts */
	/*
	 * BUT!!! when (end < 0) -- an empty original string -- we can
	 * have (first <= end < 0 <= last) and an empty string is permitted
	 * to be replaced.
	 */

	Tcl_SetObjResult(interp, objv[1]);
    } else {
	Tcl_Obj *resultPtr;

	if (first == TCL_INDEX_NONE) {
	    first = TCL_INDEX_START;
	}
	if (last + 1 > end + 1) {
	    last = end;
	}

	resultPtr = TclStringReplace(interp, objv[1], first,
		last + 1 - first, (objc == 5) ? objv[4] : NULL,
		TCL_STRING_IN_PLACE);








|



















|
|
|










|


|







2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
static int
StringRplcCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size first, last, end;

    if (objc < 4 || objc > 5) {
	Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
	return TCL_ERROR;
    }

    end = Tcl_GetCharLength(objv[1]) - 1;

    if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
	    TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * The following test screens out most empty substrings as candidates for
     * replacement. When they are detected, no replacement is done, and the
     * result is the original string.
     */

    if ((last < 0) ||	/* Range ends before start of string */
	    (first > end) ||	/* Range begins after end of string */
	    (last < first)) {	/* Range begins after it starts */
	/*
	 * BUT!!! when (end < 0) -- an empty original string -- we can
	 * have (first <= end < 0 <= last) and an empty string is permitted
	 * to be replaced.
	 */

	Tcl_SetObjResult(interp, objv[1]);
    } else {
	Tcl_Obj *resultPtr;

	if (first < 0) {
	    first = TCL_INDEX_START;
	}
	if (last > end) {
	    last = end;
	}

	resultPtr = TclStringReplace(interp, objv[1], first,
		last + 1 - first, (objc == 5) ? objv[4] : NULL,
		TCL_STRING_IN_PLACE);

2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int ch;
    const Tcl_UniChar *p, *string;
    size_t cur, index, length;
    Tcl_Obj *obj;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string index");
	return TCL_ERROR;
    }

    string = Tcl_GetUnicodeFromObj(objv[1], &length);
    if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (index + 1 >= length + 1) {
	index = length - 1;
    }
    cur = 0;
    if (index + 1 > 1) {
	p = &string[index];

	(void)TclUniCharToUCS4(p, &ch);
	for (cur = index; cur != TCL_INDEX_NONE; cur--) {
	    int delta = 0;
	    const Tcl_UniChar *next;








|











|



|







2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int ch;
    const Tcl_UniChar *p, *string;
    Tcl_Size cur, index, length;
    Tcl_Obj *obj;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string index");
	return TCL_ERROR;
    }

    string = Tcl_GetUnicodeFromObj(objv[1], &length);
    if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (index >= length) {
	index = length - 1;
    }
    cur = 0;
    if (index > 0) {
	p = &string[index];

	(void)TclUniCharToUCS4(p, &ch);
	for (cur = index; cur != TCL_INDEX_NONE; cur--) {
	    int delta = 0;
	    const Tcl_UniChar *next;

2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int ch;
    const Tcl_UniChar *p, *end, *string;
    size_t cur, index, length;
    Tcl_Obj *obj;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string index");
	return TCL_ERROR;
    }

    string = Tcl_GetUnicodeFromObj(objv[1], &length);
    if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (index == TCL_INDEX_NONE) {
	index = TCL_INDEX_START;
    }
    if (index + 1 <= length + 1) {
	p = &string[index];
	end = string+length;
	for (cur = index; p < end; cur++) {
	    p += TclUniCharToUCS4(p, &ch);
	    if (!Tcl_UniCharIsWordChar(ch)) {
		break;
	    }







|











|
|

|







2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int ch;
    const Tcl_UniChar *p, *end, *string;
    Tcl_Size cur, index, length;
    Tcl_Obj *obj;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string index");
	return TCL_ERROR;
    }

    string = Tcl_GetUnicodeFromObj(objv[1], &length);
    if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (index < 0) {
	index = 0;
    }
    if (index < length) {
	p = &string[index];
	end = string+length;
	for (cur = index; p < end; cur++) {
	    p += TclUniCharToUCS4(p, &ch);
	    if (!Tcl_UniCharIsWordChar(ch)) {
		break;
	    }
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
     * Remember to keep code here in some sync with the byte-compiled versions
     * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
     * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
     */

    const char *string2;
    int i, match, nocase = 0, reqlength = -1;
    size_t length;

    if (objc < 3 || objc > 6) {
    str_cmp_args:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nocase? ?-length int? string1 string2");
	return TCL_ERROR;
    }







|







2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
     * Remember to keep code here in some sync with the byte-compiled versions
     * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
     * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
     */

    const char *string2;
    int i, match, nocase = 0, reqlength = -1;
    Tcl_Size length;

    if (objc < 3 || objc > 6) {
    str_cmp_args:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nocase? ?-length int? string1 string2");
	return TCL_ERROR;
    }
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[],	/* Argument objects. */
    int *nocase,
    int *reqlength)
{
    int i;
    size_t length;
    const char *string;

    *reqlength = -1;
    *nocase = 0;
    if (objc < 3 || objc > 6) {
    str_cmp_args:
	Tcl_WrongNumArgs(interp, 1, objv,







|







2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[],	/* Argument objects. */
    int *nocase,
    int *reqlength)
{
    int i;
    Tcl_Size length;
    const char *string;

    *reqlength = -1;
    *nocase = 0;
    if (objc < 3 || objc > 6) {
    str_cmp_args:
	Tcl_WrongNumArgs(interp, 1, objv,
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
static int
StringLowerCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t length1, length2;
    const char *string1;
    char *string2;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
	return TCL_ERROR;
    }

    string1 = Tcl_GetStringFromObj(objv[1], &length1);

    if (objc == 2) {
	Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);

	length1 = Tcl_UtfToLower(TclGetString(resultPtr));
	Tcl_SetObjLength(resultPtr, length1);
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	size_t first, last;
	const char *start, *end;
	Tcl_Obj *resultPtr;

	length1 = Tcl_NumUtfChars(string1, length1) - 1;
	if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (first == TCL_INDEX_NONE) {
	    first = 0;
	}
	last = first;

	if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
		&last) != TCL_OK)) {
	    return TCL_ERROR;
	}

	if (last + 1 >= length1 + 1) {
	    last = length1;
	}
	if (last + 1 < first + 1) {
	    Tcl_SetObjResult(interp, objv[1]);
	    return TCL_OK;
	}

	string1 = Tcl_GetStringFromObj(objv[1], &length1);
	start = Tcl_UtfAtIndex(string1, first);
	end = Tcl_UtfAtIndex(start, last - first + 1);
	resultPtr = Tcl_NewStringObj(string1, end - string1);
	string2 = TclGetString(resultPtr) + (start - string1);

	length2 = Tcl_UtfToLower(string2);
	Tcl_SetObjLength(resultPtr, length2 + (start - string1));

	Tcl_AppendToObj(resultPtr, end, TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, resultPtr);
    }

    return TCL_OK;
}

/*







|

















|







|









|


|













|







2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
static int
StringLowerCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size length1, length2;
    const char *string1;
    char *string2;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
	return TCL_ERROR;
    }

    string1 = Tcl_GetStringFromObj(objv[1], &length1);

    if (objc == 2) {
	Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);

	length1 = Tcl_UtfToLower(TclGetString(resultPtr));
	Tcl_SetObjLength(resultPtr, length1);
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	Tcl_Size first, last;
	const char *start, *end;
	Tcl_Obj *resultPtr;

	length1 = Tcl_NumUtfChars(string1, length1) - 1;
	if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (first < 0) {
	    first = 0;
	}
	last = first;

	if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
		&last) != TCL_OK)) {
	    return TCL_ERROR;
	}

	if (last >= length1) {
	    last = length1;
	}
	if (last < first) {
	    Tcl_SetObjResult(interp, objv[1]);
	    return TCL_OK;
	}

	string1 = Tcl_GetStringFromObj(objv[1], &length1);
	start = Tcl_UtfAtIndex(string1, first);
	end = Tcl_UtfAtIndex(start, last - first + 1);
	resultPtr = Tcl_NewStringObj(string1, end - string1);
	string2 = TclGetString(resultPtr) + (start - string1);

	length2 = Tcl_UtfToLower(string2);
	Tcl_SetObjLength(resultPtr, length2 + (start - string1));

	Tcl_AppendToObj(resultPtr, end, -1);
	Tcl_SetObjResult(interp, resultPtr);
    }

    return TCL_OK;
}

/*
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
static int
StringUpperCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t length1, length2;
    const char *string1;
    char *string2;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
	return TCL_ERROR;
    }

    string1 = Tcl_GetStringFromObj(objv[1], &length1);

    if (objc == 2) {
	Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);

	length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
	Tcl_SetObjLength(resultPtr, length1);
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	size_t first, last;
	const char *start, *end;
	Tcl_Obj *resultPtr;

	length1 = Tcl_NumUtfChars(string1, length1) - 1;
	if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (first == TCL_INDEX_NONE) {
	    first = TCL_INDEX_START;
	}
	last = first;

	if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
		&last) != TCL_OK)) {
	    return TCL_ERROR;
	}

	if (last + 1 >= length1 + 1) {
	    last = length1;
	}
	if (last + 1 < first + 1) {
	    Tcl_SetObjResult(interp, objv[1]);
	    return TCL_OK;
	}

	string1 = Tcl_GetStringFromObj(objv[1], &length1);
	start = Tcl_UtfAtIndex(string1, first);
	end = Tcl_UtfAtIndex(start, last - first + 1);
	resultPtr = Tcl_NewStringObj(string1, end - string1);
	string2 = TclGetString(resultPtr) + (start - string1);

	length2 = Tcl_UtfToUpper(string2);
	Tcl_SetObjLength(resultPtr, length2 + (start - string1));

	Tcl_AppendToObj(resultPtr, end, TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, resultPtr);
    }

    return TCL_OK;
}

/*







|

















|







|
|








|


|













|







2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
static int
StringUpperCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size length1, length2;
    const char *string1;
    char *string2;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
	return TCL_ERROR;
    }

    string1 = Tcl_GetStringFromObj(objv[1], &length1);

    if (objc == 2) {
	Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);

	length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
	Tcl_SetObjLength(resultPtr, length1);
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	Tcl_Size first, last;
	const char *start, *end;
	Tcl_Obj *resultPtr;

	length1 = Tcl_NumUtfChars(string1, length1) - 1;
	if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (first < 0) {
	    first = 0;
	}
	last = first;

	if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
		&last) != TCL_OK)) {
	    return TCL_ERROR;
	}

	if (last >= length1) {
	    last = length1;
	}
	if (last < first) {
	    Tcl_SetObjResult(interp, objv[1]);
	    return TCL_OK;
	}

	string1 = Tcl_GetStringFromObj(objv[1], &length1);
	start = Tcl_UtfAtIndex(string1, first);
	end = Tcl_UtfAtIndex(start, last - first + 1);
	resultPtr = Tcl_NewStringObj(string1, end - string1);
	string2 = TclGetString(resultPtr) + (start - string1);

	length2 = Tcl_UtfToUpper(string2);
	Tcl_SetObjLength(resultPtr, length2 + (start - string1));

	Tcl_AppendToObj(resultPtr, end, -1);
	Tcl_SetObjResult(interp, resultPtr);
    }

    return TCL_OK;
}

/*
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
static int
StringTitleCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t length1, length2;
    const char *string1;
    char *string2;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
	return TCL_ERROR;
    }

    string1 = Tcl_GetStringFromObj(objv[1], &length1);

    if (objc == 2) {
	Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);

	length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
	Tcl_SetObjLength(resultPtr, length1);
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	size_t first, last;
	const char *start, *end;
	Tcl_Obj *resultPtr;

	length1 = Tcl_NumUtfChars(string1, length1) - 1;
	if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (first == TCL_INDEX_NONE) {
	    first = TCL_INDEX_START;
	}
	last = first;

	if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
		&last) != TCL_OK)) {
	    return TCL_ERROR;
	}

	if (last + 1 >= length1 + 1) {
	    last = length1;
	}
	if (last + 1 < first + 1) {
	    Tcl_SetObjResult(interp, objv[1]);
	    return TCL_OK;
	}

	string1 = Tcl_GetStringFromObj(objv[1], &length1);
	start = Tcl_UtfAtIndex(string1, first);
	end = Tcl_UtfAtIndex(start, last - first + 1);
	resultPtr = Tcl_NewStringObj(string1, end - string1);
	string2 = TclGetString(resultPtr) + (start - string1);

	length2 = Tcl_UtfToTitle(string2);
	Tcl_SetObjLength(resultPtr, length2 + (start - string1));

	Tcl_AppendToObj(resultPtr, end, TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, resultPtr);
    }

    return TCL_OK;
}

/*







|

















|







|
|








|


|













|







3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
static int
StringTitleCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size length1, length2;
    const char *string1;
    char *string2;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
	return TCL_ERROR;
    }

    string1 = Tcl_GetStringFromObj(objv[1], &length1);

    if (objc == 2) {
	Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);

	length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
	Tcl_SetObjLength(resultPtr, length1);
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	Tcl_Size first, last;
	const char *start, *end;
	Tcl_Obj *resultPtr;

	length1 = Tcl_NumUtfChars(string1, length1) - 1;
	if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (first < 0) {
	    first = 0;
	}
	last = first;

	if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
		&last) != TCL_OK)) {
	    return TCL_ERROR;
	}

	if (last >= length1) {
	    last = length1;
	}
	if (last < first) {
	    Tcl_SetObjResult(interp, objv[1]);
	    return TCL_OK;
	}

	string1 = Tcl_GetStringFromObj(objv[1], &length1);
	start = Tcl_UtfAtIndex(string1, first);
	end = Tcl_UtfAtIndex(start, last - first + 1);
	resultPtr = Tcl_NewStringObj(string1, end - string1);
	string2 = TclGetString(resultPtr) + (start - string1);

	length2 = Tcl_UtfToTitle(string2);
	Tcl_SetObjLength(resultPtr, length2 + (start - string1));

	Tcl_AppendToObj(resultPtr, end, -1);
	Tcl_SetObjResult(interp, resultPtr);
    }

    return TCL_OK;
}

/*
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
StringTrimCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *string2;
    size_t triml, trimr, length1, length2;

    if (objc == 3) {
	string2 = Tcl_GetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = tclDefaultTrimSet;
	length2 = strlen(tclDefaultTrimSet);
    } else {







|







3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
StringTrimCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *string2;
    Tcl_Size triml, trimr, length1, length2;

    if (objc == 3) {
	string2 = Tcl_GetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = tclDefaultTrimSet;
	length2 = strlen(tclDefaultTrimSet);
    } else {
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *string2;
    int trim;
    size_t length1, length2;

    if (objc == 3) {
	string2 = Tcl_GetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = tclDefaultTrimSet;
	length2 = strlen(tclDefaultTrimSet);
    } else {







|







3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *string2;
    int trim;
    Tcl_Size length1, length2;

    if (objc == 3) {
	string2 = Tcl_GetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = tclDefaultTrimSet;
	length2 = strlen(tclDefaultTrimSet);
    } else {
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *string2;
    int trim;
    size_t length1, length2;

    if (objc == 3) {
	string2 = Tcl_GetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = tclDefaultTrimSet;
	length2 = strlen(tclDefaultTrimSet);
    } else {







|







3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *string1, *string2;
    int trim;
    Tcl_Size length1, length2;

    if (objc == 3) {
	string2 = Tcl_GetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = tclDefaultTrimSet;
	length2 = strlen(tclDefaultTrimSet);
    } else {
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
 *
 *----------------------------------------------------------------------
 */

int
TclSubstOptions(
    Tcl_Interp *interp,
    size_t numOpts1,
    Tcl_Obj *const opts[],
    int *flagPtr)
{
    static const char *const substOptions[] = {
	"-nobackslashes", "-nocommands", "-novariables", NULL
    };
    enum {
	SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
    };
    int i, flags = TCL_SUBST_ALL;
    int numOpts = numOpts1;

    for (i = 0; i < numOpts; i++) {
	int optionIndex;

	if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;







|










<







3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340

3341
3342
3343
3344
3345
3346
3347
 *
 *----------------------------------------------------------------------
 */

int
TclSubstOptions(
    Tcl_Interp *interp,
    Tcl_Size numOpts,
    Tcl_Obj *const opts[],
    int *flagPtr)
{
    static const char *const substOptions[] = {
	"-nobackslashes", "-nocommands", "-novariables", NULL
    };
    enum {
	SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
    };
    int i, flags = TCL_SUBST_ALL;


    for (i = 0; i < numOpts; i++) {
	int optionIndex;

	if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, mode, foundmode, splitObjs, numMatchesSaved;
    int noCase;
    size_t patternLength, j;
    const char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *const *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;
    Interp *iPtr = (Interp *) interp;
    int pc = 0;
    int bidx = 0;		/* Index of body argument. */







|







3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, mode, foundmode, splitObjs, numMatchesSaved;
    int noCase;
    Tcl_Size patternLength, j;
    const char *pattern;
    Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
    Tcl_Obj *const *savedObjv = objv;
    Tcl_RegExp regExpr = NULL;
    Interp *iPtr = (Interp *) interp;
    int pc = 0;
    int bidx = 0;		/* Index of body argument. */
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
     * the same data for the list word itself. The cmdFramePtr line
     * information is manipulated directly.
     */

    splitObjs = 0;
    if (objc == 1) {
	Tcl_Obj **listv;
	size_t listc;

	blist = objv[0];
	if (TclListObjLengthM(interp, objv[0], &listc) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*







|







3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
     * the same data for the list word itself. The cmdFramePtr line
     * information is manipulated directly.
     */

    splitObjs = 0;
    if (objc == 1) {
	Tcl_Obj **listv;
	Tcl_Size listc;

	blist = objv[0];
	if (TclListObjLengthM(interp, objv[0], &listc) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
     * Complain if there is an odd number of words in the list of patterns and
     * bodies.
     */

    if (objc % 2) {
	Tcl_ResetResult(interp);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"extra switch pattern with no body", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
		NULL);

	/*
	 * Check if this can be due to a badly placed comment in the switch
	 * block.
	 *
	 * The following is an heuristic to detect the infamous "comment in
	 * switch" error: just check if a pattern begins with '#'.
	 */

	if (splitObjs) {
	    for (i=0 ; i<objc ; i+=2) {
		if (TclGetString(objv[i])[0] == '#') {
		    Tcl_AppendToObj(Tcl_GetObjResult(interp),
			    ", this may be due to a comment incorrectly"
			    " placed outside of a switch body - see the"
			    " \"switch\" documentation", TCL_INDEX_NONE);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
			    "BADARM", "COMMENT?", NULL);
		    break;
		}
	    }
	}








|

















|







3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
     * Complain if there is an odd number of words in the list of patterns and
     * bodies.
     */

    if (objc % 2) {
	Tcl_ResetResult(interp);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"extra switch pattern with no body", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
		NULL);

	/*
	 * Check if this can be due to a badly placed comment in the switch
	 * block.
	 *
	 * The following is an heuristic to detect the infamous "comment in
	 * switch" error: just check if a pattern begins with '#'.
	 */

	if (splitObjs) {
	    for (i=0 ; i<objc ; i+=2) {
		if (TclGetString(objv[i])[0] == '#') {
		    Tcl_AppendToObj(Tcl_GetObjResult(interp),
			    ", this may be due to a comment incorrectly"
			    " placed outside of a switch body - see the"
			    " \"switch\" documentation", -1);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
			    "BADARM", "COMMENT?", NULL);
		    break;
		}
	    }
	}

3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
	    TclNewObj(indicesObj);
	}

	for (j=0 ; j<=info.nsubs ; j++) {
	    if (indexVarObj != NULL) {
		Tcl_Obj *rangeObjAry[2];

		if (info.matches[j].end + 1 > 1) {
		    TclNewIndexObj(rangeObjAry[0], info.matches[j].start);
		    TclNewIndexObj(rangeObjAry[1], info.matches[j].end-1);
		} else {
		    TclNewIntObj(rangeObjAry[1], -1);
		    rangeObjAry[0] = rangeObjAry[1];
		}

		/*
		 * Never fails; the object is always clean at this point.
		 */

		Tcl_ListObjAppendElement(NULL, indicesObj,
			Tcl_NewListObj(2, rangeObjAry));
	    }

	    if (matchVarObj != NULL) {
		Tcl_Obj *substringObj;

		if (info.matches[j].end + 1 > 1) {
		    substringObj = Tcl_GetRange(stringObj,
			    info.matches[j].start, info.matches[j].end-1);
		} else {
		    TclNewObj(substringObj);
		}

		/*







|


















|







3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
	    TclNewObj(indicesObj);
	}

	for (j=0 ; j<=info.nsubs ; j++) {
	    if (indexVarObj != NULL) {
		Tcl_Obj *rangeObjAry[2];

		if (info.matches[j].end > 0) {
		    TclNewIndexObj(rangeObjAry[0], info.matches[j].start);
		    TclNewIndexObj(rangeObjAry[1], info.matches[j].end-1);
		} else {
		    TclNewIntObj(rangeObjAry[1], -1);
		    rangeObjAry[0] = rangeObjAry[1];
		}

		/*
		 * Never fails; the object is always clean at this point.
		 */

		Tcl_ListObjAppendElement(NULL, indicesObj,
			Tcl_NewListObj(2, rangeObjAry));
	    }

	    if (matchVarObj != NULL) {
		Tcl_Obj *substringObj;

		if (info.matches[j].end > 0) {
		    substringObj = Tcl_GetRange(stringObj,
			    info.matches[j].start, info.matches[j].end-1);
		} else {
		    TclNewObj(substringObj);
		}

		/*
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
	    for (k=0; k < objc; k++) {
		ctxPtr->line[k] = -1;
	    }
	}
    }

    for (j = i + 1; ; j += 2) {
	if (j >= (size_t)objc) {
	    /*
	     * This shouldn't happen since we've checked that the last body is
	     * not a continuation...
	     */

	    Tcl_Panic("fall-out when searching for body to match pattern");
	}







|







3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
	    for (k=0; k < objc; k++) {
		ctxPtr->line[k] = -1;
	    }
	}
    }

    for (j = i + 1; ; j += 2) {
	if (j >= objc) {
	    /*
	     * This shouldn't happen since we've checked that the last body is
	     * not a continuation...
	     */

	    Tcl_Panic("fall-out when searching for body to match pattern");
	}
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
{
    /* Unpack the preserved data */

    int splitObjs = PTR2INT(data[0]);
    CmdFrame *ctxPtr = (CmdFrame *)data[1];
    int pc = PTR2INT(data[2]);
    const char *pattern = (const char *)data[3];
    size_t patternLength = strlen(pattern);

    /*
     * Clean up TIP 280 context information
     */

    if (splitObjs) {
	Tcl_Free(ctxPtr->line);







|







3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
{
    /* Unpack the preserved data */

    int splitObjs = PTR2INT(data[0]);
    CmdFrame *ctxPtr = (CmdFrame *)data[1];
    int pc = PTR2INT(data[2]);
    const char *pattern = (const char *)data[3];
    Tcl_Size patternLength = strlen(pattern);

    /*
     * Clean up TIP 280 context information
     */

    if (splitObjs) {
	Tcl_Free(ctxPtr->line);
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
    }

    /*
     * Generate an error message if necessary.
     */

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

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







|




|







3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
    }

    /*
     * Generate an error message if necessary.
     */

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

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"%.*s%s\" arm line %d)",
		(int) (overflow ? limit : patternLength), pattern,
		(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
    }
    TclStackFree(interp, ctxPtr);
    return result;
}

/*
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
Tcl_ThrowObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *options;
    size_t len;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "type message");
	return TCL_ERROR;
    }

    /*
     * The type must be a list of at least length 1.
     */

    if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
	return TCL_ERROR;
    } else if (len < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"type must be non-empty list", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
		NULL);
	return TCL_ERROR;
    }

    /*
     * Now prepare the result options dictionary. We use the list API as it is







|














|







3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
Tcl_ThrowObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *options;
    Tcl_Size len;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "type message");
	return TCL_ERROR;
    }

    /*
     * The type must be a list of at least length 1.
     */

    if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
	return TCL_ERROR;
    } else if (len < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"type must be non-empty list", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
		NULL);
	return TCL_ERROR;
    }

    /*
     * Now prepare the result options dictionary. We use the list API as it is
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
    int i, bodyShared, haveHandlers, code;
    size_t dummy;
    static const char *const handlerNames[] = {
	"finally", "on", "trap", NULL
    };
    enum Handlers {
	TryFinally, TryOn, TryTrap
    };








|







4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
    int i, bodyShared, haveHandlers, code;
    Tcl_Size dummy;
    static const char *const handlerNames[] = {
	"finally", "on", "trap", NULL
    };
    enum Handlers {
	TryFinally, TryOn, TryTrap
    };

4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
	    Tcl_DecrRefCount(handlersObj);
	    return TCL_ERROR;
	}
	switch (type) {
	case TryFinally:	/* finally script */
	    if (i < objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"finally clause must be last", TCL_INDEX_NONE));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
			"NONTERMINAL", NULL);
		return TCL_ERROR;
	    } else if (i == objc-1) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong # args to finally clause: must be"
			" \"... finally script\"", TCL_INDEX_NONE));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
			"ARGUMENT", NULL);
		return TCL_ERROR;
	    }
	    finallyObj = objv[++i];
	    break;

	case TryOn:		/* on code variableList script */
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong # args to on clause: must be \"... on code"
			" variableList script\"", TCL_INDEX_NONE));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
			"ARGUMENT", NULL);
		return TCL_ERROR;
	    }
	    if (TclGetCompletionCodeFromObj(interp, objv[i+1],
		    &code) != TCL_OK) {







|







|












|







4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
	    Tcl_DecrRefCount(handlersObj);
	    return TCL_ERROR;
	}
	switch (type) {
	case TryFinally:	/* finally script */
	    if (i < objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"finally clause must be last", -1));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
			"NONTERMINAL", NULL);
		return TCL_ERROR;
	    } else if (i == objc-1) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong # args to finally clause: must be"
			" \"... finally script\"", -1));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
			"ARGUMENT", NULL);
		return TCL_ERROR;
	    }
	    finallyObj = objv[++i];
	    break;

	case TryOn:		/* on code variableList script */
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong # args to on clause: must be \"... on code"
			" variableList script\"", -1));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
			"ARGUMENT", NULL);
		return TCL_ERROR;
	    }
	    if (TclGetCompletionCodeFromObj(interp, objv[i+1],
		    &code) != TCL_OK) {
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
	    haveHandlers = 1;
	    i += 3;
	    break;
	}
    }
    if (bodyShared) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"last non-finally clause must not have a body of \"-\"", TCL_INDEX_NONE));
	Tcl_DecrRefCount(handlersObj);
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
		NULL);
	return TCL_ERROR;
    }
    if (!haveHandlers) {
	Tcl_DecrRefCount(handlersObj);







|







4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
	    haveHandlers = 1;
	    i += 3;
	    break;
	}
    }
    if (bodyShared) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"last non-finally clause must not have a body of \"-\"", -1));
	Tcl_DecrRefCount(handlersObj);
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
		NULL);
	return TCL_ERROR;
    }
    if (!haveHandlers) {
	Tcl_DecrRefCount(handlersObj);
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
TryPostBody(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
    int code, objc;
    size_t i, numHandlers = 0;

    handlersObj = (Tcl_Obj *)data[0];
    finallyObj = (Tcl_Obj *)data[1];
    objv = (Tcl_Obj **)data[2];
    objc = PTR2INT(data[3]);

    cmdObj = objv[0];







|







4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
TryPostBody(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
    int code, objc;
    Tcl_Size i, numHandlers = 0;

    handlersObj = (Tcl_Obj *)data[0];
    finallyObj = (Tcl_Obj *)data[1];
    objv = (Tcl_Obj **)data[2];
    objc = PTR2INT(data[3]);

    cmdObj = objv[0];
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
    if (handlersObj != NULL) {
	int found = 0;
	Tcl_Obj **handlers, **info;

	TclListObjGetElementsM(NULL, handlersObj, &numHandlers, &handlers);
	for (i=0 ; i<numHandlers ; i++) {
	    Tcl_Obj *handlerBodyObj;
	    size_t numElems = 0;

	    TclListObjGetElementsM(NULL, handlers[i], &numElems, &info);
	    if (!found) {
		Tcl_GetIntFromObj(NULL, info[1], &code);
		if (code != result) {
		    continue;
		}

		/*
		 * When processing an error, we must also perform list-prefix
		 * matching of the errorcode list. However, if this was an
		 * 'on' handler, the list that we are matching against will be
		 * empty.
		 */

		if (code == TCL_ERROR) {
		    Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
		    size_t len1, len2, j;

		    TclNewLiteralStringObj(errorCodeName, "-errorcode");
		    Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
		    Tcl_DecrRefCount(errorCodeName);
		    TclListObjGetElementsM(NULL, info[2], &len1, &bits1);
		    if (TclListObjGetElementsM(NULL, errcode, &len2,
			    &bits2) != TCL_OK) {







|

















|







4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
    if (handlersObj != NULL) {
	int found = 0;
	Tcl_Obj **handlers, **info;

	TclListObjGetElementsM(NULL, handlersObj, &numHandlers, &handlers);
	for (i=0 ; i<numHandlers ; i++) {
	    Tcl_Obj *handlerBodyObj;
	    Tcl_Size numElems = 0;

	    TclListObjGetElementsM(NULL, handlers[i], &numElems, &info);
	    if (!found) {
		Tcl_GetIntFromObj(NULL, info[1], &code);
		if (code != result) {
		    continue;
		}

		/*
		 * When processing an error, we must also perform list-prefix
		 * matching of the errorcode list. However, if this was an
		 * 'on' handler, the list that we are matching against will be
		 * empty.
		 */

		if (code == TCL_ERROR) {
		    Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
		    Tcl_Size len1, len2, j;

		    TclNewLiteralStringObj(errorCodeName, "-errorcode");
		    Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
		    Tcl_DecrRefCount(errorCodeName);
		    TclListObjGetElementsM(NULL, info[2], &len1, &bits1);
		    if (TclListObjGetElementsM(NULL, errcode, &len2,
			    &bits2) != TCL_OK) {
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
 */

void
TclListLines(
    Tcl_Obj *listObj,		/* Pointer to obj holding a string with list
				 * structure. Assumed to be valid. Assumed to
				 * contain n elements. */
    size_t line,			/* Line the list as a whole starts on. */
    int n,			/* #elements in lines */
    int *lines,			/* Array of line numbers, to fill. */
    Tcl_Obj *const *elems)      /* The list elems as Tcl_Obj*, in need of
				 * derived continuation data */
{
    const char *listStr = TclGetString(listObj);
    const char *listHead = listStr;







|







5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
 */

void
TclListLines(
    Tcl_Obj *listObj,		/* Pointer to obj holding a string with list
				 * structure. Assumed to be valid. Assumed to
				 * contain n elements. */
    Tcl_Size line,		/* Line the list as a whole starts on. */
    int n,			/* #elements in lines */
    int *lines,			/* Array of line numbers, to fill. */
    Tcl_Obj *const *elems)      /* The list elems as Tcl_Obj*, in need of
				 * derived continuation data */
{
    const char *listStr = TclGetString(listObj);
    const char *listHead = listStr;

Changes to generic/tclCompCmds.c.

283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *varTokenPtr, *dataTokenPtr;
    int isScalar, localIndex, code = TCL_OK;
    int isDataLiteral, isDataValid, isDataEven;
    size_t len;
    int keyVar, valVar, infoIndex;
    int fwd, offsetBack, offsetFwd;
    Tcl_Obj *literalObj;
    ForeachInfo *infoPtr;

    if (parsePtr->numWords != 3) {
	return TCL_ERROR;







|







283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *varTokenPtr, *dataTokenPtr;
    int isScalar, localIndex, code = TCL_OK;
    int isDataLiteral, isDataValid, isDataEven;
    Tcl_Size len;
    int keyVar, valVar, infoIndex;
    int fwd, offsetBack, offsetFwd;
    Tcl_Obj *literalObj;
    ForeachInfo *infoPtr;

    if (parsePtr->numWords != 3) {
	return TCL_ERROR;
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
     */

    keyVar = AnonymousLocal(envPtr);
    valVar = AnonymousLocal(envPtr);

    infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
    infoPtr->numLists = 1;
    infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(size_t));
    infoPtr->varLists[0]->numVars = 2;
    infoPtr->varLists[0]->varIndexes[0] = keyVar;
    infoPtr->varLists[0]->varIndexes[1] = valVar;
    infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);

    /*
     * Start issuing instructions to write to the array.







|







389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
     */

    keyVar = AnonymousLocal(envPtr);
    valVar = AnonymousLocal(envPtr);

    infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
    infoPtr->numLists = 1;
    infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(Tcl_Size));
    infoPtr->varLists[0]->numVars = 2;
    infoPtr->varLists[0]->varIndexes[0] = keyVar;
    infoPtr->varLists[0]->varIndexes[1] = valVar;
    infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);

    /*
     * Start issuing instructions to write to the array.
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
	    break;
	}
	(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
    }
    if (listObj != NULL) {
	Tcl_Obj **objs;
	const char *bytes;
	size_t len, slen;

	TclListObjGetElementsM(NULL, listObj, &len, &objs);
	objPtr = Tcl_ConcatObj(len, objs);
	Tcl_DecrRefCount(listObj);
	bytes = Tcl_GetStringFromObj(objPtr, &slen);
	PushLiteral(envPtr, bytes, slen);
	Tcl_DecrRefCount(objPtr);







|







887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
	    break;
	}
	(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
    }
    if (listObj != NULL) {
	Tcl_Obj **objs;
	const char *bytes;
	Tcl_Size len, slen;

	TclListObjGetElementsM(NULL, listObj, &len, &objs);
	objPtr = Tcl_ConcatObj(len, objs);
	Tcl_DecrRefCount(listObj);
	bytes = Tcl_GetStringFromObj(objPtr, &slen);
	PushLiteral(envPtr, bytes, slen);
	Tcl_DecrRefCount(objPtr);
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088

    /*
     * Parse the increment amount, if present.
     */

    if (parsePtr->numWords == 4) {
	const char *word;
	size_t numBytes;
	int code;
	Tcl_Token *incrTokenPtr;
	Tcl_Obj *intObj;

	incrTokenPtr = TokenAfter(keyTokenPtr);
	if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);







|







1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088

    /*
     * Parse the increment amount, if present.
     */

    if (parsePtr->numWords == 4) {
	const char *word;
	Tcl_Size numBytes;
	int code;
	Tcl_Token *incrTokenPtr;
	Tcl_Obj *intObj;

	incrTokenPtr = TokenAfter(keyTokenPtr);
	if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
{
    DefineLineInformation;	/* TIP #280 */
    int worker;			/* Temp var for building the value in. */
    Tcl_Token *tokenPtr;
    Tcl_Obj *keyObj, *valueObj, *dictObj;
    const char *bytes;
    int i;
    size_t len;

    if ((parsePtr->numWords & 1) == 0) {
	return TCL_ERROR;
    }

    /*
     * See if we can build the value at compile time...







|







1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
{
    DefineLineInformation;	/* TIP #280 */
    int worker;			/* Temp var for building the value in. */
    Tcl_Token *tokenPtr;
    Tcl_Obj *keyObj, *valueObj, *dictObj;
    const char *bytes;
    int i;
    Tcl_Size len;

    if ((parsePtr->numWords & 1) == 0) {
	return TCL_ERROR;
    }

    /*
     * See if we can build the value at compile time...
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
				 * construct a new dictionary with the loop
				 * body result. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
    int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
    int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
    size_t numVars;
    int endTargetOffset;
    int collectVar = -1;	/* Index of temp var holding the result
				 * dict. */
    const char **argv;
    Tcl_DString buffer;

    /*







|







1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
				 * construct a new dictionary with the loop
				 * body result. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
    int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
    int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
    Tcl_Size numVars;
    int endTargetOffset;
    int collectVar = -1;	/* Index of temp var holding the result
				 * dict. */
    const char **argv;
    Tcl_DString buffer;

    /*
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
PrintDictUpdateInfo(
    void *clientData,
    Tcl_Obj *appendObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
    size_t i;

    for (i=0 ; i<duiPtr->length ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ", ", TCL_INDEX_NONE);
	}
	Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", duiPtr->varIndices[i]);
    }
}

static void
DisassembleDictUpdateInfo(
    void *clientData,
    Tcl_Obj *dictObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
    size_t i;
    Tcl_Obj *variables;

    TclNewObj(variables);
    for (i=0 ; i<duiPtr->length ; i++) {
	Tcl_ListObjAppendElement(NULL, variables,
		Tcl_NewWideIntObj(duiPtr->varIndices[i]));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", TCL_INDEX_NONE),
	    variables);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileErrorCmd --







|



|













|







|







2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
PrintDictUpdateInfo(
    void *clientData,
    Tcl_Obj *appendObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
    Tcl_Size i;

    for (i=0 ; i<duiPtr->length ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ", ", -1);
	}
	Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", duiPtr->varIndices[i]);
    }
}

static void
DisassembleDictUpdateInfo(
    void *clientData,
    Tcl_Obj *dictObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
    Tcl_Size i;
    Tcl_Obj *variables;

    TclNewObj(variables);
    for (i=0 ; i<duiPtr->length ; i++) {
	Tcl_ListObjAppendElement(NULL, variables,
		Tcl_NewWideIntObj(duiPtr->varIndices[i]));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
	    variables);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileErrorCmd --
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
    ForeachInfo *infoPtr=NULL;	/* Points to the structure describing this
				 * foreach command. Stored in a AuxData
				 * record in the ByteCode. */

    Tcl_Token *tokenPtr, *bodyTokenPtr;
    int jumpBackOffset, infoIndex, range;
    int numWords, numLists, i, code = TCL_OK;
    size_t j;
    Tcl_Obj *varListObj = NULL;

    /*
     * If the foreach command isn't in a procedure, don't compile it inline:
     * the payoff is too small.
     */








|







2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
    ForeachInfo *infoPtr=NULL;	/* Points to the structure describing this
				 * foreach command. Stored in a AuxData
				 * record in the ByteCode. */

    Tcl_Token *tokenPtr, *bodyTokenPtr;
    int jumpBackOffset, infoIndex, range;
    int numWords, numLists, i, code = TCL_OK;
    Tcl_Size j;
    Tcl_Obj *varListObj = NULL;

    /*
     * If the foreach command isn't in a procedure, don't compile it inline:
     * the payoff is too small.
     */

2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
     */

    TclNewObj(varListObj);
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr = TokenAfter(tokenPtr)) {
	ForeachVarList *varListPtr;
	size_t numVars;

	if (i%2 != 1) {
	    continue;
	}

	/*
	 * If the variable list is empty, we can enter an infinite loop when
	 * the interpreted version would not.  Take care to ensure this does
	 * not happen.  [Bug 1671138]
	 */

	if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
		TCL_OK != TclListObjLengthM(NULL, varListObj, &numVars) ||
		numVars == 0) {
	    code = TCL_ERROR;
	    goto done;
	}

	varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes)
		+ numVars * sizeof(size_t));
	varListPtr->numVars = numVars;
	infoPtr->varLists[i/2] = varListPtr;
	infoPtr->numLists++;

	for (j = 0;  j < numVars;  j++) {
	    Tcl_Obj *varNameObj;
	    const char *bytes;
	    int varIndex;
	    size_t length;


	    Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
	    bytes = Tcl_GetStringFromObj(varNameObj, &length);
	    varIndex = LocalScalar(bytes, length, envPtr);
	    if (varIndex < 0) {
		code = TCL_ERROR;







|



















|








|







2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
     */

    TclNewObj(varListObj);
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr = TokenAfter(tokenPtr)) {
	ForeachVarList *varListPtr;
	Tcl_Size numVars;

	if (i%2 != 1) {
	    continue;
	}

	/*
	 * If the variable list is empty, we can enter an infinite loop when
	 * the interpreted version would not.  Take care to ensure this does
	 * not happen.  [Bug 1671138]
	 */

	if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
		TCL_OK != TclListObjLengthM(NULL, varListObj, &numVars) ||
		numVars == 0) {
	    code = TCL_ERROR;
	    goto done;
	}

	varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes)
		+ numVars * sizeof(varListPtr->varIndexes[0]));
	varListPtr->numVars = numVars;
	infoPtr->varLists[i/2] = varListPtr;
	infoPtr->numLists++;

	for (j = 0;  j < numVars;  j++) {
	    Tcl_Obj *varNameObj;
	    const char *bytes;
	    int varIndex;
	    Tcl_Size length;


	    Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
	    bytes = Tcl_GetStringFromObj(varNameObj, &length);
	    varIndex = LocalScalar(bytes, length, envPtr);
	    if (varIndex < 0) {
		code = TCL_ERROR;
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071




































3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
    void *clientData,
    Tcl_Obj *appendObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    size_t i, j;

    Tcl_AppendToObj(appendObj, "data=[", TCL_INDEX_NONE);

    for (i=0 ; i<infoPtr->numLists ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ", ", TCL_INDEX_NONE);
	}
	Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
		(infoPtr->firstValueTemp + i));
    }
    Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%" TCL_Z_MODIFIER "u",
	    infoPtr->loopCtTemp);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ",", TCL_INDEX_NONE);
	}
	Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[",
		(infoPtr->firstValueTemp + i));
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    if (j) {
		Tcl_AppendToObj(appendObj, ", ", TCL_INDEX_NONE);
	    }
	    Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
		    varsPtr->varIndexes[j]);
	}
	Tcl_AppendToObj(appendObj, "]", TCL_INDEX_NONE);
    }
}

static void
PrintNewForeachInfo(
    void *clientData,
    Tcl_Obj *appendObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    size_t i, j;

    Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=",
	    infoPtr->loopCtTemp);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ",", TCL_INDEX_NONE);
	}
	Tcl_AppendToObj(appendObj, "[", TCL_INDEX_NONE);
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    if (j) {
		Tcl_AppendToObj(appendObj, ",", TCL_INDEX_NONE);
	    }
	    Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
		    varsPtr->varIndexes[j]);
	}
	Tcl_AppendToObj(appendObj, "]", TCL_INDEX_NONE);
    }
}

static void
DisassembleForeachInfo(
    void *clientData,
    Tcl_Obj *dictObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    size_t i, j;
    Tcl_Obj *objPtr, *innerPtr;

    /*
     * Data stores.
     */

    TclNewObj(objPtr);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewWideIntObj(infoPtr->firstValueTemp + i));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", TCL_INDEX_NONE), objPtr);

    /*
     * Loop counter.
     */

    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", TCL_INDEX_NONE),




































	   Tcl_NewWideIntObj(infoPtr->loopCtTemp));

    /*
     * Assignment targets.
     */

    TclNewObj(objPtr);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	TclNewObj(innerPtr);
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    Tcl_ListObjAppendElement(NULL, innerPtr,
		    Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
	}
	Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", TCL_INDEX_NONE), objPtr);
}

static void
DisassembleNewForeachInfo(
    void *clientData,
    Tcl_Obj *dictObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    size_t i, j;
    Tcl_Obj *objPtr, *innerPtr;

    /*
     * Jump offset.
     */

    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", TCL_INDEX_NONE),
	   Tcl_NewWideIntObj(infoPtr->loopCtTemp));

    /*
     * Assignment targets.
     */

    TclNewObj(objPtr);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	TclNewObj(innerPtr);
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    Tcl_ListObjAppendElement(NULL, innerPtr,
		    Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
	}
	Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", TCL_INDEX_NONE), objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileFormatCmd --
 *







|

|



|








|






|




|












|





|

|



|




|












|











|





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
















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







2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124




































3125
3126
3127
3128
3129
3130
3131
    void *clientData,
    Tcl_Obj *appendObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    Tcl_Size i, j;

    Tcl_AppendToObj(appendObj, "data=[", -1);

    for (i=0 ; i<infoPtr->numLists ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ", ", -1);
	}
	Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
		(infoPtr->firstValueTemp + i));
    }
    Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%" TCL_Z_MODIFIER "u",
	    infoPtr->loopCtTemp);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ",", -1);
	}
	Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[",
		(infoPtr->firstValueTemp + i));
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    if (j) {
		Tcl_AppendToObj(appendObj, ", ", -1);
	    }
	    Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
		    varsPtr->varIndexes[j]);
	}
	Tcl_AppendToObj(appendObj, "]", -1);
    }
}

static void
PrintNewForeachInfo(
    void *clientData,
    Tcl_Obj *appendObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    Tcl_Size i, j;

    Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=",
	    infoPtr->loopCtTemp);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ",", -1);
	}
	Tcl_AppendToObj(appendObj, "[", -1);
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    if (j) {
		Tcl_AppendToObj(appendObj, ",", -1);
	    }
	    Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
		    varsPtr->varIndexes[j]);
	}
	Tcl_AppendToObj(appendObj, "]", -1);
    }
}

static void
DisassembleForeachInfo(
    void *clientData,
    Tcl_Obj *dictObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    Tcl_Size i, j;
    Tcl_Obj *objPtr, *innerPtr;

    /*
     * Data stores.
     */

    TclNewObj(objPtr);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewWideIntObj(infoPtr->firstValueTemp + i));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);

    /*
     * Loop counter.
     */

    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
	   Tcl_NewWideIntObj(infoPtr->loopCtTemp));

    /*
     * Assignment targets.
     */

    TclNewObj(objPtr);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	TclNewObj(innerPtr);
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    Tcl_ListObjAppendElement(NULL, innerPtr,
		    Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
	}
	Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}

static void
DisassembleNewForeachInfo(
    void *clientData,
    Tcl_Obj *dictObj,
    TCL_UNUSED(ByteCode *),
    TCL_UNUSED(size_t))
{
    ForeachInfo *infoPtr = (ForeachInfo *)clientData;
    ForeachVarList *varsPtr;
    Tcl_Size i, j;
    Tcl_Obj *objPtr, *innerPtr;

    /*
     * Jump offset.
     */

    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
	   Tcl_NewWideIntObj(infoPtr->loopCtTemp));

    /*
     * Assignment targets.
     */

    TclNewObj(objPtr);
    for (i=0 ; i<infoPtr->numLists ; i++) {
	TclNewObj(innerPtr);
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    Tcl_ListObjAppendElement(NULL, innerPtr,
		    Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
	}
	Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);




































}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileFormatCmd --
 *

Changes to generic/tclCompCmdsGR.c.

2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
{
    DefineLineInformation;	/* TIP #280 */
    /*
     * General syntax: [return ?-option value ...? ?result?]
     * An even number of words means an explicit result argument is present.
     */
    int level, code, objc, status = TCL_OK;
    size_t size;
    int numWords = parsePtr->numWords;
    int explicitResult = (0 == (numWords % 2));
    int numOptionWords = numWords - 1 - explicitResult;
    Tcl_Obj *returnOpts, **objv;
    Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);

    /*







|







2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
{
    DefineLineInformation;	/* TIP #280 */
    /*
     * General syntax: [return ?-option value ...? ?result?]
     * An even number of words means an explicit result argument is present.
     */
    int level, code, objc, status = TCL_OK;
    Tcl_Size size;
    int numWords = parsePtr->numWords;
    int explicitResult = (0 == (numWords % 2));
    int numOptionWords = numWords - 1 - explicitResult;
    Tcl_Obj *returnOpts, **objv;
    Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);

    /*
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488

void
TclCompileSyntaxError(
    Tcl_Interp *interp,
    CompileEnv *envPtr)
{
    Tcl_Obj *msg = Tcl_GetObjResult(interp);
    size_t numBytes;
    const char *bytes = Tcl_GetStringFromObj(msg, &numBytes);

    TclErrorStackResetIf(interp, bytes, numBytes);
    TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
    CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
	    TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
    Tcl_ResetResult(interp);







|







2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488

void
TclCompileSyntaxError(
    Tcl_Interp *interp,
    CompileEnv *envPtr)
{
    Tcl_Obj *msg = Tcl_GetObjResult(interp);
    Tcl_Size numBytes;
    const char *bytes = Tcl_GetStringFromObj(msg, &numBytes);

    TclErrorStackResetIf(interp, bytes, numBytes);
    TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
    CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
	    TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
    Tcl_ResetResult(interp);

Changes to generic/tclCompCmdsSZ.c.

917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *mapTokenPtr, *stringTokenPtr;
    Tcl_Obj *mapObj, **objv;
    const char *bytes;
    size_t len, slen;

    /*
     * We only handle the case:
     *
     *    string map {foo bar} $thing
     *
     * That is, a literal two-element list (doesn't need to be brace-quoted,







|







917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *mapTokenPtr, *stringTokenPtr;
    Tcl_Obj *mapObj, **objv;
    const char *bytes;
    Tcl_Size len, slen;

    /*
     * We only handle the case:
     *
     *    string map {foo bar} $thing
     *
     * That is, a literal two-element list (doesn't need to be brace-quoted,
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
    return TCL_OK;
}

void
TclSubstCompile(
    Tcl_Interp *interp,
    const char *bytes,
    size_t numBytes,
    int flags,
    size_t line,
    CompileEnv *envPtr)
{
    Tcl_Token *endTokenPtr, *tokenPtr;
    int breakOffset = 0, count = 0;
    size_t bline = line;
    Tcl_Parse parse;
    Tcl_InterpState state = NULL;

    TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
    if (state != NULL) {
	Tcl_ResetResult(interp);
    }







|

|




|







1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
    return TCL_OK;
}

void
TclSubstCompile(
    Tcl_Interp *interp,
    const char *bytes,
    Tcl_Size numBytes,
    int flags,
    Tcl_Size line,
    CompileEnv *envPtr)
{
    Tcl_Token *endTokenPtr, *tokenPtr;
    int breakOffset = 0, count = 0;
    Tcl_Size bline = line;
    Tcl_Parse parse;
    Tcl_InterpState state = NULL;

    TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
    if (state != NULL) {
	Tcl_ResetResult(interp);
    }
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
    if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
	PUSH("");
	count++;
    }

    for (endTokenPtr = tokenPtr + parse.numTokens;
	    tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
	size_t length;
	int literal, catchRange, breakJump;
	char buf[4] = "";
	JumpFixup startFixup, okFixup, returnFixup, breakFixup;
	JumpFixup continueFixup, otherFixup, endFixup;

	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:







|







1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
    if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
	PUSH("");
	count++;
    }

    for (endTokenPtr = tokenPtr + parse.numTokens;
	    tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
	Tcl_Size length;
	int literal, catchRange, breakJump;
	char buf[4] = "";
	JumpFixup startFixup, okFixup, returnFixup, breakFixup;
	JumpFixup continueFixup, otherFixup, endFixup;

	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
	     * TCL_OK or TCL_ERROR from the substituted variable read; if so,
	     * there is no need to generate elaborate exception-management
	     * code. Note that the first component of TCL_TOKEN_VARIABLE is
	     * always TCL_TOKEN_TEXT...
	     */

	    if (tokenPtr->numComponents > 1) {
		size_t i;
		int foundCommand = 0;

		for (i=2 ; i<=tokenPtr->numComponents ; i++) {
		    if (tokenPtr[i].type == TCL_TOKEN_COMMAND) {
			foundCommand = 1;
			break;
		    }







|







1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
	     * TCL_OK or TCL_ERROR from the substituted variable read; if so,
	     * there is no need to generate elaborate exception-management
	     * code. Note that the first component of TCL_TOKEN_VARIABLE is
	     * always TCL_TOKEN_TEXT...
	     */

	    if (tokenPtr->numComponents > 1) {
		Tcl_Size i;
		int foundCommand = 0;

		for (i=2 ; i<=tokenPtr->numComponents ; i++) {
		    if (tokenPtr[i].type == TCL_TOKEN_COMMAND) {
			foundCommand = 1;
			break;
		    }
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
     * copies of the string from the input token for the generated tokens (it
     * causes a crash during exception handling). When multiple tokens are
     * available at this point, this is pretty easy.
     */

    if (numWords == 1) {
	const char *bytes;
	size_t maxLen, numBytes;
	size_t bline;		/* TIP #280: line of the pattern/action list,
				 * and start of list for when tracking the
				 * location. This list comes immediately after
				 * the value we switch on. */

	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}







|
|







1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
     * copies of the string from the input token for the generated tokens (it
     * causes a crash during exception handling). When multiple tokens are
     * available at this point, this is pretty easy.
     */

    if (numWords == 1) {
	const char *bytes;
	Tcl_Size maxLen, numBytes;
	Tcl_Size bline;		/* TIP #280: line of the pattern/action list,
				 * and start of list for when tracking the
				 * location. This list comes immediately after
				 * the value we switch on. */

	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TCL_ERROR;
	}
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616

    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
	keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
	offset = PTR2INT(Tcl_GetHashValue(hPtr));

	if (i++) {
	    Tcl_AppendToObj(appendObj, ", ", TCL_INDEX_NONE);
	    if (i%4==0) {
		Tcl_AppendToObj(appendObj, "\n\t\t", TCL_INDEX_NONE);
	    }
	}
	Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u",
		keyPtr, pcOffset + offset);
    }
}








|

|







2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616

    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
	keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
	offset = PTR2INT(Tcl_GetHashValue(hPtr));

	if (i++) {
	    Tcl_AppendToObj(appendObj, ", ", -1);
	    if (i%4==0) {
		Tcl_AppendToObj(appendObj, "\n\t\t", -1);
	    }
	}
	Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u",
		keyPtr, pcOffset + offset);
    }
}

2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
    size_t offset;

    TclNewObj(mapping);
    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
	keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
	offset = PTR2INT(Tcl_GetHashValue(hPtr));
	Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, TCL_INDEX_NONE),
		Tcl_NewWideIntObj(offset));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", TCL_INDEX_NONE), mapping);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileTailcallCmd --
 *







|


|







2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
    size_t offset;

    TclNewObj(mapping);
    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
	keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
	offset = PTR2INT(Tcl_GetHashValue(hPtr));
	Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
		Tcl_NewWideIntObj(offset));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileTailcallCmd --
 *
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    int numWords = parsePtr->numWords;
    Tcl_Token *codeToken, *msgToken;
    Tcl_Obj *objPtr;
    int codeKnown, codeIsList, codeIsValid;
    size_t len;

    if (numWords != 3) {
	return TCL_ERROR;
    }
    codeToken = TokenAfter(parsePtr->tokenPtr);
    msgToken = TokenAfter(codeToken);








|







2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    int numWords = parsePtr->numWords;
    Tcl_Token *codeToken, *msgToken;
    Tcl_Obj *objPtr;
    int codeKnown, codeIsList, codeIsValid;
    Tcl_Size len;

    if (numWords != 3) {
	return TCL_ERROR;
    }
    codeToken = TokenAfter(parsePtr->tokenPtr);
    msgToken = TokenAfter(codeToken);

2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
	memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
	matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
	resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
	optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);

	for (i=0 ; i<numHandlers ; i++) {
	    Tcl_Obj *tmpObj, **objv;
	    size_t objc;

	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		goto failedToCompile;
	    }
	    if (tokenPtr[1].size == 4
		    && !strncmp(tokenPtr[1].start, "trap", 4)) {
		/*







|







2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
	memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
	matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
	resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
	optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);

	for (i=0 ; i<numHandlers ; i++) {
	    Tcl_Obj *tmpObj, **objv;
	    Tcl_Size objc;

	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		goto failedToCompile;
	    }
	    if (tokenPtr[1].size == 4
		    && !strncmp(tokenPtr[1].start, "trap", 4)) {
		/*
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
	    }
	    if (TclListObjGetElementsM(NULL, tmpObj, &objc, &objv) != TCL_OK
		    || (objc > 2)) {
		TclDecrRefCount(tmpObj);
		goto failedToCompile;
	    }
	    if (objc > 0) {
		size_t len;
		const char *varname = Tcl_GetStringFromObj(objv[0], &len);

		resultVarIndices[i] = LocalScalar(varname, len, envPtr);
		if (resultVarIndices[i] < 0) {
		    TclDecrRefCount(tmpObj);
		    goto failedToCompile;
		}
	    } else {
		resultVarIndices[i] = -1;
	    }
	    if (objc == 2) {
		size_t len;
		const char *varname = Tcl_GetStringFromObj(objv[1], &len);

		optionVarIndices[i] = LocalScalar(varname, len, envPtr);
		if (optionVarIndices[i] < 0) {
		    TclDecrRefCount(tmpObj);
		    goto failedToCompile;
		}







|











|







2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
	    }
	    if (TclListObjGetElementsM(NULL, tmpObj, &objc, &objv) != TCL_OK
		    || (objc > 2)) {
		TclDecrRefCount(tmpObj);
		goto failedToCompile;
	    }
	    if (objc > 0) {
		Tcl_Size len;
		const char *varname = Tcl_GetStringFromObj(objv[0], &len);

		resultVarIndices[i] = LocalScalar(varname, len, envPtr);
		if (resultVarIndices[i] < 0) {
		    TclDecrRefCount(tmpObj);
		    goto failedToCompile;
		}
	    } else {
		resultVarIndices[i] = -1;
	    }
	    if (objc == 2) {
		Tcl_Size len;
		const char *varname = Tcl_GetStringFromObj(objv[1], &len);

		optionVarIndices[i] = LocalScalar(varname, len, envPtr);
		if (optionVarIndices[i] < 0) {
		    TclDecrRefCount(tmpObj);
		    goto failedToCompile;
		}
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
    int *resultVars,
    int *optionVars,
    Tcl_Token **handlerTokens)
{
    DefineLineInformation;	/* TIP #280 */
    int range, resultVar, optionsVar;
    int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
    size_t slen, len;
    int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
    int *noError;
    char buf[TCL_INTEGER_SPACE];

    resultVar = AnonymousLocal(envPtr);
    optionsVar = AnonymousLocal(envPtr);
    if (resultVar < 0 || optionsVar < 0) {







|







3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
    int *resultVars,
    int *optionVars,
    Tcl_Token **handlerTokens)
{
    DefineLineInformation;	/* TIP #280 */
    int range, resultVar, optionsVar;
    int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
    Tcl_Size slen, len;
    int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
    int *noError;
    char buf[TCL_INTEGER_SPACE];

    resultVar = AnonymousLocal(envPtr);
    optionsVar = AnonymousLocal(envPtr);
    if (resultVar < 0 || optionsVar < 0) {
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
    Tcl_Token *finallyToken)	/* Not NULL */
{
    DefineLineInformation;	/* TIP #280 */
    int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0;
    int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
    int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
    char buf[TCL_INTEGER_SPACE];
    size_t slen, len;

    resultVar = AnonymousLocal(envPtr);
    optionsVar = AnonymousLocal(envPtr);
    if (resultVar < 0 || optionsVar < 0) {
	return TCL_ERROR;
    }








|







3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
    Tcl_Token *finallyToken)	/* Not NULL */
{
    DefineLineInformation;	/* TIP #280 */
    int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0;
    int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
    int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
    char buf[TCL_INTEGER_SPACE];
    Tcl_Size slen, len;

    resultVar = AnonymousLocal(envPtr);
    optionsVar = AnonymousLocal(envPtr);
    if (resultVar < 0 || optionsVar < 0) {
	return TCL_ERROR;
    }

3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
		    continue;
		}
	    }
	    return TCL_ERROR;
	}
	if (varCount == 0) {
	    const char *bytes;
	    size_t len;

	    bytes = Tcl_GetStringFromObj(leadingWord, &len);
	    if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
		flags = 0;
		haveFlags++;
	    } else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
		haveFlags++;







|







3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
		    continue;
		}
	    }
	    return TCL_ERROR;
	}
	if (varCount == 0) {
	    const char *bytes;
	    Tcl_Size len;

	    bytes = Tcl_GetStringFromObj(leadingWord, &len);
	    if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
		flags = 0;
		haveFlags++;
	    } else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
		haveFlags++;
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
    Tcl_Parse *parsePtr,
    const char *identity,
    int instruction,
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    size_t words;

    /* TODO: Consider support for compiling expanded args. */
    for (words=1 ; words<parsePtr->numWords ; words++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, words);
    }
    if (parsePtr->numWords <= 2) {
	PushLiteral(envPtr, identity, TCL_INDEX_NONE);
	words++;
    }
    if (words > 3) {
	/*
	 * Reverse order of arguments to get precise agreement with [expr] in
	 * calculations, including roundoff errors.
	 */







|







|







4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
    Tcl_Parse *parsePtr,
    const char *identity,
    int instruction,
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    Tcl_Size words;

    /* TODO: Consider support for compiling expanded args. */
    for (words=1 ; words<parsePtr->numWords ; words++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, words);
    }
    if (parsePtr->numWords <= 2) {
	PushLiteral(envPtr, identity, -1);
	words++;
    }
    if (words > 3) {
	/*
	 * Reverse order of arguments to get precise agreement with [expr] in
	 * calculations, including roundoff errors.
	 */
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
	/*
	 * No local variable space!
	 */

	return TCL_ERROR;
    } else {
	int tmpIndex = AnonymousLocal(envPtr);
	size_t words;

	tokenPtr = TokenAfter(parsePtr->tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 1);
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 2);
	STORE(tmpIndex);
	TclEmitOpcode(instruction, envPtr);







|







4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
	/*
	 * No local variable space!
	 */

	return TCL_ERROR;
    } else {
	int tmpIndex = AnonymousLocal(envPtr);
	Tcl_Size words;

	tokenPtr = TokenAfter(parsePtr->tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 1);
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 2);
	STORE(tmpIndex);
	TclEmitOpcode(instruction, envPtr);
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    TCL_UNUSED(Command *),
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    size_t words;

    /*
     * This one has its own implementation because the ** operator is the only
     * one with right associativity.
     */

    for (words=1 ; words<parsePtr->numWords ; words++) {







|







4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    TCL_UNUSED(Command *),
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    Tcl_Size words;

    /*
     * This one has its own implementation because the ** operator is the only
     * one with right associativity.
     */

    for (words=1 ; words<parsePtr->numWords ; words++) {
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    TCL_UNUSED(Command *),
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    size_t words;

    /* TODO: Consider support for compiling expanded args. */
    if (parsePtr->numWords == 1) {
	/*
	 * Fallback to direct eval to report syntax error.
	 */








|







4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    TCL_UNUSED(Command *),
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    Tcl_Size words;

    /* TODO: Consider support for compiling expanded args. */
    if (parsePtr->numWords == 1) {
	/*
	 * Fallback to direct eval to report syntax error.
	 */

4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    TCL_UNUSED(Command *),
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    size_t words;

    /* TODO: Consider support for compiling expanded args. */
    if (parsePtr->numWords == 1) {
	/*
	 * Fallback to direct eval to report syntax error.
	 */








|







4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    TCL_UNUSED(Command *),
    CompileEnv *envPtr)
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
    Tcl_Size words;

    /* TODO: Consider support for compiling expanded args. */
    if (parsePtr->numWords == 1) {
	/*
	 * Fallback to direct eval to report syntax error.
	 */

Changes to generic/tclCompExpr.c.

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
 * Declarations for local functions to this file:
 */

static void		CompileExprTree(Tcl_Interp *interp, OpNode *nodes,
			    int index, Tcl_Obj *const **litObjvPtr,
			    Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr,
			    CompileEnv *envPtr, int optimize);
static void		ConvertTreeToTokens(const char *start, size_t numBytes,
			    OpNode *nodes, Tcl_Token *tokenPtr,
			    Tcl_Parse *parsePtr);
static int		ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes,
			    int index, Tcl_Obj * const **litObjvPtr);
static int		ParseExpr(Tcl_Interp *interp, const char *start,
			    size_t numBytes, OpNode **opTreePtr,
			    Tcl_Obj *litList, Tcl_Obj *funcList,
			    Tcl_Parse *parsePtr, int parseOnly);
static size_t		ParseLexeme(const char *start, size_t numBytes,
			    unsigned char *lexemePtr, Tcl_Obj **literalPtr);

/*
 *----------------------------------------------------------------------
 *
 * ParseExpr --
 *







|





|


|







507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
 * Declarations for local functions to this file:
 */

static void		CompileExprTree(Tcl_Interp *interp, OpNode *nodes,
			    int index, Tcl_Obj *const **litObjvPtr,
			    Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr,
			    CompileEnv *envPtr, int optimize);
static void		ConvertTreeToTokens(const char *start, Tcl_Size numBytes,
			    OpNode *nodes, Tcl_Token *tokenPtr,
			    Tcl_Parse *parsePtr);
static int		ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes,
			    int index, Tcl_Obj * const **litObjvPtr);
static int		ParseExpr(Tcl_Interp *interp, const char *start,
			    Tcl_Size numBytes, OpNode **opTreePtr,
			    Tcl_Obj *litList, Tcl_Obj *funcList,
			    Tcl_Parse *parsePtr, int parseOnly);
static Tcl_Size		ParseLexeme(const char *start, Tcl_Size numBytes,
			    unsigned char *lexemePtr, Tcl_Obj **literalPtr);

/*
 *----------------------------------------------------------------------
 *
 * ParseExpr --
 *
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
 *----------------------------------------------------------------------
 */

static int
ParseExpr(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *start,		/* Start of source string to parse. */
    size_t numBytes,		/* Number of bytes in string. */
    OpNode **opTreePtr,		/* Points to space where a pointer to the
				 * allocated OpNode tree should go. */
    Tcl_Obj *litList,		/* List to append literals to. */
    Tcl_Obj *funcList,		/* List to append function names to. */
    Tcl_Parse *parsePtr,	/* Structure to fill with tokens representing
				 * those operands that require run time
				 * substitutions. */







|







554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
 *----------------------------------------------------------------------
 */

static int
ParseExpr(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *start,		/* Start of source string to parse. */
    Tcl_Size numBytes,		/* Number of bytes in string. */
    OpNode **opTreePtr,		/* Points to space where a pointer to the
				 * allocated OpNode tree should go. */
    Tcl_Obj *litList,		/* List to append literals to. */
    Tcl_Obj *funcList,		/* List to append function names to. */
    Tcl_Parse *parsePtr,	/* Structure to fill with tokens representing
				 * those operands that require run time
				 * substitutions. */
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
    unsigned int nodesAvailable = 64; /* Initial size of the storage array. This
				 * value establishes a minimum tree memory
				 * cost of only about 1 kilobyte, and is large
				 * enough for most expressions to parse with
				 * no need for array growth and
				 * reallocation. */
    unsigned int nodesUsed = 0;	/* Number of OpNodes filled. */
    size_t scanned = 0;		/* Capture number of byte scanned by parsing
				 * routines. */
    int lastParsed;		/* Stores info about what the lexeme parsed
				 * the previous pass through the parsing loop
				 * was. If it was an operator, lastParsed is
				 * the index of the OpNode for that operator.
				 * If it was not an operator, lastParsed holds
				 * an OperandTypes value encoding what we need







|







577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
    unsigned int nodesAvailable = 64; /* Initial size of the storage array. This
				 * value establishes a minimum tree memory
				 * cost of only about 1 kilobyte, and is large
				 * enough for most expressions to parse with
				 * no need for array growth and
				 * reallocation. */
    unsigned int nodesUsed = 0;	/* Number of OpNodes filled. */
    Tcl_Size scanned = 0;	/* Capture number of byte scanned by parsing
				 * routines. */
    int lastParsed;		/* Stores info about what the lexeme parsed
				 * the previous pass through the parsing loop
				 * was. If it was an operator, lastParsed is
				 * the index of the OpNode for that operator.
				 * If it was not an operator, lastParsed holds
				 * an OperandTypes value encoding what we need
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
				 * message where the error location is
				 * reported, this "mark" substring is inserted
				 * into the string being parsed to aid in
				 * pinpointing the location of the syntax
				 * error in the expression. */
    int insertMark = 0;		/* A boolean controlling whether the "mark"
				 * should be inserted. */
    const unsigned limit = 25;	/* Portions of the error message are
				 * constructed out of substrings of the
				 * original expression. In order to keep the
				 * error message readable, we impose this
				 * limit on the substring size we extract. */

    TclParseInit(interp, start, numBytes, parsePtr);








|







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
				 * message where the error location is
				 * reported, this "mark" substring is inserted
				 * into the string being parsed to aid in
				 * pinpointing the location of the syntax
				 * error in the expression. */
    int insertMark = 0;		/* A boolean controlling whether the "mark"
				 * should be inserted. */
    const int limit = 25;	/* Portions of the error message are
				 * constructed out of substrings of the
				 * original expression. In order to keep the
				 * error message readable, we impose this
				 * limit on the substring size we extract. */

    TclParseInit(interp, start, numBytes, parsePtr);

773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
			Tcl_ListObjAppendElement(NULL, funcList, literal);
			scanned = scanned2 - 1;
			break;
		    }

		    Tcl_DecrRefCount(literal);
		    msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
			    (scanned < limit) ? (int)scanned : (int)limit - 3, start,
			    (scanned < limit) ? "" : "...");
		    post = Tcl_ObjPrintf(
			    "should be \"$%.*s%s\" or \"{%.*s%s}\"",
			    (scanned < limit) ? (int)scanned : (int)limit - 3,
			    start, (scanned < limit) ? "" : "...",
			    (scanned < limit) ? (int)scanned : (int)limit - 3,
			    start, (scanned < limit) ? "" : "...");
		    Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
			    (scanned < limit) ? (int)scanned : (int)limit - 3,
			    start, (scanned < limit) ? "" : "...");
		    errCode = "BAREWORD";
		    if (start[0] == '0') {
			const char *stop;
			TclParseNumber(NULL, NULL, NULL, start, scanned,
				&stop, TCL_PARSE_NO_WHITESPACE);

			if (isdigit(UCHAR(*stop)) || (stop == start + 1)) {
			    switch (start[1]) {
			    case 'b':
				Tcl_AppendToObj(post,
					" (invalid binary number?)", TCL_INDEX_NONE);
				parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
				errCode = "BADNUMBER";
				subErrCode = "BINARY";
				break;
			    case 'o':
				Tcl_AppendToObj(post,
					" (invalid octal number?)", TCL_INDEX_NONE);
				parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
				errCode = "BADNUMBER";
				subErrCode = "OCTAL";
				break;
			    default:
				if (isdigit(UCHAR(start[1]))) {
				    Tcl_AppendToObj(post,
					    " (invalid octal number?)", TCL_INDEX_NONE);
				    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
				    errCode = "BADNUMBER";
				    subErrCode = "OCTAL";
				}
				break;
			    }
			}







|



|

|


|











|






|







|







773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
			Tcl_ListObjAppendElement(NULL, funcList, literal);
			scanned = scanned2 - 1;
			break;
		    }

		    Tcl_DecrRefCount(literal);
		    msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
			    (int)((scanned < limit) ? scanned : limit - 3), start,
			    (scanned < limit) ? "" : "...");
		    post = Tcl_ObjPrintf(
			    "should be \"$%.*s%s\" or \"{%.*s%s}\"",
			    (int) ((scanned < limit) ? scanned : limit - 3),
			    start, (scanned < limit) ? "" : "...",
			    (int) ((scanned < limit) ? scanned : limit - 3),
			    start, (scanned < limit) ? "" : "...");
		    Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
			    (int) ((scanned < limit) ? scanned : limit - 3),
			    start, (scanned < limit) ? "" : "...");
		    errCode = "BAREWORD";
		    if (start[0] == '0') {
			const char *stop;
			TclParseNumber(NULL, NULL, NULL, start, scanned,
				&stop, TCL_PARSE_NO_WHITESPACE);

			if (isdigit(UCHAR(*stop)) || (stop == start + 1)) {
			    switch (start[1]) {
			    case 'b':
				Tcl_AppendToObj(post,
					" (invalid binary number?)", -1);
				parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
				errCode = "BADNUMBER";
				subErrCode = "BINARY";
				break;
			    case 'o':
				Tcl_AppendToObj(post,
					" (invalid octal number?)", -1);
				parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
				errCode = "BADNUMBER";
				subErrCode = "OCTAL";
				break;
			    default:
				if (isdigit(UCHAR(start[1]))) {
				    Tcl_AppendToObj(post,
					    " (invalid octal number?)", -1);
				    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
				    errCode = "BADNUMBER";
				    subErrCode = "OCTAL";
				}
				break;
			    }
			}
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
		(start + scanned + limit > parsePtr->end) ? "" : "...");

	/*
	 * Next, append any postscript message.
	 */

	if (post != NULL) {
	    Tcl_AppendToObj(msg, ";\n", TCL_INDEX_NONE);
	    Tcl_AppendObjToObj(msg, post);
	    Tcl_DecrRefCount(post);
	}
	Tcl_SetObjResult(interp, msg);

	/*
	 * Finally, place context information in the errorInfo.







|







1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
		(start + scanned + limit > parsePtr->end) ? "" : "...");

	/*
	 * Next, append any postscript message.
	 */

	if (post != NULL) {
	    Tcl_AppendToObj(msg, ";\n", -1);
	    Tcl_AppendObjToObj(msg, post);
	    Tcl_DecrRefCount(post);
	}
	Tcl_SetObjResult(interp, msg);

	/*
	 * Finally, place context information in the errorInfo.
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
 *
 *----------------------------------------------------------------------
 */

static void
ConvertTreeToTokens(
    const char *start,
    size_t numBytes,
    OpNode *nodes,
    Tcl_Token *tokenPtr,
    Tcl_Parse *parsePtr)
{
    int subExprTokenIdx = 0;
    OpNode *nodePtr = nodes;
    int next = nodePtr->right;







|







1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
 *
 *----------------------------------------------------------------------
 */

static void
ConvertTreeToTokens(
    const char *start,
    Tcl_Size numBytes,
    OpNode *nodes,
    Tcl_Token *tokenPtr,
    Tcl_Parse *parsePtr)
{
    int subExprTokenIdx = 0;
    OpNode *nodePtr = nodes;
    int next = nodePtr->right;
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
 *----------------------------------------------------------------------
 */

int
Tcl_ParseExpr(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *start,		/* Start of source string to parse. */
    size_t numBytes,		/* Number of bytes in string. If -1, the
				 * string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr)	/* Structure to fill with information about
				 * the parsed expression; any previous
				 * information in the structure is ignored. */
{
    int code;
    OpNode *opTree = NULL;	/* Will point to the tree of operators. */
    Tcl_Obj *litList;	/* List to hold the literals. */
    Tcl_Obj *funcList;	/* List to hold the functon names. */
    Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
				/* Holds the Tcl_Tokens of substitutions. */

    TclNewObj(litList);
    TclNewObj(funcList);
    if (numBytes == TCL_INDEX_NONE) {
	numBytes = (start ? strlen(start) : 0);
    }

    code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
	    exprParsePtr, 1 /* parseOnly */);
    Tcl_DecrRefCount(funcList);
    Tcl_DecrRefCount(litList);







|















|







1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
 *----------------------------------------------------------------------
 */

int
Tcl_ParseExpr(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *start,		/* Start of source string to parse. */
    Tcl_Size numBytes,		/* Number of bytes in string. If -1, the
				 * string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr)	/* Structure to fill with information about
				 * the parsed expression; any previous
				 * information in the structure is ignored. */
{
    int code;
    OpNode *opTree = NULL;	/* Will point to the tree of operators. */
    Tcl_Obj *litList;	/* List to hold the literals. */
    Tcl_Obj *funcList;	/* List to hold the functon names. */
    Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
				/* Holds the Tcl_Tokens of substitutions. */

    TclNewObj(litList);
    TclNewObj(funcList);
    if (numBytes < 0) {
	numBytes = (start ? strlen(start) : 0);
    }

    code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
	    exprParsePtr, 1 /* parseOnly */);
    Tcl_DecrRefCount(funcList);
    Tcl_DecrRefCount(litList);
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
 *
 * Side effects:
 *	Code identifying lexeme parsed is written to *lexemePtr.
 *
 *----------------------------------------------------------------------
 */

static size_t
ParseLexeme(
    const char *start,		/* Start of lexeme to parse. */
    size_t numBytes,		/* Number of bytes in string. */
    unsigned char *lexemePtr,	/* Write code of parsed lexeme to this
				 * storage. */
    Tcl_Obj **literalPtr)	/* Write corresponding literal value to this
				   storage, if non-NULL. */
{
    const char *end;
    int ch;







|


|







1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
 *
 * Side effects:
 *	Code identifying lexeme parsed is written to *lexemePtr.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Size
ParseLexeme(
    const char *start,		/* Start of lexeme to parse. */
    Tcl_Size numBytes,		/* Number of bytes in string. */
    unsigned char *lexemePtr,	/* Write code of parsed lexeme to this
				 * storage. */
    Tcl_Obj **literalPtr)	/* Write corresponding literal value to this
				   storage, if non-NULL. */
{
    const char *end;
    int ch;
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
	return 1;
    }
    switch (byte) {
    case '#': {
	/*
	 * Scan forward over the comment contents.
	 */
	size_t size;

	for (size = 0; byte != '\n' && byte != 0 && size < numBytes; size++) {
	    byte = UCHAR(start[size]);
	}
	*lexemePtr = COMMENT;
	return size - (byte == '\n');
    }







|







1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
	return 1;
    }
    switch (byte) {
    case '#': {
	/*
	 * Scan forward over the comment contents.
	 */
	Tcl_Size size;

	for (size = 0; byte != '\n' && byte != 0 && size < numBytes; size++) {
	    byte = UCHAR(start[size]);
	}
	*lexemePtr = COMMENT;
	return size - (byte == '\n');
    }
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
    /*
     * We reject leading underscores in bareword.  No sensible reason why.
     * Might be inspired by reserved identifier rules in C, which of course
     * have no direct relevance here.
     */

    if (!TclIsBareword(*start) || *start == '_') {
	size_t scanned;
	if (Tcl_UtfCharComplete(start, numBytes)) {
	    scanned = TclUtfToUCS4(start, &ch);
	} else {
	    char utfBytes[8];

	    memcpy(utfBytes, start, numBytes);
	    utfBytes[numBytes] = '\0';







|







2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
    /*
     * We reject leading underscores in bareword.  No sensible reason why.
     * Might be inspired by reserved identifier rules in C, which of course
     * have no direct relevance here.
     */

    if (!TclIsBareword(*start) || *start == '_') {
	Tcl_Size scanned;
	if (Tcl_UtfCharComplete(start, numBytes)) {
	    scanned = TclUtfToUCS4(start, &ch);
	} else {
	    char utfBytes[8];

	    memcpy(utfBytes, start, numBytes);
	    utfBytes[numBytes] = '\0';
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
 *----------------------------------------------------------------------
 */

void
TclCompileExpr(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *script,		/* The source script to compile. */
    size_t numBytes,		/* Number of bytes in script. */
    CompileEnv *envPtr,		/* Holds resulting instructions. */
    int optimize)		/* 0 for one-off expressions. */
{
    OpNode *opTree = NULL;	/* Will point to the tree of operators */
    Tcl_Obj *litList;		/* List to hold the literals */
    Tcl_Obj *funcList;		/* List to hold the functon names*/
    Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
				/* Holds the Tcl_Tokens of substitutions */
    int code;

    TclNewObj(litList);
    TclNewObj(funcList);
    code = ParseExpr(interp, script, numBytes, &opTree, litList,
	    funcList, parsePtr, 0 /* parseOnly */);

    if (code == TCL_OK) {
	/*
	 * Valid parse; compile the tree.
	 */

	size_t objc;
	Tcl_Obj *const *litObjv;
	Tcl_Obj **funcObjv;

	/* TIP #280 : Track Lines within the expression */
	TclAdvanceLines(&envPtr->line, script,
		script + TclParseAllWhiteSpace(script, numBytes));








|




















|







2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
 *----------------------------------------------------------------------
 */

void
TclCompileExpr(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *script,		/* The source script to compile. */
    Tcl_Size numBytes,		/* Number of bytes in script. */
    CompileEnv *envPtr,		/* Holds resulting instructions. */
    int optimize)		/* 0 for one-off expressions. */
{
    OpNode *opTree = NULL;	/* Will point to the tree of operators */
    Tcl_Obj *litList;		/* List to hold the literals */
    Tcl_Obj *funcList;		/* List to hold the functon names*/
    Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
				/* Holds the Tcl_Tokens of substitutions */
    int code;

    TclNewObj(litList);
    TclNewObj(funcList);
    code = ParseExpr(interp, script, numBytes, &opTree, litList,
	    funcList, parsePtr, 0 /* parseOnly */);

    if (code == TCL_OK) {
	/*
	 * Valid parse; compile the tree.
	 */

	Tcl_Size objc;
	Tcl_Obj *const *litObjv;
	Tcl_Obj **funcObjv;

	/* TIP #280 : Track Lines within the expression */
	TclAdvanceLines(&envPtr->line, script,
		script + TclParseAllWhiteSpace(script, numBytes));

2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
	} else if (nodePtr->mark == MARK_RIGHT) {
	    next = nodePtr->right;

	    switch (nodePtr->lexeme) {
	    case FUNCTION: {
		Tcl_DString cmdName;
		const char *p;
		size_t length;

		Tcl_DStringInit(&cmdName);
		TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
		p = Tcl_GetStringFromObj(*funcObjv, &length);
		funcObjv++;
		Tcl_DStringAppend(&cmdName, p, length);
		TclEmitPush(TclRegisterLiteral(envPtr,







|







2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
	} else if (nodePtr->mark == MARK_RIGHT) {
	    next = nodePtr->right;

	    switch (nodePtr->lexeme) {
	    case FUNCTION: {
		Tcl_DString cmdName;
		const char *p;
		Tcl_Size length;

		Tcl_DStringInit(&cmdName);
		TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
		p = Tcl_GetStringFromObj(*funcObjv, &length);
		funcObjv++;
		Tcl_DStringAppend(&cmdName, p, length);
		TclEmitPush(TclRegisterLiteral(envPtr,
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
	    numWords = 1;	/* No arguments, so just the command */
	    break;
	case OT_LITERAL: {
	    Tcl_Obj *const *litObjv = *litObjvPtr;
	    Tcl_Obj *literal = *litObjv;

	    if (optimize) {
		size_t length;
		const char *bytes = Tcl_GetStringFromObj(literal, &length);
		int idx = TclRegisterLiteral(envPtr, bytes, length, 0);
		Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx);

		if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
		    /*
		     * Would like to do this:







|







2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
	    numWords = 1;	/* No arguments, so just the command */
	    break;
	case OT_LITERAL: {
	    Tcl_Obj *const *litObjv = *litObjvPtr;
	    Tcl_Obj *literal = *litObjv;

	    if (optimize) {
		Tcl_Size length;
		const char *bytes = Tcl_GetStringFromObj(literal, &length);
		int idx = TclRegisterLiteral(envPtr, bytes, length, 0);
		Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx);

		if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
		    /*
		     * Would like to do this:
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
		    /*
		     * Don't generate a string rep, but if we have one
		     * already, then use it to share via the literal table.
		     */

		    if (TclHasStringRep(objPtr)) {
			Tcl_Obj *tableValue;
			size_t numBytes;
			const char *bytes
				= Tcl_GetStringFromObj(objPtr, &numBytes);

			idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
			tableValue = TclFetchLiteral(envPtr, idx);
			if ((tableValue->typePtr == NULL) &&
				(objPtr->typePtr != NULL)) {







|







2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
		    /*
		     * Don't generate a string rep, but if we have one
		     * already, then use it to share via the literal table.
		     */

		    if (TclHasStringRep(objPtr)) {
			Tcl_Obj *tableValue;
			Tcl_Size numBytes;
			const char *bytes
				= Tcl_GetStringFromObj(objPtr, &numBytes);

			idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
			tableValue = TclFetchLiteral(envPtr, idx);
			if ((tableValue->typePtr == NULL) &&
				(objPtr->typePtr != NULL)) {

Changes to generic/tclCompile.c.

676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
static ByteCode *	CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int flags);
static void		DupByteCodeInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static unsigned char *	EncodeCmdLocMap(CompileEnv *envPtr,
			    ByteCode *codePtr, unsigned char *startPtr);
static void		EnterCmdExtentData(CompileEnv *envPtr,
			    size_t cmdNumber, size_t numSrcBytes, size_t numCodeBytes);
static void		EnterCmdStartData(CompileEnv *envPtr,
			    size_t cmdNumber, size_t srcOffset, size_t codeOffset);
static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static void		FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
static int		IsCompactibleCompileEnv(CompileEnv *envPtr);
static void		PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static int		SetByteCodeFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		StartExpanding(CompileEnv *envPtr);

/*
 * TIP #280: Helper for building the per-word line information of all compiled
 * commands.
 */
static void		EnterCmdWordData(ExtCmdLoc *eclPtr, size_t srcOffset,
			    Tcl_Token *tokenPtr, const char *cmd,
			    size_t numWords, size_t line, int *clNext, int **lines,
			    CompileEnv *envPtr);
static void		ReleaseCmdWordData(ExtCmdLoc *eclPtr);

/*
 * tclByteCodeType provides the standard type management procedures for the
 * bytecode type.
 */







|

|
















|

|







676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
static ByteCode *	CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int flags);
static void		DupByteCodeInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static unsigned char *	EncodeCmdLocMap(CompileEnv *envPtr,
			    ByteCode *codePtr, unsigned char *startPtr);
static void		EnterCmdExtentData(CompileEnv *envPtr,
			    Tcl_Size cmdNumber, Tcl_Size numSrcBytes, Tcl_Size numCodeBytes);
static void		EnterCmdStartData(CompileEnv *envPtr,
			    Tcl_Size cmdNumber, Tcl_Size srcOffset, Tcl_Size codeOffset);
static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static void		FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
static int		IsCompactibleCompileEnv(CompileEnv *envPtr);
static void		PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static int		SetByteCodeFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		StartExpanding(CompileEnv *envPtr);

/*
 * TIP #280: Helper for building the per-word line information of all compiled
 * commands.
 */
static void		EnterCmdWordData(ExtCmdLoc *eclPtr, Tcl_Size srcOffset,
			    Tcl_Token *tokenPtr, const char *cmd,
			    Tcl_Size numWords, Tcl_Size line, int *clNext, int **lines,
			    CompileEnv *envPtr);
static void		ReleaseCmdWordData(ExtCmdLoc *eclPtr);

/*
 * tclByteCodeType provides the standard type management procedures for the
 * bytecode type.
 */
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
    TclReleaseByteCode(codePtr);
}

static void
ReleaseCmdWordData(
    ExtCmdLoc *eclPtr)
{
    size_t i;

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







|







1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
    TclReleaseByteCode(codePtr);
}

static void
ReleaseCmdWordData(
    ExtCmdLoc *eclPtr)
{
    Tcl_Size i;

    if (eclPtr->type == TCL_LOCATION_SOURCE) {
	Tcl_DecrRefCount(eclPtr->path);
    }
    for (i=0 ; i<eclPtr->nuloc ; i++) {
	Tcl_Free(eclPtr->loc[i].line);
    }
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
	     *			ctx.data.tebc.codePtr is used instead.
	     */

	    TclGetSrcInfoForPc(ctxPtr);
	    pc = 1;
	}

	if ((ctxPtr->nline <= (size_t)word) || (ctxPtr->line[word] < 0)) {
	    /*
	     * Word is not a literal, relative counting.
	     */

	    envPtr->line = 1;
	    envPtr->extCmdMapPtr->type =
		    (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);







|







1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
	     *			ctx.data.tebc.codePtr is used instead.
	     */

	    TclGetSrcInfoForPc(ctxPtr);
	    pc = 1;
	}

	if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) {
	    /*
	     * Word is not a literal, relative counting.
	     */

	    envPtr->line = 1;
	    envPtr->extCmdMapPtr->type =
		    (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
    }
    if (envPtr->iPtr) {
	/*
	 * We never converted to Bytecode, so free the things we would
	 * have transferred to it.
	 */

	size_t i;
	LiteralEntry *entryPtr = envPtr->literalArrayPtr;
	AuxData *auxDataPtr = envPtr->auxDataArrayPtr;

	for (i = 0;  i < envPtr->literalArrayNext;  i++) {
	    TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr);
	    entryPtr++;
	}







|







1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
    }
    if (envPtr->iPtr) {
	/*
	 * We never converted to Bytecode, so free the things we would
	 * have transferred to it.
	 */

	Tcl_Size i;
	LiteralEntry *entryPtr = envPtr->literalArrayPtr;
	AuxData *auxDataPtr = envPtr->auxDataArrayPtr;

	for (i = 0;  i < envPtr->literalArrayNext;  i++) {
	    TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr);
	    entryPtr++;
	}
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
     * nested calls of TclCompileScript, considering interp recursionlimit.
     * Use factor 5/4 (1.25) to avoid being too mistaken when recognizing the
     * limit during "mixed" evaluation and compilation process (nested
     * eval+compile) and is good enough for default recursionlimit (1000).
     */
    if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "too many nested compilations (infinite loop?)", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
	TclCompileSyntaxError(interp, envPtr);
	return;
    }

    /* Each iteration compiles one command from the script. */








|







2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
     * nested calls of TclCompileScript, considering interp recursionlimit.
     * Use factor 5/4 (1.25) to avoid being too mistaken when recognizing the
     * limit during "mixed" evaluation and compilation process (nested
     * eval+compile) and is good enough for default recursionlimit (1000).
     */
    if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "too many nested compilations (infinite loop?)", -1));
	Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
	TclCompileSyntaxError(interp, envPtr);
	return;
    }

    /* Each iteration compiles one command from the script. */

2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
void
TclCompileVarSubst(
    Tcl_Interp *interp,
    Tcl_Token *tokenPtr,
    CompileEnv *envPtr)
{
    const char *p, *name = tokenPtr[1].start;
    size_t i, nameBytes = tokenPtr[1].size;
    size_t localVar;
    int localVarName = 1;

    /*
     * Determine how the variable name should be handled: if it contains any
     * namespace qualifiers it is not a local variable (localVarName=-1); if
     * it looks like an array element and the token has a single component, it
     * should not be created here [Bug 569438] (localVarName=0); otherwise,







|
|







2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
void
TclCompileVarSubst(
    Tcl_Interp *interp,
    Tcl_Token *tokenPtr,
    CompileEnv *envPtr)
{
    const char *p, *name = tokenPtr[1].start;
    Tcl_Size i, nameBytes = tokenPtr[1].size;
    Tcl_Size localVar;
    int localVarName = 1;

    /*
     * Determine how the variable name should be handled: if it contains any
     * namespace qualifiers it is not a local variable (localVarName=-1); if
     * it looks like an array element and the token has a single component, it
     * should not be created here [Bug 569438] (localVarName=0); otherwise,
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
    }

    /*
     * Either push the variable's name, or find its index in the array
     * of local variables in a procedure frame.
     */

    localVar = TCL_INDEX_NONE;
    if (localVarName != -1) {
	localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
    }
    if (localVar == TCL_INDEX_NONE) {
	PushLiteral(envPtr, name, nameBytes);
    }

    /*
     * Emit instructions to load the variable.
     */

    TclAdvanceLines(&envPtr->line, tokenPtr[1].start,
	    tokenPtr[1].start + tokenPtr[1].size);

    if (tokenPtr->numComponents == 1) {
	if (localVar == TCL_INDEX_NONE) {
	    TclEmitOpcode(INST_LOAD_STK, envPtr);
	} else if (localVar <= 255) {
	    TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
	} else {
	    TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);
	}
    } else {
	TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr);
	if (localVar == TCL_INDEX_NONE) {
	    TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
	} else if (localVar <= 255) {
	    TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);
	} else {
	    TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);
	}
    }







|



|











|








|







2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
    }

    /*
     * Either push the variable's name, or find its index in the array
     * of local variables in a procedure frame.
     */

    localVar = -1;
    if (localVarName != -1) {
	localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
    }
    if (localVar < 0) {
	PushLiteral(envPtr, name, nameBytes);
    }

    /*
     * Emit instructions to load the variable.
     */

    TclAdvanceLines(&envPtr->line, tokenPtr[1].start,
	    tokenPtr[1].start + tokenPtr[1].size);

    if (tokenPtr->numComponents == 1) {
	if (localVar < 0) {
	    TclEmitOpcode(INST_LOAD_STK, envPtr);
	} else if (localVar <= 255) {
	    TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
	} else {
	    TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);
	}
    } else {
	TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr);
	if (localVar < 0) {
	    TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
	} else if (localVar <= 255) {
	    TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);
	} else {
	    TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);
	}
    }
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
 */

static void
PreventCycle(
    Tcl_Obj *objPtr,
    CompileEnv *envPtr)
{
    size_t i;

    for (i = 0;  i < envPtr->literalArrayNext; i++) {
	if (objPtr == TclFetchLiteral(envPtr, i)) {
	    /*
	     * Prevent circular reference where the bytecode internalrep of
	     * a value contains a literal which is that same value.
	     * If this is allowed to happen, refcount decrements may not
	     * reach zero, and memory may leak.  Bugs 467523, 3357771
	     *
	     * NOTE:  [Bugs 3392070, 3389764] We make a copy based completely
	     * on the string value, and do not call Tcl_DuplicateObj() so we
             * can be sure we do not have any lingering cycles hiding in
	     * the internalrep.
	     */
	    size_t numBytes;
	    const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
	    Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);

	    Tcl_IncrRefCount(copyPtr);
	    TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr);

	    envPtr->literalArrayPtr[i].objPtr = copyPtr;







|














|







2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
 */

static void
PreventCycle(
    Tcl_Obj *objPtr,
    CompileEnv *envPtr)
{
    Tcl_Size i;

    for (i = 0;  i < envPtr->literalArrayNext; i++) {
	if (objPtr == TclFetchLiteral(envPtr, i)) {
	    /*
	     * Prevent circular reference where the bytecode internalrep of
	     * a value contains a literal which is that same value.
	     * If this is allowed to happen, refcount decrements may not
	     * reach zero, and memory may leak.  Bugs 467523, 3357771
	     *
	     * NOTE:  [Bugs 3392070, 3389764] We make a copy based completely
	     * on the string value, and do not call Tcl_DuplicateObj() so we
             * can be sure we do not have any lingering cycles hiding in
	     * the internalrep.
	     */
	    Tcl_Size numBytes;
	    const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
	    Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);

	    Tcl_IncrRefCount(copyPtr);
	    TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr);

	    envPtr->literalArrayPtr[i].objPtr = copyPtr;
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
 * Side effects:
 *	Creates and registers a new local variable if create is 1 and the
 *	variable is unknown, or if the name is NULL.
 *
 *----------------------------------------------------------------------
 */

size_t
TclFindCompiledLocal(
    const char *name,	/* Points to first character of the name of a
				 * scalar or array variable. If NULL, a
				 * temporary var should be created. */
    size_t nameBytes,		/* Number of bytes in the name. */
    int create,			/* If 1, allocate a local frame entry for the
				 * variable if it is new. */
    CompileEnv *envPtr)		/* Points to the current compile environment*/
{
    CompiledLocal *localPtr;
    size_t localVar = TCL_INDEX_NONE;
    size_t i;
    Proc *procPtr;

    /*
     * If not creating a temporary, does a local variable of the specified
     * name already exist?
     */

    procPtr = envPtr->procPtr;

    if (procPtr == NULL) {
	/*
	 * Compiling a non-body script: give it read access to the LVT in the
	 * current localCache
	 */

	LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
	const char *localName;
	Tcl_Obj **varNamePtr;
	size_t len;

	if (!cachePtr || !name) {
	    return TCL_INDEX_NONE;
	}

	varNamePtr = &cachePtr->varName0;
	for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
	    if (*varNamePtr) {
		localName = Tcl_GetStringFromObj(*varNamePtr, &len);
		if ((len == nameBytes) && !strncmp(name, localName, len)) {
		    return i;
		}
	    }
	}
	return TCL_INDEX_NONE;
    }

    if (name != NULL) {
	size_t localCt = procPtr->numCompiledLocals;

	localPtr = procPtr->firstLocalPtr;
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		char *localName = localPtr->name;

		if ((nameBytes == localPtr->nameLength) &&







|




|





|
|


















|


















|







2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
 * Side effects:
 *	Creates and registers a new local variable if create is 1 and the
 *	variable is unknown, or if the name is NULL.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
TclFindCompiledLocal(
    const char *name,	/* Points to first character of the name of a
				 * scalar or array variable. If NULL, a
				 * temporary var should be created. */
    Tcl_Size nameBytes,		/* Number of bytes in the name. */
    int create,			/* If 1, allocate a local frame entry for the
				 * variable if it is new. */
    CompileEnv *envPtr)		/* Points to the current compile environment*/
{
    CompiledLocal *localPtr;
    Tcl_Size localVar = TCL_INDEX_NONE;
    Tcl_Size i;
    Proc *procPtr;

    /*
     * If not creating a temporary, does a local variable of the specified
     * name already exist?
     */

    procPtr = envPtr->procPtr;

    if (procPtr == NULL) {
	/*
	 * Compiling a non-body script: give it read access to the LVT in the
	 * current localCache
	 */

	LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
	const char *localName;
	Tcl_Obj **varNamePtr;
	Tcl_Size len;

	if (!cachePtr || !name) {
	    return TCL_INDEX_NONE;
	}

	varNamePtr = &cachePtr->varName0;
	for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
	    if (*varNamePtr) {
		localName = Tcl_GetStringFromObj(*varNamePtr, &len);
		if ((len == nameBytes) && !strncmp(name, localName, len)) {
		    return i;
		}
	    }
	}
	return TCL_INDEX_NONE;
    }

    if (name != NULL) {
	Tcl_Size localCt = procPtr->numCompiledLocals;

	localPtr = procPtr->firstLocalPtr;
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		char *localName = localPtr->name;

		if ((nameBytes == localPtr->nameLength) &&
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
 */

static void
EnterCmdStartData(
    CompileEnv *envPtr,		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    size_t cmdIndex,		/* Index of the command whose start data is
				 * being set. */
    size_t srcOffset,		/* Offset of first char of the command. */
    size_t codeOffset)		/* Offset of first byte of command code. */
{
    CmdLocation *cmdLocPtr;

    if (cmdIndex >= envPtr->numCommands) {
	Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
    }

    if (cmdIndex >= envPtr->cmdMapEnd) {
	/*
	 * Expand the command location array by allocating more storage from
	 * the heap. The currently allocated CmdLocation entries are stored







|

|
|



|







3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
 */

static void
EnterCmdStartData(
    CompileEnv *envPtr,		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    Tcl_Size cmdIndex,		/* Index of the command whose start data is
				 * being set. */
    Tcl_Size srcOffset,		/* Offset of first char of the command. */
    Tcl_Size codeOffset)		/* Offset of first byte of command code. */
{
    CmdLocation *cmdLocPtr;

    if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) {
	Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
    }

    if (cmdIndex >= envPtr->cmdMapEnd) {
	/*
	 * Expand the command location array by allocating more storage from
	 * the heap. The currently allocated CmdLocation entries are stored
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
 */

static void
EnterCmdExtentData(
    CompileEnv *envPtr,		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    size_t cmdIndex,		/* Index of the command whose source and code
				 * length data is being set. */
    size_t numSrcBytes,		/* Number of command source chars. */
    size_t numCodeBytes)		/* Offset of last byte of command code. */
{
    CmdLocation *cmdLocPtr;

    if (cmdIndex >= envPtr->numCommands) {
	Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
    }

    if (cmdIndex > envPtr->cmdMapEnd) {
	Tcl_Panic("EnterCmdExtentData: missing start data for command %" TCL_Z_MODIFIER "u",
		cmdIndex);
    }







|

|
|



|







3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
 */

static void
EnterCmdExtentData(
    CompileEnv *envPtr,		/* Points to the compilation environment
				 * structure in which to enter command
				 * location information. */
    Tcl_Size cmdIndex,		/* Index of the command whose source and code
				 * length data is being set. */
    Tcl_Size numSrcBytes,		/* Number of command source chars. */
    Tcl_Size numCodeBytes)		/* Offset of last byte of command code. */
{
    CmdLocation *cmdLocPtr;

    if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) {
	Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
    }

    if (cmdIndex > envPtr->cmdMapEnd) {
	Tcl_Panic("EnterCmdExtentData: missing start data for command %" TCL_Z_MODIFIER "u",
		cmdIndex);
    }
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
 */

static void
EnterCmdWordData(
    ExtCmdLoc *eclPtr,		/* Points to the map environment structure in
				 * which to enter command location
				 * information. */
    size_t srcOffset,		/* Offset of first char of the command. */
    Tcl_Token *tokenPtr,
    const char *cmd,
    size_t numWords,
    size_t line,
    int *clNext,
    int **wlines,
    CompileEnv *envPtr)
{
    ECL *ePtr;
    const char *last;
    size_t wordIdx, wordLine;
    int *wwlines, *wordNext;

    if (eclPtr->nuloc >= eclPtr->nloc) {
	/*
	 * Expand the ECL array by allocating more storage from the heap. The
	 * currently allocated ECL entries are stored from eclPtr->loc[0] up
	 * to eclPtr->loc[eclPtr->nuloc-1] (inclusive).







|


|
|






|







3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
 */

static void
EnterCmdWordData(
    ExtCmdLoc *eclPtr,		/* Points to the map environment structure in
				 * which to enter command location
				 * information. */
    Tcl_Size srcOffset,		/* Offset of first char of the command. */
    Tcl_Token *tokenPtr,
    const char *cmd,
    Tcl_Size numWords,
    Tcl_Size line,
    int *clNext,
    int **wlines,
    CompileEnv *envPtr)
{
    ECL *ePtr;
    const char *last;
    Tcl_Size wordIdx, wordLine;
    int *wwlines, *wordNext;

    if (eclPtr->nuloc >= eclPtr->nloc) {
	/*
	 * Expand the ECL array by allocating more storage from the heap. The
	 * currently allocated ECL entries are stored from eclPtr->loc[0] up
	 * to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
 *	the array in expanded: a new array of double the size is allocated, if
 *	envPtr->mallocedExceptArray is non-zero the old array is freed, and
 *	ExceptionRange entries are copied from the old array to the new one.
 *
 *----------------------------------------------------------------------
 */

size_t
TclCreateExceptRange(
    ExceptionRangeType type,	/* The kind of ExceptionRange desired. */
    CompileEnv *envPtr)/* Points to CompileEnv for which to create a
				 * new ExceptionRange structure. */
{
    ExceptionRange *rangePtr;
    ExceptionAux *auxPtr;
    size_t index = envPtr->exceptArrayNext;

    if (index >= envPtr->exceptArrayEnd) {
	/*
	 * Expand the ExceptionRange array. The currently allocated entries
	 * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
	 * [inclusive].
	 */







|







|







3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
 *	the array in expanded: a new array of double the size is allocated, if
 *	envPtr->mallocedExceptArray is non-zero the old array is freed, and
 *	ExceptionRange entries are copied from the old array to the new one.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
TclCreateExceptRange(
    ExceptionRangeType type,	/* The kind of ExceptionRange desired. */
    CompileEnv *envPtr)/* Points to CompileEnv for which to create a
				 * new ExceptionRange structure. */
{
    ExceptionRange *rangePtr;
    ExceptionAux *auxPtr;
    Tcl_Size index = envPtr->exceptArrayNext;

    if (index >= envPtr->exceptArrayEnd) {
	/*
	 * Expand the ExceptionRange array. The currently allocated entries
	 * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
	 * [inclusive].
	 */
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
 *
 * Side effects:
 *	If there is not enough room in the CompileEnv's AuxData array, its size
 *	is doubled.
 *----------------------------------------------------------------------
 */

size_t
TclCreateAuxData(
    void *clientData,	/* The compilation auxiliary data to store in
				 * the new aux data record. */
    const AuxDataType *typePtr,	/* Pointer to the type to attach to this
				 * AuxData */
    CompileEnv *envPtr)/* Points to the CompileEnv for which a new
				 * aux data structure is to be allocated. */
{
    size_t index;			/* Index for the new AuxData structure. */
    AuxData *auxDataPtr;
				/* Points to the new AuxData structure */

    index = envPtr->auxDataArrayNext;
    if (index >= envPtr->auxDataArrayEnd) {
	/*
	 * Expand the AuxData array. The currently allocated entries are







|








|







3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
 *
 * Side effects:
 *	If there is not enough room in the CompileEnv's AuxData array, its size
 *	is doubled.
 *----------------------------------------------------------------------
 */

Tcl_Size
TclCreateAuxData(
    void *clientData,	/* The compilation auxiliary data to store in
				 * the new aux data record. */
    const AuxDataType *typePtr,	/* Pointer to the type to attach to this
				 * AuxData */
    CompileEnv *envPtr)/* Points to the CompileEnv for which a new
				 * aux data structure is to be allocated. */
{
    Tcl_Size index;		/* Index for the new AuxData structure. */
    AuxData *auxDataPtr;
				/* Points to the new AuxData structure */

    index = envPtr->auxDataArrayNext;
    if (index >= envPtr->auxDataArrayEnd) {
	/*
	 * Expand the AuxData array. The currently allocated entries are
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
    ByteCode *codePtr,		/* ByteCode in which to encode envPtr's
				 * command location information. */
    unsigned char *startPtr)	/* Points to the first byte in codePtr's
				 * memory block where the location information
				 * is to be stored. */
{
    CmdLocation *mapPtr = envPtr->cmdMapPtr;
    size_t i, codeDelta, codeLen, srcLen, prevOffset;
    size_t numCmds = envPtr->numCommands;
    unsigned char *p = startPtr;
    int srcDelta;

    /*
     * Encode the code offset for each command as a sequence of deltas.
     */

    codePtr->codeDeltaStart = p;
    prevOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	codeDelta = mapPtr[i].codeOffset - prevOffset;
	if (codeDelta == TCL_INDEX_NONE) {
	    Tcl_Panic("EncodeCmdLocMap: bad code offset");
	} else if (codeDelta <= 127) {
	    TclStoreInt1AtPtr(codeDelta, p);
	    p++;
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;
	    TclStoreInt4AtPtr(codeDelta, p);
	    p += 4;
	}
	prevOffset = mapPtr[i].codeOffset;
    }

    /*
     * Encode the code length for each command.
     */

    codePtr->codeLengthStart = p;
    for (i = 0;  i < numCmds;  i++) {
	codeLen = mapPtr[i].numCodeBytes;
	if (codeLen == TCL_INDEX_NONE) {
	    Tcl_Panic("EncodeCmdLocMap: bad code length");
	} else if (codeLen <= 127) {
	    TclStoreInt1AtPtr(codeLen, p);
	    p++;
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;







|
|











|




















|







4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
    ByteCode *codePtr,		/* ByteCode in which to encode envPtr's
				 * command location information. */
    unsigned char *startPtr)	/* Points to the first byte in codePtr's
				 * memory block where the location information
				 * is to be stored. */
{
    CmdLocation *mapPtr = envPtr->cmdMapPtr;
    Tcl_Size i, codeDelta, codeLen, srcLen, prevOffset;
    Tcl_Size numCmds = envPtr->numCommands;
    unsigned char *p = startPtr;
    int srcDelta;

    /*
     * Encode the code offset for each command as a sequence of deltas.
     */

    codePtr->codeDeltaStart = p;
    prevOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	codeDelta = mapPtr[i].codeOffset - prevOffset;
	if (codeDelta < 0) {
	    Tcl_Panic("EncodeCmdLocMap: bad code offset");
	} else if (codeDelta <= 127) {
	    TclStoreInt1AtPtr(codeDelta, p);
	    p++;
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;
	    TclStoreInt4AtPtr(codeDelta, p);
	    p += 4;
	}
	prevOffset = mapPtr[i].codeOffset;
    }

    /*
     * Encode the code length for each command.
     */

    codePtr->codeLengthStart = p;
    for (i = 0;  i < numCmds;  i++) {
	codeLen = mapPtr[i].numCodeBytes;
	if (codeLen < 0) {
	    Tcl_Panic("EncodeCmdLocMap: bad code length");
	} else if (codeLen <= 127) {
	    TclStoreInt1AtPtr(codeLen, p);
	    p++;
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
    /*
     * Encode the source length for each command.
     */

    codePtr->srcLengthStart = p;
    for (i = 0;  i < numCmds;  i++) {
	srcLen = mapPtr[i].numSrcBytes;
	if (srcLen == TCL_INDEX_NONE) {
	    Tcl_Panic("EncodeCmdLocMap: bad source length");
	} else if (srcLen <= 127) {
	    TclStoreInt1AtPtr(srcLen, p);
	    p++;
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;







|







4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
    /*
     * Encode the source length for each command.
     */

    codePtr->srcLengthStart = p;
    for (i = 0;  i < numCmds;  i++) {
	srcLen = mapPtr[i].numSrcBytes;
	if (srcLen < 0) {
	    Tcl_Panic("EncodeCmdLocMap: bad source length");
	} else if (srcLen <= 127) {
	    TclStoreInt1AtPtr(srcLen, p);
	    p++;
	} else {
	    TclStoreInt1AtPtr(0xFF, p);
	    p++;

Changes to generic/tclCompile.h.

1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
			    Tcl_Token *tokenPtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_Size	TclCreateAuxData(void *clientData,
			    const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_Size	TclCreateExceptRange(ExceptionRangeType type,
			    CompileEnv *envPtr);
MODULE_SCOPE ExecEnv *	TclCreateExecEnv(Tcl_Interp *interp, size_t size);
MODULE_SCOPE Tcl_Obj *	TclCreateLiteral(Interp *iPtr, const char *bytes,
			    size_t length, size_t hash, int *newPtr,
			    Namespace *nsPtr, int flags,
			    LiteralEntry **globalPtrPtr);
MODULE_SCOPE void	TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void	TclDeleteLiteralTable(Tcl_Interp *interp,
			    LiteralTable *tablePtr);
MODULE_SCOPE void	TclEmitForwardJump(CompileEnv *envPtr,
			    TclJumpType jumpType, JumpFixup *jumpFixupPtr);







|







1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
			    Tcl_Token *tokenPtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_Size	TclCreateAuxData(void *clientData,
			    const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_Size	TclCreateExceptRange(ExceptionRangeType type,
			    CompileEnv *envPtr);
MODULE_SCOPE ExecEnv *	TclCreateExecEnv(Tcl_Interp *interp, size_t size);
MODULE_SCOPE Tcl_Obj *	TclCreateLiteral(Interp *iPtr, const char *bytes,
			    Tcl_Size length, size_t hash, int *newPtr,
			    Namespace *nsPtr, int flags,
			    LiteralEntry **globalPtrPtr);
MODULE_SCOPE void	TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void	TclDeleteLiteralTable(Tcl_Interp *interp,
			    LiteralTable *tablePtr);
MODULE_SCOPE void	TclEmitForwardJump(CompileEnv *envPtr,
			    TclJumpType jumpType, JumpFixup *jumpFixupPtr);

Changes to generic/tclConfig.c.

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
    cdPtr->interp = interp;
    if (valEncoding) {
	cdPtr->encoding = (char *)Tcl_Alloc(strlen(valEncoding)+1);
	strcpy(cdPtr->encoding, valEncoding);
    } else {
	cdPtr->encoding = NULL;
    }
    cdPtr->pkg = Tcl_NewStringObj(pkgName, TCL_INDEX_NONE);

    /*
     * Phase I: Adding the provided information to the internal database of
     * package meta data.
     *
     * Phase II: Create a command for querying this database, specific to the
     * package registering its configuration. This is the approved interface







|







81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
    cdPtr->interp = interp;
    if (valEncoding) {
	cdPtr->encoding = (char *)Tcl_Alloc(strlen(valEncoding)+1);
	strcpy(cdPtr->encoding, valEncoding);
    } else {
	cdPtr->encoding = NULL;
    }
    cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);

    /*
     * Phase I: Adding the provided information to the internal database of
     * package meta data.
     *
     * Phase II: Create a command for querying this database, specific to the
     * package registering its configuration. This is the approved interface
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
    /*
     * Extend the package configuration...
     * We cannot assume that the encodings are initialized, therefore
     * store the value as-is in a byte array. See Bug [9b2e636361].
     */

    for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
	Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, TCL_INDEX_NONE),
		Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
    }

    /*
     * Write the changes back into the overall database.
     */

    Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);

    /*
     * Now create the interface command for retrieval of the package
     * information.
     */

    Tcl_DStringInit(&cmdName);
    TclDStringAppendLiteral(&cmdName, "::");
    Tcl_DStringAppend(&cmdName, pkgName, TCL_INDEX_NONE);

    /*
     * The incomplete command name is the name of the namespace to place it
     * in.
     */

    if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,







|
















|







123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
    /*
     * Extend the package configuration...
     * We cannot assume that the encodings are initialized, therefore
     * store the value as-is in a byte array. See Bug [9b2e636361].
     */

    for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
	Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
		Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
    }

    /*
     * Write the changes back into the overall database.
     */

    Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);

    /*
     * Now create the interface command for retrieval of the package
     * information.
     */

    Tcl_DStringInit(&cmdName);
    TclDStringAppendLiteral(&cmdName, "::");
    Tcl_DStringAppend(&cmdName, pkgName, -1);

    /*
     * The incomplete command name is the name of the namespace to place it
     * in.
     */

    if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    QCCD *cdPtr = (QCCD *)clientData;
    Tcl_Obj *pkgName = cdPtr->pkg;
    Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
    size_t m, n = 0;
    static const char *const subcmdStrings[] = {
	"get", "list", NULL
    };
    enum subcmds {
	CFG_GET, CFG_LIST
    } index;
    Tcl_DString conv;







|







195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    QCCD *cdPtr = (QCCD *)clientData;
    Tcl_Obj *pkgName = cdPtr->pkg;
    Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
    Tcl_Size m, n = 0;
    static const char *const subcmdStrings[] = {
	"get", "list", NULL
    };
    enum subcmds {
	CFG_GET, CFG_LIST
    } index;
    Tcl_DString conv;
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
	    || pkgDict == NULL) {
	/*
	 * Maybe a Tcl_Panic is better, because the package data has to be
	 * present.
	 */

	Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
		TclGetString(pkgName), NULL);
	return TCL_ERROR;
    }

    switch (index) {
    case CFG_GET:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "key");
	    return TCL_ERROR;
	}

	if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
		|| val == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
		    TclGetString(objv[2]), NULL);
	    return TCL_ERROR;
	}

	if (cdPtr->encoding) {
	    venc = Tcl_GetEncoding(interp, cdPtr->encoding);







|














|







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
	    || pkgDict == NULL) {
	/*
	 * Maybe a Tcl_Panic is better, because the package data has to be
	 * present.
	 */

	Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
	Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
		TclGetString(pkgName), NULL);
	return TCL_ERROR;
    }

    switch (index) {
    case CFG_GET:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "key");
	    return TCL_ERROR;
	}

	if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
		|| val == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
		    TclGetString(objv[2]), NULL);
	    return TCL_ERROR;
	}

	if (cdPtr->encoding) {
	    venc = Tcl_GetEncoding(interp, cdPtr->encoding);
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
	}

	Tcl_DictObjSize(interp, pkgDict, &m);
	listPtr = Tcl_NewListObj(m, NULL);

	if (!listPtr) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "insufficient memory to create list", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	    return TCL_ERROR;
	}

	if (m) {
	    Tcl_DictSearch s;
	    Tcl_Obj *key;







|







275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
	}

	Tcl_DictObjSize(interp, pkgDict, &m);
	listPtr = Tcl_NewListObj(m, NULL);

	if (!listPtr) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "insufficient memory to create list", -1));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	    return TCL_ERROR;
	}

	if (m) {
	    Tcl_DictSearch s;
	    Tcl_Obj *key;

Changes to generic/tclDecls.h.

1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
EXTERN int *		Tcl_UtfToUniCharDString(const char *src,
				Tcl_Size length, Tcl_DString *dsPtr);
/* 649 */
EXTERN unsigned char *	TclGetBytesFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, int *numBytesPtr);
/* 650 */
EXTERN unsigned char *	Tcl_GetBytesFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, size_t *numBytesPtr);
/* 651 */
EXTERN char *		Tcl_GetStringFromObj(Tcl_Obj *objPtr,
				size_t *lengthPtr);
/* 652 */
EXTERN Tcl_UniChar *	Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
				size_t *lengthPtr);
/* 653 */
EXTERN unsigned char *	Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr,
				size_t *numBytesPtr);
/* 654 */
EXTERN int		Tcl_UtfCharComplete(const char *src, Tcl_Size length);
/* 655 */
EXTERN const char *	Tcl_UtfNext(const char *src);
/* 656 */
EXTERN const char *	Tcl_UtfPrev(const char *src, const char *start);
/* 657 */







|


|


|


|







1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
EXTERN int *		Tcl_UtfToUniCharDString(const char *src,
				Tcl_Size length, Tcl_DString *dsPtr);
/* 649 */
EXTERN unsigned char *	TclGetBytesFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, int *numBytesPtr);
/* 650 */
EXTERN unsigned char *	Tcl_GetBytesFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, Tcl_Size *numBytesPtr);
/* 651 */
EXTERN char *		Tcl_GetStringFromObj(Tcl_Obj *objPtr,
				Tcl_Size *lengthPtr);
/* 652 */
EXTERN Tcl_UniChar *	Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
				Tcl_Size *lengthPtr);
/* 653 */
EXTERN unsigned char *	Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr,
				Tcl_Size *numBytesPtr);
/* 654 */
EXTERN int		Tcl_UtfCharComplete(const char *src, Tcl_Size length);
/* 655 */
EXTERN const char *	Tcl_UtfNext(const char *src);
/* 656 */
EXTERN const char *	Tcl_UtfPrev(const char *src, const char *start);
/* 657 */
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
				Tcl_DString *dsPtr,
				Tcl_Size *errorLocationPtr);
/* 660 */
EXTERN int		Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async,
				int sigNumber);
/* 661 */
EXTERN int		Tcl_ListObjGetElements(Tcl_Interp *interp,
				Tcl_Obj *listPtr, size_t *objcPtr,
				Tcl_Obj ***objvPtr);
/* 662 */
EXTERN int		Tcl_ListObjLength(Tcl_Interp *interp,
				Tcl_Obj *listPtr, size_t *lengthPtr);
/* 663 */
EXTERN int		Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
				size_t *sizePtr);
/* 664 */
EXTERN int		Tcl_SplitList(Tcl_Interp *interp,
				const char *listStr, size_t *argcPtr,
				const char ***argvPtr);
/* 665 */
EXTERN void		Tcl_SplitPath(const char *path, size_t *argcPtr,
				const char ***argvPtr);
/* 666 */
EXTERN Tcl_Obj *	Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr);
/* 667 */
EXTERN int		Tcl_ParseArgsObjv(Tcl_Interp *interp,
				const Tcl_ArgvInfo *argTable,
				size_t *objcPtr, Tcl_Obj *const *objv,
				Tcl_Obj ***remObjv);
/* 668 */
EXTERN Tcl_Size		Tcl_UniCharLen(const int *uniStr);
/* 669 */
EXTERN Tcl_Size		Tcl_NumUtfChars(const char *src, Tcl_Size length);
/* 670 */
EXTERN Tcl_Size		Tcl_GetCharLength(Tcl_Obj *objPtr);







|



|


|


|


|


|



|







1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
				Tcl_DString *dsPtr,
				Tcl_Size *errorLocationPtr);
/* 660 */
EXTERN int		Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async,
				int sigNumber);
/* 661 */
EXTERN int		Tcl_ListObjGetElements(Tcl_Interp *interp,
				Tcl_Obj *listPtr, Tcl_Size *objcPtr,
				Tcl_Obj ***objvPtr);
/* 662 */
EXTERN int		Tcl_ListObjLength(Tcl_Interp *interp,
				Tcl_Obj *listPtr, Tcl_Size *lengthPtr);
/* 663 */
EXTERN int		Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
				Tcl_Size *sizePtr);
/* 664 */
EXTERN int		Tcl_SplitList(Tcl_Interp *interp,
				const char *listStr, Tcl_Size *argcPtr,
				const char ***argvPtr);
/* 665 */
EXTERN void		Tcl_SplitPath(const char *path, Tcl_Size *argcPtr,
				const char ***argvPtr);
/* 666 */
EXTERN Tcl_Obj *	Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr);
/* 667 */
EXTERN int		Tcl_ParseArgsObjv(Tcl_Interp *interp,
				const Tcl_ArgvInfo *argTable,
				Tcl_Size *objcPtr, Tcl_Obj *const *objv,
				Tcl_Obj ***remObjv);
/* 668 */
EXTERN Tcl_Size		Tcl_UniCharLen(const int *uniStr);
/* 669 */
EXTERN Tcl_Size		Tcl_NumUtfChars(const char *src, Tcl_Size length);
/* 670 */
EXTERN Tcl_Size		Tcl_GetCharLength(Tcl_Obj *objPtr);
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864


1865
1866
1867
1868
1869
1870
1871
EXTERN Tcl_Command	Tcl_NRCreateCommand2(Tcl_Interp *interp,
				const char *cmdName, Tcl_ObjCmdProc2 *proc,
				Tcl_ObjCmdProc2 *nreProc2, void *clientData,
				Tcl_CmdDeleteProc *deleteProc);
/* 679 */
EXTERN int		Tcl_NRCallObjProc2(Tcl_Interp *interp,
				Tcl_ObjCmdProc2 *objProc2, void *clientData,
				size_t objc, Tcl_Obj *const objv[]);
/* 680 */
EXTERN int		Tcl_GetNumberFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, void **clientDataPtr,
				int *typePtr);
/* 681 */
EXTERN int		Tcl_GetNumber(Tcl_Interp *interp, const char *bytes,
				size_t numBytes, void **clientDataPtr,
				int *typePtr);
/* 682 */
EXTERN int		Tcl_RemoveChannelMode(Tcl_Interp *interp,
				Tcl_Channel chan, int mode);
/* 683 */
EXTERN Tcl_Size		Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
/* 684 */
EXTERN int		Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
/* 685 */
EXTERN Tcl_Obj *	Tcl_DStringToObj(Tcl_DString *dsPtr);
/* Slot 686 is reserved */


/* Slot 687 is reserved */
/* 688 */
EXTERN void		TclUnusedStubEntry(void);

typedef struct {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;







|






|











|
>
>







1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
EXTERN Tcl_Command	Tcl_NRCreateCommand2(Tcl_Interp *interp,
				const char *cmdName, Tcl_ObjCmdProc2 *proc,
				Tcl_ObjCmdProc2 *nreProc2, void *clientData,
				Tcl_CmdDeleteProc *deleteProc);
/* 679 */
EXTERN int		Tcl_NRCallObjProc2(Tcl_Interp *interp,
				Tcl_ObjCmdProc2 *objProc2, void *clientData,
				ptrdiff_t objc, Tcl_Obj *const objv[]);
/* 680 */
EXTERN int		Tcl_GetNumberFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, void **clientDataPtr,
				int *typePtr);
/* 681 */
EXTERN int		Tcl_GetNumber(Tcl_Interp *interp, const char *bytes,
				Tcl_Size numBytes, void **clientDataPtr,
				int *typePtr);
/* 682 */
EXTERN int		Tcl_RemoveChannelMode(Tcl_Interp *interp,
				Tcl_Channel chan, int mode);
/* 683 */
EXTERN Tcl_Size		Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
/* 684 */
EXTERN int		Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
/* 685 */
EXTERN Tcl_Obj *	Tcl_DStringToObj(Tcl_DString *dsPtr);
/* 686 */
EXTERN int		Tcl_GetSizeIntFromObj(Tcl_Interp *interp,
				Tcl_Obj *objPtr, Tcl_Size *sizePtr);
/* Slot 687 is reserved */
/* 688 */
EXTERN void		TclUnusedStubEntry(void);

typedef struct {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
    int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
    int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, Tcl_Size size); /* 644 */
    int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */
    Tcl_Size (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */
    char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */
    int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */
    unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */
    unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */
    char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */
    Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */
    unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */
    int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */
    const char * (*tcl_UtfNext) (const char *src); /* 655 */
    const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
    int (*tcl_UniCharIsUnicode) (int ch); /* 657 */
    int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */
    int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */
    int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
    int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */
    int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */
    int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); /* 663 */
    int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 664 */
    void (*tcl_SplitPath) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */
    Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */
    int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */
    Tcl_Size (*tcl_UniCharLen) (const int *uniStr); /* 668 */
    Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 669 */
    Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */
    const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 671 */
    Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */
    int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */
    int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */
    int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */
    Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
    Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
    Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
    int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */
    int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */
    int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */
    int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
    Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
    int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
    Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
    void (*reserved686)(void);
    void (*reserved687)(void);
    void (*tclUnusedStubEntry) (void); /* 688 */
} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus







|
|
|
|







|
|
|
|
|
|
|











|

|




|







2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
    int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
    int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, Tcl_Size size); /* 644 */
    int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */
    Tcl_Size (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */
    char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */
    int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */
    unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */
    unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 650 */
    char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 651 */
    Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 652 */
    unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 653 */
    int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */
    const char * (*tcl_UtfNext) (const char *src); /* 655 */
    const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
    int (*tcl_UniCharIsUnicode) (int ch); /* 657 */
    int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */
    int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */
    int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
    int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 661 */
    int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *lengthPtr); /* 662 */
    int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr); /* 663 */
    int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, const char ***argvPtr); /* 664 */
    void (*tcl_SplitPath) (const char *path, Tcl_Size *argcPtr, const char ***argvPtr); /* 665 */
    Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, Tcl_Size *lenPtr); /* 666 */
    int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */
    Tcl_Size (*tcl_UniCharLen) (const int *uniStr); /* 668 */
    Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 669 */
    Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */
    const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 671 */
    Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */
    int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */
    int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */
    int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */
    Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
    Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
    Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
    int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, ptrdiff_t objc, Tcl_Obj *const objv[]); /* 679 */
    int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */
    int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, void **clientDataPtr, int *typePtr); /* 681 */
    int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
    Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
    int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
    Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
    int (*tcl_GetSizeIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *sizePtr); /* 686 */
    void (*reserved687)(void);
    void (*tclUnusedStubEntry) (void); /* 688 */
} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
3885
3886
3887
3888
3889
3890
3891

3892
3893
3894
3895
3896
3897
3898
3899
	(tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
#define Tcl_GetEncodingNulLength \
	(tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
#define Tcl_GetWideUIntFromObj \
	(tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */
#define Tcl_DStringToObj \
	(tclStubsPtr->tcl_DStringToObj) /* 685 */

/* Slot 686 is reserved */
/* Slot 687 is reserved */
#define TclUnusedStubEntry \
	(tclStubsPtr->tclUnusedStubEntry) /* 688 */

#endif /* defined(USE_TCL_STUBS) */

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







>
|







3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
	(tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
#define Tcl_GetEncodingNulLength \
	(tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
#define Tcl_GetWideUIntFromObj \
	(tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */
#define Tcl_DStringToObj \
	(tclStubsPtr->tcl_DStringToObj) /* 685 */
#define Tcl_GetSizeIntFromObj \
	(tclStubsPtr->tcl_GetSizeIntFromObj) /* 686 */
/* Slot 687 is reserved */
#define TclUnusedStubEntry \
	(tclStubsPtr->tclUnusedStubEntry) /* 688 */

#endif /* defined(USE_TCL_STUBS) */

/* !END!: Do not edit above this line. */
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
	Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData)
#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \
	Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData)
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
	Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
#define Tcl_AddErrorInfo(interp, message) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE))
#define Tcl_AddObjErrorInfo(interp, message, length) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#define Tcl_Eval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0)
#define Tcl_GlobalEval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
#define Tcl_SetResult(interp, result, freeProc) \
	do { \
	    const char *__result = result; \
	    Tcl_FreeProc *__freeProc = freeProc; \
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \
	    if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
		if (__freeProc == TCL_DYNAMIC) { \
		    Tcl_Free((char *)__result); \
		} else { \
		    (*__freeProc)((char *)__result); \
		} \
	    } \







|











|







3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
	Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData)
#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \
	Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData)
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
	Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
#define Tcl_AddErrorInfo(interp, message) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1))
#define Tcl_AddObjErrorInfo(interp, message, length) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#define Tcl_Eval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0)
#define Tcl_GlobalEval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
#define Tcl_SetResult(interp, result, freeProc) \
	do { \
	    const char *__result = result; \
	    Tcl_FreeProc *__freeProc = freeProc; \
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \
	    if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
		if (__freeProc == TCL_DYNAMIC) { \
		    Tcl_Free((char *)__result); \
		} else { \
		    (*__freeProc)((char *)__result); \
		} \
	    } \
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
#undef TclGetByteArrayFromObj
#undef Tcl_GetByteArrayFromObj
#if defined(USE_TCL_STUBS)
#   if TCL_MAJOR_VERSION < 9 || !defined(TCL_NO_DEPRECATED)
#	define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
		(sizeof(*(sizePtr)) <= sizeof(int) ? \
			tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \
			tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr)))
#	define Tcl_GetStringFromObj(objPtr, sizePtr) \
		(sizeof(*(sizePtr)) <= sizeof(int) ? \
			tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \
			tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr)))
#	define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
		(sizeof(*(sizePtr)) <= sizeof(int) ? \
			tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \
			tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr)))
#   endif
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
	(tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \
		(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
	Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
	Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#if TCL_MAJOR_VERSION > 8
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \
		tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr)))
#else
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		tclStubsPtr->tclGetByteArrayFromObj(objPtr, (int *)(void *)(sizePtr)) : \
		tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (size_t *)(void *)(sizePtr)))
#endif
#else
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
	((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \
		(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
	Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
	Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetUnicodeFromObj)(objPtr, (size_t *)(void *)(sizePtr)))
#endif

#ifdef TCL_MEM_DEBUG
#   undef Tcl_Alloc
#   define Tcl_Alloc(x) \
    (Tcl_DbCkalloc((x), __FILE__, __LINE__))
#   undef Tcl_Free







|



|



|














|




|





|












|



|



|







4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
#undef TclGetByteArrayFromObj
#undef Tcl_GetByteArrayFromObj
#if defined(USE_TCL_STUBS)
#   if TCL_MAJOR_VERSION < 9 || !defined(TCL_NO_DEPRECATED)
#	define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
		(sizeof(*(sizePtr)) <= sizeof(int) ? \
			tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \
			tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#	define Tcl_GetStringFromObj(objPtr, sizePtr) \
		(sizeof(*(sizePtr)) <= sizeof(int) ? \
			tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \
			tclStubsPtr->tcl_GetStringFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#	define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
		(sizeof(*(sizePtr)) <= sizeof(int) ? \
			tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \
			tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#   endif
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
	(tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \
		(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
	Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
	Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#if TCL_MAJOR_VERSION > 8
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \
		tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#else
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		tclStubsPtr->tclGetByteArrayFromObj(objPtr, (int *)(void *)(sizePtr)) : \
		tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#endif
#else
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetBytesFromObj)(interp, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
	((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \
		(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
	Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
	((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
	Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetStringFromObj)(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetBytesFromObj)(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
	(sizeof(*(sizePtr)) <= sizeof(int) ? \
		TclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \
		(Tcl_GetUnicodeFromObj)(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#endif

#ifdef TCL_MEM_DEBUG
#   undef Tcl_Alloc
#   define Tcl_Alloc(x) \
    (Tcl_DbCkalloc((x), __FILE__, __LINE__))
#   undef Tcl_Free
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
		: (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16)
#   define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \
		? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \
		: (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
#   undef Tcl_ListObjGetElements
#   define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
		? tclStubsPtr->tclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
		: tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)))
#   undef Tcl_ListObjLength
#   define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
		? tclStubsPtr->tclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \
		: tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr)))
#   undef Tcl_DictObjSize
#   define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
		? tclStubsPtr->tclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \
		: tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr)))
#   undef Tcl_SplitList
#   define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? tclStubsPtr->tclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
		: tclStubsPtr->tcl_SplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)))
#   undef Tcl_SplitPath
#   define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? tclStubsPtr->tclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \
		: tclStubsPtr->tcl_SplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr)))
#   undef Tcl_FSSplitPath
#   define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
		? tclStubsPtr->tclFSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \
		: tclStubsPtr->tcl_FSSplitPath((pathPtr), (size_t *)(void *)(lenPtr)))
#   undef Tcl_ParseArgsObjv
#   define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
		? tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
		: tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)))
#else
#   define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
		? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \
		: (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString)
#   define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
		? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \
		: (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString)
#   define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
		? (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToUniChar \
		: (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16)
#   define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \
		? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \
		: (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
#if !defined(BUILD_tcl) && !defined(TCL_NO_DEPRECATED)
#   define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
		? TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
		: (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)))
#   define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
		? TclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \
		: (Tcl_ListObjLength)((interp), (listPtr), (size_t *)(void *)(lengthPtr)))
#   define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
		? TclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \
		: (Tcl_DictObjSize)((interp), (dictPtr), (size_t *)(void *)(sizePtr)))
#   define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? TclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
		: (Tcl_SplitList)((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)))
#   define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? TclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \
		: (Tcl_SplitPath)((path), (size_t *)(void *)(argcPtr), (argvPtr)))
#   define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
		? TclFSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \
		: (Tcl_FSSplitPath)((pathPtr), (size_t *)(void *)(lenPtr)))
#   define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
		? TclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
		: (Tcl_ParseArgsObjv)((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)))
#endif /* !defined(BUILD_tcl) */
#endif

/*
 * Deprecated Tcl procedures:
 */








|



|



|



|



|



|



|
















|


|


|


|


|


|


|







4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
		: (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16)
#   define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \
		? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \
		: (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
#   undef Tcl_ListObjGetElements
#   define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
		? tclStubsPtr->tclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
		: tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr)))
#   undef Tcl_ListObjLength
#   define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
		? tclStubsPtr->tclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \
		: tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr)))
#   undef Tcl_DictObjSize
#   define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
		? tclStubsPtr->tclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \
		: tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr)))
#   undef Tcl_SplitList
#   define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? tclStubsPtr->tclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
		: tclStubsPtr->tcl_SplitList((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
#   undef Tcl_SplitPath
#   define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? tclStubsPtr->tclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \
		: tclStubsPtr->tcl_SplitPath((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
#   undef Tcl_FSSplitPath
#   define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
		? tclStubsPtr->tclFSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \
		: tclStubsPtr->tcl_FSSplitPath((pathPtr), (Tcl_Size *)(void *)(lenPtr)))
#   undef Tcl_ParseArgsObjv
#   define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
		? tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
		: tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv)))
#else
#   define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
		? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \
		: (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString)
#   define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
		? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \
		: (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString)
#   define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
		? (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToUniChar \
		: (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16)
#   define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \
		? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \
		: (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
#if !defined(BUILD_tcl) && !defined(TCL_NO_DEPRECATED)
#   define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
		? TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
		: (Tcl_ListObjGetElements)((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr)))
#   define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
		? TclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \
		: (Tcl_ListObjLength)((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr)))
#   define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
		? TclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \
		: (Tcl_DictObjSize)((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr)))
#   define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? TclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
		: (Tcl_SplitList)((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
#   define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
		? TclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \
		: (Tcl_SplitPath)((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
#   define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
		? TclFSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \
		: (Tcl_FSSplitPath)((pathPtr), (Tcl_Size *)(void *)(lenPtr)))
#   define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
		? TclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
		: (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv)))
#endif /* !defined(BUILD_tcl) */
#endif

/*
 * Deprecated Tcl procedures:
 */

Changes to generic/tclDictObj.c.

485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
    Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 64
    char localFlags[LOCAL_SIZE], *flagPtr = NULL;
    Dict *dict;
    ChainEntry *cPtr;
    Tcl_Obj *keyPtr, *valuePtr;
    size_t i, length;
    TCL_HASH_TYPE bytesNeeded = 0;
    const char *elem;
    char *dst;

    /*
     * This field is the most useful one in the whole hash structure, and it
     * is not exposed by any API function...
     */

    size_t numElems;

    DictGetInternalRep(dictPtr, dict);

    assert (dict != NULL);

    numElems = dict->table.numEntries * 2;








|









|







485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
    Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 64
    char localFlags[LOCAL_SIZE], *flagPtr = NULL;
    Dict *dict;
    ChainEntry *cPtr;
    Tcl_Obj *keyPtr, *valuePtr;
    Tcl_Size i, length;
    TCL_HASH_TYPE bytesNeeded = 0;
    const char *elem;
    char *dst;

    /*
     * This field is the most useful one in the whole hash structure, and it
     * is not exposed by any API function...
     */

    Tcl_Size numElems;

    DictGetInternalRep(dictPtr, dict);

    assert (dict != NULL);

    numElems = dict->table.numEntries * 2;

600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
    /*
     * Since lists and dictionaries have very closely-related string
     * representations (i.e. the same parsing code) we can safely special-case
     * the conversion from lists to dictionaries.
     */

    if (TclHasInternalRep(objPtr, &tclListType.objType)) {
	size_t objc, i;
	Tcl_Obj **objv;

	/* Cannot fail, we already know the Tcl_ObjType is "list". */
	TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
	if (objc & 1) {
	    goto missingValue;
	}







|







600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
    /*
     * Since lists and dictionaries have very closely-related string
     * representations (i.e. the same parsing code) we can safely special-case
     * the conversion from lists to dictionaries.
     */

    if (TclHasInternalRep(objPtr, &tclListType.objType)) {
	Tcl_Size objc, i;
	Tcl_Obj **objv;

	/* Cannot fail, we already know the Tcl_ObjType is "list". */
	TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
	if (objc & 1) {
	    goto missingValue;
	}
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

		TclDecrRefCount(discardedValue);
	    }
	    Tcl_SetHashValue(hPtr, objv[i+1]);
	    Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
	}
    } else {
	size_t length;
	const char *nextElem = Tcl_GetStringFromObj(objPtr, &length);
	const char *limit = (nextElem + length);

	while (nextElem < limit) {
	    Tcl_Obj *keyPtr, *valuePtr;
	    const char *elemStart;
	    size_t elemSize;
	    int literal;

	    if (TclFindDictElement(interp, nextElem, (limit - nextElem),
		    &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
		goto errorInFindDictElement;
	    }
	    if (elemStart == limit) {







|






|







630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

		TclDecrRefCount(discardedValue);
	    }
	    Tcl_SetHashValue(hPtr, objv[i+1]);
	    Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
	}
    } else {
	Tcl_Size length;
	const char *nextElem = Tcl_GetStringFromObj(objPtr, &length);
	const char *limit = (nextElem + length);

	while (nextElem < limit) {
	    Tcl_Obj *keyPtr, *valuePtr;
	    const char *elemStart;
	    Tcl_Size elemSize;
	    int literal;

	    if (TclFindDictElement(interp, nextElem, (limit - nextElem),
		    &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
		goto errorInFindDictElement;
	    }
	    if (elemStart == limit) {
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
    dict->refCount = 1;
    DictSetInternalRep(objPtr, dict);
    return TCL_OK;

  missingValue:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing value to go with key", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
    }
  errorInFindDictElement:
    DeleteChainTable(dict);
    Tcl_Free(dict);
    return TCL_ERROR;
}







|







713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
    dict->refCount = 1;
    DictSetInternalRep(objPtr, dict);
    return TCL_OK;

  missingValue:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing value to go with key", -1));
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
    }
  errorInFindDictElement:
    DeleteChainTable(dict);
    Tcl_Free(dict);
    return TCL_ERROR;
}
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclTraceDictPath(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    size_t keyc,
    Tcl_Obj *const keyv[],
    int flags)
{
    Dict *dict, *newDict;
    size_t i;

    DictGetInternalRep(dictPtr, dict);
    if (dict == NULL) {
	if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
	    return NULL;
	}
	DictGetInternalRep(dictPtr, dict);







|




|







775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclTraceDictPath(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    Tcl_Size keyc,
    Tcl_Obj *const keyv[],
    int flags)
{
    Dict *dict, *newDict;
    Tcl_Size i;

    DictGetInternalRep(dictPtr, dict);
    if (dict == NULL) {
	if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
	    return NULL;
	}
	DictGetInternalRep(dictPtr, dict);
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
 */

#undef Tcl_DictObjSize
int
Tcl_DictObjSize(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    size_t *sizePtr)
{
    Dict *dict;

    dict = GetDictFromObj(interp, dictPtr);
    if (dict == NULL) {
	return TCL_ERROR;
    }







|







1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
 */

#undef Tcl_DictObjSize
int
Tcl_DictObjSize(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    Tcl_Size *sizePtr)
{
    Dict *dict;

    dict = GetDictFromObj(interp, dictPtr);
    if (dict == NULL) {
	return TCL_ERROR;
    }
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
 *----------------------------------------------------------------------
 */

int
Tcl_DictObjPutKeyList(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    size_t keyc,
    Tcl_Obj *const keyv[],
    Tcl_Obj *valuePtr)
{
    Dict *dict;
    Tcl_HashEntry *hPtr;
    int isNew;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList");
    }
    if (keyc + 1 < 2) {
	Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList");
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }







|










|







1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
 *----------------------------------------------------------------------
 */

int
Tcl_DictObjPutKeyList(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    Tcl_Size keyc,
    Tcl_Obj *const keyv[],
    Tcl_Obj *valuePtr)
{
    Dict *dict;
    Tcl_HashEntry *hPtr;
    int isNew;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList");
    }
    if (keyc < 1) {
	Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList");
    }

    dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
    if (dictPtr == NULL) {
	return TCL_ERROR;
    }
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
 *----------------------------------------------------------------------
 */

int
Tcl_DictObjRemoveKeyList(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    size_t keyc,
    Tcl_Obj *const keyv[])
{
    Dict *dict;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList");
    }







|







1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
 *----------------------------------------------------------------------
 */

int
Tcl_DictObjRemoveKeyList(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    Tcl_Size keyc,
    Tcl_Obj *const keyv[])
{
    Dict *dict;

    if (Tcl_IsShared(dictPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList");
    }
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
DictSizeCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int result;
	size_t size;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
	return TCL_ERROR;
    }
    result = Tcl_DictObjSize(interp, objv[1], &size);
    if (result == TCL_OK) {







|







2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
DictSizeCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int result;
	Tcl_Size size;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
	return TCL_ERROR;
    }
    result = Tcl_DictObjSize(interp, objv[1], &size);
    if (result == TCL_OK) {
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129

    dict = GetDictFromObj(interp, objv[1]);
    if (dict == NULL) {
	return TCL_ERROR;
    }

    statsStr = Tcl_HashStats(&dict->table);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, TCL_INDEX_NONE));
    Tcl_Free(statsStr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129

    dict = GetDictFromObj(interp, objv[1]);
    if (dict == NULL) {
	return TCL_ERROR;
    }

    statsStr = Tcl_HashStats(&dict->table);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
    Tcl_Free(statsStr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj;
    Tcl_DictSearch *searchPtr;
    size_t varc;
    int done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVarName valueVarName} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
	return TCL_ERROR;
    }
    searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
    if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
	    &done) != TCL_OK) {
	TclStackFree(interp, searchPtr);







|

















|







2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj, *valueObj;
    Tcl_DictSearch *searchPtr;
    Tcl_Size varc;
    int done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVarName valueVarName} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
	return TCL_ERROR;
    }
    searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
    if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
	    &done) != TCL_OK) {
	TclStackFree(interp, searchPtr);
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **varv, *keyObj, *valueObj;
    DictMapStorage *storagePtr;
    size_t varc;
    int done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVarName valueVarName} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
	return TCL_ERROR;
    }
    storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage));
    if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
	    &valueObj, &done) != TCL_OK) {
	TclStackFree(interp, storagePtr);







|

















|







2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **varv, *keyObj, *valueObj;
    DictMapStorage *storagePtr;
    Tcl_Size varc;
    int done;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{keyVarName valueVarName} dictionary script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (varc != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have exactly two variable names", -1));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
	return TCL_ERROR;
    }
    storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage));
    if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
	    &valueObj, &done) != TCL_OK) {
	TclStackFree(interp, storagePtr);
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
    enum FilterTypes {
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    } index;
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int done, result, satisfied;
    size_t varc;
    const char *pattern;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",







|







2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
    enum FilterTypes {
	FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
    } index;
    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
    Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
    Tcl_DictSearch search;
    int done, result, satisfied;
    Tcl_Size varc;
    const char *pattern;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
	 */

	if (TclListObjGetElementsM(interp, objv[3], &varc, &varv) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (varc != 2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "must have exactly two variable names", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL);
	    return TCL_ERROR;
	}
	keyVarObj = varv[0];
	valueVarObj = varv[1];
	scriptObj = objv[4];








|







3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
	 */

	if (TclListObjGetElementsM(interp, objv[3], &varc, &varv) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (varc != 2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "must have exactly two variable names", -1));
	    Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL);
	    return TCL_ERROR;
	}
	keyVarObj = varv[0];
	valueVarObj = varv[1];
	scriptObj = objv[4];

3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *dictPtr, *objPtr;
    int i;
    size_t dummy;

    if (objc < 5 || !(objc & 1)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"dictVarName key varName ?key varName ...? script");
	return TCL_ERROR;
    }








|







3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *dictPtr, *objPtr;
    int i;
    Tcl_Size dummy;

    if (objc < 5 || !(objc & 1)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"dictVarName key varName ?key varName ...? script");
	return TCL_ERROR;
    }

3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
FinalizeDictUpdate(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj *dictPtr, *objPtr, **objv;
    Tcl_InterpState state;
    size_t i, objc;
    Tcl_Obj *varName = (Tcl_Obj *)data[0];
    Tcl_Obj *argsObj = (Tcl_Obj *)data[1];

    /*
     * ErrorInfo handling.
     */








|







3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
FinalizeDictUpdate(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj *dictPtr, *objPtr, **objv;
    Tcl_InterpState state;
    Tcl_Size i, objc;
    Tcl_Obj *varName = (Tcl_Obj *)data[0];
    Tcl_Obj *argsObj = (Tcl_Obj *)data[1];

    /*
     * ErrorInfo handling.
     */

3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
static int
FinalizeDictWith(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **pathv;
    size_t pathc;
    Tcl_InterpState state;
    Tcl_Obj *varName = (Tcl_Obj *)data[0];
    Tcl_Obj *keysPtr = (Tcl_Obj *)data[1];
    Tcl_Obj *pathPtr = (Tcl_Obj *)data[2];
    Var *varPtr, *arrayPtr;

    if (result == TCL_ERROR) {







|







3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
static int
FinalizeDictWith(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **pathv;
    Tcl_Size pathc;
    Tcl_InterpState state;
    Tcl_Obj *varName = (Tcl_Obj *)data[0];
    Tcl_Obj *keysPtr = (Tcl_Obj *)data[1];
    Tcl_Obj *pathPtr = (Tcl_Obj *)data[2];
    Var *varPtr, *arrayPtr;

    if (result == TCL_ERROR) {
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclDictWithInit(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    size_t pathc,
    Tcl_Obj *const pathv[])
{
    Tcl_DictSearch s;
    Tcl_Obj *keyPtr, *valPtr, *keysPtr;
    int done;

    if (pathc + 1 > 1) {
	dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
		DICT_PATH_READ);
	if (dictPtr == NULL) {
	    return NULL;
	}
    }








|






|







3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclDictWithInit(
    Tcl_Interp *interp,
    Tcl_Obj *dictPtr,
    Tcl_Size pathc,
    Tcl_Obj *const pathv[])
{
    Tcl_DictSearch s;
    Tcl_Obj *keyPtr, *valPtr, *keysPtr;
    int done;

    if (pathc > 0) {
	dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
		DICT_PATH_READ);
	if (dictPtr == NULL) {
	    return NULL;
	}
    }

3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
    int pathc,			/* The number of elements in the path into the
				 * dictionary. */
    Tcl_Obj *const pathv[],	/* The elements of the path to the subdict. */
    Tcl_Obj *keysPtr)		/* List of keys to be synchronized. This is
				 * the result value from TclDictWithInit. */
{
    Tcl_Obj *dictPtr, *leafPtr, *valPtr;
    size_t i, allocdict, keyc;
    Tcl_Obj **keyv;

    /*
     * If the dictionary variable doesn't exist, drop everything silently.
     */

    dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,







|







3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
    int pathc,			/* The number of elements in the path into the
				 * dictionary. */
    Tcl_Obj *const pathv[],	/* The elements of the path to the subdict. */
    Tcl_Obj *keysPtr)		/* List of keys to be synchronized. This is
				 * the result value from TclDictWithInit. */
{
    Tcl_Obj *dictPtr, *leafPtr, *valPtr;
    Tcl_Size i, allocdict, keyc;
    Tcl_Obj **keyv;

    /*
     * If the dictionary variable doesn't exist, drop everything silently.
     */

    dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,

Changes to generic/tclDisassemble.c.

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
static Tcl_Obj *	DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
static Tcl_Obj *	DisassembleByteCodeObj(Tcl_Obj *objPtr);
static int		FormatInstruction(ByteCode *codePtr,
			    const unsigned char *pc, Tcl_Obj *bufferObj);
static void		GetLocationInformation(Proc *procPtr,
			    Tcl_Obj **fileObjPtr, int *linePtr);
static void		PrintSourceToObj(Tcl_Obj *appendObj,
			    const char *stringPtr, size_t maxChars);
static void		UpdateStringOfInstName(Tcl_Obj *objPtr);

/*
 * The structure below defines an instruction name Tcl object to allow
 * reporting of inner contexts in errorstack without string allocation.
 */








|







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
static Tcl_Obj *	DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
static Tcl_Obj *	DisassembleByteCodeObj(Tcl_Obj *objPtr);
static int		FormatInstruction(ByteCode *codePtr,
			    const unsigned char *pc, Tcl_Obj *bufferObj);
static void		GetLocationInformation(Proc *procPtr,
			    Tcl_Obj **fileObjPtr, int *linePtr);
static void		PrintSourceToObj(Tcl_Obj *appendObj,
			    const char *stringPtr, Tcl_Size maxChars);
static void		UpdateStringOfInstName(Tcl_Obj *objPtr);

/*
 * The structure below defines an instruction name Tcl object to allow
 * reporting of inner contexts in errorstack without string allocation.
 */

190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
 */

void
TclPrintObject(
    FILE *outFile,		/* The file to print the source to. */
    Tcl_Obj *objPtr,		/* Points to the Tcl object whose string
				 * representation should be printed. */
    size_t maxChars)		/* Maximum number of chars to print. */
{
    char *bytes;
    size_t length;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}

/*
 *----------------------------------------------------------------------







|


|







190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
 */

void
TclPrintObject(
    FILE *outFile,		/* The file to print the source to. */
    Tcl_Obj *objPtr,		/* Points to the Tcl object whose string
				 * representation should be printed. */
    Tcl_Size maxChars)		/* Maximum number of chars to print. */
{
    char *bytes;
    Tcl_Size length;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}

/*
 *----------------------------------------------------------------------
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
 *----------------------------------------------------------------------
 */

void
TclPrintSource(
    FILE *outFile,		/* The file to print the source to. */
    const char *stringPtr,	/* The string to print. */
    size_t maxChars)		/* Maximum number of chars to print. */
{
    Tcl_Obj *bufferObj;

    TclNewObj(bufferObj);
    PrintSourceToObj(bufferObj, stringPtr, maxChars);
    fprintf(outFile, "%s", TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);







|







221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
 *----------------------------------------------------------------------
 */

void
TclPrintSource(
    FILE *outFile,		/* The file to print the source to. */
    const char *stringPtr,	/* The string to print. */
    Tcl_Size maxChars)		/* Maximum number of chars to print. */
{
    Tcl_Obj *bufferObj;

    TclNewObj(bufferObj);
    PrintSourceToObj(bufferObj, stringPtr, maxChars);
    fprintf(outFile, "%s", TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
    /*
     * Print header lines describing the ByteCode.
     */

    Tcl_AppendPrintfToObj(bufferObj,
	    "ByteCode %p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp %p (epoch %" TCL_Z_MODIFIER "u)\n",
	    codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch);
    Tcl_AppendToObj(bufferObj, "  Source ", TCL_INDEX_NONE);
    PrintSourceToObj(bufferObj, codePtr->source,
	    TclMin(codePtr->numSrcBytes, 55));
    GetLocationInformation(codePtr->procPtr, &fileObj, &line);
    if (line >= 0 && fileObj != NULL) {
	Tcl_AppendPrintfToObj(bufferObj, "\n  File \"%s\" Line %d",
		TclGetString(fileObj), line);
    }







|







276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
    /*
     * Print header lines describing the ByteCode.
     */

    Tcl_AppendPrintfToObj(bufferObj,
	    "ByteCode %p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp %p (epoch %" TCL_Z_MODIFIER "u)\n",
	    codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch);
    Tcl_AppendToObj(bufferObj, "  Source ", -1);
    PrintSourceToObj(bufferObj, codePtr->source,
	    TclMin(codePtr->numSrcBytes, 55));
    GetLocationInformation(codePtr->procPtr, &fileObj, &line);
    if (line >= 0 && fileObj != NULL) {
	Tcl_AppendPrintfToObj(bufferObj, "\n  File \"%s\" Line %d",
		TclGetString(fileObj), line);
    }
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
			(localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
			(localPtr->flags & VAR_ARRAY) ? ", array" : "",
			(localPtr->flags & VAR_LINK) ? ", link" : "",
			(localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
			(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
			(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
		if (TclIsVarTemporary(localPtr)) {
		    Tcl_AppendToObj(bufferObj, "\n", TCL_INDEX_NONE);
		} else {
		    Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
			    localPtr->name);
		}
		localPtr = localPtr->nextPtr;
	    }
	}







|







335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
			(localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
			(localPtr->flags & VAR_ARRAY) ? ", array" : "",
			(localPtr->flags & VAR_LINK) ? ", link" : "",
			(localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
			(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
			(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
		if (TclIsVarTemporary(localPtr)) {
		    Tcl_AppendToObj(bufferObj, "\n", -1);
		} else {
		    Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
			    localPtr->name);
		}
		localPtr = localPtr->nextPtr;
	    }
	}
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
     * If there were no commands (e.g., an expression or an empty string was
     * compiled), just print all instructions and return.
     */

    if (numCmds == 0) {
	pc = codeStart;
	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", TCL_INDEX_NONE);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
	return bufferObj;
    }

    /*
     * Print table showing the code offset, source offset, and source length







|







385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
     * If there were no commands (e.g., an expression or an empty string was
     * compiled), just print all instructions and return.
     */

    if (numCmds == 0) {
	pc = codeStart;
	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
	return bufferObj;
    }

    /*
     * Print table showing the code offset, source offset, and source length
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461

	Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
		((i % 2)? "     " : "\n   "),
		(i+1), codeOffset, (codeOffset + codeLen - 1),
		srcOffset, (srcOffset + srcLen - 1));
    }
    if (numCmds > 0) {
	Tcl_AppendToObj(bufferObj, "\n", TCL_INDEX_NONE);
    }

    /*
     * Print each instruction. If the instruction corresponds to the start of
     * a command, print the command's source. Note that we don't need the code
     * length here.
     */







|







447
448
449
450
451
452
453
454
455
456
457
458
459
460
461

	Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
		((i % 2)? "     " : "\n   "),
		(i+1), codeOffset, (codeOffset + codeLen - 1),
		srcOffset, (srcOffset + srcLen - 1));
    }
    if (numCmds > 0) {
	Tcl_AppendToObj(bufferObj, "\n", -1);
    }

    /*
     * Print each instruction. If the instruction corresponds to the start of
     * a command, print the command's source. Note that we don't need the code
     * length here.
     */
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
	}

	/*
	 * Print instructions before command i.
	 */

	while ((pc-codeStart) < codeOffset) {
	    Tcl_AppendToObj(bufferObj, "    ", TCL_INDEX_NONE);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}

	Tcl_AppendPrintfToObj(bufferObj, "  Command %d: ", i+1);
	PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
		TclMin(srcLen, 55));
	Tcl_AppendToObj(bufferObj, "\n", TCL_INDEX_NONE);
    }
    if (pc < codeLimit) {
	/*
	 * Print instructions after the last command.
	 */

	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", TCL_INDEX_NONE);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
    }
    return bufferObj;
}

/*







|






|







|







496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
	}

	/*
	 * Print instructions before command i.
	 */

	while ((pc-codeStart) < codeOffset) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}

	Tcl_AppendPrintfToObj(bufferObj, "  Command %d: ", i+1);
	PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
		TclMin(srcLen, 55));
	Tcl_AppendToObj(bufferObj, "\n", -1);
    }
    if (pc < codeLimit) {
	/*
	 * Print instructions after the last command.
	 */

	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
    }
    return bufferObj;
}

/*
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
	case OPERAND_NONE:
	default:
	    break;
	}
    }
    if (suffixObj) {
	const char *bytes;
	size_t length;

	Tcl_AppendToObj(bufferObj, "\t# ", TCL_INDEX_NONE);
	bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
	PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
    } else if (suffixBuffer[0]) {
	Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
	if (suffixSrc) {
	    PrintSourceToObj(bufferObj, suffixSrc, 40);
	}
    }
    Tcl_AppendToObj(bufferObj, "\n", TCL_INDEX_NONE);
    if (auxPtr && auxPtr->type->printProc) {
	Tcl_AppendToObj(bufferObj, "\t\t[", TCL_INDEX_NONE);
	auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
		pcOffset);
	Tcl_AppendToObj(bufferObj, "]\n", TCL_INDEX_NONE);
    }
    return numBytes;
}

/*
 *----------------------------------------------------------------------
 *







|

|








|

|


|







648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
	case OPERAND_NONE:
	default:
	    break;
	}
    }
    if (suffixObj) {
	const char *bytes;
	Tcl_Size length;

	Tcl_AppendToObj(bufferObj, "\t# ", -1);
	bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
	PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
    } else if (suffixBuffer[0]) {
	Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
	if (suffixSrc) {
	    PrintSourceToObj(bufferObj, suffixSrc, 40);
	}
    }
    Tcl_AppendToObj(bufferObj, "\n", -1);
    if (auxPtr && auxPtr->type->printProc) {
	Tcl_AppendToObj(bufferObj, "\t\t[", -1);
	auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
		pcOffset);
	Tcl_AppendToObj(bufferObj, "]\n", -1);
    }
    return numBytes;
}

/*
 *----------------------------------------------------------------------
 *
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700

Tcl_Obj *
TclGetInnerContext(
    Tcl_Interp *interp,
    const unsigned char *pc,
    Tcl_Obj **tosPtr)
{
    size_t objc = 0;
    Tcl_Obj *result;
    Interp *iPtr = (Interp *) interp;

    switch (*pc) {
    case INST_STR_LEN:
    case INST_LNOT:
    case INST_BITNOT:







|







686
687
688
689
690
691
692
693
694
695
696
697
698
699
700

Tcl_Obj *
TclGetInnerContext(
    Tcl_Interp *interp,
    const unsigned char *pc,
    Tcl_Obj **tosPtr)
{
    Tcl_Size objc = 0;
    Tcl_Obj *result;
    Interp *iPtr = (Interp *) interp;

    switch (*pc) {
    case INST_STR_LEN:
    case INST_LNOT:
    case INST_BITNOT:
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769

    result = iPtr->innerContext;
    if (Tcl_IsShared(result)) {
        Tcl_DecrRefCount(result);
        iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
        Tcl_IncrRefCount(result);
    } else {
        size_t len;

        /*
         * Reset while keeping the list internalrep as much as possible.
         */

	TclListObjLengthM(interp, result, &len);
        Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);







|







755
756
757
758
759
760
761
762
763
764
765
766
767
768
769

    result = iPtr->innerContext;
    if (Tcl_IsShared(result)) {
        Tcl_DecrRefCount(result);
        iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
        Tcl_IncrRefCount(result);
    } else {
        Tcl_Size len;

        /*
         * Reset while keeping the list internalrep as much as possible.
         */

	TclListObjLengthM(interp, result, &len);
        Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
 *----------------------------------------------------------------------
 */

static void
PrintSourceToObj(
    Tcl_Obj *appendObj,		/* The object to print the source to. */
    const char *stringPtr,	/* The string to print. */
    size_t maxChars)		/* Maximum number of chars to print. */
{
    const char *p;
    size_t i = 0, len;

    if (stringPtr == NULL) {
	Tcl_AppendToObj(appendObj, "\"\"", TCL_INDEX_NONE);
	return;
    }

    Tcl_AppendToObj(appendObj, "\"", TCL_INDEX_NONE);
    p = stringPtr;
    for (;  (*p != '\0') && (i < maxChars);  p+=len) {
	int ucs4;

	len = TclUtfToUCS4(p, &ucs4);
	switch (ucs4) {
	case '"':
	    Tcl_AppendToObj(appendObj, "\\\"", TCL_INDEX_NONE);
	    i += 2;
	    continue;
	case '\f':
	    Tcl_AppendToObj(appendObj, "\\f", TCL_INDEX_NONE);
	    i += 2;
	    continue;
	case '\n':
	    Tcl_AppendToObj(appendObj, "\\n", TCL_INDEX_NONE);
	    i += 2;
	    continue;
	case '\r':
	    Tcl_AppendToObj(appendObj, "\\r", TCL_INDEX_NONE);
	    i += 2;
	    continue;
	case '\t':
	    Tcl_AppendToObj(appendObj, "\\t", TCL_INDEX_NONE);
	    i += 2;
	    continue;
	case '\v':
	    Tcl_AppendToObj(appendObj, "\\v", TCL_INDEX_NONE);
	    i += 2;
	    continue;
	default:
	    if (ucs4 > 0xFFFF) {
		Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ucs4);
		i += 10;
	    } else if (ucs4 < 0x20 || ucs4 >= 0x7F) {
		Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ucs4);
		i += 6;
	    } else {
		Tcl_AppendPrintfToObj(appendObj, "%c", ucs4);
		i++;
	    }
	    continue;
	}
    }
    if (*p != '\0') {
	Tcl_AppendToObj(appendObj, "...", TCL_INDEX_NONE);
    }
    Tcl_AppendToObj(appendObj, "\"", TCL_INDEX_NONE);
}

/*
 *----------------------------------------------------------------------
 *
 * DisassembleByteCodeAsDicts --
 *







|


|


|



|







|



|



|



|



|



|

















|

|







856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
 *----------------------------------------------------------------------
 */

static void
PrintSourceToObj(
    Tcl_Obj *appendObj,		/* The object to print the source to. */
    const char *stringPtr,	/* The string to print. */
    Tcl_Size maxChars)		/* Maximum number of chars to print. */
{
    const char *p;
    Tcl_Size i = 0, len;

    if (stringPtr == NULL) {
	Tcl_AppendToObj(appendObj, "\"\"", -1);
	return;
    }

    Tcl_AppendToObj(appendObj, "\"", -1);
    p = stringPtr;
    for (;  (*p != '\0') && (i < maxChars);  p+=len) {
	int ucs4;

	len = TclUtfToUCS4(p, &ucs4);
	switch (ucs4) {
	case '"':
	    Tcl_AppendToObj(appendObj, "\\\"", -1);
	    i += 2;
	    continue;
	case '\f':
	    Tcl_AppendToObj(appendObj, "\\f", -1);
	    i += 2;
	    continue;
	case '\n':
	    Tcl_AppendToObj(appendObj, "\\n", -1);
	    i += 2;
	    continue;
	case '\r':
	    Tcl_AppendToObj(appendObj, "\\r", -1);
	    i += 2;
	    continue;
	case '\t':
	    Tcl_AppendToObj(appendObj, "\\t", -1);
	    i += 2;
	    continue;
	case '\v':
	    Tcl_AppendToObj(appendObj, "\\v", -1);
	    i += 2;
	    continue;
	default:
	    if (ucs4 > 0xFFFF) {
		Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ucs4);
		i += 10;
	    } else if (ucs4 < 0x20 || ucs4 >= 0x7F) {
		Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ucs4);
		i += 6;
	    } else {
		Tcl_AppendPrintfToObj(appendObj, "%c", ucs4);
		i++;
	    }
	    continue;
	}
    }
    if (*p != '\0') {
	Tcl_AppendToObj(appendObj, "...", -1);
    }
    Tcl_AppendToObj(appendObj, "\"", -1);
}

/*
 *----------------------------------------------------------------------
 *
 * DisassembleByteCodeAsDicts --
 *
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026

	for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) {
	    Tcl_Obj *descriptor[2];

	    TclNewObj(descriptor[0]);
	    if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("scalar", TCL_INDEX_NONE));
	    }
	    if (localPtr->flags & VAR_ARRAY) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("array", TCL_INDEX_NONE));
	    }
	    if (localPtr->flags & VAR_LINK) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("link", TCL_INDEX_NONE));
	    }
	    if (localPtr->flags & VAR_ARGUMENT) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("arg", TCL_INDEX_NONE));
	    }
	    if (localPtr->flags & VAR_TEMPORARY) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("temp", TCL_INDEX_NONE));
	    }
	    if (localPtr->flags & VAR_RESOLVED) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("resolved", TCL_INDEX_NONE));
	    }
	    if (localPtr->flags & VAR_TEMPORARY) {
		Tcl_ListObjAppendElement(NULL, variables,
			Tcl_NewListObj(1, descriptor));
	    } else {
		descriptor[1] = Tcl_NewStringObj(localPtr->name, TCL_INDEX_NONE);
		Tcl_ListObjAppendElement(NULL, variables,
			Tcl_NewListObj(2, descriptor));
	    }
	}
    }

    /*
     * Get the instructions from the bytecode.
     */

    TclNewObj(instructions);
    for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){
	const InstructionDesc *instDesc = &tclInstructionTable[*pc];
	int address = pc - codePtr->codeStart;

	TclNewObj(inst);
	Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
		instDesc->name, TCL_INDEX_NONE));
	opnd = pc + 1;
	for (i=0 ; i<instDesc->numOperands ; i++) {
	    switch (instDesc->opTypes[i]) {
	    case OPERAND_INT1:
		val = TclGetInt1AtPtr(opnd);
		opnd += 1;
		goto formatNumber;







|



|



|



|



|



|





|

















|







968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026

	for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) {
	    Tcl_Obj *descriptor[2];

	    TclNewObj(descriptor[0]);
	    if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("scalar", -1));
	    }
	    if (localPtr->flags & VAR_ARRAY) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("array", -1));
	    }
	    if (localPtr->flags & VAR_LINK) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("link", -1));
	    }
	    if (localPtr->flags & VAR_ARGUMENT) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("arg", -1));
	    }
	    if (localPtr->flags & VAR_TEMPORARY) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("temp", -1));
	    }
	    if (localPtr->flags & VAR_RESOLVED) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("resolved", -1));
	    }
	    if (localPtr->flags & VAR_TEMPORARY) {
		Tcl_ListObjAppendElement(NULL, variables,
			Tcl_NewListObj(1, descriptor));
	    } else {
		descriptor[1] = Tcl_NewStringObj(localPtr->name, -1);
		Tcl_ListObjAppendElement(NULL, variables,
			Tcl_NewListObj(2, descriptor));
	    }
	}
    }

    /*
     * Get the instructions from the bytecode.
     */

    TclNewObj(instructions);
    for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){
	const InstructionDesc *instDesc = &tclInstructionTable[*pc];
	int address = pc - codePtr->codeStart;

	TclNewObj(inst);
	Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
		instDesc->name, -1));
	opnd = pc + 1;
	for (i=0 ; i<instDesc->numOperands ; i++) {
	    switch (instDesc->opTypes[i]) {
	    case OPERAND_INT1:
		val = TclGetInt1AtPtr(opnd);
		opnd += 1;
		goto formatNumber;
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
		val = TclGetInt4AtPtr(opnd);
		opnd += 4;
		if (val >= -1) {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			    ".%d", val));
		} else if (val == -2) {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
			    ".end", TCL_INDEX_NONE));
		} else {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			    ".end-%d", -2-val));
		}
		break;
	    case OPERAND_AUX4:
		val = TclGetInt4AtPtr(opnd);







|







1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
		val = TclGetInt4AtPtr(opnd);
		opnd += 4;
		if (val >= -1) {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			    ".%d", val));
		} else if (val == -2) {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
			    ".end", -1));
		} else {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			    ".end-%d", -2-val));
		}
		break;
	    case OPERAND_AUX4:
		val = TclGetInt4AtPtr(opnd);
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
    /*
     * Get the auxiliary data from the bytecode.
     */

    TclNewObj(aux);
    for (i=0 ; i<(int)codePtr->numAuxDataItems ; i++) {
	AuxData *auxData = &codePtr->auxDataArrayPtr[i];
	Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, TCL_INDEX_NONE);

	if (auxData->type->disassembleProc) {
	    Tcl_Obj *desc;

	    TclNewObj(desc);
	    Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", TCL_INDEX_NONE), auxDesc);
	    auxDesc = desc;
	    auxData->type->disassembleProc(auxData->clientData, auxDesc,
		    codePtr, 0);
	} else if (auxData->type->printProc) {
	    Tcl_Obj *desc;

	    TclNewObj(desc);







|





|







1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
    /*
     * Get the auxiliary data from the bytecode.
     */

    TclNewObj(aux);
    for (i=0 ; i<(int)codePtr->numAuxDataItems ; i++) {
	AuxData *auxData = &codePtr->auxDataArrayPtr[i];
	Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);

	if (auxData->type->disassembleProc) {
	    Tcl_Obj *desc;

	    TclNewObj(desc);
	    Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc);
	    auxDesc = desc;
	    auxData->type->disassembleProc(auxData->clientData, auxDesc,
		    codePtr, 0);
	} else if (auxData->type->printProc) {
	    Tcl_Obj *desc;

	    TclNewObj(desc);
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
	Tcl_Obj *cmd;

	codeOffset += Decode(codeOffPtr);
	codeLength = Decode(codeLenPtr);
	sourceOffset += Decode(srcOffPtr);
	sourceLength = Decode(srcLenPtr);
	TclNewObj(cmd);
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", TCL_INDEX_NONE),
		Tcl_NewWideIntObj(codeOffset));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", TCL_INDEX_NONE),
		Tcl_NewWideIntObj(codeOffset + codeLength - 1));

	/*
	 * Convert byte offsets to character offsets; important if multibyte
	 * characters are present in the source!
	 */

	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", TCL_INDEX_NONE),
		Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
			sourceOffset)));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", TCL_INDEX_NONE),
		Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
			sourceOffset + sourceLength - 1)));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", TCL_INDEX_NONE),
		Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
	Tcl_ListObjAppendElement(NULL, commands, cmd);
    }

#undef Decode

    /*
     * Get the source file and line number information from the CmdFrame
     * system if it is available.
     */

    GetLocationInformation(codePtr->procPtr, &file, &line);

    /*
     * Build the overall result.
     */

    TclNewObj(description);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", TCL_INDEX_NONE),
	    literals);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", TCL_INDEX_NONE),
	    variables);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", TCL_INDEX_NONE), exn);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", TCL_INDEX_NONE),
	    instructions);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", TCL_INDEX_NONE), aux);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", TCL_INDEX_NONE),
	    commands);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", TCL_INDEX_NONE),
	    Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", TCL_INDEX_NONE),
	    Tcl_NewStringObj(codePtr->nsPtr->fullName, TCL_INDEX_NONE));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", TCL_INDEX_NONE),
	    Tcl_NewWideIntObj(codePtr->maxStackDepth));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", TCL_INDEX_NONE),
	    Tcl_NewWideIntObj(codePtr->maxExceptDepth));
    if (line >= 0) {
	Tcl_DictObjPut(NULL, description,
		Tcl_NewStringObj("initiallinenumber", TCL_INDEX_NONE),
		Tcl_NewWideIntObj(line));
    }
    if (file) {
	Tcl_DictObjPut(NULL, description,
		Tcl_NewStringObj("sourcefile", TCL_INDEX_NONE), file);
    }
    return description;
}

/*
 *----------------------------------------------------------------------
 *







|

|







|


|


|


















|

|

|
|

|
|

|

|
|
|

|



|




|







1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
	Tcl_Obj *cmd;

	codeOffset += Decode(codeOffPtr);
	codeLength = Decode(codeLenPtr);
	sourceOffset += Decode(srcOffPtr);
	sourceLength = Decode(srcLenPtr);
	TclNewObj(cmd);
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1),
		Tcl_NewWideIntObj(codeOffset));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1),
		Tcl_NewWideIntObj(codeOffset + codeLength - 1));

	/*
	 * Convert byte offsets to character offsets; important if multibyte
	 * characters are present in the source!
	 */

	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
		Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
			sourceOffset)));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
		Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
			sourceOffset + sourceLength - 1)));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
		Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
	Tcl_ListObjAppendElement(NULL, commands, cmd);
    }

#undef Decode

    /*
     * Get the source file and line number information from the CmdFrame
     * system if it is available.
     */

    GetLocationInformation(codePtr->procPtr, &file, &line);

    /*
     * Build the overall result.
     */

    TclNewObj(description);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1),
	    literals);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1),
	    variables);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1),
	    instructions);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1),
	    commands);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1),
	    Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1),
	    Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1),
	    Tcl_NewWideIntObj(codePtr->maxStackDepth));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
	    Tcl_NewWideIntObj(codePtr->maxExceptDepth));
    if (line >= 0) {
	Tcl_DictObjPut(NULL, description,
		Tcl_NewStringObj("initiallinenumber", -1),
		Tcl_NewWideIntObj(line));
    }
    if (file) {
	Tcl_DictObjPut(NULL, description,
		Tcl_NewStringObj("sourcefile", -1), file);
    }
    return description;
}

/*
 *----------------------------------------------------------------------
 *
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "CONSRUCTOR", NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod(methodPtr);
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of constructor", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Compile if necessary.







|







1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "CONSRUCTOR", NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod(methodPtr);
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of constructor", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Compile if necessary.
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "DESRUCTOR", NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod(methodPtr);
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of destructor", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Compile if necessary.







|







1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "DESRUCTOR", NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod(methodPtr);
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of destructor", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Compile if necessary.
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(objv[3]), NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of method", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}
	if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
	    Command cmd;








|







1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(objv[3]), NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of method", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}
	if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
	    Command cmd;

1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
     * Do the actual disassembly.
     */

    ByteCodeGetInternalRep(codeObjPtr, &tclByteCodeType, codePtr);

    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not disassemble prebuilt bytecode", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		"BYTECODE", NULL);
	return TCL_ERROR;
    }
    if (clientData) {
	Tcl_SetObjResult(interp,
		DisassembleByteCodeAsDicts(codeObjPtr));







|







1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
     * Do the actual disassembly.
     */

    ByteCodeGetInternalRep(codeObjPtr, &tclByteCodeType, codePtr);

    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not disassemble prebuilt bytecode", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		"BYTECODE", NULL);
	return TCL_ERROR;
    }
    if (clientData) {
	Tcl_SetObjResult(interp,
		DisassembleByteCodeAsDicts(codeObjPtr));

Changes to generic/tclEncoding.c.

1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
	dstCharsPtr = &dstChars;
	flags &= ~TCL_ENCODING_CHAR_LIMIT;
    } else if (charLimited) {
	maxChars = *dstCharsPtr;
    }

    if (!noTerminate) {
	if ((int) dstLen < 1) {
	    return TCL_CONVERT_NOSPACE;
	}
	/*
	 * If there are any null characters in the middle of the buffer,
	 * they will converted to the UTF-8 null character (\xC0\x80). To get
	 * the actual \0 at the end of the destination buffer, we need to
	 * append it manually.  First make room for it...
	 */








|
|
|







1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
	dstCharsPtr = &dstChars;
	flags &= ~TCL_ENCODING_CHAR_LIMIT;
    } else if (charLimited) {
	maxChars = *dstCharsPtr;
    }

    if (!noTerminate) {
        if (dstLen < 1) {
            return TCL_CONVERT_NOSPACE;
        }
	/*
	 * If there are any null characters in the middle of the buffer,
	 * they will converted to the UTF-8 null character (\xC0\x80). To get
	 * the actual \0 at the end of the destination buffer, we need to
	 * append it manually.  First make room for it...
	 */

1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
	 *     of a multibyte character
	 * In both cases we have to grow buffer, move the input source pointer
	 * and loop. Otherwise, return the result we got.
	 */
	if ((result != TCL_CONVERT_NOSPACE) &&
	    !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) {
	    Tcl_Size nBytesProcessed = (src - srcStart);
	    size_t i = soFar + encodingPtr->nullSize - 1;
	    /* Loop as DStringSetLength only stores one nul byte at a time */
	    while (i+1 >= soFar+1) {
		Tcl_DStringSetLength(dstPtr, i--);
	    }
	    if (errorLocPtr) {
		/*
		 * Do not write error message into interpreter if caller
		 * wants to know error location.
		 */







|

|







1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
	 *     of a multibyte character
	 * In both cases we have to grow buffer, move the input source pointer
	 * and loop. Otherwise, return the result we got.
	 */
	if ((result != TCL_CONVERT_NOSPACE) &&
	    !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) {
	    Tcl_Size nBytesProcessed = (src - srcStart);
	    Tcl_Size i = soFar + encodingPtr->nullSize - 1;
	    /* Loop as DStringSetLength only stores one nul byte at a time */
	    while (i >= soFar) {
		Tcl_DStringSetLength(dstPtr, i--);
	    }
	    if (errorLocPtr) {
		/*
		 * Do not write error message into interpreter if caller
		 * wants to know error location.
		 */

Changes to generic/tclEnsemble.c.

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

/*
 * The internal rep for caching ensemble subcommand lookups and spelling
 * corrections.
 */

typedef struct {
    size_t epoch;               /* Used to confirm when the data in this
                                 * really structure matches up with the
                                 * ensemble. */
    Command *token;             /* Reference to the command for which this
                                 * structure is a cache of the resolution. */
    Tcl_Obj *fix;               /* Corrected spelling, if needed. */
    Tcl_HashEntry *hPtr;        /* Direct link to entry in the subcommand hash
                                 * table. */
} EnsembleCmdRep;

static inline Tcl_Obj *
NewNsObj(
    Tcl_Namespace *namespacePtr)
{
    Namespace *nsPtr = (Namespace *) namespacePtr;

    if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
	return Tcl_NewStringObj("::", 2);
    }
    return Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
}

/*
 *----------------------------------------------------------------------
 *
 * TclNamespaceEnsembleCmd --
 *







|


















|







102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

/*
 * The internal rep for caching ensemble subcommand lookups and spelling
 * corrections.
 */

typedef struct {
    Tcl_Size epoch;               /* Used to confirm when the data in this
                                 * really structure matches up with the
                                 * ensemble. */
    Command *token;             /* Reference to the command for which this
                                 * structure is a cache of the resolution. */
    Tcl_Obj *fix;               /* Corrected spelling, if needed. */
    Tcl_HashEntry *hPtr;        /* Direct link to entry in the subcommand hash
                                 * table. */
} EnsembleCmdRep;

static inline Tcl_Obj *
NewNsObj(
    Tcl_Namespace *namespacePtr)
{
    Namespace *nsPtr = (Namespace *) namespacePtr;

    if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
	return Tcl_NewStringObj("::", 2);
    }
    return Tcl_NewStringObj(nsPtr->fullName, -1);
}

/*
 *----------------------------------------------------------------------
 *
 * TclNamespaceEnsembleCmd --
 *
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
	    "subcommand", 0, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case ENS_CREATE: {
	const char *name;
	size_t len;
	int allocatedMapFlag = 0;
	/*
	 * Defaults
	 */
	Tcl_Obj *subcmdObj = NULL;
	Tcl_Obj *mapObj = NULL;
	int permitPrefix = 1;







|







185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
	    "subcommand", 0, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case ENS_CREATE: {
	const char *name;
	Tcl_Size len;
	int allocatedMapFlag = 0;
	/*
	 * Defaults
	 */
	Tcl_Obj *subcmdObj = NULL;
	Tcl_Obj *mapObj = NULL;
	int permitPrefix = 1;
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
		    if (len < 1) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"ensemble subcommand implementations "
				"must be non-empty lists", TCL_INDEX_NONE));
			Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				"EMPTY_TARGET", NULL);
			Tcl_DictObjDone(&search);
			if (patchedDict) {
			    Tcl_DecrRefCount(patchedDict);
			}
			if (allocatedMapFlag) {







|







285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
		    if (len < 1) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"ensemble subcommand implementations "
				"must be non-empty lists", -1));
			Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				"EMPTY_TARGET", NULL);
			Tcl_DictObjDone(&search);
			if (patchedDict) {
			    Tcl_DecrRefCount(patchedDict);
			}
			if (allocatedMapFlag) {
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
	    Tcl_Obj *resultObj, *tmpObj = NULL;	/* silence gcc 4 warning */
	    int flags = 0;			/* silence gcc 4 warning */

	    TclNewObj(resultObj);

	    /* -map option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], TCL_INDEX_NONE));
	    Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -namespace option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
			    -1));
	    namespacePtr = NULL;		/* silence gcc 4 warning */
	    Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
	    Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));

	    /* -parameters option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], TCL_INDEX_NONE));
	    Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -prefix option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], TCL_INDEX_NONE));
	    Tcl_GetEnsembleFlags(NULL, token, &flags);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));

	    /* -subcommands option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1));
	    Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -unknown option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
	    Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    Tcl_SetObjResult(interp, resultObj);
	} else {
	    size_t len;
	    int allocatedMapFlag = 0;
	    Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
		    *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
	    int permitPrefix, flags = 0;	/* silence gcc 4 warning */

	    Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
	    Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);







|














|






|




















|







456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
	    Tcl_Obj *resultObj, *tmpObj = NULL;	/* silence gcc 4 warning */
	    int flags = 0;			/* silence gcc 4 warning */

	    TclNewObj(resultObj);

	    /* -map option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1));
	    Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -namespace option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
			    -1));
	    namespacePtr = NULL;		/* silence gcc 4 warning */
	    Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
	    Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));

	    /* -parameters option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1));
	    Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -prefix option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1));
	    Tcl_GetEnsembleFlags(NULL, token, &flags);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));

	    /* -subcommands option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1));
	    Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    /* -unknown option */
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
	    Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    (tmpObj != NULL) ? tmpObj : Tcl_NewObj());

	    Tcl_SetObjResult(interp, resultObj);
	} else {
	    Tcl_Size len;
	    int allocatedMapFlag = 0;
	    Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
		    *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
	    int permitPrefix, flags = 0;	/* silence gcc 4 warning */

	    Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
	    Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
			}
			if (len < 1) {
			    Tcl_SetObjResult(interp, Tcl_NewStringObj(
				    "ensemble subcommand implementations "
				    "must be non-empty lists", TCL_INDEX_NONE));
			    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				    "EMPTY_TARGET", NULL);
			    Tcl_DictObjDone(&search);
			    if (patchedDict) {
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;







|







573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
			}
			if (len < 1) {
			    Tcl_SetObjResult(interp, Tcl_NewStringObj(
				    "ensemble subcommand implementations "
				    "must be non-empty lists", -1));
			    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				    "EMPTY_TARGET", NULL);
			    Tcl_DictObjDone(&search);
			    if (patchedDict) {
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
		    if (patchedDict) {
			allocatedMapFlag = 1;
		    }
		    continue;
		}
		case CONF_NAMESPACE:
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "option -namespace is read-only", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
			    NULL);
		    goto freeMapAndError;
		case CONF_PREFIX:
		    if (Tcl_GetBooleanFromObj(interp, objv[1],
			    &permitPrefix) != TCL_OK) {
			goto freeMapAndError;







|







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
		    if (patchedDict) {
			allocatedMapFlag = 1;
		    }
		    continue;
		}
		case CONF_NAMESPACE:
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "option -namespace is read-only", -1));
		    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
			    NULL);
		    goto freeMapAndError;
		case CONF_PREFIX:
		    if (Tcl_GetBooleanFromObj(interp, objv[1],
			    &permitPrefix) != TCL_OK) {
			goto freeMapAndError;
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (subcmdList != NULL) {
	size_t length;

	if (TclListObjLengthM(interp, subcmdList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    subcmdList = NULL;
	}







|




|







794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (subcmdList != NULL) {
	Tcl_Size length;

	if (TclListObjLengthM(interp, subcmdList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    subcmdList = NULL;
	}
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj *paramList)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;
    size_t length;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (paramList == NULL) {
	length = 0;
    } else {
	if (TclListObjLengthM(interp, paramList, &length) != TCL_OK) {







|



|







866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
    Tcl_Interp *interp,
    Tcl_Command token,
    Tcl_Obj *paramList)
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;
    Tcl_Size length;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (paramList == NULL) {
	length = 0;
    } else {
	if (TclListObjLengthM(interp, paramList, &length) != TCL_OK) {
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldDict;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (mapDict != NULL) {
	size_t size;
	int done;
	Tcl_DictSearch search;
	Tcl_Obj *valuePtr;

	if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
	    return TCL_ERROR;
	}







|




|







946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldDict;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (mapDict != NULL) {
	Tcl_Size size;
	int done;
	Tcl_DictSearch search;
	Tcl_Obj *valuePtr;

	if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
	    return TCL_ERROR;
	}
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (unknownList != NULL) {
	size_t length;

	if (TclListObjLengthM(interp, unknownList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    unknownList = NULL;
	}







|




|







1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    Tcl_Obj *oldList;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }
    if (unknownList != NULL) {
	Tcl_Size length;

	if (TclListObjLengthM(interp, unknownList, &length) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (length < 1) {
	    unknownList = NULL;
	}
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    int wasCompiled;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;








|







1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;
    int wasCompiled;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"command is not an ensemble", -1));
	Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;

1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *subcmdListPtr = ensemblePtr->subcmdList;







|







1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *subcmdListPtr = ensemblePtr->subcmdList;
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *paramListPtr = ensemblePtr->parameterList;







|







1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *paramListPtr = ensemblePtr->parameterList;
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *mapDictPtr = ensemblePtr->subcommandDict;







|







1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *mapDictPtr = ensemblePtr->subcommandDict;
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *unknownListPtr = ensemblePtr->unknownHandler;







|







1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *unknownListPtr = ensemblePtr->unknownHandler;
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *flagsPtr = ensemblePtr->flags;







|







1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *flagsPtr = ensemblePtr->flags;
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;







|







1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
{
    Command *cmdPtr = (Command *) token;
    EnsembleConfig *ensemblePtr;

    if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command is not an ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
	}
	return TCL_ERROR;
    }

    ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
    *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
    const EnsembleImplMap map[]) /* The subcommands to create */
{
    Tcl_Command ensemble;
    Tcl_Namespace *ns;
    Tcl_DString buf, hiddenBuf;
    const char **nameParts = NULL;
    const char *cmdName = NULL;
    size_t i, nameCount = 0;
    int ensembleFlags = 0, hiddenLen;

    /*
     * Construct the path for the ensemble namespace and create it.
     */

    Tcl_DStringInit(&buf);
    Tcl_DStringInit(&hiddenBuf);
    TclDStringAppendLiteral(&hiddenBuf, "tcl:");
    Tcl_DStringAppend(&hiddenBuf, name, TCL_INDEX_NONE);
    TclDStringAppendLiteral(&hiddenBuf, ":");
    hiddenLen = Tcl_DStringLength(&hiddenBuf);
    if (name[0] == ':' && name[1] == ':') {
	/*
	 * An absolute name, so use it directly.
	 */

	cmdName = name;
	Tcl_DStringAppend(&buf, name, TCL_INDEX_NONE);
	ensembleFlags = TCL_ENSEMBLE_PREFIX;
    } else {
	/*
	 * Not an absolute name, so do munging of it. Note that this treats a
	 * multi-word list differently to a single word.
	 */

	TclDStringAppendLiteral(&buf, "::tcl");

	if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
	    Tcl_Panic("invalid ensemble name '%s'", name);
	}

	for (i = 0; i < nameCount; ++i) {
	    TclDStringAppendLiteral(&buf, "::");
	    Tcl_DStringAppend(&buf, nameParts[i], TCL_INDEX_NONE);
	}
    }

    ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
	    TCL_CREATE_NS_IF_UNKNOWN);
    if (!ns) {
	Tcl_Panic("unable to find or create %s namespace!",







|









|








|















|







1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
    const EnsembleImplMap map[]) /* The subcommands to create */
{
    Tcl_Command ensemble;
    Tcl_Namespace *ns;
    Tcl_DString buf, hiddenBuf;
    const char **nameParts = NULL;
    const char *cmdName = NULL;
    Tcl_Size i, nameCount = 0;
    int ensembleFlags = 0, hiddenLen;

    /*
     * Construct the path for the ensemble namespace and create it.
     */

    Tcl_DStringInit(&buf);
    Tcl_DStringInit(&hiddenBuf);
    TclDStringAppendLiteral(&hiddenBuf, "tcl:");
    Tcl_DStringAppend(&hiddenBuf, name, -1);
    TclDStringAppendLiteral(&hiddenBuf, ":");
    hiddenLen = Tcl_DStringLength(&hiddenBuf);
    if (name[0] == ':' && name[1] == ':') {
	/*
	 * An absolute name, so use it directly.
	 */

	cmdName = name;
	Tcl_DStringAppend(&buf, name, -1);
	ensembleFlags = TCL_ENSEMBLE_PREFIX;
    } else {
	/*
	 * Not an absolute name, so do munging of it. Note that this treats a
	 * multi-word list differently to a single word.
	 */

	TclDStringAppendLiteral(&buf, "::tcl");

	if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
	    Tcl_Panic("invalid ensemble name '%s'", name);
	}

	for (i = 0; i < nameCount; ++i) {
	    TclDStringAppendLiteral(&buf, "::");
	    Tcl_DStringAppend(&buf, nameParts[i], -1);
	}
    }

    ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
	    TCL_CREATE_NS_IF_UNKNOWN);
    if (!ns) {
	Tcl_Panic("unable to find or create %s namespace!",
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
    if (ensemble != NULL) {
	Tcl_Obj *mapDict, *fromObj, *toObj;
	Command *cmdPtr;

	TclDStringAppendLiteral(&buf, "::");
	TclNewObj(mapDict);
	for (i=0 ; map[i].name != NULL ; i++) {
	    fromObj = Tcl_NewStringObj(map[i].name, TCL_INDEX_NONE);
	    TclNewStringObj(toObj, Tcl_DStringValue(&buf),
		    Tcl_DStringLength(&buf));
	    Tcl_AppendToObj(toObj, map[i].name, TCL_INDEX_NONE);
	    Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);

	    if (map[i].proc || map[i].nreProc) {
		/*
		 * If the command is unsafe, hide it when we're in a safe
		 * interpreter. The code to do this is really hokey! It also
		 * doesn't work properly yet; this function is always
		 * currently called before the safe-interp flag is set so the
		 * Tcl_IsSafe check fails.
		 */

		if (map[i].unsafe && Tcl_IsSafe(interp)) {
		    cmdPtr = (Command *)
			    Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
			    map[i].nreProc, map[i].clientData, NULL);
		    Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
		    if (Tcl_HideCommand(interp, "___tmp",
			    Tcl_DStringAppend(&hiddenBuf, map[i].name, TCL_INDEX_NONE))) {
			Tcl_Panic("%s", Tcl_GetStringResult(interp));
		    }
		} else {
		    /*
		     * Not hidden, so just create it. Yay!
		     */








|


|

















|







1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
    if (ensemble != NULL) {
	Tcl_Obj *mapDict, *fromObj, *toObj;
	Command *cmdPtr;

	TclDStringAppendLiteral(&buf, "::");
	TclNewObj(mapDict);
	for (i=0 ; map[i].name != NULL ; i++) {
	    fromObj = Tcl_NewStringObj(map[i].name, -1);
	    TclNewStringObj(toObj, Tcl_DStringValue(&buf),
		    Tcl_DStringLength(&buf));
	    Tcl_AppendToObj(toObj, map[i].name, -1);
	    Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);

	    if (map[i].proc || map[i].nreProc) {
		/*
		 * If the command is unsafe, hide it when we're in a safe
		 * interpreter. The code to do this is really hokey! It also
		 * doesn't work properly yet; this function is always
		 * currently called before the safe-interp flag is set so the
		 * Tcl_IsSafe check fails.
		 */

		if (map[i].unsafe && Tcl_IsSafe(interp)) {
		    cmdPtr = (Command *)
			    Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
			    map[i].nreProc, map[i].clientData, NULL);
		    Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
		    if (Tcl_HideCommand(interp, "___tmp",
			    Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
			Tcl_Panic("%s", Tcl_GetStringResult(interp));
		    }
		} else {
		    /*
		     * Not hidden, so just create it. Yay!
		     */

1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
				 * subcommand. */
    Tcl_HashEntry *hPtr;	/* Used for efficient lookup of fully
				 * specified but not yet cached command
				 * names. */
    int reparseCount = 0;	/* Number of reparses. */
    Tcl_Obj *errorObj;		/* Used for building error messages. */
    Tcl_Obj *subObj;
    size_t subIdx;

    /*
     * Must recheck objc since numParameters might have changed. See test
     * namespace-53.9.
     */

  restartEnsembleParse:
    subIdx = 1 + ensemblePtr->numParameters;
    if ((size_t)objc < subIdx + 1) {
	/*
	 * No subcommand argument. Make error message.
	 */

	Tcl_DString buf;	/* Message being built */

	Tcl_DStringInit(&buf);
	if (ensemblePtr->parameterList) {
	    Tcl_DStringAppend(&buf,
		    TclGetString(ensemblePtr->parameterList), TCL_INDEX_NONE);
	    TclDStringAppendLiteral(&buf, " ");
	}
	TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
	Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
	Tcl_DStringFree(&buf);

	return TCL_ERROR;
    }

    if (ensemblePtr->nsPtr->flags & NS_DEAD) {
	/*
	 * Don't know how we got here, but make things give up quickly.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "ensemble activated for deleted namespace", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
	}
	return TCL_ERROR;
    }

    /*
     * If the table of subcommands is valid just lookup up the command there







|








|









|
















|







1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
				 * subcommand. */
    Tcl_HashEntry *hPtr;	/* Used for efficient lookup of fully
				 * specified but not yet cached command
				 * names. */
    int reparseCount = 0;	/* Number of reparses. */
    Tcl_Obj *errorObj;		/* Used for building error messages. */
    Tcl_Obj *subObj;
    Tcl_Size subIdx;

    /*
     * Must recheck objc since numParameters might have changed. See test
     * namespace-53.9.
     */

  restartEnsembleParse:
    subIdx = 1 + ensemblePtr->numParameters;
    if (objc < subIdx + 1) {
	/*
	 * No subcommand argument. Make error message.
	 */

	Tcl_DString buf;	/* Message being built */

	Tcl_DStringInit(&buf);
	if (ensemblePtr->parameterList) {
	    Tcl_DStringAppend(&buf,
		    TclGetString(ensemblePtr->parameterList), -1);
	    TclDStringAppendLiteral(&buf, " ");
	}
	TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
	Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
	Tcl_DStringFree(&buf);

	return TCL_ERROR;
    }

    if (ensemblePtr->nsPtr->flags & NS_DEAD) {
	/*
	 * Don't know how we got here, but make things give up quickly.
	 */

	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "ensemble activated for deleted namespace", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
	}
	return TCL_ERROR;
    }

    /*
     * If the table of subcommands is valid just lookup up the command there
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
	 * the export table, scan the sorted array for matches.
	 */

	const char *subcmdName; /* Name of the subcommand or unique prefix of
				 * it (a non-unique prefix produces an error).
				 */
	char *fullName = NULL;	/* Full name of the subcommand. */
	size_t stringLength, i;
	size_t tableLength = ensemblePtr->subcommandTable.numEntries;
	Tcl_Obj *fix;

	subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
	for (i=0 ; i<tableLength ; i++) {
	    int cmp = strncmp(subcmdName,
		    ensemblePtr->subcommandArrayPtr[i],
		    stringLength);







|
|







1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
	 * the export table, scan the sorted array for matches.
	 */

	const char *subcmdName; /* Name of the subcommand or unique prefix of
				 * it (a non-unique prefix produces an error).
				 */
	char *fullName = NULL;	/* Full name of the subcommand. */
	Tcl_Size stringLength, i;
	Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries;
	Tcl_Obj *fix;

	subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
	for (i=0 ; i<tableLength ; i++) {
	    int cmp = strncmp(subcmdName,
		    ensemblePtr->subcommandArrayPtr[i],
		    stringLength);
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
		    fullName);
	}

	/*
	 * Record the spelling correction for usage message.
	 */

	fix = Tcl_NewStringObj(fullName, TCL_INDEX_NONE);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
	TclSpellFix(interp, objv, objc, subIdx, subObj, fix);







|







1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
		    fullName);
	}

	/*
	 * Record the spelling correction for usage message.
	 */

	fix = Tcl_NewStringObj(fullName, -1);

	/*
	 * Cache for later in the subcommand object.
	 */

	MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
	TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
     * but don't do that because caching of the command object should help.
     */

    {
	Tcl_Obj *copyPtr;	/* The list of words to dispatch on.
				 * Will be freed by the dispatch engine. */
	Tcl_Obj **copyObjv;
	size_t copyObjc, prefixObjc;

	TclListObjLengthM(NULL, prefixObj, &prefixObjc);

	if (objc == 2) {
	    copyPtr = TclListObjCopy(NULL, prefixObj);
	} else {
	    copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);







|







1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
     * but don't do that because caching of the command object should help.
     */

    {
	Tcl_Obj *copyPtr;	/* The list of words to dispatch on.
				 * Will be freed by the dispatch engine. */
	Tcl_Obj **copyObjv;
	Tcl_Size copyObjc, prefixObjc;

	TclListObjLengthM(NULL, prefixObj, &prefixObjc);

	if (objc == 2) {
	    copyPtr = TclListObjCopy(NULL, prefixObj);
	} else {
	    copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
		ensemblePtr->nsPtr->fullName));
	return TCL_ERROR;
    }
    errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
	    (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
	    TclGetString(subObj));
    if (ensemblePtr->subcommandTable.numEntries == 1) {
	Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], TCL_INDEX_NONE);
    } else {
	size_t i;

	for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
	    Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], TCL_INDEX_NONE);
	    Tcl_AppendToObj(errorObj, ", ", 2);
	}
	Tcl_AppendPrintfToObj(errorObj, "or %s",
		ensemblePtr->subcommandArrayPtr[i]);
    }
    Tcl_SetObjResult(interp, errorObj);
    return TCL_ERROR;







|

|


|







1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
		ensemblePtr->nsPtr->fullName));
	return TCL_ERROR;
    }
    errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
	    (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
	    TclGetString(subObj));
    if (ensemblePtr->subcommandTable.numEntries == 1) {
	Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
    } else {
	Tcl_Size i;

	for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
	    Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
	    Tcl_AppendToObj(errorObj, ", ", 2);
	}
	Tcl_AppendPrintfToObj(errorObj, "or %s",
		ensemblePtr->subcommandArrayPtr[i]);
    }
    Tcl_SetObjResult(interp, errorObj);
    return TCL_ERROR;
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
 *
 *----------------------------------------------------------------------
 */

int
TclInitRewriteEnsemble(
    Tcl_Interp *interp,
    size_t numRemoved,
    size_t numInserted,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;

    int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);

    if (isRootEnsemble) {
	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
	iPtr->ensembleRewrite.numInsertedObjs = numInserted;
    } else {
	size_t numIns = iPtr->ensembleRewrite.numInsertedObjs;

	if (numIns < numRemoved) {
	    iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
	    iPtr->ensembleRewrite.numInsertedObjs = numInserted;
	} else {
	    iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
	}







|
|











|







2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
 *
 *----------------------------------------------------------------------
 */

int
TclInitRewriteEnsemble(
    Tcl_Interp *interp,
    Tcl_Size numRemoved,
    Tcl_Size numInserted,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;

    int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);

    if (isRootEnsemble) {
	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
	iPtr->ensembleRewrite.numInsertedObjs = numInserted;
    } else {
	Tcl_Size numIns = iPtr->ensembleRewrite.numInsertedObjs;

	if (numIns < numRemoved) {
	    iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
	    iPtr->ensembleRewrite.numInsertedObjs = numInserted;
	} else {
	    iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
	}
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
    return result;
}

void
TclSpellFix(
    Tcl_Interp *interp,
    Tcl_Obj *const *objv,
    size_t objc,
    size_t badIdx,
    Tcl_Obj *bad,
    Tcl_Obj *fix)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *const *search;
    Tcl_Obj **store;
    size_t idx;
    size_t size;

    if (iPtr->ensembleRewrite.sourceObjs == NULL) {
	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = 0;
	iPtr->ensembleRewrite.numInsertedObjs = 0;
    }








|
|






|
|







2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
    return result;
}

void
TclSpellFix(
    Tcl_Interp *interp,
    Tcl_Obj *const *objv,
    Tcl_Size objc,
    Tcl_Size badIdx,
    Tcl_Obj *bad,
    Tcl_Obj *fix)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *const *search;
    Tcl_Obj **store;
    Tcl_Size idx;
    Tcl_Size size;

    if (iPtr->ensembleRewrite.sourceObjs == NULL) {
	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = 0;
	iPtr->ensembleRewrite.numInsertedObjs = 0;
    }

2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
 *----------------------------------------------------------------------
 */

Tcl_Obj *const *
TclFetchEnsembleRoot(
    Tcl_Interp *interp,
    Tcl_Obj *const *objv,
    size_t objc,
    size_t *objcPtr)
{
    Tcl_Obj *const *sourceObjs;
    Interp *iPtr = (Interp *) interp;

    if (iPtr->ensembleRewrite.sourceObjs) {
	*objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
		- iPtr->ensembleRewrite.numInsertedObjs;







|
|







2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
 *----------------------------------------------------------------------
 */

Tcl_Obj *const *
TclFetchEnsembleRoot(
    Tcl_Interp *interp,
    Tcl_Obj *const *objv,
    Tcl_Size objc,
    Tcl_Size *objcPtr)
{
    Tcl_Obj *const *sourceObjs;
    Interp *iPtr = (Interp *) interp;

    if (iPtr->ensembleRewrite.sourceObjs) {
	*objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
		- iPtr->ensembleRewrite.numInsertedObjs;
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
EnsembleUnknownCallback(
    Tcl_Interp *interp,
    EnsembleConfig *ensemblePtr,
    int objc,
    Tcl_Obj *const objv[],
    Tcl_Obj **prefixObjPtr)
{
    size_t paramc;
    int result;
	size_t i, prefixObjc;
    Tcl_Obj **paramv, *unknownCmd, *ensObj;

    /*
     * Create the "unknown" command callback to determine what to do.
     */

    unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
    TclNewObj(ensObj);
    Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
    Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
    for (i = 1 ; i < (size_t)objc ; i++) {
	Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
    }
    TclListObjGetElementsM(NULL, unknownCmd, &paramc, &paramv);
    Tcl_IncrRefCount(unknownCmd);

    /*
     * Call the "unknown" handler.  No attempt to NRE-enable this as deep
     * recursion through unknown handlers is perverse. It is always an error
     * for an unknown handler to delete its ensemble. Don't do that.
     */

    Tcl_Preserve(ensemblePtr);
    TclSkipTailcall(interp);
    result = Tcl_EvalObjv(interp, paramc, paramv, 0);
    if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler deleted its ensemble", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
		    NULL);
	}
	result = TCL_ERROR;
    }
    Tcl_Release(ensemblePtr);








|

|










|

















|







2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
EnsembleUnknownCallback(
    Tcl_Interp *interp,
    EnsembleConfig *ensemblePtr,
    int objc,
    Tcl_Obj *const objv[],
    Tcl_Obj **prefixObjPtr)
{
    Tcl_Size paramc;
    int result;
    Tcl_Size i, prefixObjc;
    Tcl_Obj **paramv, *unknownCmd, *ensObj;

    /*
     * Create the "unknown" command callback to determine what to do.
     */

    unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
    TclNewObj(ensObj);
    Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
    Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
    for (i = 1 ; i < objc ; i++) {
	Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
    }
    TclListObjGetElementsM(NULL, unknownCmd, &paramc, &paramv);
    Tcl_IncrRefCount(unknownCmd);

    /*
     * Call the "unknown" handler.  No attempt to NRE-enable this as deep
     * recursion through unknown handlers is perverse. It is always an error
     * for an unknown handler to delete its ensemble. Don't do that.
     */

    Tcl_Preserve(ensemblePtr);
    TclSkipTailcall(interp);
    result = Tcl_EvalObjv(interp, paramc, paramv, 0);
    if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler deleted its ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
		    NULL);
	}
	result = TCL_ERROR;
    }
    Tcl_Release(ensemblePtr);

2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
     * Convert exceptional result to an error.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (result != TCL_ERROR) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler returned bad code: ", TCL_INDEX_NONE));
	    switch (result) {
	    case TCL_RETURN:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", TCL_INDEX_NONE);
		break;
	    case TCL_BREAK:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", TCL_INDEX_NONE);
		break;
	    case TCL_CONTINUE:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", TCL_INDEX_NONE);
		break;
	    default:
		Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
	    }
	    Tcl_AddErrorInfo(interp, "\n    result of "
		    "ensemble unknown subcommand handler: ");
	    Tcl_AppendObjToErrorInfo(interp, unknownCmd);







|


|


|


|







2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
     * Convert exceptional result to an error.
     */

    if (!Tcl_InterpDeleted(interp)) {
	if (result != TCL_ERROR) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler returned bad code: ", -1));
	    switch (result) {
	    case TCL_RETURN:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);
		break;
	    case TCL_BREAK:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);
		break;
	    case TCL_CONTINUE:
		Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);
		break;
	    default:
		Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
	    }
	    Tcl_AddErrorInfo(interp, "\n    result of "
		    "ensemble unknown subcommand handler: ");
	    Tcl_AppendObjToErrorInfo(interp, unknownCmd);
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606

static void
BuildEnsembleConfig(
    EnsembleConfig *ensemblePtr)
{
    Tcl_HashSearch search;	/* Used for scanning the commands in
				 * the namespace for this ensemble. */
    size_t i, j;
    int isNew;
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
    Tcl_Obj *subList = ensemblePtr->subcmdList;

    ClearTable(ensemblePtr);
    Tcl_InitHashTable(hash, TCL_STRING_KEYS);

    if (subList) {
        size_t subc;
        Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
        const char *name;

        /*
         * There is a list of exactly what subcommands go in the table.
         * Determine the target for each.
         */







|










|







2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606

static void
BuildEnsembleConfig(
    EnsembleConfig *ensemblePtr)
{
    Tcl_HashSearch search;	/* Used for scanning the commands in
				 * the namespace for this ensemble. */
    Tcl_Size i, j;
    int isNew;
    Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
    Tcl_Obj *subList = ensemblePtr->subcmdList;

    ClearTable(ensemblePtr);
    Tcl_InitHashTable(hash, TCL_STRING_KEYS);

    if (subList) {
        Tcl_Size subc;
        Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
        const char *name;

        /*
         * There is a list of exactly what subcommands go in the table.
         * Determine the target for each.
         */
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
                }
                Tcl_SetHashValue(hPtr, subv[i+1]);
                Tcl_IncrRefCount(subv[i+1]);

                name = TclGetString(subv[i+1]);
                hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
                if (isNew) {
                    cmdObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
                    cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
                    Tcl_SetHashValue(hPtr, cmdPrefixObj);
                    Tcl_IncrRefCount(cmdPrefixObj);
                }
            }
        } else {
            /*







|







2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
                }
                Tcl_SetHashValue(hPtr, subv[i+1]);
                Tcl_IncrRefCount(subv[i+1]);

                name = TclGetString(subv[i+1]);
                hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
                if (isNew) {
                    cmdObj = Tcl_NewStringObj(name, -1);
                    cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
                    Tcl_SetHashValue(hPtr, cmdPrefixObj);
                    Tcl_IncrRefCount(cmdPrefixObj);
                }
            }
        } else {
            /*
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
                /*
                 * Target was not in the dictionary.  Map onto the namespace.
                 * In this case there is no guarantee that the command
                 * is actually there.  It is the responsibility of the
		 * programmer (or [::unknown] of course) to provide the procedure.
                 */

                cmdObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
                cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
                Tcl_SetHashValue(hPtr, cmdPrefixObj);
                Tcl_IncrRefCount(cmdPrefixObj);
            }
        }
    } else if (mapDict) {
        /*







|







2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
                /*
                 * Target was not in the dictionary.  Map onto the namespace.
                 * In this case there is no guarantee that the command
                 * is actually there.  It is the responsibility of the
		 * programmer (or [::unknown] of course) to provide the procedure.
                 */

                cmdObj = Tcl_NewStringObj(name, -1);
                cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
                Tcl_SetHashValue(hPtr, cmdPrefixObj);
                Tcl_IncrRefCount(cmdPrefixObj);
            }
        }
    } else if (mapDict) {
        /*
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
    Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
    Tcl_Obj *replaced, *replacement;
    Tcl_Command ensemble = (Tcl_Command) cmdPtr;
    Command *oldCmdPtr = cmdPtr, *newCmdPtr;
    int result, flags = 0, depth = 1, invokeAnyway = 0;
    int ourResult = TCL_ERROR;
    size_t i, len, numBytes;
    const char *word;

    TclNewObj(replaced);
    Tcl_IncrRefCount(replaced);
    if ((int)parsePtr->numWords <= depth) {
	goto failed;
    }
    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * Too hard.
	 */








|




|







2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
    Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
    Tcl_Obj *replaced, *replacement;
    Tcl_Command ensemble = (Tcl_Command) cmdPtr;
    Command *oldCmdPtr = cmdPtr, *newCmdPtr;
    int result, flags = 0, depth = 1, invokeAnyway = 0;
    int ourResult = TCL_ERROR;
    Tcl_Size i, len, numBytes;
    const char *word;

    TclNewObj(replaced);
    Tcl_IncrRefCount(replaced);
    if (parsePtr->numWords <= depth) {
	goto failed;
    }
    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * Too hard.
	 */

2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
     * Check to see if there's also a subcommand list; must check to see if
     * the subcommand we are calling is in that list if it exists, since that
     * list filters the entries in the map.
     */

    (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
    if (listObj != NULL) {
	size_t sclen;
	const char *str;
	Tcl_Obj *matchObj = NULL;

	if (TclListObjGetElementsM(NULL, listObj, &len, &elems) != TCL_OK) {
	    goto failed;
	}
	for (i=0 ; i<len ; i++) {







|







2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
     * Check to see if there's also a subcommand list; must check to see if
     * the subcommand we are calling is in that list if it exists, since that
     * list filters the entries in the map.
     */

    (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
    if (listObj != NULL) {
	Tcl_Size sclen;
	const char *str;
	Tcl_Obj *matchObj = NULL;

	if (TclListObjGetElementsM(NULL, listObj, &len, &elems) != TCL_OK) {
	    goto failed;
	}
	for (i=0 ; i<len ; i++) {
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
    return ourResult;
}

int
TclAttemptCompileProc(
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    size_t depth,
    Command *cmdPtr,
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;
    int result;
    size_t i;
    Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
    size_t savedStackDepth = envPtr->currStackDepth;
    unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
    size_t savedAuxDataArrayNext = envPtr->auxDataArrayNext;
    size_t savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
    size_t savedExceptDepth = envPtr->exceptDepth;
#endif

    if (cmdPtr->compileProc == NULL) {
	return TCL_ERROR;
    }

    /*







|





|

|

|
|

|







3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
    return ourResult;
}

int
TclAttemptCompileProc(
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    Tcl_Size depth,
    Command *cmdPtr,
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;
    int result;
    Tcl_Size i;
    Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
    Tcl_Size savedStackDepth = envPtr->currStackDepth;
    unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
    Tcl_Size savedAuxDataArrayNext = envPtr->auxDataArrayNext;
    Tcl_Size savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
    Tcl_Size savedExceptDepth = envPtr->exceptDepth;
#endif

    if (cmdPtr->compileProc == NULL) {
	return TCL_ERROR;
    }

    /*
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;
    Tcl_Token *tokPtr;
    Tcl_Obj *objPtr, **words;
    const char *bytes;
    int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
    size_t i, numWords, length;

    /*
     * Push the words of the command. Take care; the command words may be
     * scripts that have backslashes in them, and [info frame 0] can see the
     * difference. Hence the call to TclContinuationsEnterDerived...
     */








|







3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;
    Tcl_Token *tokPtr;
    Tcl_Obj *objPtr, **words;
    const char *bytes;
    int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
    Tcl_Size i, numWords, length;

    /*
     * Push the words of the command. Take care; the command words may be
     * scripts that have backslashes in them, and [info frame 0] can see the
     * difference. Hence the call to TclContinuationsEnterDerived...
     */

Changes to generic/tclEnv.c.

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
    char **cache;		/* Array containing all of the environment
				 * strings that Tcl has allocated. */
#ifndef USE_PUTENV
    techar **ourEnviron;		/* Cache of the array that we allocate. We
				 * need to track this in case another
				 * subsystem swaps around the environ array
				 * like we do. */
    size_t ourEnvironSize;		/* Non-zero means that the environ array was
				 * malloced and has this many total entries
				 * allocated to it (not all may be in use at
				 * once). Zero means that the environment
				 * array is in its original static state. */
#endif
} env;








|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
    char **cache;		/* Array containing all of the environment
				 * strings that Tcl has allocated. */
#ifndef USE_PUTENV
    techar **ourEnviron;		/* Cache of the array that we allocate. We
				 * need to track this in case another
				 * subsystem swaps around the environ array
				 * like we do. */
    Tcl_Size ourEnvironSize;	/* Non-zero means that the environ array was
				 * malloced and has this many total entries
				 * allocated to it (not all may be in use at
				 * once). Zero means that the environment
				 * array is in its original static state. */
#endif
} env;

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

	    if (strcasecmp(p1, "PATH") == 0) {
		p1 = "PATH";
	    } else if (strcasecmp(p1, "COMSPEC") == 0) {
		p1 = "COMSPEC";
	    }
#endif
	    obj1 = Tcl_NewStringObj(p1, TCL_INDEX_NONE);
	    obj2 = Tcl_NewStringObj(p2, TCL_INDEX_NONE);
	    Tcl_DStringFree(&envString);

	    Tcl_IncrRefCount(obj1);
	    Tcl_IncrRefCount(obj2);
	    Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
	    hPtr = Tcl_FindHashEntry(&namesHash, obj1);
	    if (hPtr != NULL) {







|
|







181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

	    if (strcasecmp(p1, "PATH") == 0) {
		p1 = "PATH";
	    } else if (strcasecmp(p1, "COMSPEC") == 0) {
		p1 = "COMSPEC";
	    }
#endif
	    obj1 = Tcl_NewStringObj(p1, -1);
	    obj2 = Tcl_NewStringObj(p2, -1);
	    Tcl_DStringFree(&envString);

	    Tcl_IncrRefCount(obj1);
	    Tcl_IncrRefCount(obj2);
	    Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
	    hPtr = Tcl_FindHashEntry(&namesHash, obj1);
	    if (hPtr != NULL) {
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
void
TclSetEnv(
    const char *name,		/* Name of variable whose value is to be set
				 * (UTF-8). */
    const char *value)		/* New value for variable (UTF-8). */
{
    Tcl_DString envString;
    size_t nameLength, valueLength;
    size_t index, length;
    char *p, *oldValue;
    const techar *p2;

    /*
     * Figure out where the entry is going to go. If the name doesn't already
     * exist, enlarge the array if necessary to make room. If the name exists,
     * free its old entry.







|
|







249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
void
TclSetEnv(
    const char *name,		/* Name of variable whose value is to be set
				 * (UTF-8). */
    const char *value)		/* New value for variable (UTF-8). */
{
    Tcl_DString envString;
    Tcl_Size nameLength, valueLength;
    Tcl_Size index, length;
    char *p, *oldValue;
    const techar *p2;

    /*
     * Figure out where the entry is going to go. If the name doesn't already
     * exist, enlarge the array if necessary to make room. If the name exists,
     * free its old entry.
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
 */

void
TclUnsetEnv(
    const char *name)		/* Name of variable to remove (UTF-8). */
{
    char *oldValue;
    size_t length, index;
#ifdef USE_PUTENV_FOR_UNSET
    Tcl_DString envString;
    char *string;
#else
    char **envPtr;
#endif /* USE_PUTENV_FOR_UNSET */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    /*
     * First make sure that the environment variable exists to avoid doing
     * needless work and to avoid recursion on the unset.
     */

    if (index == TCL_INDEX_NONE) {
	Tcl_MutexUnlock(&envMutex);
	return;
    }

    /*
     * Remember the old value so we can free it if Tcl created the string.
     */







|















|







449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
 */

void
TclUnsetEnv(
    const char *name)		/* Name of variable to remove (UTF-8). */
{
    char *oldValue;
    Tcl_Size length, index;
#ifdef USE_PUTENV_FOR_UNSET
    Tcl_DString envString;
    char *string;
#else
    char **envPtr;
#endif /* USE_PUTENV_FOR_UNSET */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    /*
     * First make sure that the environment variable exists to avoid doing
     * needless work and to avoid recursion on the unset.
     */

    if (index == -1) {
	Tcl_MutexUnlock(&envMutex);
	return;
    }

    /*
     * Remember the old value so we can free it if Tcl created the string.
     */
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
TclGetEnv(
    const char *name,		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr)	/* Uninitialized or free DString in which the
				 * value of the environment variable is
				 * stored. */
{
    size_t length, index;
    const char *result;

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);
    result = NULL;
    if (index != TCL_INDEX_NONE) {
	Tcl_DString envStr;

	result = tenviron2utfdstr(tenviron[index], -1, &envStr);
	result += length;
	if (*result == '=') {
	    result++;
	    Tcl_DStringInit(valuePtr);
	    Tcl_DStringAppend(valuePtr, result, TCL_INDEX_NONE);
	    result = Tcl_DStringValue(valuePtr);
	} else {
	    result = NULL;
	}
	Tcl_DStringFree(&envStr);
    }
    Tcl_MutexUnlock(&envMutex);







|





|







|







564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
TclGetEnv(
    const char *name,		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr)	/* Uninitialized or free DString in which the
				 * value of the environment variable is
				 * stored. */
{
    Tcl_Size length, index;
    const char *result;

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);
    result = NULL;
    if (index != -1) {
	Tcl_DString envStr;

	result = tenviron2utfdstr(tenviron[index], -1, &envStr);
	result += length;
	if (*result == '=') {
	    result++;
	    Tcl_DStringInit(valuePtr);
	    Tcl_DStringAppend(valuePtr, result, -1);
	    result = Tcl_DStringValue(valuePtr);
	} else {
	    result = NULL;
	}
	Tcl_DStringFree(&envStr);
    }
    Tcl_MutexUnlock(&envMutex);

Changes to generic/tclEvent.c.

220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
     * that could lead us here.
     */

    Tcl_Preserve(assocPtr);
    Tcl_Preserve(interp);
    while (assocPtr->firstBgPtr != NULL) {
	int code;
	size_t prefixObjc;
	Tcl_Obj **prefixObjv, **tempObjv;

	/*
	 * Note we copy the handler command prefix each pass through, so we do
	 * support one handler setting another handler.
	 */








|







220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
     * that could lead us here.
     */

    Tcl_Preserve(assocPtr);
    Tcl_Preserve(interp);
    while (assocPtr->firstBgPtr != NULL) {
	int code;
	Tcl_Size prefixObjc;
	Tcl_Obj **prefixObjv, **tempObjv;

	/*
	 * Note we copy the handler command prefix each pass through, so we do
	 * support one handler setting another handler.
	 */

277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

		TclNewLiteralStringObj(keyPtr, "-errorinfo");
		Tcl_IncrRefCount(keyPtr);
		Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
		Tcl_DecrRefCount(keyPtr);

		Tcl_WriteChars(errChannel,
			"error in background error handler:\n", TCL_INDEX_NONE);
		if (valuePtr) {
		    Tcl_WriteObj(errChannel, valuePtr);
		} else {
		    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		}
		Tcl_WriteChars(errChannel, "\n", 1);
		Tcl_Flush(errChannel);







|







277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

		TclNewLiteralStringObj(keyPtr, "-errorinfo");
		Tcl_IncrRefCount(keyPtr);
		Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
		Tcl_DecrRefCount(keyPtr);

		Tcl_WriteChars(errChannel,
			"error in background error handler:\n", -1);
		if (valuePtr) {
		    Tcl_WriteObj(errChannel, valuePtr);
		} else {
		    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		}
		Tcl_WriteChars(errChannel, "\n", 1);
		Tcl_Flush(errChannel);
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366

    TclNewLiteralStringObj(keyPtr, "-level");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result != TCL_OK || valuePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing return option \"-level\"", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
	return TCL_ERROR;
    }
    TclNewLiteralStringObj(keyPtr, "-code");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result != TCL_OK || valuePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing return option \"-code\"", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
	return TCL_ERROR;
    }








|












|







339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366

    TclNewLiteralStringObj(keyPtr, "-level");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result != TCL_OK || valuePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing return option \"-level\"", -1));
	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
	return TCL_ERROR;
    }
    TclNewLiteralStringObj(keyPtr, "-code");
    Tcl_IncrRefCount(keyPtr);
    result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (result != TCL_OK || valuePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing return option \"-code\"", -1));
	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
	return TCL_ERROR;
    }

470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494

		Tcl_IncrRefCount(resultPtr);
		if (Tcl_FindCommand(interp, "bgerror", NULL,
			TCL_GLOBAL_ONLY) == NULL) {
		    Tcl_RestoreInterpState(interp, saved);
		    Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp,
			    "errorInfo", NULL, TCL_GLOBAL_ONLY));
		    Tcl_WriteChars(errChannel, "\n", TCL_INDEX_NONE);
		} else {
		    Tcl_DiscardInterpState(saved);
		    Tcl_WriteChars(errChannel,
			    "bgerror failed to handle background error.\n", TCL_INDEX_NONE);
		    Tcl_WriteChars(errChannel, "    Original error: ", TCL_INDEX_NONE);
		    Tcl_WriteObj(errChannel, tempObjv[1]);
		    Tcl_WriteChars(errChannel, "\n", TCL_INDEX_NONE);
		    Tcl_WriteChars(errChannel, "    Error in bgerror: ", TCL_INDEX_NONE);
		    Tcl_WriteObj(errChannel, resultPtr);
		    Tcl_WriteChars(errChannel, "\n", TCL_INDEX_NONE);
		}
		Tcl_DecrRefCount(resultPtr);
		Tcl_Flush(errChannel);
	    } else {
		Tcl_DiscardInterpState(saved);
	    }
	}







|



|
|

|
|

|







470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494

		Tcl_IncrRefCount(resultPtr);
		if (Tcl_FindCommand(interp, "bgerror", NULL,
			TCL_GLOBAL_ONLY) == NULL) {
		    Tcl_RestoreInterpState(interp, saved);
		    Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp,
			    "errorInfo", NULL, TCL_GLOBAL_ONLY));
		    Tcl_WriteChars(errChannel, "\n", -1);
		} else {
		    Tcl_DiscardInterpState(saved);
		    Tcl_WriteChars(errChannel,
			    "bgerror failed to handle background error.\n", -1);
		    Tcl_WriteChars(errChannel, "    Original error: ", -1);
		    Tcl_WriteObj(errChannel, tempObjv[1]);
		    Tcl_WriteChars(errChannel, "\n", -1);
		    Tcl_WriteChars(errChannel, "    Error in bgerror: ", -1);
		    Tcl_WriteObj(errChannel, resultPtr);
		    Tcl_WriteChars(errChannel, "\n", -1);
		}
		Tcl_DecrRefCount(resultPtr);
		Tcl_Flush(errChannel);
	    } else {
		Tcl_DiscardInterpState(saved);
	    }
	}
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
	    if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) {
		result = TCL_ERROR;
		goto done;
	    }
	    if (timeout < 0) {
		Tcl_ResetResult(interp);
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"timeout must be positive", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    break;
	case OPT_LAST:
	    i++;







|







1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
	    if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) {
		result = TCL_ERROR;
		goto done;
	    }
	    if (timeout < 0) {
		Tcl_ResetResult(interp);
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"timeout must be positive", -1));
		Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	    break;
	case OPT_LAST:
	    i++;
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
	}
    }

  endOfOptionLoop:
    if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
		 TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"can't wait: would block forever", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"timer events disabled with timeout specified", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", NULL);
	result = TCL_ERROR;
	goto done;
    }

    for (result = TCL_OK; i < objc; i++) {
	result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,







|







|







1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
	}
    }

  endOfOptionLoop:
    if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
		 TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"can't wait: would block forever", -1));
	Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
	result = TCL_ERROR;
	goto done;
    }

    if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"timer events disabled with timeout specified", -1));
	Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", NULL);
	result = TCL_ERROR;
	goto done;
    }

    for (result = TCL_OK; i < objc; i++) {
	result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
	goto done;
    }

    if (!(mask & TCL_FILE_EVENTS)) {
	for (i = 0; i < numItems; i++) {
	    if (vwaitItems[i].mask) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"file events disabled with channel(s) specified", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	}
    }








|







1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
	goto done;
    }

    if (!(mask & TCL_FILE_EVENTS)) {
	for (i = 0; i < numItems; i++) {
	    if (vwaitItems[i].mask) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"file events disabled with channel(s) specified", -1));
		Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", NULL);
		result = TCL_ERROR;
		goto done;
	    }
	}
    }

1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
	   ((!any && (done < numItems)) || (any && !done))) {
	foundEvent = Tcl_DoOneEvent(mask);
	if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
	    break;
	}
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", NULL);
	    break;
	}
	if ((numItems == 0) && (timeout == 0)) {
	    /*
	     * Behavior like "update": clear interpreter's result because
	     * event handlers could have executed commands.







|







1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
	   ((!any && (done < numItems)) || (any && !done))) {
	foundEvent = Tcl_DoOneEvent(mask);
	if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
	    break;
	}
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
	    Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", NULL);
	    break;
	}
	if ((numItems == 0) && (timeout == 0)) {
	    /*
	     * Behavior like "update": clear interpreter's result because
	     * event handlers could have executed commands.
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985

    while (Tcl_DoOneEvent(flags) != 0) {
	if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}
    }

    /*
     * Must clear the interpreter's result because event handlers could have
     * executed commands.







|







1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985

    while (Tcl_DoOneEvent(flags) != 0) {
	if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
	    return TCL_ERROR;
	}
    }

    /*
     * Must clear the interpreter's result because event handlers could have
     * executed commands.
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
 *----------------------------------------------------------------------
 */

int
Tcl_CreateThread(
    Tcl_ThreadId *idPtr,	/* Return, the ID of the thread */
    Tcl_ThreadCreateProc *proc,	/* Main() function of the thread */
    void *clientData,	/* The one argument to Main() */
    size_t stackSize,		/* Size of stack for the new thread */
    int flags)			/* Flags controlling behaviour of the new
				 * thread. */
{
#if TCL_THREADS
    ThreadClientData *cdPtr = (ThreadClientData *)Tcl_Alloc(sizeof(ThreadClientData));
    int result;








|
|







2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
 *----------------------------------------------------------------------
 */

int
Tcl_CreateThread(
    Tcl_ThreadId *idPtr,	/* Return, the ID of the thread */
    Tcl_ThreadCreateProc *proc,	/* Main() function of the thread */
    void *clientData,		/* The one argument to Main() */
    Tcl_Size stackSize,		/* Size of stack for the new thread */
    int flags)			/* Flags controlling behaviour of the new
				 * thread. */
{
#if TCL_THREADS
    ThreadClientData *cdPtr = (ThreadClientData *)Tcl_Alloc(sizeof(ThreadClientData));
    int result;

Changes to generic/tclExecute.c.

631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
			    Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr);
static Tcl_Obj *	ExecuteExtendedUnaryMathOp(int opcode,
			    Tcl_Obj *valuePtr);
static void		FreeExprCodeInternalRep(Tcl_Obj *objPtr);
static ExceptionRange *	GetExceptRangeForPc(const unsigned char *pc,
			    int searchMode, ByteCode *codePtr);
static const char *	GetSrcInfoForPc(const unsigned char *pc,
			    ByteCode *codePtr, size_t *lengthPtr,
			    const unsigned char **pcBeg, int *cmdIdxPtr);
static Tcl_Obj **	GrowEvaluationStack(ExecEnv *eePtr, size_t growth,
			    int move);
static void		IllegalExprOperandType(Tcl_Interp *interp,
			    const unsigned char *pc, Tcl_Obj *opndPtr);
static void		InitByteCodeExecution(Tcl_Interp *interp);
static inline int	wordSkip(void *ptr);







|







631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
			    Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr);
static Tcl_Obj *	ExecuteExtendedUnaryMathOp(int opcode,
			    Tcl_Obj *valuePtr);
static void		FreeExprCodeInternalRep(Tcl_Obj *objPtr);
static ExceptionRange *	GetExceptRangeForPc(const unsigned char *pc,
			    int searchMode, ByteCode *codePtr);
static const char *	GetSrcInfoForPc(const unsigned char *pc,
			    ByteCode *codePtr, Tcl_Size *lengthPtr,
			    const unsigned char **pcBeg, int *cmdIdxPtr);
static Tcl_Obj **	GrowEvaluationStack(ExecEnv *eePtr, size_t growth,
			    int move);
static void		IllegalExprOperandType(Tcl_Interp *interp,
			    const unsigned char *pc, Tcl_Obj *opndPtr);
static void		InitByteCodeExecution(Tcl_Interp *interp);
static inline int	wordSkip(void *ptr);
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
	eePtr->execStackPtr = esPtr;
    }
}

void *
TclStackAlloc(
    Tcl_Interp *interp,
    size_t numBytes)
{
    Interp *iPtr = (Interp *) interp;
    size_t numWords;

    if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
	return (void *) Tcl_Alloc(numBytes);
    }
    numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
    return StackAllocWords(interp, numWords);
}

void *
TclStackRealloc(
    Tcl_Interp *interp,
    void *ptr,
    size_t numBytes)
{
    Interp *iPtr = (Interp *) interp;
    ExecEnv *eePtr;
    ExecStack *esPtr;
    Tcl_Obj **markerPtr;
    size_t numWords;

    if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
	return Tcl_Realloc(ptr, numBytes);
    }

    eePtr = iPtr->execEnvPtr;
    esPtr = eePtr->execStackPtr;







|


|












|





|







1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
	eePtr->execStackPtr = esPtr;
    }
}

void *
TclStackAlloc(
    Tcl_Interp *interp,
    Tcl_Size numBytes)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Size numWords;

    if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
	return (void *) Tcl_Alloc(numBytes);
    }
    numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
    return StackAllocWords(interp, numWords);
}

void *
TclStackRealloc(
    Tcl_Interp *interp,
    void *ptr,
    Tcl_Size numBytes)
{
    Interp *iPtr = (Interp *) interp;
    ExecEnv *eePtr;
    ExecStack *esPtr;
    Tcl_Obj **markerPtr;
    Tcl_Size numWords;

    if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
	return Tcl_Realloc(ptr, numBytes);
    }

    eePtr = iPtr->execEnvPtr;
    esPtr = eePtr->execStackPtr;
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
		     */

		    Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
		    ctxCopyPtr->data.eval.path = NULL;
		}
	    }

	    if ((size_t)word < ctxCopyPtr->nline) {
		/*
		 * Note: We do not care if the line[word] is -1. This is a
		 * difference and requires a recompile (location changed from
		 * absolute to relative, literal is used fixed and through
		 * variable)
		 *
		 * Example:







|







1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
		     */

		    Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
		    ctxCopyPtr->data.eval.path = NULL;
		}
	    }

	    if (word < ctxCopyPtr->nline) {
		/*
		 * Note: We do not care if the line[word] is -1. This is a
		 * difference and requires a recompile (location changed from
		 * absolute to relative, literal is used fixed and through
		 * variable)
		 *
		 * Example:
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
     * Locals - variables that are used within opcodes or bounded sections of
     * the file (jumps between opcodes within a family).
     * NOTE: These are now mostly defined locally where needed.
     */

    Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
    Tcl_Obj **objv = NULL;
    size_t length, objc = 0;
    int opnd, pcAdjustment;
    Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
    char cmdNameBuf[21];
#endif

#ifdef TCL_COMPILE_DEBUG







|







2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
     * Locals - variables that are used within opcodes or bounded sections of
     * the file (jumps between opcodes within a family).
     * NOTE: These are now mostly defined locally where needed.
     */

    Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
    Tcl_Obj **objv = NULL;
    Tcl_Size length, objc = 0;
    int opnd, pcAdjustment;
    Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
    char cmdNameBuf[21];
#endif

#ifdef TCL_COMPILE_DEBUG
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444

    case INST_YIELD:
	corPtr = iPtr->execEnvPtr->corPtr;
	TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
	if (!corPtr) {
	    TRACE_APPEND(("ERROR: yield outside coroutine\n"));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yield can only be called in a coroutine", TCL_INDEX_NONE));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    if (traceInstructions) {
		TRACE_APPEND(("YIELD...\n"));
	    } else {
		fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n",
			iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
			Tcl_GetString(OBJ_AT_TOS));
	    }
	    fflush(stdout);
	}
#endif
	yieldParameter = NULL;	/*==CORO_ACTIVATE_YIELD*/
	Tcl_SetObjResult(interp, OBJ_AT_TOS);
	goto doYield;

    case INST_YIELD_TO_INVOKE:
	corPtr = iPtr->execEnvPtr->corPtr;
	valuePtr = OBJ_AT_TOS;
	if (!corPtr) {
	    TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
		    O2S(valuePtr)));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yieldto can only be called in a coroutine", TCL_INDEX_NONE));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}
	if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
	    TRACE(("[%.30s] => ERROR: yield in deleted\n",
		    O2S(valuePtr)));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yieldto called in deleted namespace", TCL_INDEX_NONE));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    if (traceInstructions) {
		TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
	    } else {
		/* FIXME: What is the right thing to trace? */
		fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n",
			iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
			TclGetString(valuePtr));
	    }
	    fflush(stdout);
	}
#endif

	/*







|












|
|
















|










|













|
|







2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444

    case INST_YIELD:
	corPtr = iPtr->execEnvPtr->corPtr;
	TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
	if (!corPtr) {
	    TRACE_APPEND(("ERROR: yield outside coroutine\n"));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yield can only be called in a coroutine", -1));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    if (traceInstructions) {
		TRACE_APPEND(("YIELD...\n"));
	    } else {
		fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) yielding value \"%.30s\"\n",
			iPtr->numLevels, (pc - codePtr->codeStart),
			Tcl_GetString(OBJ_AT_TOS));
	    }
	    fflush(stdout);
	}
#endif
	yieldParameter = NULL;	/*==CORO_ACTIVATE_YIELD*/
	Tcl_SetObjResult(interp, OBJ_AT_TOS);
	goto doYield;

    case INST_YIELD_TO_INVOKE:
	corPtr = iPtr->execEnvPtr->corPtr;
	valuePtr = OBJ_AT_TOS;
	if (!corPtr) {
	    TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
		    O2S(valuePtr)));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yieldto can only be called in a coroutine", -1));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}
	if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
	    TRACE(("[%.30s] => ERROR: yield in deleted\n",
		    O2S(valuePtr)));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yieldto called in deleted namespace", -1));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    if (traceInstructions) {
		TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
	    } else {
		/* FIXME: What is the right thing to trace? */
		fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) yielding to [%.30s]\n",
			iPtr->numLevels, (pc - codePtr->codeStart),
			TclGetString(valuePtr));
	    }
	    fflush(stdout);
	}
#endif

	/*
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
	Tcl_Obj *listPtr, *nsObjPtr;

	opnd = TclGetUInt1AtPtr(pc+1);

	if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
	    TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tailcall can only be called from a proc or lambda", TCL_INDEX_NONE));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG







|







2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
	Tcl_Obj *listPtr, *nsObjPtr;

	opnd = TclGetUInt1AtPtr(pc+1);

	if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
	    TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tailcall can only be called from a proc or lambda", -1));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521

	/*
	 * Push the evaluation of the called command into the NR callback
	 * stack.
	 */

	listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
	nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, TCL_INDEX_NONE);
	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
	if (iPtr->varFramePtr->tailcallPtr) {
	    Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
	}
	iPtr->varFramePtr->tailcallPtr = listPtr;

	result = TCL_RETURN;







|







2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521

	/*
	 * Push the evaluation of the called command into the NR callback
	 * stack.
	 */

	listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
	nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
	if (iPtr->varFramePtr->tailcallPtr) {
	    Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
	}
	iPtr->varFramePtr->tailcallPtr = listPtr;

	result = TCL_RETURN;
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
	/* Ugly abuse! */
	starting = 1;
#endif
	TRACE(("=> drop %" TCL_Z_MODIFIER "u items\n", objc));
	NEXT_INST_V(1, objc, 0);

    case INST_EXPAND_STKTOP: {
	size_t i;
	TEBCdata *newTD;
	ptrdiff_t oldCatchTopOff, oldTosPtrOff;

	/*
	 * Make sure that the element at stackTop is a list; if not, just
	 * leave with an error. Note that the element from the expand list
	 * will be removed at checkForCatch.







|







2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
	/* Ugly abuse! */
	starting = 1;
#endif
	TRACE(("=> drop %" TCL_Z_MODIFIER "u items\n", objc));
	NEXT_INST_V(1, objc, 0);

    case INST_EXPAND_STKTOP: {
	Tcl_Size i;
	TEBCdata *newTD;
	ptrdiff_t oldCatchTopOff, oldTosPtrOff;

	/*
	 * Make sure that the element at stackTop is a list; if not, just
	 * leave with an error. Note that the element from the expand list
	 * will be removed at checkForCatch.
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806

    doInvocation:
	objv = &OBJ_AT_DEPTH(objc-1);
	cleanup = objc;

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    size_t i;

	    if (traceInstructions) {
		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
		TRACE(("%" TCL_Z_MODIFIER "u => call ", objc));
	    } else {
		fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels,
			(size_t)(pc - codePtr->codeStart));
	    }
	    for (i = 0;  i < objc;  i++) {
		TclPrintObject(stdout, objv[i], 15);
		fprintf(stdout, " ");
	    }
	    fprintf(stdout, "\n");
	    fflush(stdout);







|





|
|







2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806

    doInvocation:
	objv = &OBJ_AT_DEPTH(objc-1);
	cleanup = objc;

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    Tcl_Size i;

	    if (traceInstructions) {
		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
		TRACE(("%" TCL_Z_MODIFIER "u => call ", objc));
	    } else {
		fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking ", iPtr->numLevels,
			(pc - codePtr->codeStart));
	    }
	    for (i = 0;  i < objc;  i++) {
		TclPrintObject(stdout, objv[i], 15);
		fprintf(stdout, " ");
	    }
	    fprintf(stdout, "\n");
	    fflush(stdout);
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
	objc = TclGetUInt4AtPtr(pc+1);
	opnd = TclGetUInt1AtPtr(pc+5);
	objPtr = POP_OBJECT();
	objv = &OBJ_AT_DEPTH(objc-1);
	cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    size_t i;

	    if (traceInstructions) {
		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
		TRACE(("%" TCL_Z_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr)));
	    } else {
		fprintf(stdout,
			"%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ",
			iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
			O2S(objPtr));
	    }
	    for (i = 0;  i < objc;  i++) {
		if (i < (size_t)opnd) {
		    fprintf(stdout, "<");
		    TclPrintObject(stdout, objv[i], 15);
		    fprintf(stdout, ">");
		} else {
		    TclPrintObject(stdout, objv[i], 15);
		}
		fprintf(stdout, " ");







|






|
|



|







2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
	objc = TclGetUInt4AtPtr(pc+1);
	opnd = TclGetUInt1AtPtr(pc+5);
	objPtr = POP_OBJECT();
	objv = &OBJ_AT_DEPTH(objc-1);
	cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    Tcl_Size i;

	    if (traceInstructions) {
		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
		TRACE(("%" TCL_Z_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr)));
	    } else {
		fprintf(stdout,
			"%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking (using implementation %s) ",
			iPtr->numLevels, (pc - codePtr->codeStart),
			O2S(objPtr));
	    }
	    for (i = 0;  i < objc;  i++) {
		if (i < opnd) {
		    fprintf(stdout, "<");
		    TclPrintObject(stdout, objv[i], 15);
		    fprintf(stdout, ">");
		} else {
		    TclPrintObject(stdout, objv[i], 15);
		}
		fprintf(stdout, " ");
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
     * WARNING: more 'goto' here than your doctor recommended! The different
     * instructions set the value of some variables and then jump to somme
     * common execution code.
     */

    {
	int storeFlags;
	size_t len;

    case INST_STORE_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	goto doStoreArrayDirect;

    case INST_STORE_ARRAY1:







|







3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
     * WARNING: more 'goto' here than your doctor recommended! The different
     * instructions set the value of some variables and then jump to somme
     * common execution code.
     */

    {
	int storeFlags;
	Tcl_Size len;

    case INST_STORE_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	goto doStoreArrayDirect;

    case INST_STORE_ARRAY1:
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
     *	   Start of TclOO support instructions.
     */

    {
	Object *oPtr;
	CallFrame *framePtr;
	CallContext *contextPtr;
	size_t skip, newDepth;

    case INST_TCLOO_SELF:
	framePtr = iPtr->varFramePtr;
	if (framePtr == NULL ||
		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	    TRACE(("=> ERROR: no TclOO call context\n"));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(







|







4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
     *	   Start of TclOO support instructions.
     */

    {
	Object *oPtr;
	CallFrame *framePtr;
	CallContext *contextPtr;
	Tcl_Size skip, newDepth;

    case INST_TCLOO_SELF:
	framePtr = iPtr->varFramePtr;
	if (framePtr == NULL ||
		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	    TRACE(("=> ERROR: no TclOO call context\n"));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
	oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
	if (oPtr == NULL) {
	    TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
	    goto gotError;
	} else {
	    Class *classPtr = oPtr->classPtr;
	    struct MInvoke *miPtr;
	    size_t i;
	    const char *methodType;

	    if (classPtr == NULL) {
		TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"\"%s\" is not a class", TclGetString(valuePtr)));
		DECACHE_STACK_INFO();







|







4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
	oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
	if (oPtr == NULL) {
	    TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
	    goto gotError;
	} else {
	    Class *classPtr = oPtr->classPtr;
	    struct MInvoke *miPtr;
	    Tcl_Size i;
	    const char *methodType;

	    if (classPtr == NULL) {
		TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"\"%s\" is not a class", TclGetString(valuePtr)));
		DECACHE_STACK_INFO();
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
			if (traceInstructions) {
			    strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
			} else {
			    fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ",
				    iPtr->numLevels,
				    (size_t)(pc - codePtr->codeStart));
			}
			for (i = 0;  i < (size_t)opnd;  i++) {
			    TclPrintObject(stdout, objv[i], 15);
			    fprintf(stdout, " ");
			}
			fprintf(stdout, "\n");
			fflush(stdout);
		    }
#endif /*TCL_COMPILE_DEBUG*/







|







4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
			if (traceInstructions) {
			    strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
			} else {
			    fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ",
				    iPtr->numLevels,
				    (size_t)(pc - codePtr->codeStart));
			}
			for (i = 0;  i < opnd;  i++) {
			    TclPrintObject(stdout, objv[i], 15);
			    fprintf(stdout, " ");
			}
			fprintf(stdout, "\n");
			fflush(stdout);
		    }
#endif /*TCL_COMPILE_DEBUG*/
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
     *     End of TclOO support instructions.
     * -----------------------------------------------------------------
     *	   Start of INST_LIST and related instructions.
     */

    {
	int numIndices, nocase, match, cflags;
	size_t slength, length2, fromIdx, toIdx, index, s1len, s2len;
	const char *s1, *s2;

    case INST_LIST:
	/*
	 * Pop the opnd (objc) top stack elements into a new list obj and then
	 * decrement their ref counts.
	 */







|







4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
     *     End of TclOO support instructions.
     * -----------------------------------------------------------------
     *	   Start of INST_LIST and related instructions.
     */

    {
	int numIndices, nocase, match, cflags;
	Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len;
	const char *s1, *s2;

    case INST_LIST:
	/*
	 * Pop the opnd (objc) top stack elements into a new list obj and then
	 * decrement their ref counts.
	 */
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
	    length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr);

	    /* Decode end-offset index values. */

	    index = TclIndexDecode(opnd, length-1);

	    /* Compute value @ index */
	    if (index < length) {
		objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
		if (objResultPtr == NULL) {
		    CACHE_STACK_INFO();
		    TRACE_ERROR(interp);
		    goto gotError;
		}
	    } else {







|







4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
	    length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr);

	    /* Decode end-offset index values. */

	    index = TclIndexDecode(opnd, length-1);

	    /* Compute value @ index */
	    if (index >= 0 && index < length) {
		objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
		if (objResultPtr == NULL) {
		    CACHE_STACK_INFO();
		    TRACE_ERROR(interp);
		    goto gotError;
		}
	    } else {
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770

	/* Decode end-offset index values. */

	index = TclIndexDecode(opnd, objc - 1);
	pcAdjustment = 5;

    lindexFastPath:
	if (index < (size_t)objc) {
	    objResultPtr = objv[index];
	} else {
	    TclNewObj(objResultPtr);
	}

    lindexFastPath2:








|







4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770

	/* Decode end-offset index values. */

	index = TclIndexDecode(opnd, objc - 1);
	pcAdjustment = 5;

    lindexFastPath:
	if (index >= 0 && index < objc) {
	    objResultPtr = objv[index];
	} else {
	    TclNewObj(objResultPtr);
	}

    lindexFastPath2:

4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
	    TclNewObj(objResultPtr);
	    TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
	    NEXT_INST_F(9, 1, 1);
	}
	toIdx = TclIndexDecode(toIdx, objc - 1);
	if (toIdx == TCL_INDEX_NONE) {
	    goto emptyList;
	} else if (toIdx + 1 >= (size_t)objc + 1) {
	    toIdx = objc - 1;
	}

	assert (toIdx < (size_t)objc);
	/*
	assert ( fromIdx != TCL_INDEX_NONE );
	 *
	 * Extra safety for legacy bytecodes:
	 */
	if (fromIdx == TCL_INDEX_NONE) {
	    fromIdx = TCL_INDEX_START;







|



|







4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
	    TclNewObj(objResultPtr);
	    TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
	    NEXT_INST_F(9, 1, 1);
	}
	toIdx = TclIndexDecode(toIdx, objc - 1);
	if (toIdx == TCL_INDEX_NONE) {
	    goto emptyList;
	} else if (toIdx >= objc) {
	    toIdx = objc - 1;
	}

	assert (toIdx >= 0 && toIdx < objc);
	/*
	assert ( fromIdx != TCL_INDEX_NONE );
	 *
	 * Extra safety for legacy bytecodes:
	 */
	if (fromIdx == TCL_INDEX_NONE) {
	    fromIdx = TCL_INDEX_START;
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
	TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
	if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	match = 0;
	if (length > 0) {
	    size_t i = 0;
	    Tcl_Obj *o;
	    int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType.objType);
	    /*
	     * An empty list doesn't match anything.
	     */

	    do {







|







4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
	TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
	if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	match = 0;
	if (length > 0) {
	    Tcl_Size i = 0;
	    Tcl_Obj *o;
	    int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType.objType);
	    /*
	     * An empty list doesn't match anything.
	     */

	    do {
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
    stringCompare:
	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;

	{
	    int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ)
		    || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ));
	    match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, TCL_INDEX_NONE);
	}

	/*
	 * Make sure only -1,0,1 is returned
	 * TODO: consider peephole opt.
	 */








|







5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
    stringCompare:
	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;

	{
	    int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ)
		    || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ));
	    match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, -1);
	}

	/*
	 * Make sure only -1,0,1 is returned
	 * TODO: consider peephole opt.
	 */

5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
	if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) {
	    CACHE_STACK_INFO();
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	CACHE_STACK_INFO();

	if (index >= slength) {
	    TclNewObj(objResultPtr);
	} else if (TclIsPureByteArray(valuePtr)) {
	    objResultPtr = Tcl_NewByteArrayObj(
		    Tcl_GetByteArrayFromObj(valuePtr, (size_t *)NULL)+index, 1);
	} else if (valuePtr->bytes && slength == valuePtr->length) {
	    objResultPtr = Tcl_NewStringObj((const char *)
		    valuePtr->bytes+index, 1);







|







5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
	if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) {
	    CACHE_STACK_INFO();
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	CACHE_STACK_INFO();

	if (index < 0 || index >= slength) {
	    TclNewObj(objResultPtr);
	} else if (TclIsPureByteArray(valuePtr)) {
	    objResultPtr = Tcl_NewByteArrayObj(
		    Tcl_GetByteArrayFromObj(valuePtr, (size_t *)NULL)+index, 1);
	} else if (valuePtr->bytes && slength == valuePtr->length) {
	    objResultPtr = Tcl_NewStringObj((const char *)
		    valuePtr->bytes+index, 1);
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
	    objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
	}
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_F(9, 1, 1);

    {
	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
	size_t length3;
	Tcl_Obj *value3Ptr;

    case INST_STR_REPLACE:
	value3Ptr = POP_OBJECT();
	valuePtr = OBJ_AT_DEPTH(2);
	slength = Tcl_GetCharLength(valuePtr) - 1;
	TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),







|







5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
	    objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
	}
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_F(9, 1, 1);

    {
	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
	Tcl_Size length3;
	Tcl_Obj *value3Ptr;

    case INST_STR_REPLACE:
	value3Ptr = POP_OBJECT();
	valuePtr = OBJ_AT_DEPTH(2);
	slength = Tcl_GetCharLength(valuePtr) - 1;
	TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
	}
	CACHE_STACK_INFO();
	TclDecrRefCount(OBJ_AT_TOS);
	(void) POP_OBJECT();
	TclDecrRefCount(OBJ_AT_TOS);
	(void) POP_OBJECT();

	if ((toIdx == TCL_INDEX_NONE) ||
		(fromIdx + 1 > slength + 1) ||
		(toIdx + 1 < fromIdx + 1)) {
	    TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
	    TclDecrRefCount(value3Ptr);
	    NEXT_INST_F(1, 0, 0);
	}

	if (fromIdx == TCL_INDEX_NONE) {
	    fromIdx = TCL_INDEX_START;
	}

	if (toIdx + 1 > slength + 1) {
	    toIdx = slength;
	}

	if ((fromIdx == TCL_INDEX_START) && (toIdx == slength)) {
	    TclDecrRefCount(OBJ_AT_TOS);
	    OBJ_AT_TOS = value3Ptr;
	    TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
	    NEXT_INST_F(1, 0, 0);
	}

	objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,







|
|
|





|
|


|



|







5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
	}
	CACHE_STACK_INFO();
	TclDecrRefCount(OBJ_AT_TOS);
	(void) POP_OBJECT();
	TclDecrRefCount(OBJ_AT_TOS);
	(void) POP_OBJECT();

	if ((toIdx < 0) ||
		(fromIdx > slength) ||
		(toIdx < fromIdx)) {
	    TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
	    TclDecrRefCount(value3Ptr);
	    NEXT_INST_F(1, 0, 0);
	}

	if (fromIdx < 0) {
	    fromIdx = 0;
	}

	if (toIdx > slength) {
	    toIdx = slength;
	}

	if ((fromIdx == 0) && (toIdx == slength)) {
	    TclDecrRefCount(OBJ_AT_TOS);
	    OBJ_AT_TOS = value3Ptr;
	    TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
	    NEXT_INST_F(1, 0, 0);
	}

	objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464

	objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
	p = ustring1;
	end = ustring1 + slength;
	for (; ustring1 < end; ustring1++) {
	    if ((*ustring1 == *ustring2) &&
		/* Fix bug [69218ab7b]: restrict max compare length. */
		((size_t)(end-ustring1) >= length2) && (length2==1 ||
		    memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
			    == 0)) {
		if (p != ustring1) {
		    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
		    p = ustring1 + length2;
		} else {
		    p += length2;







|







5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464

	objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
	p = ustring1;
	end = ustring1 + slength;
	for (; ustring1 < end; ustring1++) {
	    if ((*ustring1 == *ustring2) &&
		/* Fix bug [69218ab7b]: restrict max compare length. */
		((end-ustring1) >= length2) && (length2==1 ||
		    memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
			    == 0)) {
		if (p != ustring1) {
		    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
		    p = ustring1 + length2;
		} else {
		    p += length2;
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
	 * Peep-hole optimisation: if you're about to jump, do jump from here.
	 */

	JUMP_PEEPHOLE_F(match, 2, 2);

    {
	const char *string1, *string2;
	size_t trim1, trim2;

    case INST_STR_TRIM_LEFT:
	valuePtr = OBJ_UNDER_TOS;	/* String */
	value2Ptr = OBJ_AT_TOS;		/* TrimSet */
	string2 = Tcl_GetStringFromObj(value2Ptr, &length2);
	string1 = Tcl_GetStringFromObj(valuePtr, &slength);
	trim1 = TclTrimLeft(string1, slength, string2, length2);







|







5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
	 * Peep-hole optimisation: if you're about to jump, do jump from here.
	 */

	JUMP_PEEPHOLE_F(match, 2, 2);

    {
	const char *string1, *string2;
	Tcl_Size trim1, trim2;

    case INST_STR_TRIM_LEFT:
	valuePtr = OBJ_UNDER_TOS;	/* String */
	value2Ptr = OBJ_AT_TOS;		/* TrimSet */
	string2 = Tcl_GetStringFromObj(value2Ptr, &length2);
	string1 = Tcl_GetStringFromObj(valuePtr, &slength);
	trim1 = TclTrimLeft(string1, slength, string2, length2);
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
		    goto wideResultOfArithmetic;
		}
		break;

	    case INST_RSHIFT:
		if (w2 < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "negative shift argument", TCL_INDEX_NONE));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
		    DECACHE_STACK_INFO();
		    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
			    "domain error: argument not in valid range",
			    NULL);
		    CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */







|







5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
		    goto wideResultOfArithmetic;
		}
		break;

	    case INST_RSHIFT:
		if (w2 < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
		    DECACHE_STACK_INFO();
		    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
			    "domain error: argument not in valid range",
			    NULL);
		    CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
		    goto wideResultOfArithmetic;
		}
		break;

	    case INST_LSHIFT:
		if (w2 < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "negative shift argument", TCL_INDEX_NONE));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
		    DECACHE_STACK_INFO();
		    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
			    "domain error: argument not in valid range",
			    NULL);
		    CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */







|







5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
		    goto wideResultOfArithmetic;
		}
		break;

	    case INST_LSHIFT:
		if (w2 < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
		    DECACHE_STACK_INFO();
		    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
			    "domain error: argument not in valid range",
			    NULL);
		    CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
		     * Technically, we could hold the value (1 << (INT_MAX+1))
		     * in an mp_int, but since we're using mp_mul_2d() to do
		     * the work, and it takes only an int argument, that's a
		     * good place to draw the line.
		     */

		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "integer value too large to represent", TCL_INDEX_NONE));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
		    DECACHE_STACK_INFO();
		    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
			    "integer value too large to represent", NULL);
		    CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
		    goto gotError;







|







5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
		     * Technically, we could hold the value (1 << (INT_MAX+1))
		     * in an mp_int, but since we're using mp_mul_2d() to do
		     * the work, and it takes only an int argument, that's a
		     * good place to draw the line.
		     */

		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "integer value too large to represent", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
		    DECACHE_STACK_INFO();
		    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
			    "integer value too large to represent", NULL);
		    CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
		    goto gotError;
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
	TRACE(("=> CONTINUE!\n"));
	goto processExceptionReturn;

    {
	ForeachInfo *infoPtr;
	Tcl_Obj *listPtr, **elements;
	ForeachVarList *varListPtr;
	size_t numLists, listLen, numVars, listTmpDepth;
	size_t iterNum, iterMax, iterTmp;
	size_t varIndex, valIndex, i, j;

    case INST_FOREACH_START:
	/*
	 * Initialize the data for the looping construct, pushing the
	 * corresponding Tcl_Objs to the stack.
	 */








|
|
|







6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
	TRACE(("=> CONTINUE!\n"));
	goto processExceptionReturn;

    {
	ForeachInfo *infoPtr;
	Tcl_Obj *listPtr, **elements;
	ForeachVarList *varListPtr;
	Tcl_Size numLists, listLen, numVars, listTmpDepth;
	Tcl_Size iterNum, iterMax, iterTmp;
	Tcl_Size varIndex, valIndex, i, j;

    case INST_FOREACH_START:
	/*
	 * Initialize the data for the looping construct, pushing the
	 * corresponding Tcl_Objs to the stack.
	 */

6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
    /*
     * -----------------------------------------------------------------
     *	   Start of dictionary-related instructions.
     */

    {
	int opnd2, allocateDict, done, allocdict;
	size_t i;
	Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
	Tcl_Obj *emptyPtr, **keyPtrPtr;
	Tcl_DictSearch *searchPtr;
	DictUpdateInfo *duiPtr;

    case INST_DICT_VERIFY: {
	size_t size;
	dictPtr = OBJ_AT_TOS;
	TRACE(("\"%.30s\" => ", O2S(dictPtr)));
	if (Tcl_DictObjSize(interp, dictPtr, &size) != TCL_OK) {
	    TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
		    O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
	    goto gotError;
	}







|






|







6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
    /*
     * -----------------------------------------------------------------
     *	   Start of dictionary-related instructions.
     */

    {
	int opnd2, allocateDict, done, allocdict;
	Tcl_Size i;
	Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
	Tcl_Obj *emptyPtr, **keyPtrPtr;
	Tcl_DictSearch *searchPtr;
	DictUpdateInfo *duiPtr;

    case INST_DICT_VERIFY: {
	Tcl_Size size;
	dictPtr = OBJ_AT_TOS;
	TRACE(("\"%.30s\" => ", O2S(dictPtr)));
	if (Tcl_DictObjSize(interp, dictPtr, &size) != TCL_OK) {
	    TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
		    O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
	    goto gotError;
	}
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448

	/*
	 * Division by zero in an expression. Control only reaches this point
	 * by "goto divideByZero".
	 */

    divideByZero:
	Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", TCL_INDEX_NONE));
	DECACHE_STACK_INFO();
	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
	CACHE_STACK_INFO();
	goto gotError;

    outOfMemory:
	Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", TCL_INDEX_NONE));
	DECACHE_STACK_INFO();
	Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", NULL);
	CACHE_STACK_INFO();
	goto gotError;

	/*
	 * Exponentiation of zero by negative number in an expression. Control
	 * only reaches this point by "goto exponOfZero".
	 */

    exponOfZero:
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"exponentiation of zero by negative power", TCL_INDEX_NONE));
	DECACHE_STACK_INFO();
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
		"exponentiation of zero by negative power", NULL);
	CACHE_STACK_INFO();

	/*
	 * Almost all error paths feed through here rather than assigning to







|






|












|







7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448

	/*
	 * Division by zero in an expression. Control only reaches this point
	 * by "goto divideByZero".
	 */

    divideByZero:
	Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
	DECACHE_STACK_INFO();
	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
	CACHE_STACK_INFO();
	goto gotError;

    outOfMemory:
	Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1));
	DECACHE_STACK_INFO();
	Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", NULL);
	CACHE_STACK_INFO();
	goto gotError;

	/*
	 * Exponentiation of zero by negative number in an expression. Control
	 * only reaches this point by "goto exponOfZero".
	 */

    exponOfZero:
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"exponentiation of zero by negative power", -1));
	DECACHE_STACK_INFO();
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
		"exponentiation of zero by negative power", NULL);
	CACHE_STACK_INFO();

	/*
	 * Almost all error paths feed through here rather than assigning to
7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476

    checkForCatch:
	if (iPtr->execEnvPtr->rewind) {
	    goto abnormalReturn;
	}
	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	    const unsigned char *pcBeg;
	    size_t xxx1length;

	    bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, &pcBeg, NULL);
	    DECACHE_STACK_INFO();
	    TclLogCommandInfo(interp, codePtr->source, bytes,
		    bytes ? xxx1length : 0, pcBeg, tosPtr);
	    CACHE_STACK_INFO();
	}







|







7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476

    checkForCatch:
	if (iPtr->execEnvPtr->rewind) {
	    goto abnormalReturn;
	}
	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	    const unsigned char *pcBeg;
	    Tcl_Size xxx1length;

	    bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, &pcBeg, NULL);
	    DECACHE_STACK_INFO();
	    TclLogCommandInfo(interp, codePtr->source, bytes,
		    bytes ? xxx1length : 0, pcBeg, tosPtr);
	    CACHE_STACK_INFO();
	}
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642
7643

     * case INST_START_CMD:
     */

	instStartCmdFailed:
	{
	    const char *bytes;
	    size_t xxx1length;

	    xxx1length = 0;

	    if (TclInterpReady(interp) == TCL_ERROR) {
		goto gotError;
	    }








|







7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642
7643

     * case INST_START_CMD:
     */

	instStartCmdFailed:
	{
	    const char *bytes;
	    Tcl_Size xxx1length;

	    xxx1length = 0;

	    if (TclInterpReady(interp) == TCL_ERROR) {
		goto gotError;
	    }

7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
	    break;
	default:
	    /* Unused, here to silence compiler warning */
	    invalid = 0;
	}
	if (invalid) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "negative shift argument", TCL_INDEX_NONE));
	    return GENERAL_ARITHMETIC_ERROR;
	}

	/*
	 * Zero shifted any number of bits is still zero.
	 */








|







7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
	    break;
	default:
	    /* Unused, here to silence compiler warning */
	    invalid = 0;
	}
	if (invalid) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "negative shift argument", -1));
	    return GENERAL_ARITHMETIC_ERROR;
	}

	/*
	 * Zero shifted any number of bits is still zero.
	 */

8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
		 * Technically, we could hold the value (1 << (INT_MAX+1)) in
		 * an mp_int, but since we're using mp_mul_2d() to do the
		 * work, and it takes only an int argument, that's a good
		 * place to draw the line.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"integer value too large to represent", TCL_INDEX_NONE));
		return GENERAL_ARITHMETIC_ERROR;
	    }
	    shift = (int)(*((const Tcl_WideInt *)ptr2));

	    /*
	     * Handle shifts within the native wide range.
	     */







|







8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
		 * Technically, we could hold the value (1 << (INT_MAX+1)) in
		 * an mp_int, but since we're using mp_mul_2d() to do the
		 * work, and it takes only an int argument, that's a good
		 * place to draw the line.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"integer value too large to represent", -1));
		return GENERAL_ARITHMETIC_ERROR;
	    }
	    shift = (int)(*((const Tcl_WideInt *)ptr2));

	    /*
	     * Handle shifts within the native wide range.
	     */
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
	 * range of the long int type. This means any numeric Tcl_Obj value
	 * not using TCL_NUMBER_INT type must hold a value larger than we
	 * accept.
	 */

	if (type2 != TCL_NUMBER_INT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "exponent too large", TCL_INDEX_NONE));
	    return GENERAL_ARITHMETIC_ERROR;
	}

	/* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */
	assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT);

	if (w1 == 2) {







|







8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
	 * range of the long int type. This means any numeric Tcl_Obj value
	 * not using TCL_NUMBER_INT type must hold a value larger than we
	 * accept.
	 */

	if (type2 != TCL_NUMBER_INT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "exponent too large", -1));
	    return GENERAL_ARITHMETIC_ERROR;
	}

	/* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */
	assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT);

	if (w1 == 2) {
8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368

    overflowExpon:

	if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
		|| (value2Ptr->typePtr != &tclIntType.objType)
		|| (Tcl_WideUInt)w2 >= (1<<28)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "exponent too large", TCL_INDEX_NONE));
	    return GENERAL_ARITHMETIC_ERROR;
	}
	Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
	err = mp_init(&bigResult);
	if (err == MP_OKAY) {
	    err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
	}







|







8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368

    overflowExpon:

	if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
		|| (value2Ptr->typePtr != &tclIntType.objType)
		|| (Tcl_WideUInt)w2 >= (1<<28)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "exponent too large", -1));
	    return GENERAL_ARITHMETIC_ERROR;
	}
	Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
	err = mp_init(&bigResult);
	if (err == MP_OKAY) {
	    err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
	}
9060
9061
9062
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
9073
9074
	/*
	 * We now have the command. We can get the srcOffset back and from
	 * there find the list of word locations for this command.
	 */

	ExtCmdLoc *eclPtr;
	ECL *locPtr = NULL;
	size_t srcOffset;
	int i;
	Interp *iPtr = (Interp *) *codePtr->interpHandle;
	Tcl_HashEntry *hePtr =
		Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);

	if (!hePtr) {
	    return;







|







9060
9061
9062
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
9073
9074
	/*
	 * We now have the command. We can get the srcOffset back and from
	 * there find the list of word locations for this command.
	 */

	ExtCmdLoc *eclPtr;
	ECL *locPtr = NULL;
	Tcl_Size srcOffset;
	int i;
	Interp *iPtr = (Interp *) *codePtr->interpHandle;
	Tcl_HashEntry *hePtr =
		Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);

	if (!hePtr) {
	    return;
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
GetSrcInfoForPc(
    const unsigned char *pc,	/* The program counter value for which to
				 * return the closest command's source info.
				 * This points within a bytecode instruction
				 * in codePtr's code. */
    ByteCode *codePtr,		/* The bytecode sequence in which to look up
				 * the command source for the pc. */
    size_t *lengthPtr,		/* If non-NULL, the location where the length
				 * of the command's source should be stored.
				 * If NULL, no length is stored. */
    const unsigned char **pcBeg,/* If non-NULL, the bytecode location
				 * where the current instruction starts.
				 * If NULL; no pointer is stored. */
    int *cmdIdxPtr)		/* If non-NULL, the location where the index
				 * of the command containing the pc should
				 * be stored. */
{
    size_t pcOffset = (size_t)(pc - codePtr->codeStart);
    size_t numCmds = codePtr->numCommands;
    unsigned char *codeDeltaNext, *codeLengthNext;
    unsigned char *srcDeltaNext, *srcLengthNext;
    size_t codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
    int bestDist = INT_MAX;	/* Distance of pc to best cmd's start pc. */
    int bestSrcOffset = -1;	/* Initialized to avoid compiler warning. */
    int bestSrcLength = -1;	/* Initialized to avoid compiler warning. */
    int bestCmdIdx = -1;

    /* The pc must point within the bytecode */
    assert (pcOffset < codePtr->numCodeBytes);







|









|
|


|







9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
GetSrcInfoForPc(
    const unsigned char *pc,	/* The program counter value for which to
				 * return the closest command's source info.
				 * This points within a bytecode instruction
				 * in codePtr's code. */
    ByteCode *codePtr,		/* The bytecode sequence in which to look up
				 * the command source for the pc. */
    Tcl_Size *lengthPtr,	/* If non-NULL, the location where the length
				 * of the command's source should be stored.
				 * If NULL, no length is stored. */
    const unsigned char **pcBeg,/* If non-NULL, the bytecode location
				 * where the current instruction starts.
				 * If NULL; no pointer is stored. */
    int *cmdIdxPtr)		/* If non-NULL, the location where the index
				 * of the command containing the pc should
				 * be stored. */
{
    Tcl_Size pcOffset = pc - codePtr->codeStart;
    Tcl_Size numCmds = codePtr->numCommands;
    unsigned char *codeDeltaNext, *codeLengthNext;
    unsigned char *srcDeltaNext, *srcLengthNext;
    Tcl_Size codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
    int bestDist = INT_MAX;	/* Distance of pc to best cmd's start pc. */
    int bestSrcOffset = -1;	/* Initialized to avoid compiler warning. */
    int bestSrcLength = -1;	/* Initialized to avoid compiler warning. */
    int bestCmdIdx = -1;

    /* The pc must point within the bytecode */
    assert (pcOffset < codePtr->numCodeBytes);
9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
    double value)		/* Value returned after error; used to
				 * distinguish underflows from overflows. */
{
    const char *s;

    if ((errno == EDOM) || isnan(value)) {
	s = "domain error: argument not in valid range";
	Tcl_SetObjResult(interp, Tcl_NewStringObj(s, TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL);
    } else if ((errno == ERANGE) || isinf(value)) {
	if (value == 0.0) {
	    s = "floating-point value too small to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL);
	}
    } else {
	Tcl_Obj *objPtr = Tcl_ObjPrintf(
		"unknown floating-point error, errno = %d", errno);

	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",







|




|



|







9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
    double value)		/* Value returned after error; used to
				 * distinguish underflows from overflows. */
{
    const char *s;

    if ((errno == EDOM) || isnan(value)) {
	s = "domain error: argument not in valid range";
	Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL);
    } else if ((errno == ERANGE) || isinf(value)) {
	if (value == 0.0) {
	    s = "floating-point value too small to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL);
	} else {
	    s = "floating-point value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL);
	}
    } else {
	Tcl_Obj *objPtr = Tcl_ObjPrintf(
		"unknown floating-point error, errno = %d", errno);

	Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",

Changes to generic/tclFCmd.c.

217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Used for error reporting. */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[])	/* Argument strings passed to Tcl_FileCmd. */
{
    Tcl_Obj *errfile = NULL;
    int result, i;
    size_t j, pobjc;
    Tcl_Obj *split = NULL;
    Tcl_Obj *target = NULL;
    Tcl_StatBuf statBuf;

    result = TCL_OK;
    for (i = 1; i < objc; i++) {
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {







|







217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Used for error reporting. */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[])	/* Argument strings passed to Tcl_FileCmd. */
{
    Tcl_Obj *errfile = NULL;
    int result, i;
    Tcl_Size j, pobjc;
    Tcl_Obj *split = NULL;
    Tcl_Obj *target = NULL;
    Tcl_StatBuf statBuf;

    result = TCL_OK;
    for (i = 1; i < objc; i++) {
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
 */

static Tcl_Obj *
FileBasename(
    TCL_UNUSED(Tcl_Interp *),	/* Interp, for error return. */
    Tcl_Obj *pathPtr)		/* Path whose basename to extract. */
{
    size_t objc;
    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;

    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
    Tcl_IncrRefCount(splitPtr);

    if (objc != 0) {







|







870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
 */

static Tcl_Obj *
FileBasename(
    TCL_UNUSED(Tcl_Interp *),	/* Interp, for error return. */
    Tcl_Obj *pathPtr)		/* Path whose basename to extract. */
{
    Tcl_Size objc;
    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;

    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
    Tcl_IncrRefCount(splitPtr);

    if (objc != 0) {
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
    int objc,			/* Number of command line arguments. */
    Tcl_Obj *const objv[])	/* The command line objects. */
{
    int result;
    const char *const *attributeStrings;
    const char **attributeStringsAllocated = NULL;
    Tcl_Obj *objStrings = NULL;
    size_t numObjStrings = TCL_INDEX_NONE;
    Tcl_Obj *filePtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
	return TCL_ERROR;
    }








|







943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
    int objc,			/* Number of command line arguments. */
    Tcl_Obj *const objv[])	/* The command line objects. */
{
    int result;
    const char *const *attributeStrings;
    const char **attributeStringsAllocated = NULL;
    Tcl_Obj *objStrings = NULL;
    Tcl_Size numObjStrings = TCL_INDEX_NONE;
    Tcl_Obj *filePtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
	return TCL_ERROR;
    }

967
968
969
970
971
972
973
974
975
976
977
978
979
980
981

    /*
     * Get the set of attribute names from the filesystem.
     */

    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	size_t index;
	Tcl_Obj *objPtr;

	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/*
		 * There was an error, probably that the filePtr is not
		 * accepted by any filesystem







|







967
968
969
970
971
972
973
974
975
976
977
978
979
980
981

    /*
     * Get the set of attribute names from the filesystem.
     */

    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	Tcl_Size index;
	Tcl_Obj *objPtr;

	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/*
		 * There was an error, probably that the filePtr is not
		 * accepted by any filesystem
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052

		Tcl_ResetResult(interp);
	    }

	    res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr);
	    if (res == TCL_OK) {
		Tcl_Obj *objPtr =
			Tcl_NewStringObj(attributeStrings[index], TCL_INDEX_NONE);

		Tcl_ListObjAppendElement(interp, listPtr, objPtr);
		Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
		nbAtts++;
	    }
	}








|







1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052

		Tcl_ResetResult(interp);
	    }

	    res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr);
	    if (res == TCL_OK) {
		Tcl_Obj *objPtr =
			Tcl_NewStringObj(attributeStrings[index], -1);

		Tcl_ListObjAppendElement(interp, listPtr, objPtr);
		Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
		nbAtts++;
	    }
	}

1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
    if (nameVarObj != NULL) {
	if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    Tcl_UnregisterChannel(interp, chan);
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), TCL_INDEX_NONE));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileTempDirCmd --







|







1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
    if (nameVarObj != NULL) {
	if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    Tcl_UnregisterChannel(interp, chan);
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileTempDirCmd --

Changes to generic/tclFileName.c.

377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclpGetNativePathType(
    Tcl_Obj *pathPtr,		/* Native path of interest */
    size_t *driveNameLengthPtr,	/* Returns length of drive, if non-NULL and
				 * path was absolute */
    Tcl_Obj **driveNameRef)
{
    Tcl_PathType type = TCL_PATH_ABSOLUTE;
    const char *path = TclGetString(pathPtr);

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX: {







|
|







377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclpGetNativePathType(
    Tcl_Obj *pathPtr,		/* Native path of interest */
    Tcl_Size *driveNameLengthPtr, /* Returns length of drive, if non-NULL and
				   * path was absolute */
    Tcl_Obj **driveNameRef)
{
    Tcl_PathType type = TCL_PATH_ABSOLUTE;
    const char *path = TclGetString(pathPtr);

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX: {
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclpNativeSplitPath(
    Tcl_Obj *pathPtr,		/* Path to split. */
    size_t *lenPtr)		/* int to store number of path elements. */
{
    Tcl_Obj *resultPtr = NULL;	/* Needed only to prevent gcc warnings. */

    /*
     * Perform platform specific splitting.
     */








|







461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclpNativeSplitPath(
    Tcl_Obj *pathPtr,		/* Path to split. */
    Tcl_Size *lenPtr)		/* int to store number of path elements. */
{
    Tcl_Obj *resultPtr = NULL;	/* Needed only to prevent gcc warnings. */

    /*
     * Perform platform specific splitting.
     */

518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
 *----------------------------------------------------------------------
 */

#undef Tcl_SplitPath
void
Tcl_SplitPath(
    const char *path,		/* Pointer to string containing a path. */
    size_t *argcPtr,		/* Pointer to location to fill in with the
				 * number of elements in the path. */
    const char ***argvPtr)	/* Pointer to place to store pointer to array
				 * of pointers to path elements. */
{
    Tcl_Obj *resultPtr = NULL;	/* Needed only to prevent gcc warnings. */
    Tcl_Obj *tmpPtr, *eltPtr;
    size_t i, size, len;
    char *p;
    const char *str;

    /*
     * Perform the splitting, using objectified, vfs-aware code.
     */

    tmpPtr = Tcl_NewStringObj(path, TCL_INDEX_NONE);
    Tcl_IncrRefCount(tmpPtr);
    resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(tmpPtr);

    /*
     * Calculate space required for the result.







|






|







|







518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
 *----------------------------------------------------------------------
 */

#undef Tcl_SplitPath
void
Tcl_SplitPath(
    const char *path,		/* Pointer to string containing a path. */
    Tcl_Size *argcPtr,		/* Pointer to location to fill in with the
				 * number of elements in the path. */
    const char ***argvPtr)	/* Pointer to place to store pointer to array
				 * of pointers to path elements. */
{
    Tcl_Obj *resultPtr = NULL;	/* Needed only to prevent gcc warnings. */
    Tcl_Obj *tmpPtr, *eltPtr;
    Tcl_Size i, size, len;
    char *p;
    const char *str;

    /*
     * Perform the splitting, using objectified, vfs-aware code.
     */

    tmpPtr = Tcl_NewStringObj(path, -1);
    Tcl_IncrRefCount(tmpPtr);
    resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(tmpPtr);

    /*
     * Calculate space required for the result.
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSJoinToPath(
    Tcl_Obj *pathPtr,		/* Valid path or NULL. */
    size_t objc,			/* Number of array elements to join */
    Tcl_Obj *const objv[])	/* Path elements to join. */
{
    if (pathPtr == NULL) {
	return TclJoinPath(objc, objv, 0);
    }
    if (objc == 0) {
	return TclJoinPath(1, &pathPtr, 0);
    }
    if (objc == 1) {
	Tcl_Obj *pair[2];

	pair[0] = pathPtr;
	pair[1] = objv[0];
	return TclJoinPath(2, pair, 0);
    } else {
	size_t elemc = objc + 1;
	Tcl_Obj *ret, **elemv = (Tcl_Obj**)Tcl_Alloc(elemc*sizeof(Tcl_Obj *));

	elemv[0] = pathPtr;
	memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
	ret = TclJoinPath(elemc, elemv, 0);
	Tcl_Free(elemv);
	return ret;







|















|







754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSJoinToPath(
    Tcl_Obj *pathPtr,		/* Valid path or NULL. */
    Tcl_Size objc,		/* Number of array elements to join */
    Tcl_Obj *const objv[])	/* Path elements to join. */
{
    if (pathPtr == NULL) {
	return TclJoinPath(objc, objv, 0);
    }
    if (objc == 0) {
	return TclJoinPath(1, &pathPtr, 0);
    }
    if (objc == 1) {
	Tcl_Obj *pair[2];

	pair[0] = pathPtr;
	pair[1] = objv[0];
	return TclJoinPath(2, pair, 0);
    } else {
	Tcl_Size elemc = objc + 1;
	Tcl_Obj *ret, **elemv = (Tcl_Obj**)Tcl_Alloc(elemc*sizeof(Tcl_Obj *));

	elemv[0] = pathPtr;
	memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
	ret = TclJoinPath(elemc, elemv, 0);
	Tcl_Free(elemv);
	return ret;
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
 *	Modifies the Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_JoinPath(
    size_t argc,
    const char *const *argv,
    Tcl_DString *resultPtr)	/* Pointer to previously initialized DString */
{
    size_t i, len;
    Tcl_Obj *listObj;
    Tcl_Obj *resultObj;
    const char *resultStr;

    /*
     * Build the list of paths.
     */

    TclNewObj(listObj);
    for (i = 0; i < argc; i++) {
	Tcl_ListObjAppendElement(NULL, listObj,
		Tcl_NewStringObj(argv[i], TCL_INDEX_NONE));
    }

    /*
     * Ask the objectified code to join the paths.
     */

    Tcl_IncrRefCount(listObj);







|



|











|







923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
 *	Modifies the Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_JoinPath(
    Tcl_Size argc,
    const char *const *argv,
    Tcl_DString *resultPtr)	/* Pointer to previously initialized DString */
{
    Tcl_Size i, len;
    Tcl_Obj *listObj;
    Tcl_Obj *resultObj;
    const char *resultStr;

    /*
     * Build the list of paths.
     */

    TclNewObj(listObj);
    for (i = 0; i < argc; i++) {
	Tcl_ListObjAppendElement(NULL, listObj,
		Tcl_NewStringObj(argv[i], -1));
    }

    /*
     * Ask the objectified code to join the paths.
     */

    Tcl_IncrRefCount(listObj);
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
    const char *name,		/* File name, which may begin with "~" (to
				 * indicate current user's home directory) or
				 * "~<user>" (to indicate any user's home
				 * directory). */
    Tcl_DString *bufferPtr)	/* Uninitialized or free DString filled with
				 * name. */
{
    Tcl_Obj *path = Tcl_NewStringObj(name, TCL_INDEX_NONE);
    Tcl_Obj *transPtr;

    Tcl_IncrRefCount(path);
    transPtr = Tcl_FSGetTranslatedPath(interp, path);
    if (transPtr == NULL) {
	Tcl_DecrRefCount(path);
	return NULL;







|







999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
    const char *name,		/* File name, which may begin with "~" (to
				 * indicate current user's home directory) or
				 * "~<user>" (to indicate any user's home
				 * directory). */
    Tcl_DString *bufferPtr)	/* Uninitialized or free DString filled with
				 * name. */
{
    Tcl_Obj *path = Tcl_NewStringObj(name, -1);
    Tcl_Obj *transPtr;

    Tcl_IncrRefCount(path);
    transPtr = Tcl_FSGetTranslatedPath(interp, path);
    if (transPtr == NULL) {
	Tcl_DecrRefCount(path);
	return NULL;
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
Tcl_GlobObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, globFlags, join, dir, result;
    size_t length;
    char *string;
    const char *separators;
    Tcl_Obj *typePtr, *look;
    Tcl_Obj *pathOrDir = NULL;
    Tcl_DString prefix;
    static const char *const options[] = {
	"-directory", "-join", "-nocomplain", "-path", "-tails",







|







1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
Tcl_GlobObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, globFlags, join, dir, result;
    Tcl_Size length;
    char *string;
    const char *separators;
    Tcl_Obj *typePtr, *look;
    Tcl_Obj *pathOrDir = NULL;
    Tcl_DString prefix;
    static const char *const options[] = {
	"-directory", "-join", "-nocomplain", "-path", "-tails",
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
	     * Do nothing; This is normal operations in Tcl 9.
	     * Keep accepting as a no-op option to accommodate old scripts.
	     */
	    break;
	case GLOB_DIR:				/* -dir */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing argument to \"-directory\"", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		return TCL_ERROR;
	    }
	    if (dir != PATH_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			dir == PATH_DIR
			    ? "\"-directory\" may only be used once"







|







1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
	     * Do nothing; This is normal operations in Tcl 9.
	     * Keep accepting as a no-op option to accommodate old scripts.
	     */
	    break;
	case GLOB_DIR:				/* -dir */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing argument to \"-directory\"", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		return TCL_ERROR;
	    }
	    if (dir != PATH_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			dir == PATH_DIR
			    ? "\"-directory\" may only be used once"
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
	    break;
	case GLOB_TAILS:				/* -tails */
	    globFlags |= TCL_GLOBMODE_TAILS;
	    break;
	case GLOB_PATH:				/* -path */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing argument to \"-path\"", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		return TCL_ERROR;
	    }
	    if (dir != PATH_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			dir == PATH_GENERAL
			    ? "\"-path\" may only be used once"
			    : "\"-path\" cannot be used with \"-dictionary\"",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
			"BADOPTIONCOMBINATION", NULL);
		return TCL_ERROR;
	    }
	    dir = PATH_GENERAL;
	    pathOrDir = objv[i+1];
	    i++;
	    break;
	case GLOB_TYPE:				/* -types */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing argument to \"-types\"", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		return TCL_ERROR;
	    }
	    typePtr = objv[i+1];
	    if (TclListObjLengthM(interp, typePtr, &length) != TCL_OK) {
		return TCL_ERROR;
	    }
	    i++;
	    break;
	case GLOB_LAST:				/* -- */
	    i++;
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"\"-tails\" must be used with either "
		"\"-directory\" or \"-path\"", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
		"BADOPTIONCOMBINATION", NULL);
	return TCL_ERROR;
    }

    separators = NULL;
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	separators = "/";
	break;
    case TCL_PLATFORM_WINDOWS:
	separators = "/\\:";
	break;
    }

    if (dir == PATH_GENERAL) {
	size_t pathlength;
	const char *last;
	const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);

	/*
	 * Find the last path separator in the path
	 */








|




















|



















|
















|







1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
	    break;
	case GLOB_TAILS:				/* -tails */
	    globFlags |= TCL_GLOBMODE_TAILS;
	    break;
	case GLOB_PATH:				/* -path */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing argument to \"-path\"", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		return TCL_ERROR;
	    }
	    if (dir != PATH_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			dir == PATH_GENERAL
			    ? "\"-path\" may only be used once"
			    : "\"-path\" cannot be used with \"-dictionary\"",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
			"BADOPTIONCOMBINATION", NULL);
		return TCL_ERROR;
	    }
	    dir = PATH_GENERAL;
	    pathOrDir = objv[i+1];
	    i++;
	    break;
	case GLOB_TYPE:				/* -types */
	    if (i == (objc-1)) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing argument to \"-types\"", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		return TCL_ERROR;
	    }
	    typePtr = objv[i+1];
	    if (TclListObjLengthM(interp, typePtr, &length) != TCL_OK) {
		return TCL_ERROR;
	    }
	    i++;
	    break;
	case GLOB_LAST:				/* -- */
	    i++;
	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"\"-tails\" must be used with either "
		"\"-directory\" or \"-path\"", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
		"BADOPTIONCOMBINATION", NULL);
	return TCL_ERROR;
    }

    separators = NULL;
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	separators = "/";
	break;
    case TCL_PLATFORM_WINDOWS:
	separators = "/\\:";
	break;
    }

    if (dir == PATH_GENERAL) {
	Tcl_Size pathlength;
	const char *last;
	const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);

	/*
	 * Find the last path separator in the path
	 */

1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
		/*
		 * The whole thing is a prefix. This means we must remove any
		 * 'tails' flag too, since it is irrelevant now (the same
		 * effect will happen without it), but in particular its use
		 * in TclGlob requires a non-NULL pathOrDir.
		 */

		Tcl_DStringAppend(&pref, first, TCL_INDEX_NONE);
		globFlags &= ~TCL_GLOBMODE_TAILS;
		pathOrDir = NULL;
	    } else {
		/*
		 * Have to split off the end.
		 */








|







1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
		/*
		 * The whole thing is a prefix. This means we must remove any
		 * 'tails' flag too, since it is irrelevant now (the same
		 * effect will happen without it), but in particular its use
		 * in TclGlob requires a non-NULL pathOrDir.
		 */

		Tcl_DStringAppend(&pref, first, -1);
		globFlags &= ~TCL_GLOBMODE_TAILS;
		pathOrDir = NULL;
	    } else {
		/*
		 * Have to split off the end.
		 */

1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
		Tcl_DStringAppend(&prefix, find, 1);
		search = find+1;
		if (*search == '\0') {
		    break;
		}
	    }
	    if (*search != '\0') {
		Tcl_DStringAppend(&prefix, search, TCL_INDEX_NONE);
	    }
	    Tcl_DStringFree(&pref);
	}
    }

    if (pathOrDir != NULL) {
	Tcl_IncrRefCount(pathOrDir);







|







1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
		Tcl_DStringAppend(&prefix, find, 1);
		search = find+1;
		if (*search == '\0') {
		    break;
		}
	    }
	    if (*search != '\0') {
		Tcl_DStringAppend(&prefix, search, -1);
	    }
	    Tcl_DStringFree(&pref);
	}
    }

    if (pathOrDir != NULL) {
	Tcl_IncrRefCount(pathOrDir);
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
		    goto badMacTypesArg;
		}
		globTypes->macType = look;
		Tcl_IncrRefCount(look);

	    } else {
		Tcl_Obj *item;
		size_t llen;

		if ((TclListObjLengthM(NULL, look, &llen) == TCL_OK)
			&& (llen == 3)) {
		    Tcl_ListObjIndex(interp, look, 0, &item);
		    if (!strcmp("macintosh", TclGetString(item))) {
			Tcl_ListObjIndex(interp, look, 1, &item);
			if (!strcmp("type", TclGetString(item))) {







|







1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
		    goto badMacTypesArg;
		}
		globTypes->macType = look;
		Tcl_IncrRefCount(look);

	    } else {
		Tcl_Obj *item;
		Tcl_Size llen;

		if ((TclListObjLengthM(NULL, look, &llen) == TCL_OK)
			&& (llen == 3)) {
		    Tcl_ListObjIndex(interp, look, 0, &item);
		    if (!strcmp("macintosh", TclGetString(item))) {
			Tcl_ListObjIndex(interp, look, 1, &item);
			if (!strcmp("type", TclGetString(item))) {
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;

	    badMacTypesArg:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"only one MacOS type or creator argument"
			" to \"-types\" allowed", TCL_INDEX_NONE));
		result = TCL_ERROR;
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
		join = 0;
		goto endOfGlob;
	    }
	}
    }







|







1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;

	    badMacTypesArg:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"only one MacOS type or creator argument"
			" to \"-types\" allowed", -1));
		result = TCL_ERROR;
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
		join = 0;
		goto endOfGlob;
	    }
	}
    }
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
		}
		p++;
	    }
	    tail = p;
	    Tcl_IncrRefCount(pathPrefix);
	} else if (pathPrefix == NULL && (tail[0] == '/'
		|| (tail[0] == '\\' && tail[1] == '\\'))) {
	    size_t driveNameLen;
	    Tcl_Obj *driveName;
	    Tcl_Obj *temp = Tcl_NewStringObj(tail, TCL_INDEX_NONE);
	    Tcl_IncrRefCount(temp);

	    switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) {
	    case TCL_PATH_VOLUME_RELATIVE: {
		/*
		 * Volume relative path which is equivalent to a path in the
		 * root of the cwd's volume. We will actually return







|

|







1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
		}
		p++;
	    }
	    tail = p;
	    Tcl_IncrRefCount(pathPrefix);
	} else if (pathPrefix == NULL && (tail[0] == '/'
		|| (tail[0] == '\\' && tail[1] == '\\'))) {
	    Tcl_Size driveNameLen;
	    Tcl_Obj *driveName;
	    Tcl_Obj *temp = Tcl_NewStringObj(tail, -1);
	    Tcl_IncrRefCount(temp);

	    switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) {
	    case TCL_PATH_VOLUME_RELATIVE: {
		/*
		 * Volume relative path which is equivalent to a path in the
		 * root of the cwd's volume. We will actually return
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718

    /*
     * Finally if we still haven't managed to generate a path prefix, check if
     * the path starts with a current volume.
     */

    if (pathPrefix == NULL) {
	size_t driveNameLen;
	Tcl_Obj *driveName;
	if (TclFSNonnativePathType(tail, strlen(tail), NULL,
		&driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) {
	    pathPrefix = driveName;
	    tail += driveNameLen;
	}
    }







|







1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718

    /*
     * Finally if we still haven't managed to generate a path prefix, check if
     * the path starts with a current volume.
     */

    if (pathPrefix == NULL) {
	Tcl_Size driveNameLen;
	Tcl_Obj *driveName;
	if (TclFSNonnativePathType(tail, strlen(tail), NULL,
		&driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) {
	    pathPrefix = driveName;
	    tail += driveNameLen;
	}
    }
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
     * that would add a lot of complexity to the code. This way is a little
     * slower (when the -tails flag is given), but much simpler to code.
     *
     * We do it by rewriting the result list in-place.
     */

    if (globFlags & TCL_GLOBMODE_TAILS) {
	size_t objc, i;
	Tcl_Obj **objv;
	size_t prefixLen;
	const char *pre;

	/*
	 * If this length has never been set, set it here.
	 */

	if (pathPrefix == NULL) {







|

|







1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
     * that would add a lot of complexity to the code. This way is a little
     * slower (when the -tails flag is given), but much simpler to code.
     *
     * We do it by rewriting the result list in-place.
     */

    if (globFlags & TCL_GLOBMODE_TAILS) {
	Tcl_Size objc, i;
	Tcl_Obj **objv;
	Tcl_Size prefixLen;
	const char *pre;

	/*
	 * If this length has never been set, set it here.
	 */

	if (pathPrefix == NULL) {
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
		    || (pre[1] != ':')) {
		prefixLen++;
	    }
	}

	TclListObjGetElementsM(NULL, filenamesObj, &objc, &objv);
	for (i = 0; i< objc; i++) {
	    size_t len;
	    const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
	    Tcl_Obj *elem;

	    if (len == prefixLen) {
		if ((pattern[0] == '\0')
			|| (strchr(separators, pattern[0]) == NULL)) {
		    TclNewLiteralStringObj(elem, ".");







|







1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
		    || (pre[1] != ':')) {
		prefixLen++;
	    }
	}

	TclListObjGetElementsM(NULL, filenamesObj, &objc, &objv);
	for (i = 0; i< objc; i++) {
	    Tcl_Size len;
	    const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
	    Tcl_Obj *elem;

	    if (len == prefixLen) {
		if ((pattern[0] == '\0')
			|| (strchr(separators, pattern[0]) == NULL)) {
		    TclNewLiteralStringObj(elem, ".");
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
		 * Balanced braces.
		 */

		closeBrace = p;
		break;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unmatched open-brace in file name", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
		    NULL);
	    return TCL_ERROR;

	} else if (*p == '}') {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unmatched close-brace in file name", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
		    NULL);
	    return TCL_ERROR;
	}
    }

    /*







|






|







2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
		 * Balanced braces.
		 */

		closeBrace = p;
		break;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unmatched open-brace in file name", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
		    NULL);
	    return TCL_ERROR;

	} else if (*p == '}') {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unmatched close-brace in file name", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
		    NULL);
	    return TCL_ERROR;
	}
    }

    /*
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
	*closeBrace = '\0';
	for (p = openBrace; p != closeBrace; ) {
	    p++;
	    element = p;
	    SkipToChar(&p, ',');
	    Tcl_DStringSetLength(&newName, baseLength);
	    Tcl_DStringAppend(&newName, element, p-element);
	    Tcl_DStringAppend(&newName, closeBrace+1, TCL_INDEX_NONE);
	    result = DoGlob(interp, matchesObj, separators, pathPtr, flags,
		    Tcl_DStringValue(&newName), types);
	    if (result != TCL_OK) {
		break;
	    }
	}
	*closeBrace = '}';







|







2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
	*closeBrace = '\0';
	for (p = openBrace; p != closeBrace; ) {
	    p++;
	    element = p;
	    SkipToChar(&p, ',');
	    Tcl_DStringSetLength(&newName, baseLength);
	    Tcl_DStringAppend(&newName, element, p-element);
	    Tcl_DStringAppend(&newName, closeBrace+1, -1);
	    result = DoGlob(interp, matchesObj, separators, pathPtr, flags,
		    Tcl_DStringValue(&newName), types);
	    if (result != TCL_OK) {
		break;
	    }
	}
	*closeBrace = '}';
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
	*p = '\0';
	TclNewObj(subdirsPtr);
	Tcl_IncrRefCount(subdirsPtr);
	result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
		pattern, &dirOnly);
	*p = save;
	if (result == TCL_OK) {
	    size_t i, subdirc, repair = TCL_INDEX_NONE;
	    Tcl_Obj **subdirv;

	    result = TclListObjGetElementsM(interp, subdirsPtr,
		    &subdirc, &subdirv);
	    for (i=0; result==TCL_OK && i<subdirc; i++) {
		Tcl_Obj *copy = NULL;

		result = DoGlob(interp, matchesObj, separators, subdirv[i],
			1, p+1, types);
		if (copy) {
		    size_t end;

		    Tcl_DecrRefCount(subdirv[i]);
		    subdirv[i] = copy;
		    TclListObjLengthM(NULL, matchesObj, &end);
		    while (repair + 1 <= end) {
			const char *bytes;
			size_t numBytes;
			Tcl_Obj *fixme, *newObj;

			Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
			bytes = Tcl_GetStringFromObj(fixme, &numBytes);
			newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
			Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
				1, &newObj);







|










|




|

|







2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
	*p = '\0';
	TclNewObj(subdirsPtr);
	Tcl_IncrRefCount(subdirsPtr);
	result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
		pattern, &dirOnly);
	*p = save;
	if (result == TCL_OK) {
	    Tcl_Size i, subdirc, repair = -1;
	    Tcl_Obj **subdirv;

	    result = TclListObjGetElementsM(interp, subdirsPtr,
		    &subdirc, &subdirv);
	    for (i=0; result==TCL_OK && i<subdirc; i++) {
		Tcl_Obj *copy = NULL;

		result = DoGlob(interp, matchesObj, separators, subdirv[i],
			1, p+1, types);
		if (copy) {
		    Tcl_Size end;

		    Tcl_DecrRefCount(subdirv[i]);
		    subdirv[i] = copy;
		    TclListObjLengthM(NULL, matchesObj, &end);
		    while (repair < end) {
			const char *bytes;
			Tcl_Size numBytes;
			Tcl_Obj *fixme, *newObj;

			Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
			bytes = Tcl_GetStringFromObj(fixme, &numBytes);
			newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
			Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
				1, &newObj);

Changes to generic/tclFileSystem.h.

44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
/*
 * Private shared functions for use by tclIOUtil.c, tclPathObj.c and
 * tclFileName.c, and any platform-specific filesystem code.
 */

MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **filesystemPtrPtr,
			    size_t *driveNameLengthPtr);
MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr,
			    size_t pathLen, const Tcl_Filesystem **filesystemPtrPtr,
			    size_t *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **filesystemPtrPtr,
			    size_t *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE int	TclFSEpochOk(size_t filesystemEpoch);
MODULE_SCOPE int	TclFSCwdIsNative(void);
MODULE_SCOPE Tcl_Obj *	TclWinVolumeRelativeNormalize(Tcl_Interp *interp,
			    const char *path, Tcl_Obj **useThisCwdPtr);

MODULE_SCOPE Tcl_FSPathInFilesystemProc TclNativePathInFilesystem;
MODULE_SCOPE Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep;







|

|
|


|







44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
/*
 * Private shared functions for use by tclIOUtil.c, tclPathObj.c and
 * tclFileName.c, and any platform-specific filesystem code.
 */

MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **filesystemPtrPtr,
			    Tcl_Size *driveNameLengthPtr);
MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr,
			    Tcl_Size pathLen, const Tcl_Filesystem **filesystemPtrPtr,
			    Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **filesystemPtrPtr,
			    Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE int	TclFSEpochOk(size_t filesystemEpoch);
MODULE_SCOPE int	TclFSCwdIsNative(void);
MODULE_SCOPE Tcl_Obj *	TclWinVolumeRelativeNormalize(Tcl_Interp *interp,
			    const char *path, Tcl_Obj **useThisCwdPtr);

MODULE_SCOPE Tcl_FSPathInFilesystemProc TclNativePathInFilesystem;
MODULE_SCOPE Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep;

Changes to generic/tclHash.c.

434
435
436
437
438
439
440
441
442
443
444
445
446
447
448

void
Tcl_DeleteHashTable(
    Tcl_HashTable *tablePtr)	/* Table to delete. */
{
    Tcl_HashEntry *hPtr, *nextPtr;
    const Tcl_HashKeyType *typePtr;
    size_t i;

    if (tablePtr->keyType == TCL_STRING_KEYS) {
	typePtr = &tclStringHashKeyType;
    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
	typePtr = &tclOneWordHashKeyType;
    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
	    || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {







|







434
435
436
437
438
439
440
441
442
443
444
445
446
447
448

void
Tcl_DeleteHashTable(
    Tcl_HashTable *tablePtr)	/* Table to delete. */
{
    Tcl_HashEntry *hPtr, *nextPtr;
    const Tcl_HashKeyType *typePtr;
    Tcl_Size i;

    if (tablePtr->keyType == TCL_STRING_KEYS) {
	typePtr = &tclStringHashKeyType;
    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
	typePtr = &tclOneWordHashKeyType;
    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
	    || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
 */

char *
Tcl_HashStats(
    Tcl_HashTable *tablePtr)	/* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
    size_t i;
    TCL_HASH_TYPE count[NUM_COUNTERS], overflow, j;
    double average, tmp;
    Tcl_HashEntry *hPtr;
    char *result, *p;

    /*
     * Compute a histogram of bucket usage.







|







583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
 */

char *
Tcl_HashStats(
    Tcl_HashTable *tablePtr)	/* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
    Tcl_Size i;
    TCL_HASH_TYPE count[NUM_COUNTERS], overflow, j;
    double average, tmp;
    Tcl_HashEntry *hPtr;
    char *result, *p;

    /*
     * Compute a histogram of bucket usage.

Changes to generic/tclHistory.c.

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
    int result;

    if (cmd[0]) {
	/*
	 * Call Tcl_RecordAndEvalObj to do the actual work.
	 */

	cmdPtr = Tcl_NewStringObj(cmd, TCL_INDEX_NONE);
	Tcl_IncrRefCount(cmdPtr);
	result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);

	/*
	 * Discard the Tcl object created to hold the command.
	 */








|







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
    int result;

    if (cmd[0]) {
	/*
	 * Call Tcl_RecordAndEvalObj to do the actual work.
	 */

	cmdPtr = Tcl_NewStringObj(cmd, -1);
	Tcl_IncrRefCount(cmdPtr);
	result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);

	/*
	 * Discard the Tcl object created to hold the command.
	 */

Changes to generic/tclIO.c.

1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240

    statePtr = ((Channel *) chan)->state->bottomChanPtr->state;

    if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "illegal recursive call to close through close-handler"
                    " of channel", TCL_INDEX_NONE));
	}
	return TCL_ERROR;
    }

    if (DetachChannel(interp, chan) != TCL_OK) {
	return TCL_OK;
    }







|







1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240

    statePtr = ((Channel *) chan)->state->bottomChanPtr->state;

    if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "illegal recursive call to close through close-handler"
                    " of channel", -1));
	}
	return TCL_ERROR;
    }

    if (DetachChannel(interp, chan) != TCL_OK) {
	return TCL_OK;
    }
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
    if (!GotFlag(statePtr, CHANNEL_DEAD)) {
	return 0;
    }

    Tcl_SetErrno(EINVAL);
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "unable to access channel: invalid channel", TCL_INDEX_NONE));
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *







|







2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
    if (!GotFlag(statePtr, CHANNEL_DEAD)) {
	return 0;
    }

    Tcl_SetErrno(EINVAL);
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "unable to access channel: invalid channel", -1));
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
		 * regular message if nothing was found in the bypasses.
		 */

		Tcl_SetErrno(errorCode);
		if (interp != NULL && !TclChanCaughtErrorBypass(interp,
			(Tcl_Channel) chanPtr)) {
		    Tcl_SetObjResult(interp,
			    Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
		}

		/*
		 * An unreportable bypassed message is kept, for the caller of
		 * Tcl_Seek, Tcl_Write, etc.
		 */
	    }







|







2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
		 * regular message if nothing was found in the bypasses.
		 */

		Tcl_SetErrno(errorCode);
		if (interp != NULL && !TclChanCaughtErrorBypass(interp,
			(Tcl_Channel) chanPtr)) {
		    Tcl_SetObjResult(interp,
			    Tcl_NewStringObj(Tcl_PosixError(interp), -1));
		}

		/*
		 * An unreportable bypassed message is kept, for the caller of
		 * Tcl_Seek, Tcl_Write, etc.
		 */
	    }
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
	Tcl_Panic("called Tcl_Close on channel with refCount > 0");
    }

    if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "illegal recursive call to close through close-handler"
                    " of channel", TCL_INDEX_NONE));
	}
	return TCL_ERROR;
    }
    SetFlag(statePtr, CHANNEL_INCLOSE);

    /*
     * When the channel has an escape sequence driven encoding such as







|







3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
	Tcl_Panic("called Tcl_Close on channel with refCount > 0");
    }

    if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "illegal recursive call to close through close-handler"
                    " of channel", -1));
	}
	return TCL_ERROR;
    }
    SetFlag(statePtr, CHANNEL_INCLOSE);

    /*
     * When the channel has an escape sequence driven encoding such as
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
	result = EINVAL;
    }

    if (stickyError != 0) {
	Tcl_SetErrno(stickyError);
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
	}
	return TCL_ERROR;
    }

    /*
     * Bug 97069ea11a: set error message if a flush code is set and no error
     * message set up to now.
     */

    if (flushcode != 0) {
	/* flushcode has precedence, if available */
	result = flushcode;
    }
    if ((result != 0) && (result != TCL_ERROR) && (interp != NULL)
	    && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) {
	Tcl_SetErrno(result);
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
    }
    if (result != 0) {
	return TCL_ERROR;
    }
    return TCL_OK;
}








|

















|







3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
	result = EINVAL;
    }

    if (stickyError != 0) {
	Tcl_SetErrno(stickyError);
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj(Tcl_PosixError(interp), -1));
	}
	return TCL_ERROR;
    }

    /*
     * Bug 97069ea11a: set error message if a flush code is set and no error
     * message set up to now.
     */

    if (flushcode != 0) {
	/* flushcode has precedence, if available */
	result = flushcode;
    }
    if ((result != 0) && (result != TCL_ERROR) && (interp != NULL)
	    && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) {
	Tcl_SetErrno(result);
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj(Tcl_PosixError(interp), -1));
    }
    if (result != 0) {
	return TCL_ERROR;
    }
    return TCL_OK;
}

3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668

    /*
     * Is the channel unstacked ? If not we fail.
     */

    if (chanPtr != statePtr->topChanPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"half-close not applicable to stack of transformations", TCL_INDEX_NONE));
	return TCL_ERROR;
    }

    /*
     * Check direction against channel mode. It is an error if we try to close
     * a direction not supported by the channel (already closed, or never
     * opened for that direction).







|







3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668

    /*
     * Is the channel unstacked ? If not we fail.
     */

    if (chanPtr != statePtr->topChanPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"half-close not applicable to stack of transformations", -1));
	return TCL_ERROR;
    }

    /*
     * Check direction against channel mode. It is an error if we try to close
     * a direction not supported by the channel (already closed, or never
     * opened for that direction).
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
     * That won't do.
     */

    if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "illegal recursive call to close through close-handler"
                    " of channel", TCL_INDEX_NONE));
	}
	return TCL_ERROR;
    }

    if (flags & TCL_CLOSE_READ) {
	/*
	 * Call the finalization code directly. There are no events to handle,







|







3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
     * That won't do.
     */

    if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "illegal recursive call to close through close-handler"
                    " of channel", -1));
	}
	return TCL_ERROR;
    }

    if (flags & TCL_CLOSE_READ) {
	/*
	 * Call the finalization code directly. There are no events to handle,
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267

    int factor = *factorPtr;
    int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;

    (void) Tcl_GetStringFromObj(objPtr, &numBytes);
    Tcl_AppendToObj(objPtr, NULL, dstLimit);
    if (toRead == srcLen) {
	size_t size;

	dst = TclGetStringStorage(objPtr, &size) + numBytes;
	dstLimit = (size - numBytes) > INT_MAX ? INT_MAX : (size - numBytes);
    } else {
	dst = TclGetString(objPtr) + numBytes;
    }








|







6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267

    int factor = *factorPtr;
    int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;

    (void) Tcl_GetStringFromObj(objPtr, &numBytes);
    Tcl_AppendToObj(objPtr, NULL, dstLimit);
    if (toRead == srcLen) {
	Tcl_Size size;

	dst = TclGetStringStorage(objPtr, &size) + numBytes;
	dstLimit = (size - numBytes) > INT_MAX ? INT_MAX : (size - numBytes);
    } else {
	dst = TclGetString(objPtr) + numBytes;
    }

6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
	     *
	     * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used
	     * to prevent exactly this situation. I.e. it should never happen.
	     * Therefore it is ok to panic should it happen despite the
	     * precautions.
	     */

	    if (nextPtr->nextRemoved < (size_t)srcLen) {
		Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
	    }

	    nextPtr->nextRemoved -= srcLen;
	    memcpy(RemovePoint(nextPtr), src, srcLen);
	    RecycleBuffer(statePtr, bufPtr, 0);
	    statePtr->inQueueHead = nextPtr;







|







6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
	     *
	     * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used
	     * to prevent exactly this situation. I.e. it should never happen.
	     * Therefore it is ok to panic should it happen despite the
	     * precautions.
	     */

	    if (nextPtr->nextRemoved < srcLen) {
		Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
	    }

	    nextPtr->nextRemoved -= srcLen;
	    memcpy(RemovePoint(nextPtr), src, srcLen);
	    RecycleBuffer(statePtr, bufPtr, 0);
	    statePtr->inQueueHead = nextPtr;
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
{
    ChannelState *statePtr;	/* State of real channel structure. */

    /*
     * Clip the buffer size to force it into the [1,1M] range
     */

    if (sz < 1 || sz > (TCL_INDEX_NONE>>1)) {
	sz = 1;
    } else if (sz > MAX_CHANNEL_BUFFER_SIZE) {
	sz = MAX_CHANNEL_BUFFER_SIZE;
    }

    statePtr = ((Channel *) chan)->state;








|







7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
{
    ChannelState *statePtr;	/* State of real channel structure. */

    /*
     * Clip the buffer size to force it into the [1,1M] range
     */

    if (sz < 1) {
	sz = 1;
    } else if (sz > MAX_CHANNEL_BUFFER_SIZE) {
	sz = MAX_CHANNEL_BUFFER_SIZE;
    }

    statePtr = ((Channel *) chan)->state;

7816
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
		"blocking buffering buffersize encoding eofchar profile translation";
	const char **argv;
	Tcl_Size argc, i;
	Tcl_DString ds;
        Tcl_Obj *errObj;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, genericopt, TCL_INDEX_NONE);
	if (optionList && (*optionList)) {
	    TclDStringAppendLiteral(&ds, " ");
	    Tcl_DStringAppend(&ds, optionList, TCL_INDEX_NONE);
	}
	if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
		&argc, &argv) != TCL_OK) {
	    Tcl_Panic("malformed option list in channel driver");
	}
	Tcl_ResetResult(interp);
	errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",







|


|







7816
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
		"blocking buffering buffersize encoding eofchar profile translation";
	const char **argv;
	Tcl_Size argc, i;
	Tcl_DString ds;
        Tcl_Obj *errObj;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, genericopt, -1);
	if (optionList && (*optionList)) {
	    TclDStringAppendLiteral(&ds, " ");
	    Tcl_DStringAppend(&ds, optionList, -1);
	}
	if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
		&argc, &argv) != TCL_OK) {
	    Tcl_Panic("malformed option list in channel driver");
	}
	Tcl_ResetResult(interp);
	errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-eofchar");
	}
	if ((flags & TCL_READABLE) && (statePtr->inEofChar != 0)) {
	    snprintf(buf, sizeof(buf), "%c", statePtr->inEofChar);
	}
	if (len > 0) {
		Tcl_DStringAppend(dsPtr, buf, TCL_INDEX_NONE);
	    return TCL_OK;
	}
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0 || HaveOpt(1, "-profile")) {
	int profile;
	const char *profileName;







|







7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-eofchar");
	}
	if ((flags & TCL_READABLE) && (statePtr->inEofChar != 0)) {
	    snprintf(buf, sizeof(buf), "%c", statePtr->inEofChar);
	}
	if (len > 0) {
		Tcl_DStringAppend(dsPtr, buf, -1);
	    return TCL_OK;
	}
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0 || HaveOpt(1, "-profile")) {
	int profile;
	const char *profileName;
8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
     * If the channel is in the middle of a background copy, fail.
     */

    if (statePtr->csPtrR || statePtr->csPtrW) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "unable to set channel options: background copy in"
                    " progress", TCL_INDEX_NONE));
	}
	return TCL_ERROR;
    }

    /*
     * Disallow options on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit







|







8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
     * If the channel is in the middle of a background copy, fail.
     */

    if (statePtr->csPtrR || statePtr->csPtrW) {
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "unable to set channel options: background copy in"
                    " progress", -1));
	}
	return TCL_ERROR;
    }

    /*
     * Disallow options on dead channels -- channels that have been closed but
     * not yet been deallocated. Such channels can be found if the exit
8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
	} else if ((newValue[0] == 'n') &&
		(strncmp(newValue, "none", len) == 0)) {
	    ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
	    SetFlag(statePtr, CHANNEL_UNBUFFERED);
	} else if (interp) {
            Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "bad value for -buffering: must be one of"
                    " full, line, or none", TCL_INDEX_NONE));
            return TCL_ERROR;
	}
	return TCL_OK;
    } else if (HaveOpt(7, "-buffersize")) {
	Tcl_WideInt newBufferSize;
	Tcl_Obj obj;
	int code;







|







8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
	} else if ((newValue[0] == 'n') &&
		(strncmp(newValue, "none", len) == 0)) {
	    ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
	    SetFlag(statePtr, CHANNEL_UNBUFFERED);
	} else if (interp) {
            Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "bad value for -buffering: must be one of"
                    " full, line, or none", -1));
            return TCL_ERROR;
	}
	return TCL_OK;
    } else if (HaveOpt(7, "-buffersize")) {
	Tcl_WideInt newBufferSize;
	Tcl_Obj obj;
	int code;
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
8239
	    if (GotFlag(statePtr, TCL_READABLE)) {
		statePtr->inEofChar = newValue[0];
	    }
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"bad value for -eofchar: must be non-NUL ASCII"
			" character", TCL_INDEX_NONE));
	    }
	    Tcl_Free((void *)argv);
	    return TCL_ERROR;
	}
	if (argv != NULL) {
	    Tcl_Free((void *)argv);
	}







|







8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
8239
	    if (GotFlag(statePtr, TCL_READABLE)) {
		statePtr->inEofChar = newValue[0];
	    }
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"bad value for -eofchar: must be non-NUL ASCII"
			" character", -1));
	    }
	    Tcl_Free((void *)argv);
	    return TCL_ERROR;
	}
	if (argv != NULL) {
	    Tcl_Free((void *)argv);
	}
8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
	} else if (argc == 2) {
	    readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
	    writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"bad value for -translation: must be a one or two"
			" element list", TCL_INDEX_NONE));
	    }
	    Tcl_Free((void *)argv);
	    return TCL_ERROR;
	}

	if (readMode) {
	    TclEolTranslation translation;







|







8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
	} else if (argc == 2) {
	    readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
	    writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"bad value for -translation: must be a one or two"
			" element list", -1));
	    }
	    Tcl_Free((void *)argv);
	    return TCL_ERROR;
	}

	if (readMode) {
	    TclEolTranslation translation;
8308
8309
8310
8311
8312
8313
8314
8315
8316
8317
8318
8319
8320
8321
8322
		translation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(readMode, "platform") == 0) {
		translation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "bad value for -translation: must be one of "
                            "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE));
		}
		Tcl_Free((void *)argv);
		return TCL_ERROR;
	    }

	    /*
	     * Reset the EOL flags since we need to look at any buffered data







|







8308
8309
8310
8311
8312
8313
8314
8315
8316
8317
8318
8319
8320
8321
8322
		translation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(readMode, "platform") == 0) {
		translation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "bad value for -translation: must be one of "
                            "auto, binary, cr, lf, crlf, or platform", -1));
		}
		Tcl_Free((void *)argv);
		return TCL_ERROR;
	    }

	    /*
	     * Reset the EOL flags since we need to look at any buffered data
8363
8364
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
		statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(writeMode, "platform") == 0) {
		statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "bad value for -translation: must be one of "
                            "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE));
		}
		Tcl_Free((void *)argv);
		return TCL_ERROR;
	    }
	}
	Tcl_Free((void *)argv);
	return TCL_OK;







|







8363
8364
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
		statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(writeMode, "platform") == 0) {
		statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "bad value for -translation: must be one of "
                            "auto, binary, cr, lf, crlf, or platform", -1));
		}
		Tcl_Free((void *)argv);
		return TCL_ERROR;
	    }
	}
	Tcl_Free((void *)argv);
	return TCL_OK;
9671
9672
9673
9674
9675
9676
9677
9678
9679
9680
9681
9682
9683
9684
9685
    Tcl_Interp *interp;
    Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL;
    Tcl_Channel inChan, outChan;
    ChannelState *inStatePtr, *outStatePtr;
    int result = TCL_OK;
    Tcl_Size sizeb;
    Tcl_WideInt total;
    Tcl_WideInt size; /* TODO - be careful if total and size are made unsigned  */
    const char *buffer;
    int moveBytes;
    int underflow;		/* Input underflow */

    inChan	= (Tcl_Channel) csPtr->readPtr;
    outChan	= (Tcl_Channel) csPtr->writePtr;
    inStatePtr	= csPtr->readPtr->state;







|







9671
9672
9673
9674
9675
9676
9677
9678
9679
9680
9681
9682
9683
9684
9685
    Tcl_Interp *interp;
    Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL;
    Tcl_Channel inChan, outChan;
    ChannelState *inStatePtr, *outStatePtr;
    int result = TCL_OK;
    Tcl_Size sizeb;
    Tcl_WideInt total;
    Tcl_WideInt size;
    const char *buffer;
    int moveBytes;
    int underflow;		/* Input underflow */

    inChan	= (Tcl_Channel) csPtr->readPtr;
    outChan	= (Tcl_Channel) csPtr->writePtr;
    inStatePtr	= csPtr->readPtr->state;
9752
9753
9754
9755
9756
9757
9758
9759
9760
9761
9762
9763
9764
9765
9766
		size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
                              !GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
	    } else {
		size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
			!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)
			,0 /* No append */);
	    }
	    underflow = (size >= 0) && ((size_t)size < sizeb);	/* Input underflow */
	}

	if (size < 0) {
	readError:
	    if (interp) {
		TclNewObj(errObj);
		Tcl_AppendStringsToObj(errObj, "error reading \"",







|







9752
9753
9754
9755
9756
9757
9758
9759
9760
9761
9762
9763
9764
9765
9766
		size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
                              !GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
	    } else {
		size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
			!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)
			,0 /* No append */);
	    }
	    underflow = (size >= 0) && (size < sizeb);	/* Input underflow */
	}

	if (size < 0) {
	readError:
	    if (interp) {
		TclNewObj(errObj);
		Tcl_AppendStringsToObj(errObj, "error reading \"",
9831
9832
9833
9834
9835
9836
9837
9838
9839
9840
9841
9842
9843
9844
9845
	 * characters, and both EOL translation and encoding
	 * conversion may have changed this number unpredictably in relation
	 * to 'size' (It can be smaller or larger, in the latter case able to
	 * drive toRead below -1, causing infinite looping). Completely
	 * unsuitable for updating totals and toRead.
	 */

	if (sizeb == TCL_INDEX_NONE) {
	writeError:
	    if (interp) {
		TclNewObj(errObj);
		Tcl_AppendStringsToObj(errObj, "error writing \"",
			Tcl_GetChannelName(outChan), "\": ", NULL);
		if (msg != NULL) {
		    Tcl_AppendObjToObj(errObj, msg);







|







9831
9832
9833
9834
9835
9836
9837
9838
9839
9840
9841
9842
9843
9844
9845
	 * characters, and both EOL translation and encoding
	 * conversion may have changed this number unpredictably in relation
	 * to 'size' (It can be smaller or larger, in the latter case able to
	 * drive toRead below -1, causing infinite looping). Completely
	 * unsuitable for updating totals and toRead.
	 */

	if (sizeb < 0) {
	writeError:
	    if (interp) {
		TclNewObj(errObj);
		Tcl_AppendStringsToObj(errObj, "error writing \"",
			Tcl_GetChannelName(outChan), "\": ", NULL);
		if (msg != NULL) {
		    Tcl_AppendObjToObj(errObj, msg);
10063
10064
10065
10066
10067
10068
10069
10070
10071
10072
10073
10074
10075
10076
10077

	/*
	 * Don't read more data if we have what we need.
	 */

	while (!bufPtr ||			/* We got no buffer!   OR */
		(!IsBufferFull(bufPtr) && 	/* Our buffer has room AND */
		((size_t)BytesLeft(bufPtr) < bytesToRead))) {
						/* Not enough bytes in it yet
						 * to fill the dst */
	    int code;

	moreData:
	    code = GetInput(chanPtr);
	    bufPtr = statePtr->inQueueHead;







|







10063
10064
10065
10066
10067
10068
10069
10070
10071
10072
10073
10074
10075
10076
10077

	/*
	 * Don't read more data if we have what we need.
	 */

	while (!bufPtr ||			/* We got no buffer!   OR */
		(!IsBufferFull(bufPtr) && 	/* Our buffer has room AND */
		((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) {
						/* Not enough bytes in it yet
						 * to fill the dst */
	    int code;

	moreData:
	    code = GetInput(chanPtr);
	    bufPtr = statePtr->inQueueHead;
10538
10539
10540
10541
10542
10543
10544
10545
10546
10547
10548
10549
10550
10551
10552
    hTblPtr = GetChannelTable(interp);
    TclNewObj(resultPtr);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)
	    && !((pattern[0] == 's') && (pattern[1] == 't')
	    && (pattern[2] == 'd'))) {
	if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL)
		&& (Tcl_ListObjAppendElement(interp, resultPtr,
		Tcl_NewStringObj(pattern, TCL_INDEX_NONE)) != TCL_OK)) {
	    goto error;
	}
	goto done;
    }

    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {







|







10538
10539
10540
10541
10542
10543
10544
10545
10546
10547
10548
10549
10550
10551
10552
    hTblPtr = GetChannelTable(interp);
    TclNewObj(resultPtr);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)
	    && !((pattern[0] == 's') && (pattern[1] == 't')
	    && (pattern[2] == 'd'))) {
	if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL)
		&& (Tcl_ListObjAppendElement(interp, resultPtr,
		Tcl_NewStringObj(pattern, -1)) != TCL_OK)) {
	    goto error;
	}
	goto done;
    }

    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
10565
10566
10567
10568
10569
10570
10571
10572
10573
10574
10575
10576
10577
10578
10579
	     */

	    name = statePtr->channelName;
	}

	if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
		(Tcl_ListObjAppendElement(interp, resultPtr,
			Tcl_NewStringObj(name, TCL_INDEX_NONE)) != TCL_OK)) {
	error:
	    TclDecrRefCount(resultPtr);
	    return TCL_ERROR;
	}
    }

  done:







|







10565
10566
10567
10568
10569
10570
10571
10572
10573
10574
10575
10576
10577
10578
10579
	     */

	    name = statePtr->channelName;
	}

	if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
		(Tcl_ListObjAppendElement(interp, resultPtr,
			Tcl_NewStringObj(name, -1)) != TCL_OK)) {
	error:
	    TclDecrRefCount(resultPtr);
	    return TCL_ERROR;
	}
    }

  done:

Changes to generic/tclIOCmd.c.

103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to puts on. */
    Tcl_Obj *string;		/* String to write. */
    Tcl_Obj *chanObjPtr = NULL;	/* channel object. */
    int newline;		/* Add a newline at end? */
    size_t result;		/* Result of puts operation. */
    int mode;			/* Mode in which channel is opened. */

    switch (objc) {
    case 2:			/* [puts $x] */
	string = objv[1];
	newline = 1;
	break;







|







103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to puts on. */
    Tcl_Obj *string;		/* String to write. */
    Tcl_Obj *chanObjPtr = NULL;	/* channel object. */
    int newline;		/* Add a newline at end? */
    Tcl_Size result;		/* Result of puts operation. */
    int mode;			/* Mode in which channel is opened. */

    switch (objc) {
    case 2:			/* [puts $x] */
	string = objv[1];
	newline = 1;
	break;
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
Tcl_GetsObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    size_t lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *linePtr, *chanObjPtr;
    int code = TCL_OK;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;







|







277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
Tcl_GetsObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    Tcl_Size lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *linePtr, *chanObjPtr;
    int code = TCL_OK;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int newline, i;		/* Discard newline at end? */
    Tcl_WideInt toRead;			/* How many bytes to read? */
    size_t charactersRead;		/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *resultPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;

    argerror:







|







365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int newline, i;		/* Discard newline at end? */
    Tcl_WideInt toRead;			/* How many bytes to read? */
    Tcl_Size charactersRead;		/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *resultPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;

    argerror:
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && (newline != 0)) {
	const char *result;
	size_t length;

	result = Tcl_GetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);







|







452
453
454
455
456
457
458
459
460
461
462
463
464
465
466

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && (newline != 0)) {
	const char *result;
	Tcl_Size length;

	result = Tcl_GetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
    if (objc == 2) {
	modeString = "r";
    } else {
	modeString = TclGetString(objv[2]);
	if (objc == 4) {
	    const char *permString = TclGetString(objv[3]);
	    int code = TCL_ERROR;
	    int scanned = TclParseAllWhiteSpace(permString, TCL_INDEX_NONE);

	    /*
	     * Support legacy octal numbers.
	     */

	    if ((permString[scanned] == '0')
		    && (permString[scanned+1] >= '0')







|







1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
    if (objc == 2) {
	modeString = "r";
    } else {
	modeString = TclGetString(objv[2]);
	if (objc == 4) {
	    const char *permString = TclGetString(objv[3]);
	    int code = TCL_ERROR;
	    int scanned = TclParseAllWhiteSpace(permString, -1);

	    /*
	     * Support legacy octal numbers.
	     */

	    if ((permString[scanned] == '0')
		    && (permString[scanned+1] >= '0')
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {
	chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
    } else {
	int mode, seekFlag, binary;
	size_t cmdObjc;
	const char **cmdArgv;

	if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
	    return TCL_ERROR;
	}

	mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);







|







1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {
	chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
    } else {
	int mode, seekFlag, binary;
	Tcl_Size cmdObjc;
	const char **cmdArgv;

	if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
	    return TCL_ERROR;
	}

	mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);

Changes to generic/tclIOGT.c.

254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
    Tcl_Interp *interp,		/* Interpreter for result. */
    Tcl_Channel chan,		/* Channel to transform. */
    Tcl_Obj *cmdObjPtr)		/* Script to use for transform. */
{
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* State info for channel. */
    int mode;			/* Read/write mode of the channel. */
    size_t objc;
    TransformChannelData *dataPtr;
    Tcl_DString ds;

    if (chan == NULL) {
	return TCL_ERROR;
    }

    if (TCL_OK != TclListObjLengthM(interp, cmdObjPtr, &objc)) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("-command value is not a list", TCL_INDEX_NONE));
	return TCL_ERROR;
    }

    chanPtr = (Channel *) chan;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;
    chan = (Tcl_Channel) chanPtr;







|









|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
    Tcl_Interp *interp,		/* Interpreter for result. */
    Tcl_Channel chan,		/* Channel to transform. */
    Tcl_Obj *cmdObjPtr)		/* Script to use for transform. */
{
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* State info for channel. */
    int mode;			/* Read/write mode of the channel. */
    Tcl_Size objc;
    TransformChannelData *dataPtr;
    Tcl_DString ds;

    if (chan == NULL) {
	return TCL_ERROR;
    }

    if (TCL_OK != TclListObjLengthM(interp, cmdObjPtr, &objc)) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("-command value is not a list", -1));
	return TCL_ERROR;
    }

    chanPtr = (Channel *) chan;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;
    chan = (Tcl_Channel) chanPtr;
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
     */

    if (preserve == P_PRESERVE) {
	state = Tcl_SaveInterpState(eval, res);
    }

    Tcl_IncrRefCount(command);
    Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, TCL_INDEX_NONE));

    /*
     * Use a byte-array to prevent the misinterpretation of binary data coming
     * through as Utf while at the tcl level.
     */

    Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));







|







393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
     */

    if (preserve == P_PRESERVE) {
	state = Tcl_SaveInterpState(eval, res);
    }

    Tcl_IncrRefCount(command);
    Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));

    /*
     * Use a byte-array to prevent the misinterpretation of binary data coming
     * through as Utf while at the tcl level.
     */

    Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));

Changes to generic/tclIORChan.c.

262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
 * ForwardParamBase. Where an operation does not need any special types, it
 * has no "subtype" and just uses ForwardParamBase, as listed above.)
 */

struct ForwardParamInput {
    ForwardParamBase base;	/* "Supertype". MUST COME FIRST. */
    char *buf;			/* O: Where to store the read bytes */
    size_t toRead;			/* I: #bytes to read,
				 * O: #bytes actually read */
};
struct ForwardParamOutput {
    ForwardParamBase base;	/* "Supertype". MUST COME FIRST. */
    const char *buf;		/* I: Where the bytes to write come from */
    int toWrite;		/* I: #bytes to write,
				 * O: #bytes actually written */
};
struct ForwardParamSeek {
    ForwardParamBase base;	/* "Supertype". MUST COME FIRST. */
    int seekMode;		/* I: How to seek */
    Tcl_WideInt offset;		/* I: Where to seek,
				 * O: New location */







|





|







262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
 * ForwardParamBase. Where an operation does not need any special types, it
 * has no "subtype" and just uses ForwardParamBase, as listed above.)
 */

struct ForwardParamInput {
    ForwardParamBase base;	/* "Supertype". MUST COME FIRST. */
    char *buf;			/* O: Where to store the read bytes */
    Tcl_Size toRead;			/* I: #bytes to read,
				 * O: #bytes actually read */
};
struct ForwardParamOutput {
    ForwardParamBase base;	/* "Supertype". MUST COME FIRST. */
    const char *buf;		/* I: Where the bytes to write come from */
    Tcl_Size toWrite;		/* I: #bytes to write,
				 * O: #bytes actually written */
};
struct ForwardParamSeek {
    ForwardParamBase base;	/* "Supertype". MUST COME FIRST. */
    int seekMode;		/* I: How to seek */
    Tcl_WideInt offset;		/* I: Where to seek,
				 * O: New location */
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
    Tcl_Obj *rcId;		/* Handle of the new channel */
    int mode;			/* R/W mode of new channel. Has to match
				 * abilities of handler commands */
    Tcl_Obj *cmdObj;		/* Command prefix, list of words */
    Tcl_Obj *cmdNameObj;	/* Command name */
    Tcl_Channel chan;		/* Token for the new channel */
    Tcl_Obj *modeObj;		/* mode in obj form for method call */
    size_t listc;			/* Result of 'initialize', and of */
    Tcl_Obj **listv;		/* its sublist in the 2nd element */
    int methIndex;		/* Encoded method name */
    int result;			/* Result code for 'initialize' */
    Tcl_Obj *resObj;		/* Result data for 'initialize' */
    int methods;		/* Bitmask for supported methods. */
    Channel *chanPtr;		/* 'chan' resolved to internal struct. */
    Tcl_Obj *err;		/* Error message */







|







509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
    Tcl_Obj *rcId;		/* Handle of the new channel */
    int mode;			/* R/W mode of new channel. Has to match
				 * abilities of handler commands */
    Tcl_Obj *cmdObj;		/* Command prefix, list of words */
    Tcl_Obj *cmdNameObj;	/* Command name */
    Tcl_Channel chan;		/* Token for the new channel */
    Tcl_Obj *modeObj;		/* mode in obj form for method call */
    Tcl_Size listc;			/* Result of 'initialize', and of */
    Tcl_Obj **listv;		/* its sublist in the 2nd element */
    int methIndex;		/* Encoded method name */
    int result;			/* Result code for 'initialize' */
    Tcl_Obj *resObj;		/* Result data for 'initialize' */
    int methods;		/* Bitmask for supported methods. */
    Channel *chanPtr;		/* 'chan' resolved to internal struct. */
    Tcl_Obj *err;		/* Error message */
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
}

static void
UnmarshallErrorResult(
    Tcl_Interp *interp,
    Tcl_Obj *msgObj)
{
    size_t lc;
    Tcl_Obj **lv;
    int explicitResult;
    size_t numOptions;

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. This is OK because the other side uses







|


|







1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
}

static void
UnmarshallErrorResult(
    Tcl_Interp *interp,
    Tcl_Obj *msgObj)
{
    Tcl_Size lc;
    Tcl_Obj **lv;
    int explicitResult;
    Tcl_Size numOptions;

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. This is OK because the other side uses
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
    void *clientData,
    char *buf,
    int toRead,
    int *errorCodePtr)
{
    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
    Tcl_Obj *toReadObj;
    size_t bytec = 0;		/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */
    Tcl_Obj *resObj;		/* Result data for 'read' */

    /*
     * Are we in the correct thread?
     */








|







1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
    void *clientData,
    char *buf,
    int toRead,
    int *errorCodePtr)
{
    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
    Tcl_Obj *toReadObj;
    Tcl_Size bytec = 0;		/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */
    Tcl_Obj *resObj;		/* Result data for 'read' */

    /*
     * Are we in the correct thread?
     */

1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
    }

    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

    if (bytev == NULL) {
	SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte);
	goto invalid;
    } else if ((size_t)toRead < bytec) {
	SetChannelErrorStr(rcPtr->chan, msg_read_toomuch);
	goto invalid;
    }

    *errorCodePtr = EOK;

    if (bytec + 1 > 1) {
	memcpy(buf, bytev, bytec);
    }

 stop:
    Tcl_DecrRefCount(toReadObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
    Tcl_Release(rcPtr);







|






|







1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
    }

    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

    if (bytev == NULL) {
	SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte);
	goto invalid;
    } else if (toRead < bytec) {
	SetChannelErrorStr(rcPtr->chan, msg_read_toomuch);
	goto invalid;
    }

    *errorCodePtr = EOK;

    if (bytec > 0) {
	memcpy(buf, bytev, bytec);
    }

 stop:
    Tcl_DecrRefCount(toReadObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
    Tcl_Release(rcPtr);
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
     * This code is special. It has regular passing of Tcl result, and errors.
     * The bypass functions are not required.
     */

    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
    Tcl_Obj *optionObj;
    Tcl_Obj *resObj;		/* Result data for 'configure' */
    size_t listc;
    int result = TCL_OK;
    Tcl_Obj **listv;
    MethodName method;

    /*
     * Are we in the correct thread?
     */







|







1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
     * This code is special. It has regular passing of Tcl result, and errors.
     * The bypass functions are not required.
     */

    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
    Tcl_Obj *optionObj;
    Tcl_Obj *resObj;		/* Result data for 'configure' */
    Tcl_Size listc;
    int result = TCL_OK;
    Tcl_Obj **listv;
    MethodName method;

    /*
     * Are we in the correct thread?
     */
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
	/*
	 * Odd number of elements is wrong.
	 */

	Tcl_ResetResult(interp);
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"Expected list with even number of "
		"elements, got %" TCL_Z_MODIFIER "u element%s instead", listc,
		(listc == 1 ? "" : "s")));
        goto error;
    } else {
	size_t len;
	const char *str = Tcl_GetStringFromObj(resObj, &len);

	if (len) {
	    TclDStringAppendLiteral(dsPtr, " ");
	    Tcl_DStringAppend(dsPtr, str, len);
	}
        goto ok;







|



|







2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
	/*
	 * Odd number of elements is wrong.
	 */

	Tcl_ResetResult(interp);
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"Expected list with even number of "
		"elements, got %" TCL_SIZE_MODIFIER "u element%s instead", listc,
		(listc == 1 ? "" : "s")));
        goto error;
    } else {
	Tcl_Size len;
	const char *str = Tcl_GetStringFromObj(resObj, &len);

	if (len) {
	    TclDStringAppendLiteral(dsPtr, " ");
	    Tcl_DStringAppend(dsPtr, str, len);
	}
        goto ok;
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
EncodeEventMask(
    Tcl_Interp *interp,
    const char *objName,
    Tcl_Obj *obj,
    int *mask)
{
    int events;			/* Mask of events to post */
    size_t listc;			/* #elements in eventspec list */
    Tcl_Obj **listv;		/* Elements of eventspec list */
    int evIndex;		/* Id of event for an element of the eventspec
				 * list. */

    if (TclListObjGetElementsM(interp, obj, &listc, &listv) != TCL_OK) {
	return TCL_ERROR;
    }







|







2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
EncodeEventMask(
    Tcl_Interp *interp,
    const char *objName,
    Tcl_Obj *obj,
    int *mask)
{
    int events;			/* Mask of events to post */
    Tcl_Size listc;			/* #elements in eventspec list */
    Tcl_Obj **listv;		/* Elements of eventspec list */
    int evIndex;		/* Id of event for an element of the eventspec
				 * list. */

    if (TclListObjGetElementsM(interp, obj, &listc, &listv) != TCL_OK) {
	return TCL_ERROR;
    }
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
	     * the full state of the result, including additional options.
	     *
	     * This is complex and ugly, and would be completely unnecessary
	     * if we only added support for a TCL_FORBID_EXCEPTIONS flag.
	     */

	    if (result != TCL_ERROR) {
		size_t cmdLen;
		const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);

		Tcl_IncrRefCount(cmd);
		Tcl_ResetResult(rcPtr->interp);
		Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
			"chan handler returned bad code: %d", result));
		Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,







|







2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
	     * the full state of the result, including additional options.
	     *
	     * This is complex and ugly, and would be completely unnecessary
	     * if we only added support for a TCL_FORBID_EXCEPTIONS flag.
	     */

	    if (result != TCL_ERROR) {
		Tcl_Size cmdLen;
		const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);

		Tcl_IncrRefCount(cmd);
		Tcl_ResetResult(rcPtr->interp);
		Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
			"chan handler returned bad code: %d", result));
		Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
	    }
	    paramPtr->input.toRead = TCL_IO_FAILURE;
	} else {
	    /*
	     * Process a regular result.
	     */

	    size_t bytec = 0;		/* Number of returned bytes */
	    unsigned char *bytev;	/* Array of returned bytes */

	    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	    if (bytev == NULL) {
		ForwardSetStaticError(paramPtr, msg_read_nonbyte);
		paramPtr->input.toRead = -1;
	    } else if (paramPtr->input.toRead < bytec) {
		ForwardSetStaticError(paramPtr, msg_read_toomuch);
		paramPtr->input.toRead = TCL_IO_FAILURE;
	    } else {
		if (bytec + 1 > 1) {
		    memcpy(paramPtr->input.buf, bytev, bytec);
		}
		paramPtr->input.toRead = bytec;
	    }
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(toReadObj);







|











|







3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
	    }
	    paramPtr->input.toRead = TCL_IO_FAILURE;
	} else {
	    /*
	     * Process a regular result.
	     */

	    Tcl_Size bytec = 0;		/* Number of returned bytes */
	    unsigned char *bytev;	/* Array of returned bytes */

	    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	    if (bytev == NULL) {
		ForwardSetStaticError(paramPtr, msg_read_nonbyte);
		paramPtr->input.toRead = -1;
	    } else if (paramPtr->input.toRead < bytec) {
		ForwardSetStaticError(paramPtr, msg_read_toomuch);
		paramPtr->input.toRead = TCL_IO_FAILURE;
	    } else {
		if (bytec > 0) {
		    memcpy(paramPtr->input.buf, bytev, bytec);
		}
		paramPtr->input.toRead = bytec;
	    }
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(toReadObj);
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    /*
	     * Extract list, validate that it is a list, and #elements. See
	     * NOTE (4) as well.
	     */

	    size_t listc;
	    Tcl_Obj **listv;

	    if (TclListObjGetElementsM(interp, resObj, &listc,
                    &listv) != TCL_OK) {
		Tcl_DecrRefCount(resObj);
		resObj = MarshallError(interp);
		ForwardSetObjError(paramPtr, resObj);
	    } else if ((listc % 2) == 1) {
		/*
		 * Odd number of elements is wrong. [x].
		 */

		char *buf = (char *)Tcl_Alloc(200);
		snprintf(buf, 200,
			"{Expected list with even number of elements, got %" TCL_Z_MODIFIER "u %s instead}",
			listc, (listc == 1 ? "element" : "elements"));

		ForwardSetDynamicError(paramPtr, buf);
	    } else {
		size_t len;
		const char *str = Tcl_GetStringFromObj(resObj, &len);

		if (len) {
		    TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
		    Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
		}
	    }







|














|




|







3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    /*
	     * Extract list, validate that it is a list, and #elements. See
	     * NOTE (4) as well.
	     */

	    Tcl_Size listc;
	    Tcl_Obj **listv;

	    if (TclListObjGetElementsM(interp, resObj, &listc,
                    &listv) != TCL_OK) {
		Tcl_DecrRefCount(resObj);
		resObj = MarshallError(interp);
		ForwardSetObjError(paramPtr, resObj);
	    } else if ((listc % 2) == 1) {
		/*
		 * Odd number of elements is wrong. [x].
		 */

		char *buf = (char *)Tcl_Alloc(200);
		snprintf(buf, 200,
			"{Expected list with even number of elements, got %" TCL_SIZE_MODIFIER "u %s instead}",
			listc, (listc == 1 ? "element" : "elements"));

		ForwardSetDynamicError(paramPtr, buf);
	    } else {
		Tcl_Size len;
		const char *str = Tcl_GetStringFromObj(resObj, &len);

		if (len) {
		    TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
		    Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
		}
	    }
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
}

static void
ForwardSetObjError(
    ForwardParam *paramPtr,
    Tcl_Obj *obj)
{
    size_t len;
    const char *msgStr = Tcl_GetStringFromObj(obj, &len);

    len++;
    ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
    memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif







|







3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
}

static void
ForwardSetObjError(
    ForwardParam *paramPtr,
    Tcl_Obj *obj)
{
    Tcl_Size len;
    const char *msgStr = Tcl_GetStringFromObj(obj, &len);

    len++;
    ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
    memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif

Changes to generic/tclIORTrans.c.

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
    int mode;			/* R/W mode of parent, later the new channel.
				 * Has to match the abilities of the handler
				 * commands */
    Tcl_Obj *cmdObj;		/* Command prefix, list of words */
    Tcl_Obj *cmdNameObj;	/* Command name */
    Tcl_Obj *rtId;		/* Handle of the new transform (channel) */
    Tcl_Obj *modeObj;		/* mode in obj form for method call */
    size_t listc;			/* Result of 'initialize', and of */
    Tcl_Obj **listv;		/* its sublist in the 2nd element */
    int methIndex;		/* Encoded method name */
    int result;			/* Result code for 'initialize' */
    Tcl_Obj *resObj;		/* Result data for 'initialize' */
    int methods;		/* Bitmask for supported methods. */
    ReflectedTransformMap *rtmPtr;
				/* Map of reflected transforms with handlers







|







507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
    int mode;			/* R/W mode of parent, later the new channel.
				 * Has to match the abilities of the handler
				 * commands */
    Tcl_Obj *cmdObj;		/* Command prefix, list of words */
    Tcl_Obj *cmdNameObj;	/* Command name */
    Tcl_Obj *rtId;		/* Handle of the new transform (channel) */
    Tcl_Obj *modeObj;		/* mode in obj form for method call */
    Tcl_Size listc;			/* Result of 'initialize', and of */
    Tcl_Obj **listv;		/* its sublist in the 2nd element */
    int methIndex;		/* Encoded method name */
    int result;			/* Result code for 'initialize' */
    Tcl_Obj *resObj;		/* Result data for 'initialize' */
    int methods;		/* Bitmask for supported methods. */
    ReflectedTransformMap *rtmPtr;
				/* Map of reflected transforms with handlers
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
}

static void
UnmarshallErrorResult(
    Tcl_Interp *interp,
    Tcl_Obj *msgObj)
{
    size_t lc;
    Tcl_Obj **lv;
    int explicitResult;
    size_t numOptions;

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. This is OK because the other side uses







|


|







816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
}

static void
UnmarshallErrorResult(
    Tcl_Interp *interp,
    Tcl_Obj *msgObj)
{
    Tcl_Size lc;
    Tcl_Obj **lv;
    int explicitResult;
    Tcl_Size numOptions;

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. This is OK because the other side uses
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
    Tcl_Interp *interp,
    Tcl_Obj *cmdpfxObj,
    TCL_UNUSED(int) /*mode*/,
    Tcl_Obj *handleObj,
    Tcl_Channel parentChan)
{
    ReflectedTransform *rtPtr;
    size_t i, listc;
    Tcl_Obj **listv;

    rtPtr = (ReflectedTransform *)Tcl_Alloc(sizeof(ReflectedTransform));

    /* rtPtr->chan: Assigned by caller. Dummy data here. */
    /* rtPtr->methods: Assigned by caller. Dummy data here. */








|







1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
    Tcl_Interp *interp,
    Tcl_Obj *cmdpfxObj,
    TCL_UNUSED(int) /*mode*/,
    Tcl_Obj *handleObj,
    Tcl_Channel parentChan)
{
    ReflectedTransform *rtPtr;
    Tcl_Size i, listc;
    Tcl_Obj **listv;

    rtPtr = (ReflectedTransform *)Tcl_Alloc(sizeof(ReflectedTransform));

    /* rtPtr->chan: Assigned by caller. Dummy data here. */
    /* rtPtr->methods: Assigned by caller. Dummy data here. */

Changes to generic/tclIOSock.c.

113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#if !defined(_WIN32) && !defined(__CYGWIN__)
#   define SOCKET int
#endif

int
TclSockMinimumBuffers(
    void *sock,			/* Socket file descriptor */
    size_t size1)			/* Minimum buffer size */
{
    int current;
    socklen_t len;
    int size = size1;

    if ((size_t)size != size1) {
	return TCL_ERROR;
    }
    len = sizeof(int);
    getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF,
	    (char *) &current, &len);
    if (current < size) {
	len = sizeof(int);







|





|







113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#if !defined(_WIN32) && !defined(__CYGWIN__)
#   define SOCKET int
#endif

int
TclSockMinimumBuffers(
    void *sock,			/* Socket file descriptor */
    Tcl_Size size1)		/* Minimum buffer size */
{
    int current;
    socklen_t len;
    int size = size1;

    if (size != size1) {
	return TCL_ERROR;
    }
    len = sizeof(int);
    getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF,
	    (char *) &current, &len);
    if (current < size) {
	len = sizeof(int);

Changes to generic/tclIOUtil.c.

985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
				 * of the correct type. */
    Tcl_GlobTypeData *types)	/* Specifies acceptable types.
				 * May be NULL. The directory flag is
				 * particularly significant. */
{
    const Tcl_Filesystem *fsPtr;
    Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
    size_t resLength, i;
    int ret = -1;

    if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) {
	/*
	 * Currently external callers may not query mounts, which would be a
	 * valuable future step. This is the only routine that knows about
	 * mounts, so we're being called recursively by ourself. Return no







|







985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
				 * of the correct type. */
    Tcl_GlobTypeData *types)	/* Specifies acceptable types.
				 * May be NULL. The directory flag is
				 * particularly significant. */
{
    const Tcl_Filesystem *fsPtr;
    Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
    Tcl_Size resLength, i;
    int ret = -1;

    if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) {
	/*
	 * Currently external callers may not query mounts, which would be a
	 * valuable future step. This is the only routine that knows about
	 * mounts, so we're being called recursively by ourself. Return no
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
1129
1130
1131
1132
				 * not be shared. */
    Tcl_Obj *pathPtr,		/* The directory that was searched. */
    const char *pattern,	/* Pattern to match mounts against. */
    Tcl_GlobTypeData *types)	/* Acceptable types.  May be NULL. The
				 * directory flag is particularly significant.
				 */
{
    size_t mLength, gLength, i;
    int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
    Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);

    if (mounts == NULL) {
	return;
    }

    if (TclListObjLengthM(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
	goto endOfMounts;
    }
    if (TclListObjLengthM(NULL, resultPtr, &gLength) != TCL_OK) {
	goto endOfMounts;
    }
    for (i=0 ; i<mLength ; i++) {
	Tcl_Obj *mElt;
	size_t j;
	int found = 0;

	Tcl_ListObjIndex(NULL, mounts, i, &mElt);

	for (j=0 ; j<gLength ; j++) {
	    Tcl_Obj *gElt;








|















|







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
1129
1130
1131
1132
				 * not be shared. */
    Tcl_Obj *pathPtr,		/* The directory that was searched. */
    const char *pattern,	/* Pattern to match mounts against. */
    Tcl_GlobTypeData *types)	/* Acceptable types.  May be NULL. The
				 * directory flag is particularly significant.
				 */
{
    Tcl_Size mLength, gLength, i;
    int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
    Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);

    if (mounts == NULL) {
	return;
    }

    if (TclListObjLengthM(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
	goto endOfMounts;
    }
    if (TclListObjLengthM(NULL, resultPtr, &gLength) != TCL_OK) {
	goto endOfMounts;
    }
    for (i=0 ; i<mLength ; i++) {
	Tcl_Obj *mElt;
	Tcl_Size j;
	int found = 0;

	Tcl_ListObjIndex(NULL, mounts, i, &mElt);

	for (j=0 ; j<gLength ; j++) {
	    Tcl_Obj *gElt;

1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
		    gLength--;
		}
		break;		/* Break out of for loop. */
	    }
	}
	if (!found && dir) {
	    Tcl_Obj *norm;
	    size_t len, mlen;

	    /*
	     * mElt is normalized and lies inside pathPtr so
	     * add to the result the right representation of mElt,
	     * i.e. the representation relative to pathPtr.
	     */








|







1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
		    gLength--;
		}
		break;		/* Break out of for loop. */
	    }
	}
	if (!found && dir) {
	    Tcl_Obj *norm;
	    Tcl_Size len, mlen;

	    /*
	     * mElt is normalized and lies inside pathPtr so
	     * add to the result the right representation of mElt,
	     * i.e. the representation relative to pathPtr.
	     */

1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
    int *seekFlagPtr,		/* Sets this to 1 to tell the the caller to seek to
				 * EOF after opening the file, and 0 otherwise. */
    int *binaryPtr)		/* Sets this to 1 to tell the caller to
				 * configure the channel for binary
				 * operations after opening the file. */
{
    int mode, c, gotRW;
    size_t modeArgc, i;
    const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)

    /*
     * Check for the simpler fopen-like access modes like "r" which are
     * distinguished from the POSIX access modes by the presence of a
     * lower-case first letter.







|







1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
    int *seekFlagPtr,		/* Sets this to 1 to tell the the caller to seek to
				 * EOF after opening the file, and 0 otherwise. */
    int *binaryPtr)		/* Sets this to 1 to tell the caller to
				 * configure the channel for binary
				 * operations after opening the file. */
{
    int mode, c, gotRW;
    Tcl_Size modeArgc, i;
    const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)

    /*
     * Check for the simpler fopen-like access modes like "r" which are
     * distinguished from the POSIX access modes by the presence of a
     * lower-case first letter.
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
    }

    if (attrTable != NULL) {
	/*
	 * It's a constant attribute table, so use T_GIFO.
	 */

	Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, TCL_INDEX_NONE);
	int result;

	result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT,
		indexPtr);
	TclDecrRefCount(tmpObj);
	if (listObj != NULL) {
	    TclDecrRefCount(listObj);
	}
	return result;
    } else if (listObj != NULL) {
	/*
	 * It's a non-constant attribute list, so do a literal search.
	 */

	size_t i, objc;
	Tcl_Obj **objv;

	if (TclListObjGetElementsM(NULL, listObj, &objc, &objv) != TCL_OK) {
	    TclDecrRefCount(listObj);
	    return TCL_ERROR;
	}
	for (i=0 ; i<objc ; i++) {







|














|







2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
    }

    if (attrTable != NULL) {
	/*
	 * It's a constant attribute table, so use T_GIFO.
	 */

	Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1);
	int result;

	result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT,
		indexPtr);
	TclDecrRefCount(tmpObj);
	if (listObj != NULL) {
	    TclDecrRefCount(listObj);
	}
	return result;
    } else if (listObj != NULL) {
	/*
	 * It's a non-constant attribute list, so do a literal search.
	 */

	Tcl_Size i, objc;
	Tcl_Obj **objv;

	if (TclListObjGetElementsM(NULL, listObj, &objc, &objv) != TCL_OK) {
	    TclDecrRefCount(listObj);
	    return TCL_ERROR;
	}
	for (i=0 ; i<objc ; i++) {
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
	  * Try to delete the file we probably created and then exit.
	  */

	Tcl_FSDeleteFile(copyToPtr);
	Tcl_DecrRefCount(copyToPtr);
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "couldn't load from current filesystem", TCL_INDEX_NONE));
	}
	return TCL_ERROR;
    }

    if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
	Tcl_FSDeleteFile(copyToPtr);
	Tcl_DecrRefCount(copyToPtr);







|







3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
	  * Try to delete the file we probably created and then exit.
	  */

	Tcl_FSDeleteFile(copyToPtr);
	Tcl_DecrRefCount(copyToPtr);
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "couldn't load from current filesystem", -1));
	}
	return TCL_ERROR;
    }

    if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
	Tcl_FSDeleteFile(copyToPtr);
	Tcl_DecrRefCount(copyToPtr);
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
 *---------------------------------------------------------------------------
 */

#undef Tcl_FSSplitPath
Tcl_Obj *
Tcl_FSSplitPath(
    Tcl_Obj *pathPtr,		/* The pathname to split. */
    size_t *lenPtr)		/* A place to hold the number of pathname
				 * elements. */
{
    Tcl_Obj *result = NULL;	/* Just to squelch gcc warnings. */
    const Tcl_Filesystem *fsPtr;
    char separator = '/';
    size_t driveNameLength;
    const char *p;

    /*
     * Perform platform-specific splitting.
     */

    if (TclFSGetPathType(pathPtr, &fsPtr,







|





|







3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
 *---------------------------------------------------------------------------
 */

#undef Tcl_FSSplitPath
Tcl_Obj *
Tcl_FSSplitPath(
    Tcl_Obj *pathPtr,		/* The pathname to split. */
    Tcl_Size *lenPtr)		/* A place to hold the number of pathname
				 * elements. */
{
    Tcl_Obj *result = NULL;	/* Just to squelch gcc warnings. */
    const Tcl_Filesystem *fsPtr;
    char separator = '/';
    Tcl_Size driveNameLength;
    const char *p;

    /*
     * Perform platform-specific splitting.
     */

    if (TclFSGetPathType(pathPtr, &fsPtr,
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937

    /*
     * Add the remaining pathname elements to the list.
     */

    for (;;) {
	const char *elementStart = p;
	size_t length;

	while ((*p != '\0') && (*p != separator)) {
	    p++;
	}
	length = p - elementStart;
	if (length > 0) {
	    Tcl_Obj *nextElt;







|







3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937

    /*
     * Add the remaining pathname elements to the list.
     */

    for (;;) {
	const char *elementStart = p;
	Tcl_Size length;

	while ((*p != '\0') && (*p != separator)) {
	    p++;
	}
	length = p - elementStart;
	if (length > 0) {
	    Tcl_Obj *nextElt;
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
Tcl_PathType
TclGetPathType(
    Tcl_Obj *pathPtr,		/* Pathname to determine type of. */
    const Tcl_Filesystem **filesystemPtrPtr,
				/* If not NULL, a place in which to store a
				 * pointer to the filesystem for this pathname
				 * if it is absolute. */
    size_t *driveNameLengthPtr,	/* If not NULL, a place in which to store the
				 * length of the volume name. */
    Tcl_Obj **driveNameRef)	/* If not NULL, for an absolute pathname, a
				 * place to store a pointer to an object with a
				 * refCount of 1, and whose value is the name
				 * of the volume. */
{
    size_t pathLen;
    const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
    Tcl_PathType type;

    type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
	    driveNameLengthPtr, driveNameRef);

    if (type != TCL_PATH_ABSOLUTE) {







|






|







3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
Tcl_PathType
TclGetPathType(
    Tcl_Obj *pathPtr,		/* Pathname to determine type of. */
    const Tcl_Filesystem **filesystemPtrPtr,
				/* If not NULL, a place in which to store a
				 * pointer to the filesystem for this pathname
				 * if it is absolute. */
    Tcl_Size *driveNameLengthPtr,	/* If not NULL, a place in which to store the
				 * length of the volume name. */
    Tcl_Obj **driveNameRef)	/* If not NULL, for an absolute pathname, a
				 * place to store a pointer to an object with a
				 * refCount of 1, and whose value is the name
				 * of the volume. */
{
    Tcl_Size pathLen;
    const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
    Tcl_PathType type;

    type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
	    driveNameLengthPtr, driveNameRef);

    if (type != TCL_PATH_ABSOLUTE) {
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSNonnativePathType(
    const char *path,		/* Pathname to determine the type of. */
    size_t pathLen,		/* Length of the pathname. */
    const Tcl_Filesystem **filesystemPtrPtr,
				/* If not NULL, a  place to store a pointer to
				 * the filesystem for this pathname when it is
				 * an absolute pathname. */
    size_t *driveNameLengthPtr,	/* If not NULL, a place to store the length of
				 * the volume name if the pathname is absolute.
				 */
    Tcl_Obj **driveNameRef)	/* If not NULL, a place to store a pointer to
				 * an object having its its refCount already
				 * incremented, and contining the name of the
				 * volume if the pathname is absolute. */
{







|




|







4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSNonnativePathType(
    const char *path,		/* Pathname to determine the type of. */
    Tcl_Size pathLen,		/* Length of the pathname. */
    const Tcl_Filesystem **filesystemPtrPtr,
				/* If not NULL, a  place to store a pointer to
				 * the filesystem for this pathname when it is
				 * an absolute pathname. */
    Tcl_Size *driveNameLengthPtr,/* If not NULL, a place to store the length of
				 * the volume name if the pathname is absolute.
				 */
    Tcl_Obj **driveNameRef)	/* If not NULL, a place to store a pointer to
				 * an object having its its refCount already
				 * incremented, and contining the name of the
				 * volume if the pathname is absolute. */
{
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
	 * no reason to waste time doing that in this frequently-called
	 * function.  It is better to save the overhead of the native
	 * filesystem continuously returning a list of volumes.
	 */

	if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
		&& (fsRecPtr->fsPtr->listVolumesProc != NULL)) {
	    size_t numVolumes;
	    Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();

	    if (thisFsVolumes != NULL) {
		if (TclListObjLengthM(NULL, thisFsVolumes, &numVolumes)
			!= TCL_OK) {
		    /*
		     * This is VERY bad; the listVolumesProc didn't return a
		     * valid list. Set numVolumes to -1 to skip the loop below
		     * and just return with the current value of 'type'.
		     *
		     * It would be better to signal an error here, but
		     * Tcl_Panic seems a bit excessive.
		     */

		    numVolumes = TCL_INDEX_NONE;
		}
		while (numVolumes + 1 > 1) {
		    Tcl_Obj *vol;
		    size_t len;
		    const char *strVol;

		    numVolumes--;
		    Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
		    strVol = Tcl_GetStringFromObj(vol,&len);
		    if (pathLen < len) {
			continue;







|
















|

|







4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
	 * no reason to waste time doing that in this frequently-called
	 * function.  It is better to save the overhead of the native
	 * filesystem continuously returning a list of volumes.
	 */

	if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
		&& (fsRecPtr->fsPtr->listVolumesProc != NULL)) {
	    Tcl_Size numVolumes;
	    Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();

	    if (thisFsVolumes != NULL) {
		if (TclListObjLengthM(NULL, thisFsVolumes, &numVolumes)
			!= TCL_OK) {
		    /*
		     * This is VERY bad; the listVolumesProc didn't return a
		     * valid list. Set numVolumes to -1 to skip the loop below
		     * and just return with the current value of 'type'.
		     *
		     * It would be better to signal an error here, but
		     * Tcl_Panic seems a bit excessive.
		     */

		    numVolumes = TCL_INDEX_NONE;
		}
		while (numVolumes > 0) {
		    Tcl_Obj *vol;
		    Tcl_Size len;
		    const char *strVol;

		    numVolumes--;
		    Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
		    strVol = Tcl_GetStringFromObj(vol,&len);
		    if (pathLen < len) {
			continue;
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
	return -1;
    }

    if (recursive) {
	Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
	if (cwdPtr != NULL) {
	    const char *cwdStr, *normPathStr;
	    size_t cwdLen, normLen;
	    Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

	    if (normPath != NULL) {
		normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
		cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
		if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
			normLen) == 0)) {







|







4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
	return -1;
    }

    if (recursive) {
	Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
	if (cwdPtr != NULL) {
	    const char *cwdStr, *normPathStr;
	    Tcl_Size cwdLen, normLen;
	    Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

	    if (normPath != NULL) {
		normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
		cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
		if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
			normLen) == 0)) {
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621

    if (fsPtr == NULL) {
	return NULL;
    }

    resPtr = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(NULL, resPtr,
	    Tcl_NewStringObj(fsPtr->typeName, TCL_INDEX_NONE));

    if (fsPtr->filesystemPathTypeProc != NULL) {
	Tcl_Obj *typePtr = fsPtr->filesystemPathTypeProc(pathPtr);

	if (typePtr != NULL) {
	    Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
	}







|







4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621

    if (fsPtr == NULL) {
	return NULL;
    }

    resPtr = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(NULL, resPtr,
	    Tcl_NewStringObj(fsPtr->typeName, -1));

    if (fsPtr->filesystemPathTypeProc != NULL) {
	Tcl_Obj *typePtr = fsPtr->filesystemPathTypeProc(pathPtr);

	if (typePtr != NULL) {
	    Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
	}

Changes to generic/tclIndexObj.c.

10
11
12
13
14
15
16

17
18
19
20
21
22
23
 * Copyright © 2006 Sam Bromley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"


/*
 * Prototypes for functions defined later in this file:
 */

static int		GetIndexFromObjList(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr,







>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * Copyright © 2006 Sam Bromley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

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

/*
 * Prototypes for functions defined later in this file:
 */

static int		GetIndexFromObjList(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr,
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
 * pointer to one of these structures.
 *
 * Keep this structure declaration in sync with tclTestObj.c
 */

typedef struct {
    void *tablePtr;		/* Pointer to the table of strings */
    Tcl_Size offset;	/* Offset between table entries */
    Tcl_Size index;		/* Selected index into table. */
} IndexRep;

/*
 * The following macros greatly simplify moving through a table...
 */

#define STRING_AT(table, offset) \







|
|







52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
 * pointer to one of these structures.
 *
 * Keep this structure declaration in sync with tclTestObj.c
 */

typedef struct {
    void *tablePtr;		/* Pointer to the table of strings */
    Tcl_Size offset;			/* Offset between table entries */
    Tcl_Size index;			/* Selected index into table. */
} IndexRep;

/*
 * The following macros greatly simplify moving through a table...
 */

#define STRING_AT(table, offset) \
118
119
120
121
122
123
124



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

    result = TclListObjGetElementsM(interp, tableObjPtr, &objc, &objv);
    if (result != TCL_OK) {
	return result;
    }




    /*
     * Build a string table from the list.
     */

    tablePtr = (const char **)Tcl_Alloc((objc + 1) * sizeof(char *));
    for (t = 0; t < objc; t++) {
	if (objv[t] == objPtr) {
	    /*
	     * An exact match is always chosen, so we can stop here.
	     */

	    Tcl_Free((void *)tablePtr);
	    *indexPtr = t;
	    return TCL_OK;
	}

	tablePtr[t] = TclGetString(objv[t]);
    }
    tablePtr[objc] = NULL;








>
>
>












|







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
     */

    result = TclListObjGetElementsM(interp, tableObjPtr, &objc, &objv);
    if (result != TCL_OK) {
	return result;
    }

    /* Return type is int* so caller should not be passing larger table */
    assert(objc <= INT_MAX);

    /*
     * Build a string table from the list.
     */

    tablePtr = (const char **)Tcl_Alloc((objc + 1) * sizeof(char *));
    for (t = 0; t < objc; t++) {
	if (objv[t] == objPtr) {
	    /*
	     * An exact match is always chosen, so we can stop here.
	     */

	    Tcl_Free((void *)tablePtr);
	    *indexPtr = (int) t;
	    return TCL_OK;
	}

	tablePtr[t] = TclGetString(objv[t]);
    }
    tablePtr[objc] = NULL;

183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* Object containing the string to lookup. */
    const void *tablePtr,	/* The first string in the table. The second
				 * string will be at this address plus the
				 * offset, the third plus the offset again,
				 * etc. The last entry must be NULL and there
				 * must not be duplicate entries. */
    size_t offset,			/* The number of bytes between entries */
    const char *msg,		/* Identifying word to use in error
				 * messages. */
    int flags,			/* 0, TCL_EXACT, TCL_NULL_OK or TCL_INDEX_TEMP_TABLE */
    void *indexPtr)		/* Place to store resulting index. */
{
    Tcl_Size index, idx, numAbbrev;
    const char *key, *p1;
    const char *p2;
    const char *const *entryPtr;
    Tcl_Obj *resultPtr;
    IndexRep *indexRep;
    const Tcl_ObjInternalRep *irPtr;

    /* Protect against invalid values, like TCL_INDEX_NONE or 0. */
    if (offset+1 <= sizeof(char *)) {
	offset = sizeof(char *);
    }
    /*
     * See if there is a valid cached result from a previous lookup.
     */

    if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
    irPtr = TclFetchInternalRep(objPtr, &indexType);







|













<
|
|







187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* Object containing the string to lookup. */
    const void *tablePtr,	/* The first string in the table. The second
				 * string will be at this address plus the
				 * offset, the third plus the offset again,
				 * etc. The last entry must be NULL and there
				 * must not be duplicate entries. */
    Tcl_Size offset,		/* The number of bytes between entries */
    const char *msg,		/* Identifying word to use in error
				 * messages. */
    int flags,			/* 0, TCL_EXACT, TCL_NULL_OK or TCL_INDEX_TEMP_TABLE */
    void *indexPtr)		/* Place to store resulting index. */
{
    Tcl_Size index, idx, numAbbrev;
    const char *key, *p1;
    const char *p2;
    const char *const *entryPtr;
    Tcl_Obj *resultPtr;
    IndexRep *indexRep;
    const Tcl_ObjInternalRep *irPtr;


    if (offset < (Tcl_Size) sizeof(char *)) {
	return TclIndexInvalidError(interp, "struct offset", offset);
    }
    /*
     * See if there is a valid cached result from a previous lookup.
     */

    if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
    irPtr = TclFetchInternalRep(objPtr, &indexType);
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
	switch (index) {
	case PRFMATCH_EXACT:
	    flags |= TCL_EXACT;
	    break;
	case PRFMATCH_MESSAGE:
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing value for -message", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    message = TclGetString(objv[i]);
	    break;
	case PRFMATCH_ERROR:
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing value for -error", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    result = TclListObjLengthM(interp, objv[i], &errorLength);
	    if (result != TCL_OK) {
		return TCL_ERROR;







|









|







532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
	switch (index) {
	case PRFMATCH_EXACT:
	    flags |= TCL_EXACT;
	    break;
	case PRFMATCH_MESSAGE:
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing value for -message", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    message = TclGetString(objv[i]);
	    break;
	case PRFMATCH_ERROR:
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"missing value for -error", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    result = TclListObjLengthM(interp, objv[i], &errorLength);
	    if (result != TCL_OK) {
		return TCL_ERROR;
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
 *
 *----------------------------------------------------------------------
 */

void
Tcl_WrongNumArgs(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,			/* Number of arguments to print from objv. */
    Tcl_Obj *const objv[],	/* Initial argument objects, which should be
				 * included in the error message. */
    const char *message)	/* Error message to print after the leading
				 * objects in objv. The message may be
				 * NULL. */
{
    Tcl_Obj *objPtr;
    Tcl_Size i, len, elemLen;
    char flags;
    Interp *iPtr = (Interp *)interp;
    const char *elementStr;

    TclNewObj(objPtr);
    if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
	iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
	Tcl_AppendToObj(objPtr, " or \"", TCL_INDEX_NONE);
    } else {
	Tcl_AppendToObj(objPtr, "wrong # args: should be \"", TCL_INDEX_NONE);
    }

    /*
     * If processing an an ensemble implementation, rewrite the results in
     * terms of how the ensemble was invoked.
     */








|
















|

|







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

void
Tcl_WrongNumArgs(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,		/* Number of arguments to print from objv. */
    Tcl_Obj *const objv[],	/* Initial argument objects, which should be
				 * included in the error message. */
    const char *message)	/* Error message to print after the leading
				 * objects in objv. The message may be
				 * NULL. */
{
    Tcl_Obj *objPtr;
    Tcl_Size i, len, elemLen;
    char flags;
    Interp *iPtr = (Interp *)interp;
    const char *elementStr;

    TclNewObj(objPtr);
    if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
	iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
	Tcl_AppendToObj(objPtr, " or \"", -1);
    } else {
	Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
    }

    /*
     * If processing an an ensemble implementation, rewrite the results in
     * terms of how the ensemble was invoked.
     */

885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
	    }

	    /*
	     * Add a space if the word is not the last one (which has a
	     * moderately complex condition here).
	     */

	    if (i + 1 < toPrint || objc!=0 || message!=NULL) {
		Tcl_AppendStringsToObj(objPtr, " ", NULL);
	    }
	}
    }

    /*
     * Now add the arguments (other than those rewritten) that the caller took







|







888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
	    }

	    /*
	     * Add a space if the word is not the last one (which has a
	     * moderately complex condition here).
	     */

	    if (i<toPrint-1 || objc!=0 || message!=NULL) {
		Tcl_AppendStringsToObj(objPtr, " ", NULL);
	    }
	}
    }

    /*
     * Now add the arguments (other than those rewritten) that the caller took
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997

#undef Tcl_ParseArgsObjv
int
Tcl_ParseArgsObjv(
    Tcl_Interp *interp,		/* Place to store error message. */
    const Tcl_ArgvInfo *argTable,
				/* Array of option descriptions. */
    size_t *objcPtr,		/* Number of arguments in objv. Modified to
				 * hold # args left in objv at end. */
    Tcl_Obj *const *objv,	/* Array of arguments to be parsed. */
    Tcl_Obj ***remObjv)		/* Pointer to array of arguments that were not
				 * processed here. Should be NULL if no return
				 * of arguments is desired. */
{
    Tcl_Obj **leftovers;	/* Array to write back to remObjv on







|







986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000

#undef Tcl_ParseArgsObjv
int
Tcl_ParseArgsObjv(
    Tcl_Interp *interp,		/* Place to store error message. */
    const Tcl_ArgvInfo *argTable,
				/* Array of option descriptions. */
    Tcl_Size *objcPtr,		/* Number of arguments in objv. Modified to
				 * hold # args left in objv at end. */
    Tcl_Obj *const *objv,	/* Array of arguments to be parsed. */
    Tcl_Obj ***remObjv)		/* Pointer to array of arguments that were not
				 * processed here. Should be NULL if no return
				 * of arguments is desired. */
{
    Tcl_Obj **leftovers;	/* Array to write back to remObjv on
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
				/* Descriptor that matches current argument */
    Tcl_Obj *curArg;		/* Current argument */
    const char *str = NULL;
    char c;		/* Second character of current arg (used for
				 * quick check for matching; use 2nd char.
				 * because first char. will almost always be
				 * '-'). */
    Tcl_Size srcIndex;	/* Location from which to read next argument
				 * from objv. */
    Tcl_Size dstIndex;	/* Used to keep track of current arguments
				 * being processed, primarily for error
				 * reporting. */
    Tcl_Size objc;		/* # arguments in objv still to process. */
    Tcl_Size length;		/* Number of characters in current argument */

    if (remObjv != NULL) {
	/*
	 * Then we should copy the name of the command (0th argument). The
	 * upper bound on the number of elements is known, and (undocumented,
	 * but historically true) there should be a NULL argument after the
	 * last result. [Bug 3413857]







|

|


|
|







1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
				/* Descriptor that matches current argument */
    Tcl_Obj *curArg;		/* Current argument */
    const char *str = NULL;
    char c;		/* Second character of current arg (used for
				 * quick check for matching; use 2nd char.
				 * because first char. will almost always be
				 * '-'). */
    Tcl_Size srcIndex;		/* Location from which to read next argument
				 * from objv. */
    Tcl_Size dstIndex;		/* Used to keep track of current arguments
				 * being processed, primarily for error
				 * reporting. */
    Tcl_Size objc;			/* # arguments in objv still to process. */
    Tcl_Size length;			/* Number of characters in current argument */

    if (remObjv != NULL) {
	/*
	 * Then we should copy the name of the command (0th argument). The
	 * upper bound on the number of elements is known, and (undocumented,
	 * but historically true) there should be a NULL argument after the
	 * last result. [Bug 3413857]
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
	    if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
		srcIndex++;
		objc--;
	    }
	    break;
	}
	case TCL_ARGV_GENFUNC: {
	    int i = (int)objc;

	    if (objc > INT_MAX) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"too many (%" TCL_Z_MODIFIER "u) arguments for TCL_ARGV_GENFUNC", objc));
		goto error;
	    }
	    Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
		    infoPtr->srcPtr;

	    i = handlerProc(infoPtr->clientData, interp, i,
		    &objv[srcIndex], infoPtr->dstPtr);
	    if (i < 0) {
		goto error;
	    }
	    objc = i;
	    break;
	}







<



|





|







1167
1168
1169
1170
1171
1172
1173

1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
	    if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
		srcIndex++;
		objc--;
	    }
	    break;
	}
	case TCL_ARGV_GENFUNC: {


	    if (objc > INT_MAX) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"too many (%" TCL_SIZE_MODIFIER "d) arguments for TCL_ARGV_GENFUNC", objc));
		goto error;
	    }
	    Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
		    infoPtr->srcPtr;

	    int i = handlerProc(infoPtr->clientData, interp, (int) objc,
		    &objv[srcIndex], infoPtr->dstPtr);
	    if (i < 0) {
		goto error;
	    }
	    objc = i;
	    break;
	}
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
    for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
	Tcl_Size length;

	if (infoPtr->keyStr == NULL) {
	    continue;
	}
	length = strlen(infoPtr->keyStr);
	if (length > (Tcl_Size)width) {
	    width = length;
	}
    }

    /*
     * Now add the option information, with pretty-printing.
     */

    msg = Tcl_NewStringObj("Command-specific options:", TCL_INDEX_NONE);
    for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
	if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
	    Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr);
	    continue;
	}
	Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr);
	numSpaces = width + 1 - strlen(infoPtr->keyStr);
	while (numSpaces > 0) {
	    if (numSpaces >= NUM_SPACES) {
		Tcl_AppendToObj(msg, spaces, NUM_SPACES);
	    } else {
		Tcl_AppendToObj(msg, spaces, numSpaces);
	    }
	    numSpaces -= NUM_SPACES;
	}
	Tcl_AppendToObj(msg, infoPtr->helpStr, TCL_INDEX_NONE);
	switch (infoPtr->type) {
	case TCL_ARGV_INT:
	    Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d",
		    *((int *) infoPtr->dstPtr));
	    break;
	case TCL_ARGV_FLOAT:
	    Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g",







|








|















|







1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
    for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
	Tcl_Size length;

	if (infoPtr->keyStr == NULL) {
	    continue;
	}
	length = strlen(infoPtr->keyStr);
	if (length > width) {
	    width = length;
	}
    }

    /*
     * Now add the option information, with pretty-printing.
     */

    msg = Tcl_NewStringObj("Command-specific options:", -1);
    for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
	if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
	    Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr);
	    continue;
	}
	Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr);
	numSpaces = width + 1 - strlen(infoPtr->keyStr);
	while (numSpaces > 0) {
	    if (numSpaces >= NUM_SPACES) {
		Tcl_AppendToObj(msg, spaces, NUM_SPACES);
	    } else {
		Tcl_AppendToObj(msg, spaces, numSpaces);
	    }
	    numSpaces -= NUM_SPACES;
	}
	Tcl_AppendToObj(msg, infoPtr->helpStr, -1);
	switch (infoPtr->type) {
	case TCL_ARGV_INT:
	    Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d",
		    *((int *) infoPtr->dstPtr));
	    break;
	case TCL_ARGV_FLOAT:
	    Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g",

Changes to generic/tclInt.decls.

345
346
347
348
349
350
351

352
353
354
355
356
357
358
359
360
declare 141 {
    const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
    int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CompileHookProc *hookProc, void *clientData)
}

declare 143 {
    Tcl_Size TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
	    LiteralEntry **litPtrPtr)
}
declare 144 {
    void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
	    int index)
}
declare 145 {







>

|







345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
declare 141 {
    const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
    int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CompileHookProc *hookProc, void *clientData)
}
# Do NOT change width of the size. TclEmitPush cannot handle it
declare 143 {
    int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
	    LiteralEntry **litPtrPtr)
}
declare 144 {
    void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
	    int index)
}
declare 145 {
659
660
661
662
663
664
665

666
667
668
669
670
671
672
673
674
}
# TIP #285: Script cancellation support.
declare 250 {
    void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}

# Allow extensions for optimization

declare 251 {
    Tcl_Size TclRegisterLiteral(void *envPtr,
	    const char *bytes, Tcl_Size length, int flags)
}

# Exporting of the internal API to variables.

declare 252 {
    Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,







>

|







660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
}
# TIP #285: Script cancellation support.
declare 250 {
    void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}

# Allow extensions for optimization
# Do NOT change width of the size. TclEmitPush cannot handle it
declare 251 {
    int TclRegisterLiteral(void *envPtr,
	    const char *bytes, Tcl_Size length, int flags)
}

# Exporting of the internal API to variables.

declare 252 {
    Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,

Changes to generic/tclInt.h.

104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
#    endif
#endif

/*
 * Maximum *signed* value that can be stored in a Tcl_Size type. This is
 * primarily used for checking overflows in dynamically allocating memory.
 */
#define TCL_SIZE_SMAX ((((Tcl_Size) 1) << ((8*sizeof(Tcl_Size)) - 1)) - 1)

/*
 * Macros used to cast between pointers and integers (e.g. when storing an int
 * in ClientData), on 64-bit architectures they avoid gcc warning about "cast
 * to/from pointer from/to integer of different size".
 */








|







104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
#    endif
#endif

/*
 * Maximum *signed* value that can be stored in a Tcl_Size type. This is
 * primarily used for checking overflows in dynamically allocating memory.
 */
#define TCL_SIZE_SMAX ((((Tcl_Size) 1) << ((8*(Tcl_Size)sizeof(Tcl_Size)) - 1)) - 1)

/*
 * Macros used to cast between pointers and integers (e.g. when storing an int
 * in ClientData), on 64-bit architectures they avoid gcc warning about "cast
 * to/from pointer from/to integer of different size".
 */

1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114

#define TCL_TRACE_ENTER_EXEC	1
#define TCL_TRACE_LEAVE_EXEC	2

typedef struct {  /* For internal core use only */
    Tcl_ObjType objType;
    struct {
	size_t (*lengthProc)(Tcl_Obj *obj);
    } abstractList;
} TclObjTypeWithAbstractList;
#define TCL_OBJTYPE_V0_1(lengthProc) (sizeof(TclObjTypeWithAbstractList)) \
	}, {lengthProc /* For internal core use only */
#define ABSTRACTLIST_PROC(objPtr, proc) (((objPtr)->typePtr \
	&& ((objPtr)->typePtr->version > offsetof(TclObjTypeWithAbstractList, abstractList.proc))) ? \
	((const TclObjTypeWithAbstractList *)(objPtr)->typePtr)->abstractList.proc : NULL)

MODULE_SCOPE size_t TclLengthOne(Tcl_Obj *);

/*
 * The structure below defines an entry in the assocData hash table which is
 * associated with an interpreter. The entry contains a pointer to a function
 * to call when the interpreter is deleted, and a pointer to a user-defined
 * piece of data.
 */







|








|







1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114

#define TCL_TRACE_ENTER_EXEC	1
#define TCL_TRACE_LEAVE_EXEC	2

typedef struct {  /* For internal core use only */
    Tcl_ObjType objType;
    struct {
	Tcl_Size (*lengthProc)(Tcl_Obj *obj);
    } abstractList;
} TclObjTypeWithAbstractList;
#define TCL_OBJTYPE_V0_1(lengthProc) (sizeof(TclObjTypeWithAbstractList)) \
	}, {lengthProc /* For internal core use only */
#define ABSTRACTLIST_PROC(objPtr, proc) (((objPtr)->typePtr \
	&& ((objPtr)->typePtr->version > offsetof(TclObjTypeWithAbstractList, abstractList.proc))) ? \
	((const TclObjTypeWithAbstractList *)(objPtr)->typePtr)->abstractList.proc : NULL)

MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *);

/*
 * The structure below defines an entry in the assocData hash table which is
 * associated with an interpreter. The entry contains a pointer to a function
 * to call when the interpreter is deleted, and a pointer to a user-defined
 * piece of data.
 */
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524

#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this
                                   store have their string representation
                                   derived from the list representation */

/* Max number of elements that can be contained in a list */
#define LIST_MAX                                               \
    ((ListSizeT_MAX - offsetof(ListStore, slots)) \
		   / sizeof(Tcl_Obj *))
/* Memory size needed for a ListStore to hold numSlots_ elements */
#define LIST_SIZE(numSlots_) \
	(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *)))

/*
 * ListSpan --
 * See comments above for ListStore
 */
typedef struct ListSpan {
    Tcl_Size spanStart;    /* Starting index of the span */
    Tcl_Size spanLength;   /* Number of elements in the span */
    size_t refCount;     /* Count of references to this span record */
} ListSpan;
#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
#define LIST_SPAN_THRESHOLD 101
#endif

/*
 * ListRep --







|
<


|








|







2497
2498
2499
2500
2501
2502
2503
2504

2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523

#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this
                                   store have their string representation
                                   derived from the list representation */

/* Max number of elements that can be contained in a list */
#define LIST_MAX                                               \
    ((Tcl_Size)((ListSizeT_MAX - offsetof(ListStore, slots)) / sizeof(Tcl_Obj *)))

/* Memory size needed for a ListStore to hold numSlots_ elements */
#define LIST_SIZE(numSlots_) \
	((Tcl_Size)(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *))))

/*
 * ListSpan --
 * See comments above for ListStore
 */
typedef struct ListSpan {
    Tcl_Size spanStart;    /* Starting index of the span */
    Tcl_Size spanLength;   /* Number of elements in the span */
    Tcl_Size refCount;     /* Count of references to this span record */
} ListSpan;
#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
#define LIST_SPAN_THRESHOLD 101
#endif

/*
 * ListRep --
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
    (((objPtr)->typePtr == &tclIntType.objType \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
	    ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
    ((((objPtr)->typePtr == &tclIntType.objType) && ((objPtr)->internalRep.wideValue >= 0) \
	    && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \
	    ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))

/*
 * Macro used to save a function call for common uses of
 * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
 *







|







2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
    (((objPtr)->typePtr == &tclIntType.objType \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
	    ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
    ((((objPtr)->typePtr == &tclIntType.objType) && ((objPtr)->internalRep.wideValue >= 0) \
	    && ((objPtr)->internalRep.wideValue <= endValue)) \
	    ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))

/*
 * Macro used to save a function call for common uses of
 * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
 *
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Size indexCount, Tcl_Obj *const indexArray[],
			    Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
			    const EnsembleImplMap map[]);
MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes,
			    const char **endPtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE Tcl_Obj *  TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int	TclNokia770Doubles(void);
MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);







|







3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Size indexCount, Tcl_Obj *const indexArray[],
			    Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
			    const EnsembleImplMap map[]);
MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Size	TclMaxListLength(const char *bytes, Tcl_Size numBytes,
			    const char **endPtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE Tcl_Obj *  TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int	TclNokia770Doubles(void);
MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
#endif
MODULE_SCOPE int	TclCreateSocketAddress(Tcl_Interp *interp,
			    struct addrinfo **addrlist,
			    const char *host, int port, int willBind,
			    const char **errorMsgPtr);
MODULE_SCOPE int	TclpThreadCreate(Tcl_ThreadId *idPtr,
			    Tcl_ThreadCreateProc *proc, void *clientData,
			    Tcl_Size stackSize, int flags);
MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr);
MODULE_SCOPE void	TclpInitLibraryPath(char **valuePtr,
			    Tcl_Size *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void	TclpInitLock(void);
MODULE_SCOPE void *TclpInitNotifier(void);
MODULE_SCOPE void	TclpInitPlatform(void);
MODULE_SCOPE void	TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes(void);
MODULE_SCOPE void	TclpGlobalLock(void);
MODULE_SCOPE void	TclpGlobalUnlock(void);







|
|

|







3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
#endif
MODULE_SCOPE int	TclCreateSocketAddress(Tcl_Interp *interp,
			    struct addrinfo **addrlist,
			    const char *host, int port, int willBind,
			    const char **errorMsgPtr);
MODULE_SCOPE int	TclpThreadCreate(Tcl_ThreadId *idPtr,
			    Tcl_ThreadCreateProc *proc, void *clientData,
			    size_t stackSize, int flags);
MODULE_SCOPE Tcl_Size	TclpFindVariable(const char *name, Tcl_Size *lengthPtr);
MODULE_SCOPE void	TclpInitLibraryPath(char **valuePtr,
			    TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void	TclpInitLock(void);
MODULE_SCOPE void *TclpInitNotifier(void);
MODULE_SCOPE void	TclpInitPlatform(void);
MODULE_SCOPE void	TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes(void);
MODULE_SCOPE void	TclpGlobalLock(void);
MODULE_SCOPE void	TclpGlobalUnlock(void);
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
MODULE_SCOPE void	TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void	TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void	TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void	TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int	TclReToGlob(Tcl_Interp *interp, const char *reStr,
			    Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
			    int *quantifiersFoundPtr);
MODULE_SCOPE Tcl_Size TclScanElement(const char *string, Tcl_Size length,
			    char *flagPtr);
MODULE_SCOPE void	TclSetBgErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *cmdPrefix);
MODULE_SCOPE void	TclSetBignumInternalRep(Tcl_Obj *objPtr,
			    void *bignumValue);
MODULE_SCOPE int	TclSetBooleanFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);







|







3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
MODULE_SCOPE void	TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void	TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void	TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void	TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int	TclReToGlob(Tcl_Interp *interp, const char *reStr,
			    Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
			    int *quantifiersFoundPtr);
MODULE_SCOPE Tcl_Size	TclScanElement(const char *string, Tcl_Size length,
			    char *flagPtr);
MODULE_SCOPE void	TclSetBgErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *cmdPrefix);
MODULE_SCOPE void	TclSetBignumInternalRep(Tcl_Obj *objPtr,
			    void *bignumValue);
MODULE_SCOPE int	TclSetBooleanFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
			    const char *trim, Tcl_Size numTrim);
MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
MODULE_SCOPE void	TclRegisterCommandTypeName(
			    Tcl_ObjCmdProc *implementationProc,
			    const char *nameStr);
MODULE_SCOPE int	TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int	TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE Tcl_Size	TclUtfCount(int ch);
#if TCL_UTF_MAX > 3
#   define TclUtfToUCS4 Tcl_UtfToUniChar
#   define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
#   define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src))
#else
    MODULE_SCOPE int	TclUtfToUCS4(const char *, int *);
    MODULE_SCOPE int	TclUniCharToUCS4(const Tcl_UniChar *, int *);







|







3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
			    const char *trim, Tcl_Size numTrim);
MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
MODULE_SCOPE void	TclRegisterCommandTypeName(
			    Tcl_ObjCmdProc *implementationProc,
			    const char *nameStr);
MODULE_SCOPE int	TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int	TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int	TclUtfCount(int ch);
#if TCL_UTF_MAX > 3
#   define TclUtfToUCS4 Tcl_UtfToUniChar
#   define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
#   define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src))
#else
    MODULE_SCOPE int	TclUtfToUCS4(const char *, int *);
    MODULE_SCOPE int	TclUniCharToUCS4(const Tcl_UniChar *, int *);
4166
4167
4168
4169
4170
4171
4172
4173
4174


4175
4176
4177
4178
4179






























4180
4181
4182
4183
4184
4185
4186

/*
 * Utility routines for encoding index values as integers. Used by both
 * some of the command compilers and by [lsort] and [lsearch].
 */

MODULE_SCOPE int	TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    Tcl_Size before, Tcl_Size after, int *indexPtr);
MODULE_SCOPE Tcl_Size	TclIndexDecode(int encoded, Tcl_Size endValue);


#endif /* TCL_MAJOR_VERSION > 8 */

/* Constants used in index value encoding routines. */
#define TCL_INDEX_END           ((Tcl_Size)-2)
#define TCL_INDEX_START         ((Tcl_Size)0)































/*
 *----------------------------------------------------------------------
 *
 * TclScaleTime --
 *
 *	TIP #233 (Virtualized Time): Wrapper around the time virutalisation







|

>
>





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







4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217

/*
 * Utility routines for encoding index values as integers. Used by both
 * some of the command compilers and by [lsort] and [lsearch].
 */

MODULE_SCOPE int	TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    int before, int after, int *indexPtr);
MODULE_SCOPE Tcl_Size	TclIndexDecode(int encoded, Tcl_Size endValue);
MODULE_SCOPE int	TclIndexInvalidError(Tcl_Interp *interp,
			    const char *idxType, Tcl_Size idx);
#endif /* TCL_MAJOR_VERSION > 8 */

/* Constants used in index value encoding routines. */
#define TCL_INDEX_END           ((Tcl_Size)-2)
#define TCL_INDEX_START         ((Tcl_Size)0)

/*
 *------------------------------------------------------------------------
 *
 * TclGetSizeIntFromObj --
 *
 *    Extract a Tcl_Size from a Tcl_Obj
 *
 * Results:
 *    TCL_OK / TCL_ERROR
 *
 * Side effects:
 *    On success, the integer value is stored in *sizePtr. On error,
 *    an error message in interp it it is not NULL.
 *
 *------------------------------------------------------------------------
 */
static inline int TclGetSizeIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *sizePtr) {
#if TCL_SIZE_MAX == INT_MAX
    return TclGetIntFromObj(interp, objPtr, sizePtr);
#else
    Tcl_WideInt wide;
    if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) {
	return TCL_ERROR;
    }
    *sizePtr = (Tcl_Size)wide;
    return TCL_OK;
#endif
}


/*
 *----------------------------------------------------------------------
 *
 * TclScaleTime --
 *
 *	TIP #233 (Virtualized Time): Wrapper around the time virutalisation
4595
4596
4597
4598
4599
4600
4601

4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
#endif

/* Token growth tuning, default to the general value. */
#ifndef TCL_MIN_TOKEN_GROWTH
#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
#endif


#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr)	\
    do {								\
	size_t _needed = (used) + (append);					\
	if (_needed > (available)) {					\
	    size_t allocated = 2 * _needed;					\
	    Tcl_Token *oldPtr = (tokenPtr);				\
	    Tcl_Token *newPtr;						\
	    if (oldPtr == (staticPtr)) {				\
		oldPtr = NULL;						\
	    }								\
	    newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr,	\
		    allocated * sizeof(Tcl_Token));	\







>


|

|







4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
#endif

/* Token growth tuning, default to the general value. */
#ifndef TCL_MIN_TOKEN_GROWTH
#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
#endif

/* TODO - code below does not check for integer overflow */
#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr)	\
    do {								\
	Tcl_Size _needed = (used) + (append);				\
	if (_needed > (available)) {					\
	    Tcl_Size allocated = 2 * _needed;				\
	    Tcl_Token *oldPtr = (tokenPtr);				\
	    Tcl_Token *newPtr;						\
	    if (oldPtr == (staticPtr)) {				\
		oldPtr = NULL;						\
	    }								\
	    newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr,	\
		    allocated * sizeof(Tcl_Token));	\
4657
4658
4659
4660
4661
4662
4663
4664
4665

4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
/*
 *----------------------------------------------------------------
 * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
 * -sensitive points where it pays to avoid a function call in the common case
 * of counting along a string of all one-byte characters.  The ANSI C
 * "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclNumUtfCharsM(int numChars, const char *bytes,
 *				int numBytes);

 *----------------------------------------------------------------
 */

#define TclNumUtfCharsM(numChars, bytes, numBytes) \
    do { \
	size_t _count, _i = (numBytes); \
	unsigned char *_str = (unsigned char *) (bytes); \
	while (_i && (*_str < 0xC0)) { _i--; _str++; } \
	_count = (numBytes) - _i; \
	if (_i) { \
	    _count += Tcl_NumUtfChars((bytes) + _count, _i); \
	} \
	(numChars) = _count; \
    } while (0);








|
|
>





|

|







4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
/*
 *----------------------------------------------------------------
 * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
 * -sensitive points where it pays to avoid a function call in the common case
 * of counting along a string of all one-byte characters.  The ANSI C
 * "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclNumUtfCharsM(Tcl_Size numChars, const char *bytes,
 *				Tcl_Size numBytes);
 * numBytes must be >= 0
 *----------------------------------------------------------------
 */

#define TclNumUtfCharsM(numChars, bytes, numBytes) \
    do { \
	Tcl_Size _count = 0, _i = (numBytes); \
	unsigned char *_str = (unsigned char *) (bytes); \
	while (_i > 0 && (*_str < 0xC0)) { _i--; _str++; } \
	_count = (numBytes) - _i; \
	if (_i) { \
	    _count += Tcl_NumUtfChars((bytes) + _count, _i); \
	} \
	(numChars) = _count; \
    } while (0);

4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
	    (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_);	\
	    (objPtr)->typePtr = &tclIntType.objType;		\
	}	\
	TCL_DTRACE_OBJ_CREATE(objPtr);			\
    } while (0)

#define TclNewIndexObj(objPtr, uw) \
    do {						\
	TclIncrObjsAllocated();				\
	TclAllocObjStorage(objPtr);			\
	(objPtr)->refCount = 0;				\
	(objPtr)->bytes = NULL;				\
	Tcl_WideUInt uw_ = (uw);		\
	if (uw_ >= TCL_INDEX_NONE) {			\
	    (objPtr)->internalRep.wideValue = -1; \
	    (objPtr)->typePtr = &tclIntType.objType;		\
	} else if (uw_ > WIDE_MAX) {			\
	    mp_int bignumValue_;		\
	    if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) {	\
		Tcl_Panic("%s: memory overflow", "TclNewUIntObj");	\
	    }	\
	    TclSetBignumInternalRep((objPtr), &bignumValue_);	\
	} else {	\
	    (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
	    (objPtr)->typePtr = &tclIntType.objType;		\
	}	\
	TCL_DTRACE_OBJ_CREATE(objPtr);			\
    } while (0)

#define TclNewDoubleObj(objPtr, d) \
    do {							\
	TclIncrObjsAllocated();					\
	TclAllocObjStorage(objPtr);				\
	(objPtr)->refCount = 0;					\
	(objPtr)->bytes = NULL;					\







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







4879
4880
4881
4882
4883
4884
4885



4886

















4887
4888
4889
4890
4891
4892
4893
	    (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_);	\
	    (objPtr)->typePtr = &tclIntType.objType;		\
	}	\
	TCL_DTRACE_OBJ_CREATE(objPtr);			\
    } while (0)

#define TclNewIndexObj(objPtr, uw) \



    TclNewIntObj(objPtr, uw)


















#define TclNewDoubleObj(objPtr, d) \
    do {							\
	TclIncrObjsAllocated();					\
	TclAllocObjStorage(objPtr);				\
	(objPtr)->refCount = 0;					\
	(objPtr)->bytes = NULL;					\

Changes to generic/tclIntDecls.h.

305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
/* 141 */
EXTERN const char *	TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 142 */
EXTERN int		TclSetByteCodeFromAny(Tcl_Interp *interp,
				Tcl_Obj *objPtr, CompileHookProc *hookProc,
				void *clientData);
/* 143 */
EXTERN Tcl_Size		TclAddLiteralObj(struct CompileEnv *envPtr,
				Tcl_Obj *objPtr, LiteralEntry **litPtrPtr);
/* 144 */
EXTERN void		TclHideLiteral(Tcl_Interp *interp,
				struct CompileEnv *envPtr, int index);
/* 145 */
EXTERN const struct AuxDataType * TclGetAuxDataType(const char *typeName);
/* 146 */







|







305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
/* 141 */
EXTERN const char *	TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 142 */
EXTERN int		TclSetByteCodeFromAny(Tcl_Interp *interp,
				Tcl_Obj *objPtr, CompileHookProc *hookProc,
				void *clientData);
/* 143 */
EXTERN int		TclAddLiteralObj(struct CompileEnv *envPtr,
				Tcl_Obj *objPtr, LiteralEntry **litPtrPtr);
/* 144 */
EXTERN void		TclHideLiteral(Tcl_Interp *interp,
				struct CompileEnv *envPtr, int index);
/* 145 */
EXTERN const struct AuxDataType * TclGetAuxDataType(const char *typeName);
/* 146 */
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
/* 249 */
EXTERN char *		TclDoubleDigits(double dv, int ndigits, int flags,
				int *decpt, int *signum, char **endPtr);
/* 250 */
EXTERN void		TclSetChildCancelFlags(Tcl_Interp *interp, int flags,
				int force);
/* 251 */
EXTERN Tcl_Size		TclRegisterLiteral(void *envPtr, const char *bytes,
				Tcl_Size length, int flags);
/* 252 */
EXTERN Tcl_Obj *	TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
				Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
				Tcl_Obj *part2Ptr, int flags);
/* 253 */
EXTERN Tcl_Obj *	TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr,







|







540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
/* 249 */
EXTERN char *		TclDoubleDigits(double dv, int ndigits, int flags,
				int *decpt, int *signum, char **endPtr);
/* 250 */
EXTERN void		TclSetChildCancelFlags(Tcl_Interp *interp, int flags,
				int force);
/* 251 */
EXTERN int		TclRegisterLiteral(void *envPtr, const char *bytes,
				Tcl_Size length, int flags);
/* 252 */
EXTERN Tcl_Obj *	TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
				Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
				Tcl_Obj *part2Ptr, int flags);
/* 253 */
EXTERN Tcl_Obj *	TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr,
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
    void (*reserved136)(void);
    void (*reserved137)(void);
    const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
    void (*reserved139)(void);
    void (*reserved140)(void);
    const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
    int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */
    Tcl_Size (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
    void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
    const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
    TclHandle (*tclHandleCreate) (void *ptr); /* 146 */
    void (*tclHandleFree) (TclHandle handle); /* 147 */
    TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */
    void (*tclHandleRelease) (TclHandle handle); /* 149 */
    int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */







|







727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
    void (*reserved136)(void);
    void (*reserved137)(void);
    const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
    void (*reserved139)(void);
    void (*reserved140)(void);
    const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
    int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */
    int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
    void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
    const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
    TclHandle (*tclHandleCreate) (void *ptr); /* 146 */
    void (*tclHandleFree) (TclHandle handle); /* 147 */
    TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */
    void (*tclHandleRelease) (TclHandle handle); /* 149 */
    int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
    Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
    Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
    int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, Tcl_Size numRemoved, Tcl_Size numInserted, Tcl_Obj *const *objv); /* 246 */
    void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
    int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */
    char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
    void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
    Tcl_Size (*tclRegisterLiteral) (void *envPtr, const char *bytes, Tcl_Size length, int flags); /* 251 */
    Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */
    Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */
    Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */
    int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
    int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */
    void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */
    Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */







|







835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
    Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
    Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
    int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, Tcl_Size numRemoved, Tcl_Size numInserted, Tcl_Obj *const *objv); /* 246 */
    void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
    int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */
    char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
    void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
    int (*tclRegisterLiteral) (void *envPtr, const char *bytes, Tcl_Size length, int flags); /* 251 */
    Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */
    Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */
    Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */
    int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
    int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */
    void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */
    Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */

Changes to generic/tclInterp.c.

833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
		Tcl_CmdInfo cmdInfo;

		snprintf(buf, sizeof(buf), "interp%d", i);
		if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
		    break;
		}
	    }
	    childPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
	}
	if (ChildCreate(interp, childPtr, safe) == NULL) {
	    if (buf[0] != '\0') {
		Tcl_DecrRefCount(childPtr);
	    }
	    return TCL_ERROR;
	}







|







833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
		Tcl_CmdInfo cmdInfo;

		snprintf(buf, sizeof(buf), "interp%d", i);
		if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
		    break;
		}
	    }
	    childPtr = Tcl_NewStringObj(buf, -1);
	}
	if (ChildCreate(interp, childPtr, safe) == NULL) {
	    if (buf[0] != '\0') {
		Tcl_DecrRefCount(childPtr);
	    }
	    return TCL_ERROR;
	}
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882

	for (i = 2; i < objc; i++) {
	    childInterp = GetInterp(interp, objv[i]);
	    if (childInterp == NULL) {
		return TCL_ERROR;
	    } else if (childInterp == interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot delete the current interpreter", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			"DELETESELF", NULL);
		return TCL_ERROR;
	    }
	    iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
	    Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp,
		    iiPtr->child.interpCmd);







|







868
869
870
871
872
873
874
875
876
877
878
879
880
881
882

	for (i = 2; i < objc; i++) {
	    childInterp = GetInterp(interp, objv[i]);
	    if (childInterp == NULL) {
		return TCL_ERROR;
	    } else if (childInterp == interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot delete the current interpreter", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			"DELETESELF", NULL);
		return TCL_ERROR;
	    }
	    iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
	    Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp,
		    iiPtr->child.interpCmd);
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
	}
	iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
	TclNewObj(resultPtr);
	hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch);
	for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
	    string = (char *)Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr);
	    Tcl_ListObjAppendElement(NULL, resultPtr,
		    Tcl_NewStringObj(string, TCL_INDEX_NONE));
	}
	Tcl_SetObjResult(interp, resultPtr);
	return TCL_OK;
    }
    case OPT_TRANSFER:
    case OPT_SHARE: {
	Tcl_Interp *parentInterp;	/* The parent of the child. */







|







1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
	}
	iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
	TclNewObj(resultPtr);
	hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch);
	for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
	    string = (char *)Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr);
	    Tcl_ListObjAppendElement(NULL, resultPtr,
		    Tcl_NewStringObj(string, -1));
	}
	Tcl_SetObjResult(interp, resultPtr);
	return TCL_OK;
    }
    case OPT_TRANSFER:
    case OPT_SHARE: {
	Tcl_Interp *parentInterp;	/* The parent of the child. */
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224

int
Tcl_CreateAlias(
    Tcl_Interp *childInterp,	/* Interpreter for source command. */
    const char *childCmd,	/* Command to install in child. */
    Tcl_Interp *targetInterp,	/* Interpreter for target command. */
    const char *targetCmd,	/* Name of target command. */
    size_t argc,			/* How many additional arguments? */
    const char *const *argv)	/* These are the additional args. */
{
    Tcl_Obj *childObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    size_t i;
    int result;

    objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc);
    for (i = 0; i < argc; i++) {
	objv[i] = Tcl_NewStringObj(argv[i], TCL_INDEX_NONE);
	Tcl_IncrRefCount(objv[i]);
    }

    childObjPtr = Tcl_NewStringObj(childCmd, TCL_INDEX_NONE);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, TCL_INDEX_NONE);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, argc, objv);

    for (i = 0; i < argc; i++) {
	Tcl_DecrRefCount(objv[i]);







|




|




|



|


|







1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224

int
Tcl_CreateAlias(
    Tcl_Interp *childInterp,	/* Interpreter for source command. */
    const char *childCmd,	/* Command to install in child. */
    Tcl_Interp *targetInterp,	/* Interpreter for target command. */
    const char *targetCmd,	/* Name of target command. */
    Tcl_Size argc,			/* How many additional arguments? */
    const char *const *argv)	/* These are the additional args. */
{
    Tcl_Obj *childObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    Tcl_Size i;
    int result;

    objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc);
    for (i = 0; i < argc; i++) {
	objv[i] = Tcl_NewStringObj(argv[i], -1);
	Tcl_IncrRefCount(objv[i]);
    }

    childObjPtr = Tcl_NewStringObj(childCmd, -1);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, argc, objv);

    for (i = 0; i < argc; i++) {
	Tcl_DecrRefCount(objv[i]);
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271

int
Tcl_CreateAliasObj(
    Tcl_Interp *childInterp,	/* Interpreter for source command. */
    const char *childCmd,	/* Command to install in child. */
    Tcl_Interp *targetInterp,	/* Interpreter for target command. */
    const char *targetCmd,	/* Name of target command. */
    size_t objc,			/* How many additional arguments? */
    Tcl_Obj *const objv[])	/* Argument vector. */
{
    Tcl_Obj *childObjPtr, *targetObjPtr;
    int result;

    childObjPtr = Tcl_NewStringObj(childCmd, TCL_INDEX_NONE);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, TCL_INDEX_NONE);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, objc, objv);

    Tcl_DecrRefCount(childObjPtr);
    Tcl_DecrRefCount(targetObjPtr);







|





|


|







1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271

int
Tcl_CreateAliasObj(
    Tcl_Interp *childInterp,	/* Interpreter for source command. */
    const char *childCmd,	/* Command to install in child. */
    Tcl_Interp *targetInterp,	/* Interpreter for target command. */
    const char *targetCmd,	/* Name of target command. */
    Tcl_Size objc,			/* How many additional arguments? */
    Tcl_Obj *const objv[])	/* Argument vector. */
{
    Tcl_Obj *childObjPtr, *targetObjPtr;
    int result;

    childObjPtr = Tcl_NewStringObj(childCmd, -1);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, objc, objv);

    Tcl_DecrRefCount(childObjPtr);
    Tcl_DecrRefCount(targetObjPtr);
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
    Tcl_Interp *interp,		/* Interpreter to start search at. */
    const char *childPath,	/* Name of child to create. */
    int isSafe)			/* Should new child be "safe" ? */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *childInterp;

    pathPtr = Tcl_NewStringObj(childPath, TCL_INDEX_NONE);
    childInterp = ChildCreate(interp, pathPtr, isSafe);
    Tcl_DecrRefCount(pathPtr);

    return childInterp;
}

/*







|







2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
    Tcl_Interp *interp,		/* Interpreter to start search at. */
    const char *childPath,	/* Name of child to create. */
    int isSafe)			/* Should new child be "safe" ? */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *childInterp;

    pathPtr = Tcl_NewStringObj(childPath, -1);
    childInterp = ChildCreate(interp, pathPtr, isSafe);
    Tcl_DecrRefCount(pathPtr);

    return childInterp;
}

/*
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
Tcl_GetChild(
    Tcl_Interp *interp,		/* Interpreter to start search from. */
    const char *childPath)	/* Path of child to find. */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *childInterp;

    pathPtr = Tcl_NewStringObj(childPath, TCL_INDEX_NONE);
    childInterp = GetInterp(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);

    return childInterp;
}

/*







|







2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
Tcl_GetChild(
    Tcl_Interp *interp,		/* Interpreter to start search from. */
    const char *childPath)	/* Path of child to find. */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *childInterp;

    pathPtr = Tcl_NewStringObj(childPath, -1);
    childInterp = GetInterp(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);

    return childInterp;
}

/*
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
    }
    iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
    if (Tcl_GetInterpPath(interp, iiPtr->child.parentInterp) != TCL_OK){
	return TCL_ERROR;
    }
    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
	    Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->parent.childTable,
		    iiPtr->child.childEntryPtr), TCL_INDEX_NONE));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetInterp --







|







2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
    }
    iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
    if (Tcl_GetInterpPath(interp, iiPtr->child.parentInterp) != TCL_OK){
	return TCL_ERROR;
    }
    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
	    Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->parent.childTable,
		    iiPtr->child.childEntryPtr), -1));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetInterp --
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
    Tcl_Interp *interp,		/* Interp. to start search from. */
    Tcl_Obj *pathPtr)		/* List object containing name of interp. to
				 * be found. */
{
    Tcl_HashEntry *hPtr;	/* Search element. */
    Child *childPtr;		/* Interim child record. */
    Tcl_Obj **objv;
    size_t objc, i;
    Tcl_Interp *searchInterp;	/* Interim storage for interp. to find. */
    InterpInfo *parentInfoPtr;

    if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }








|







2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
    Tcl_Interp *interp,		/* Interp. to start search from. */
    Tcl_Obj *pathPtr)		/* List object containing name of interp. to
				 * be found. */
{
    Tcl_HashEntry *hPtr;	/* Search element. */
    Child *childPtr;		/* Interim child record. */
    Tcl_Obj **objv;
    Tcl_Size objc, i;
    Tcl_Interp *searchInterp;	/* Interim storage for interp. to find. */
    InterpInfo *parentInfoPtr;

    if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }

2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
ChildBgerror(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *childInterp,	/* Interp in which limit is set/queried. */
    int objc,			/* Set or Query. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    if (objc) {
	size_t length;

	if (TCL_ERROR == TclListObjLengthM(NULL, objv[0], &length)
		|| (length < 1)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "cmdPrefix must be list of length >= 1", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
		    "BGERRORFORMAT", NULL);
	    return TCL_ERROR;
	}
	TclSetBgErrorHandler(childInterp, objv[0]);
    }
    Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp));







|




|







2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
ChildBgerror(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *childInterp,	/* Interp in which limit is set/queried. */
    int objc,			/* Set or Query. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    if (objc) {
	Tcl_Size length;

	if (TCL_ERROR == TclListObjLengthM(NULL, objv[0], &length)
		|| (length < 1)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "cmdPrefix must be list of length >= 1", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
		    "BGERRORFORMAT", NULL);
	    return TCL_ERROR;
	}
	TclSetBgErrorHandler(childInterp, objv[0]);
    }
    Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp));
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
{
    Tcl_Interp *parentInterp, *childInterp;
    Child *childPtr;
    InterpInfo *parentInfoPtr;
    Tcl_HashEntry *hPtr;
    const char *path;
    int isNew;
    size_t objc;
    Tcl_Obj **objv;

    if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }
    if (objc < 2) {
	parentInterp = interp;







|







2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
{
    Tcl_Interp *parentInterp, *childInterp;
    Child *childPtr;
    InterpInfo *parentInfoPtr;
    Tcl_HashEntry *hPtr;
    const char *path;
    int isNew;
    Tcl_Size objc;
    Tcl_Obj **objv;

    if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }
    if (objc < 2) {
	parentInterp = interp;
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
    Interp *iPtr;
    Tcl_Obj *resultPtr;

    iPtr = (Interp *) childInterp;
    if (objc == 0) {
	TclNewObj(resultPtr);
	Tcl_ListObjAppendElement(NULL, resultPtr,
		Tcl_NewStringObj("-frame", TCL_INDEX_NONE));
	Tcl_ListObjAppendElement(NULL, resultPtr,
		Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option",
		0, &debugType) != TCL_OK) {
	    return TCL_ERROR;







|







2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
    Interp *iPtr;
    Tcl_Obj *resultPtr;

    iPtr = (Interp *) childInterp;
    if (objc == 0) {
	TclNewObj(resultPtr);
	Tcl_ListObjAppendElement(NULL, resultPtr,
		Tcl_NewStringObj("-frame", -1));
	Tcl_ListObjAppendElement(NULL, resultPtr,
		Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option",
		0, &debugType) != TCL_OK) {
	    return TCL_ERROR;
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014

3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
{
    Interp *iPtr;
    Tcl_WideInt limit;

    if (objc) {
	if (Tcl_IsSafe(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
		    "safe interpreters cannot change recursion limit", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
		    NULL);
	    return TCL_ERROR;
	}
	if (TclGetWideIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (limit <= 0 || (size_t)limit >= ((Tcl_WideUInt)WIDE_MAX & TCL_INDEX_NONE)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "recursion limit must be > 0 and < %" TCL_LL_MODIFIER "u", (Tcl_WideUInt)WIDE_MAX & TCL_INDEX_NONE));

	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
		    NULL);
	    return TCL_ERROR;
	}
	Tcl_SetRecursionLimit(childInterp, limit);
	iPtr = (Interp *) childInterp;
	if (interp == childInterp && iPtr->numLevels > (size_t)limit) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "falling back due to new recursion limit", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, objv[0]);
	return TCL_OK;
    } else {
	limit = Tcl_SetRecursionLimit(childInterp, 0);







|







|
|
|
>
|
<




|

|







2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016

3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
{
    Interp *iPtr;
    Tcl_WideInt limit;

    if (objc) {
	if (Tcl_IsSafe(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
		    "safe interpreters cannot change recursion limit", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
		    NULL);
	    return TCL_ERROR;
	}
	if (TclGetWideIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (limit <= 0) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "recursion limit must be > 0", -1));
	    Tcl_SetErrorCode(
		interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", NULL);

	    return TCL_ERROR;
	}
	Tcl_SetRecursionLimit(childInterp, limit);
	iPtr = (Interp *) childInterp;
	if (interp == childInterp && iPtr->numLevels > limit) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "falling back due to new recursion limit", -1));
	    Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, objv[0]);
	return TCL_OK;
    } else {
	limit = Tcl_SetRecursionLimit(childInterp, 0);
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
    TclNewObj(listObjPtr);
    hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr;
    if (hTblPtr != NULL) {
	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
		hPtr != NULL;
		hPtr = Tcl_NextHashEntry(&hSearch)) {
	    Tcl_ListObjAppendElement(NULL, listObjPtr,
		    Tcl_NewStringObj((const char *)Tcl_GetHashKey(hTblPtr, hPtr), TCL_INDEX_NONE));
	}
    }
    Tcl_SetObjResult(interp, listObjPtr);
    return TCL_OK;
}

/*







|







3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
    TclNewObj(listObjPtr);
    hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr;
    if (hTblPtr != NULL) {
	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
		hPtr != NULL;
		hPtr = Tcl_NextHashEntry(&hSearch)) {
	    Tcl_ListObjAppendElement(NULL, listObjPtr,
		    Tcl_NewStringObj((const char *)Tcl_GetHashKey(hTblPtr, hPtr), -1));
	}
    }
    Tcl_SetObjResult(interp, listObjPtr);
    return TCL_OK;
}

/*
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
	iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS;
	Tcl_Preserve(interp);
	RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
	if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
	    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
	} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command count limit exceeded", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
	    Tcl_Release(interp);
	    return TCL_ERROR;
	}
	Tcl_Release(interp);
    }








|







3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
	iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS;
	Tcl_Preserve(interp);
	RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
	if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
	    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
	} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "command count limit exceeded", -1));
	    Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
	    Tcl_Release(interp);
	    return TCL_ERROR;
	}
	Tcl_Release(interp);
    }

3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
	    RunLimitHandlers(iPtr->limit.timeHandlers, interp);
	    if (iPtr->limit.time.sec > now.sec ||
		    (iPtr->limit.time.sec == now.sec &&
		    iPtr->limit.time.usec >= now.usec)) {
		iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
	    } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"time limit exceeded", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
		Tcl_Release(interp);
		return TCL_ERROR;
	    }
	    Tcl_Release(interp);
	}
    }







|







3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
	    RunLimitHandlers(iPtr->limit.timeHandlers, interp);
	    if (iPtr->limit.time.sec > now.sec ||
		    (iPtr->limit.time.sec == now.sec &&
		    iPtr->limit.time.usec >= now.usec)) {
		iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
	    } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"time limit exceeded", -1));
		Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
		Tcl_Release(interp);
		return TCL_ERROR;
	    }
	    Tcl_Release(interp);
	}
    }
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetCommands(
    Tcl_Interp *interp,
    size_t commandLimit)
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.cmdCount = commandLimit;
    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}








|







3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LimitSetCommands(
    Tcl_Interp *interp,
    Tcl_Size commandLimit)
{
    Interp *iPtr = (Interp *) interp;

    iPtr->limit.cmdCount = commandLimit;
    iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}

4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
     * interpreter's limits; it may only manipulate its children. Note that
     * the low level API enforces this with Tcl_Panic, which we want to
     * avoid. [Bug 3398794]
     */

    if (interp == childInterp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"limits on current interpreter inaccessible", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
	return TCL_ERROR;
    }

    if (objc == consumedObjc) {
	Tcl_Obj *dictPtr;

	TclNewObj(dictPtr);
	key.interp = childInterp;
	key.type = TCL_LIMIT_COMMANDS;
	hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
	if (hPtr != NULL) {
	    limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
	    if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], TCL_INDEX_NONE),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;

	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], TCL_INDEX_NONE), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], TCL_INDEX_NONE),
		Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
		TCL_LIMIT_COMMANDS)));

	if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], TCL_INDEX_NONE),
		    Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
	} else {
	    Tcl_Obj *empty;

	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[2], TCL_INDEX_NONE), empty);
	}
	Tcl_SetObjResult(interp, dictPtr);
	return TCL_OK;
    } else if (objc == consumedObjc+1) {
	if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
		0, &index) != TCL_OK) {
	    return TCL_ERROR;







|














|










|

|




|






|







4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
     * interpreter's limits; it may only manipulate its children. Note that
     * the low level API enforces this with Tcl_Panic, which we want to
     * avoid. [Bug 3398794]
     */

    if (interp == childInterp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"limits on current interpreter inaccessible", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
	return TCL_ERROR;
    }

    if (objc == consumedObjc) {
	Tcl_Obj *dictPtr;

	TclNewObj(dictPtr);
	key.interp = childInterp;
	key.type = TCL_LIMIT_COMMANDS;
	hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
	if (hPtr != NULL) {
	    limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
	    if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;

	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], -1), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
		Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
		TCL_LIMIT_COMMANDS)));

	if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
		    Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
	} else {
	    Tcl_Obj *empty;

	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[2], -1), empty);
	}
	Tcl_SetObjResult(interp, dictPtr);
	return TCL_OK;
    } else if (objc == consumedObjc+1) {
	if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
		0, &index) != TCL_OK) {
	    return TCL_ERROR;
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
	}
	return TCL_OK;
    } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
	Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
	return TCL_ERROR;
    } else {
	int i;
	size_t scriptLen = 0, limitLen = 0;
	Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
	int gran = 0, limit = 0;

	for (i=consumedObjc ; i<objc ; i+=2) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (index) {
	    case OPT_CMD:
		scriptObj = objv[i+1];
		(void) Tcl_GetStringFromObj(scriptObj, &scriptLen);
		break;
	    case OPT_GRAN:
		granObj = objv[i+1];
		if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "granularity must be at least 1", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_VAL:
		limitObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
		if (limitLen == 0) {
		    break;
		}
		if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (limit < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "command limit value must be at least 0", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    }
	}







|




















|
















|







4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
	}
	return TCL_OK;
    } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
	Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
	return TCL_ERROR;
    } else {
	int i;
	Tcl_Size scriptLen = 0, limitLen = 0;
	Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
	int gran = 0, limit = 0;

	for (i=consumedObjc ; i<objc ; i+=2) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (index) {
	    case OPT_CMD:
		scriptObj = objv[i+1];
		(void) Tcl_GetStringFromObj(scriptObj, &scriptLen);
		break;
	    case OPT_GRAN:
		granObj = objv[i+1];
		if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "granularity must be at least 1", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_VAL:
		limitObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
		if (limitLen == 0) {
		    break;
		}
		if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (limit < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "command limit value must be at least 0", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    }
	}
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
     * interpreter's limits; it may only manipulate its children. Note that
     * the low level API enforces this with Tcl_Panic, which we want to
     * avoid. [Bug 3398794]
     */

    if (interp == childInterp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"limits on current interpreter inaccessible", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
	return TCL_ERROR;
    }

    if (objc == consumedObjc) {
	Tcl_Obj *dictPtr;

	TclNewObj(dictPtr);
	key.interp = childInterp;
	key.type = TCL_LIMIT_TIME;
	hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
	if (hPtr != NULL) {
	    limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
	    if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], TCL_INDEX_NONE),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;
	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], TCL_INDEX_NONE), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], TCL_INDEX_NONE),
		Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
		TCL_LIMIT_TIME)));

	if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
	    Tcl_Time limitMoment;

	    Tcl_LimitGetTime(childInterp, &limitMoment);
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], TCL_INDEX_NONE),
		    Tcl_NewWideIntObj(limitMoment.usec/1000));
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], TCL_INDEX_NONE),
		    Tcl_NewWideIntObj(limitMoment.sec));
	} else {
	    Tcl_Obj *empty;

	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[2], TCL_INDEX_NONE), empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[3], TCL_INDEX_NONE), empty);
	}
	Tcl_SetObjResult(interp, dictPtr);
	return TCL_OK;
    } else if (objc == consumedObjc+1) {
	if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
		0, &index) != TCL_OK) {
	    return TCL_ERROR;







|














|









|

|







|

|






|

|







4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
     * interpreter's limits; it may only manipulate its children. Note that
     * the low level API enforces this with Tcl_Panic, which we want to
     * avoid. [Bug 3398794]
     */

    if (interp == childInterp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"limits on current interpreter inaccessible", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
	return TCL_ERROR;
    }

    if (objc == consumedObjc) {
	Tcl_Obj *dictPtr;

	TclNewObj(dictPtr);
	key.interp = childInterp;
	key.type = TCL_LIMIT_TIME;
	hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
	if (hPtr != NULL) {
	    limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
	    if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
		Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
			limitCBPtr->scriptObj);
	    } else {
		goto putEmptyCommandInDict;
	    }
	} else {
	    Tcl_Obj *empty;
	putEmptyCommandInDict:
	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[0], -1), empty);
	}
	Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
		Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
		TCL_LIMIT_TIME)));

	if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
	    Tcl_Time limitMoment;

	    Tcl_LimitGetTime(childInterp, &limitMoment);
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
		    Tcl_NewWideIntObj(limitMoment.usec/1000));
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1),
		    Tcl_NewWideIntObj(limitMoment.sec));
	} else {
	    Tcl_Obj *empty;

	    TclNewObj(empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[2], -1), empty);
	    Tcl_DictObjPut(NULL, dictPtr,
		    Tcl_NewStringObj(options[3], -1), empty);
	}
	Tcl_SetObjResult(interp, dictPtr);
	return TCL_OK;
    } else if (objc == consumedObjc+1) {
	if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
		0, &index) != TCL_OK) {
	    return TCL_ERROR;
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
	}
	return TCL_OK;
    } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
	Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
	return TCL_ERROR;
    } else {
	int i;
	size_t scriptLen = 0, milliLen = 0, secLen = 0;
	Tcl_Obj *scriptObj = NULL, *granObj = NULL;
	Tcl_Obj *milliObj = NULL, *secObj = NULL;
	int gran = 0;
	Tcl_Time limitMoment;
	Tcl_WideInt tmp;

	Tcl_LimitGetTime(childInterp, &limitMoment);







|







4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
	}
	return TCL_OK;
    } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
	Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
	return TCL_ERROR;
    } else {
	int i;
	Tcl_Size scriptLen = 0, milliLen = 0, secLen = 0;
	Tcl_Obj *scriptObj = NULL, *granObj = NULL;
	Tcl_Obj *milliObj = NULL, *secObj = NULL;
	int gran = 0;
	Tcl_Time limitMoment;
	Tcl_WideInt tmp;

	Tcl_LimitGetTime(childInterp, &limitMoment);
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
	    case OPT_GRAN:
		granObj = objv[i+1];
		if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "granularity must be at least 1", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_MILLI:
		milliObj = objv[i+1];







|







4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
	    case OPT_GRAN:
		granObj = objv[i+1];
		if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "granularity must be at least 1", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_MILLI:
		milliObj = objv[i+1];
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
		 * Setting -milliseconds but clearing -seconds, or resetting
		 * -milliseconds but not resetting -seconds? Bad voodoo!
		 */

		if (secObj != NULL && secLen == 0 && milliLen > 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "may only set -milliseconds if -seconds is not "
			    "also being reset", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADUSAGE", NULL);
		    return TCL_ERROR;
		}
		if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "may only reset -milliseconds if -seconds is "
			    "also being reset", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADUSAGE", NULL);
		    return TCL_ERROR;
		}
	    }

	    if (milliLen > 0 || secLen > 0) {







|







|







4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
		 * Setting -milliseconds but clearing -seconds, or resetting
		 * -milliseconds but not resetting -seconds? Bad voodoo!
		 */

		if (secObj != NULL && secLen == 0 && milliLen > 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "may only set -milliseconds if -seconds is not "
			    "also being reset", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADUSAGE", NULL);
		    return TCL_ERROR;
		}
		if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "may only reset -milliseconds if -seconds is "
			    "also being reset", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADUSAGE", NULL);
		    return TCL_ERROR;
		}
	    }

	    if (milliLen > 0 || secLen > 0) {

Changes to generic/tclLink.c.

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    Namespace *nsPtr;		/* Namespace containing Tcl variable */
    Tcl_Obj *varName;		/* Name of variable (must be global). This is
				 * needed during trace callbacks, since the
				 * actual variable may be aliased at that time
				 * via upvar. */
    void *addr;			/* Location of C variable. */
    size_t bytes;		/* Size of C variable array. This is 0 when
				 * single variables, and >0 used for array
				 * variables. */
    size_t numElems;	/* Number of elements in C variable array.
				 * Zero for single variables. */
    int type;			/* Type of link (TCL_LINK_INT, etc.). */
    union {
	char c;
	unsigned char uc;
	int i;
	unsigned int ui;







|


|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    Namespace *nsPtr;		/* Namespace containing Tcl variable */
    Tcl_Obj *varName;		/* Name of variable (must be global). This is
				 * needed during trace callbacks, since the
				 * actual variable may be aliased at that time
				 * via upvar. */
    void *addr;			/* Location of C variable. */
    Tcl_Size bytes;		/* Size of C variable array. This is 0 when
				 * single variables, and >0 used for array
				 * variables. */
    Tcl_Size numElems;	/* Number of elements in C variable array.
				 * Zero for single variables. */
    int type;			/* Type of link (TCL_LINK_INT, etc.). */
    union {
	char c;
	unsigned char uc;
	int i;
	unsigned int ui;
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
		"variable '%s' is already linked", varName));
	return TCL_ERROR;
    }

    linkPtr = (Link *)Tcl_Alloc(sizeof(Link));
    linkPtr->interp = interp;
    linkPtr->nsPtr = NULL;
    linkPtr->varName = Tcl_NewStringObj(varName, TCL_INDEX_NONE);
    Tcl_IncrRefCount(linkPtr->varName);
    linkPtr->addr = addr;
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
	|| defined(_WIN32) || defined(__CYGWIN__))
    if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
	linkPtr->type = TCL_LINK_LONG;







|







171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
		"variable '%s' is already linked", varName));
	return TCL_ERROR;
    }

    linkPtr = (Link *)Tcl_Alloc(sizeof(Link));
    linkPtr->interp = interp;
    linkPtr->nsPtr = NULL;
    linkPtr->varName = Tcl_NewStringObj(varName, -1);
    Tcl_IncrRefCount(linkPtr->varName);
    linkPtr->addr = addr;
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
	|| defined(_WIN32) || defined(__CYGWIN__))
    if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
	linkPtr->type = TCL_LINK_LONG;
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
    const char *varName,	/* Name of a global variable in interp. */
    void *addr,			/* Address of a C variable to be linked to
				 * varName. If NULL then the necessary space
				 * will be allocated and returned as the
				 * interpreter result. */
    int type,			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY OR'ed in. */
    size_t size)			/* Size of C variable array, >1 if array */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    Namespace *dummy;
    const char *name;
    int code;

    if (size < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"wrong array size given", TCL_INDEX_NONE));
	return TCL_ERROR;
    }

    linkPtr = (Link *)Tcl_Alloc(sizeof(Link));
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
	|| defined(_WIN32) || defined(__CYGWIN__))







|









|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
    const char *varName,	/* Name of a global variable in interp. */
    void *addr,			/* Address of a C variable to be linked to
				 * varName. If NULL then the necessary space
				 * will be allocated and returned as the
				 * interpreter result. */
    int type,			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY OR'ed in. */
    Tcl_Size size)		/* Size of C variable array, >1 if array */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    Namespace *dummy;
    const char *name;
    int code;

    if (size < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"wrong array size given", -1));
	return TCL_ERROR;
    }

    linkPtr = (Link *)Tcl_Alloc(sizeof(Link));
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
	|| defined(_WIN32) || defined(__CYGWIN__))
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    case TCL_LINK_CHARS:
    case TCL_LINK_BINARY:
	linkPtr->bytes = size * sizeof(char);
	break;
    default:
	LinkFree(linkPtr);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad linked array variable type", TCL_INDEX_NONE));
	return TCL_ERROR;
    }

    /*
     * Allocate C variable space in case no address is given
     */








|







336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    case TCL_LINK_CHARS:
    case TCL_LINK_BINARY:
	linkPtr->bytes = size * sizeof(char);
	break;
    default:
	LinkFree(linkPtr);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad linked array variable type", -1));
	return TCL_ERROR;
    }

    /*
     * Allocate C variable space in case no address is given
     */

376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
    }

    /*
     * Set common structure values.
     */

    linkPtr->interp = interp;
    linkPtr->varName = Tcl_NewStringObj(varName, TCL_INDEX_NONE);
    Tcl_IncrRefCount(linkPtr->varName);

    TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
	    &(linkPtr->nsPtr), &dummy, &dummy, &name);
    linkPtr->nsPtr->refCount++;

    objPtr = ObjValue(linkPtr);







|







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
    }

    /*
     * Set common structure values.
     */

    linkPtr->interp = interp;
    linkPtr->varName = Tcl_NewStringObj(varName, -1);
    Tcl_IncrRefCount(linkPtr->varName);

    TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
	    &(linkPtr->nsPtr), &dummy, &dummy, &name);
    linkPtr->nsPtr->refCount++;

    objPtr = ObjValue(linkPtr);
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
				/* Links can only be made to global variables,
				 * so we can find them with need to resolve
				 * caller-supplied name in caller context. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *)clientData;
    int changed;
    size_t valueLength = 0;
    const char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    Tcl_WideUInt valueUWide;
    double valueDouble;
    size_t objc, i;
    Tcl_Obj **objv;

    /*
     * If the variable is being unset, then just re-create it (with a trace)
     * unless the whole interpreter is going away.
     */








|







|







711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
				/* Links can only be made to global variables,
				 * so we can find them with need to resolve
				 * caller-supplied name in caller context. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *)clientData;
    int changed;
    Tcl_Size valueLength = 0;
    const char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    Tcl_WideUInt valueUWide;
    double valueDouble;
    Tcl_Size objc, i;
    Tcl_Obj **objv;

    /*
     * If the variable is being unset, then just re-create it (with a trace)
     * unless the whole interpreter is going away.
     */

1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259

static Tcl_Obj *
ObjValue(
    Link *linkPtr)		/* Structure describing linked variable. */
{
    char *p;
    Tcl_Obj *resultObj, **objv;
    size_t i;

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
	    for (i=0; i < linkPtr->numElems; i++) {







|







1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259

static Tcl_Obj *
ObjValue(
    Link *linkPtr)		/* Structure describing linked variable. */
{
    char *p;
    Tcl_Obj *resultObj, **objv;
    Tcl_Size i;

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
	    for (i=0; i < linkPtr->numElems; i++) {
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443

    case TCL_LINK_STRING:
	p = LinkedVar(char *);
	if (p == NULL) {
	    TclNewLiteralStringObj(resultObj, "NULL");
	    return resultObj;
	}
	return Tcl_NewStringObj(p, TCL_INDEX_NONE);

    case TCL_LINK_CHARS:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0';
	    /* take care of proper string end */
	    return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes);







|







1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443

    case TCL_LINK_STRING:
	p = LinkedVar(char *);
	if (p == NULL) {
	    TclNewLiteralStringObj(resultObj, "NULL");
	    return resultObj;
	}
	return Tcl_NewStringObj(p, -1);

    case TCL_LINK_CHARS:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0';
	    /* take care of proper string end */
	    return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes);

Changes to generic/tclListObj.c.

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
 * being passed AFTER validation. On Tcl9 length types are unsigned hence
 * the checks against LIST_MAX. On Tcl8 length types are signed hence the
 * also checks against 0.
 */
#define LIST_INDEX_ASSERT(idxarg_)                                 \
    do {                                                           \
	Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \
	LIST_ASSERT(idx_ != TCL_INDEX_NONE && idx_ < LIST_MAX);                 \
    } while (0)
/* Ditto for counts except upper limit is different */
#define LIST_COUNT_ASSERT(countarg_)                                   \
    do {                                                               \
	Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \
	LIST_ASSERT(count_ != TCL_INDEX_NONE && count_ <= LIST_MAX);                \
    } while (0)

#else

#define LIST_ASSERT(cond_) ((void) 0)
#define LIST_INDEX_ASSERT(idx_) ((void) 0)
#define LIST_COUNT_ASSERT(count_) ((void) 0)







|





|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
 * being passed AFTER validation. On Tcl9 length types are unsigned hence
 * the checks against LIST_MAX. On Tcl8 length types are signed hence the
 * also checks against 0.
 */
#define LIST_INDEX_ASSERT(idxarg_)                                 \
    do {                                                           \
	Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \
	LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX);                 \
    } while (0)
/* Ditto for counts except upper limit is different */
#define LIST_COUNT_ASSERT(countarg_)                                   \
    do {                                                               \
	Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \
	LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX);                \
    } while (0)

#else

#define LIST_ASSERT(cond_) ((void) 0)
#define LIST_INDEX_ASSERT(idx_) ((void) 0)
#define LIST_COUNT_ASSERT(count_) ((void) 0)
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size numSlots);
static void	ListRepValidate(const ListRep *repPtr, const char *file,
		    int lineNum);
static void	DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void	FreeListInternalRep(Tcl_Obj *listPtr);
static int	SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void	UpdateStringOfList(Tcl_Obj *listPtr);
static size_t ListLength(Tcl_Obj *listPtr);

/*
 * The structure below defines the list Tcl object type by means of functions
 * that can be invoked by generic object code.
 *
 * The internal representation of a list object is ListRep defined in tcl.h.
 */







|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size numSlots);
static void	ListRepValidate(const ListRep *repPtr, const char *file,
		    int lineNum);
static void	DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void	FreeListInternalRep(Tcl_Obj *listPtr);
static int	SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void	UpdateStringOfList(Tcl_Obj *listPtr);
static Tcl_Size ListLength(Tcl_Obj *listPtr);

/*
 * The structure below defines the list Tcl object type by means of functions
 * that can be invoked by generic object code.
 *
 * The internal representation of a list object is ListRep defined in tcl.h.
 */
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
 */
static int
ListLimitExceededError(Tcl_Interp *interp)
{
    if (interp != NULL) {
	Tcl_SetObjResult(
	    interp,
	    Tcl_NewStringObj("max length of a Tcl list exceeded", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
    }
    return TCL_ERROR;
}

/*
 *------------------------------------------------------------------------







|







522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
 */
static int
ListLimitExceededError(Tcl_Interp *interp)
{
    if (interp != NULL) {
	Tcl_SetObjResult(
	    interp,
	    Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
    }
    return TCL_ERROR;
}

/*
 *------------------------------------------------------------------------
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
    /* Take the opportunity to garbage collect */
    /* TODO - we probably do not need the preserveSrcRep here unlike later */
    if (!preserveSrcRep) {
        /* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
	ListRepFreeUnreferenced(srcRepPtr);
    } /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */

    if (rangeStart == TCL_INDEX_NONE) {
	rangeStart = 0;
    }
    if ((rangeEnd != TCL_INDEX_NONE) && (rangeEnd >= numSrcElems)) {
	rangeEnd = numSrcElems - 1;
    }
    if (rangeStart + 1 > rangeEnd + 1) {
	/* Empty list of capacity 1. */
	ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr);
	return;
    }

    rangeLen = rangeEnd - rangeStart + 1;








|


|


|







1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
    /* Take the opportunity to garbage collect */
    /* TODO - we probably do not need the preserveSrcRep here unlike later */
    if (!preserveSrcRep) {
        /* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
	ListRepFreeUnreferenced(srcRepPtr);
    } /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */

    if (rangeStart < 0) {
	rangeStart = 0;
    }
    if (rangeEnd >= numSrcElems) {
	rangeEnd = numSrcElems - 1;
    }
    if (rangeStart > rangeEnd) {
	/* Empty list of capacity 1. */
	ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr);
	return;
    }

    rangeLen = rangeEnd - rangeStart + 1;

1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
    if (Tcl_IsShared(toObj)) {
	Tcl_Panic("%s called with shared object", "TclListObjAppendElements");
    }

    if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK)
	return TCL_ERROR; /* Cannot be converted to a list */

    if (elemCount == 0)
	return TCL_OK; /* Nothing to do. Note AFTER check for list above */

    ListRepElements(&listRep, toLen, toObjv);
    if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) {
	return ListLimitExceededError(interp);
    }








|







1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
    if (Tcl_IsShared(toObj)) {
	Tcl_Panic("%s called with shared object", "TclListObjAppendElements");
    }

    if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK)
	return TCL_ERROR; /* Cannot be converted to a list */

    if (elemCount <= 0)
	return TCL_OK; /* Nothing to do. Note AFTER check for list above */

    ListRepElements(&listRep, toLen, toObjv);
    if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) {
	return ListLimitExceededError(interp);
    }

1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
     * other hand, this code will be faster for the case where the object
     * is currently a dict. Benchmark the two cases.
     */
    if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
	!= TCL_OK) {
	return TCL_ERROR;
    }
    if (index >= numElems) {
	*objPtrPtr = NULL;
    } else {
	*objPtrPtr = elemObjs[index];
    }

    return TCL_OK;
}







|







1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
     * other hand, this code will be faster for the case where the object
     * is currently a dict. Benchmark the two cases.
     */
    if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
	!= TCL_OK) {
	return TCL_ERROR;
    }
    if (index < 0 || index >= numElems) {
	*objPtrPtr = NULL;
    } else {
	*objPtrPtr = elemObjs[index];
    }

    return TCL_OK;
}
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
Tcl_ListObjLength(
    Tcl_Interp *interp,	/* Used to report errors if not NULL. */
    Tcl_Obj *listObj,	/* List object whose #elements to return. */
    Tcl_Size *lenPtr)	/* The resulting length is stored here. */
{
    ListRep listRep;

    size_t (*lengthProc)(Tcl_Obj *obj) =  ABSTRACTLIST_PROC(listObj, lengthProc);
    if (lengthProc) {
	*lenPtr = lengthProc(listObj);
	return TCL_OK;
    }

    /*
     * TODO
     * Unlike the original list code, this does not optimize for lindex'ing
     * an empty string when the internal rep is not already a list. On the
     * other hand, this code will be faster for the case where the object
     * is currently a dict. Benchmark the two cases.
     */
    if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
	return TCL_ERROR;
    }
    *lenPtr = ListRepLength(&listRep);
    return TCL_OK;
}

size_t ListLength(
    Tcl_Obj *listPtr)
{
	ListRep listRep;
	ListObjGetRep(listPtr, &listRep);

    return ListRepLength(&listRep);
}

/*
 *----------------------------------------------------------------------
 *







|



















|
|

|
|







2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
Tcl_ListObjLength(
    Tcl_Interp *interp,	/* Used to report errors if not NULL. */
    Tcl_Obj *listObj,	/* List object whose #elements to return. */
    Tcl_Size *lenPtr)	/* The resulting length is stored here. */
{
    ListRep listRep;

    Tcl_Size (*lengthProc)(Tcl_Obj *obj) =  ABSTRACTLIST_PROC(listObj, lengthProc);
    if (lengthProc) {
	*lenPtr = lengthProc(listObj);
	return TCL_OK;
    }

    /*
     * TODO
     * Unlike the original list code, this does not optimize for lindex'ing
     * an empty string when the internal rep is not already a list. On the
     * other hand, this code will be faster for the case where the object
     * is currently a dict. Benchmark the two cases.
     */
    if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
	return TCL_ERROR;
    }
    *lenPtr = ListRepLength(&listRep);
    return TCL_OK;
}

Tcl_Size 
ListLength(Tcl_Obj *listPtr)
{
    ListRep listRep;
    ListObjGetRep(listPtr, &listRep);

    return ListRepLength(&listRep);
}

/*
 *----------------------------------------------------------------------
 *
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
    if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
	return TCL_ERROR; /* Cannot be converted to a list */

    /* TODO - will need modification if Tcl9 sticks to unsigned indices */

    /* Make limits sane */
    origListLen = ListRepLength(&listRep);
    if (first == TCL_INDEX_NONE) {
	first = 0;
    }
    if (first > origListLen) {
	first = origListLen;	/* So we'll insert after last element. */
    }
    if (numToDelete == TCL_INDEX_NONE) {
	numToDelete = 0;
    } else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */
             || origListLen < first + numToDelete) {
	numToDelete = origListLen - first;
    }

    if (numToInsert > ListSizeT_MAX - (origListLen - numToDelete)) {







|





|







2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
    if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
	return TCL_ERROR; /* Cannot be converted to a list */

    /* TODO - will need modification if Tcl9 sticks to unsigned indices */

    /* Make limits sane */
    origListLen = ListRepLength(&listRep);
    if (first < 0) {
	first = 0;
    }
    if (first > origListLen) {
	first = origListLen;	/* So we'll insert after last element. */
    }
    if (numToDelete < 0) {
	numToDelete = 0;
    } else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */
             || origListLen < first + numToDelete) {
	numToDelete = origListLen - first;
    }

    if (numToInsert > ListSizeT_MAX - (origListLen - numToDelete)) {
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
 *
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclLindexFlat(
    Tcl_Interp *interp,		/* Tcl interpreter. */
    Tcl_Obj *listObj,		/* Tcl object representing the list. */
    Tcl_Size indexCount,		/* Count of indices. */
    Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
				 * represent the indices in the list. */
{
    Tcl_Size i;

    /* Handle ArithSeries as special case */
    if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) {







|







2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
 *
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclLindexFlat(
    Tcl_Interp *interp,		/* Tcl interpreter. */
    Tcl_Obj *listObj,		/* Tcl object representing the list. */
    Tcl_Size indexCount,	/* Count of indices. */
    Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
				 * represent the indices in the list. */
{
    Tcl_Size i;

    /* Handle ArithSeries as special case */
    if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) {
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
	    break;
	}
	LIST_ASSERT_TYPE(sublistCopy);
	ListObjGetElements(sublistCopy, listLen, elemPtrs);

	if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
		&index) == TCL_OK) {
	    if (index >= listLen) {
		/*
		 * Index is out of range. Break out of loop with empty result.
		 * First check remaining indices for validity
		 */

		while (++i < indexCount) {
		    if (TclGetIntForIndexM(







|







2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
	    break;
	}
	LIST_ASSERT_TYPE(sublistCopy);
	ListObjGetElements(sublistCopy, listLen, elemPtrs);

	if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
		&index) == TCL_OK) {
	    if (index < 0 || index >= listLen) {
		/*
		 * Index is out of range. Break out of loop with empty result.
		 * First check remaining indices for validity
		 */

		while (++i < indexCount) {
		    if (TclGetIntForIndexM(
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
	    /* ...the index we're trying to use isn't an index at all. */
	    result = TCL_ERROR;
	    indexArray++; /* Why bother with this increment? TBD */
	    break;
	}
	indexArray++;

	if (index > elemCount
	    || (valueObj == NULL && index >= elemCount)) {
	    /* ...the index points outside the sublist. */
	    if (interp != NULL) {
		Tcl_SetObjResult(interp,
		                 Tcl_ObjPrintf("index \"%s\" out of range",
		                               Tcl_GetString(indexArray[-1])));
		Tcl_SetErrorCode(interp,







|







2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
	    /* ...the index we're trying to use isn't an index at all. */
	    result = TCL_ERROR;
	    indexArray++; /* Why bother with this increment? TBD */
	    break;
	}
	indexArray++;

	if (index < 0 || index > elemCount
	    || (valueObj == NULL && index >= elemCount)) {
	    /* ...the index points outside the sublist. */
	    if (interp != NULL) {
		Tcl_SetObjResult(interp,
		                 Tcl_ObjPrintf("index \"%s\" out of range",
		                               Tcl_GetString(indexArray[-1])));
		Tcl_SetErrorCode(interp,

Changes to generic/tclLiteral.c.

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
 */

Tcl_Obj *
TclCreateLiteral(
    Interp *iPtr,
    const char *bytes,	/* The start of the string. Note that this is
				 * not a NUL-terminated string. */
    size_t length,		/* Number of bytes in the string. */
    size_t hash,		/* The string's hash. If the value is
				 * TCL_INDEX_NONE, it will be computed here. */
    int *newPtr,
    Namespace *nsPtr,
    int flags,
    LiteralEntry **globalPtrPtr)
{
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    LiteralEntry *globalPtr;
    size_t globalHash;
    Tcl_Obj *objPtr;

    /*
     * Is it in the interpreter's global literal table?
     */

    if (hash == TCL_INDEX_NONE) {
	hash = HashString(bytes, length);
    }
    globalHash = (hash & globalTablePtr->mask);
    for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL;
	    globalPtr = globalPtr->nextPtr) {
	objPtr = globalPtr->objPtr;
	if (globalPtr->nsPtr == nsPtr) {
	    /*
	     * Literals should always have UTF-8 representations... but this
	     * is not guaranteed so we need to be careful anyway.
	     *
	     * https://stackoverflow.com/q/54337750/301832
	     */

	    size_t objLength;
	    const char *objBytes = Tcl_GetStringFromObj(objPtr, &objLength);

	    if ((objLength == length) && ((length == 0)
		    || ((objBytes[0] == bytes[0])
		    && (memcmp(objBytes, bytes, length) == 0)))) {
		/*
		 * A literal was found: return it







|
|
|














|














|







174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
 */

Tcl_Obj *
TclCreateLiteral(
    Interp *iPtr,
    const char *bytes,	/* The start of the string. Note that this is
				 * not a NUL-terminated string. */
    Tcl_Size length,	/* Number of bytes in the string. */
    TCL_HASH_TYPE hash, /* The string's hash. If the value is
				         * TCL_INDEX_NONE, it will be computed here. */
    int *newPtr,
    Namespace *nsPtr,
    int flags,
    LiteralEntry **globalPtrPtr)
{
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    LiteralEntry *globalPtr;
    size_t globalHash;
    Tcl_Obj *objPtr;

    /*
     * Is it in the interpreter's global literal table?
     */

    if (hash == (TCL_HASH_TYPE) TCL_INDEX_NONE) {
	hash = HashString(bytes, length);
    }
    globalHash = (hash & globalTablePtr->mask);
    for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL;
	    globalPtr = globalPtr->nextPtr) {
	objPtr = globalPtr->objPtr;
	if (globalPtr->nsPtr == nsPtr) {
	    /*
	     * Literals should always have UTF-8 representations... but this
	     * is not guaranteed so we need to be careful anyway.
	     *
	     * https://stackoverflow.com/q/54337750/301832
	     */

	    Tcl_Size objLength;
	    const char *objBytes = Tcl_GetStringFromObj(objPtr, &objLength);

	    if ((objLength == length) && ((length == 0)
		    || ((objBytes[0] == bytes[0])
		    && (memcmp(objBytes, bytes, length) == 0)))) {
		/*
		 * A literal was found: return it
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclFetchLiteral(
    CompileEnv *envPtr,		/* Points to the CompileEnv from which to
				 * fetch the registered literal value. */
    size_t index)		/* Index of the desired literal, as returned
				 * by prior call to TclRegisterLiteral() */
{
    if (index >= envPtr->literalArrayNext) {
	return NULL;
    }
    return envPtr->literalArrayPtr[index].objPtr;
}







|







347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclFetchLiteral(
    CompileEnv *envPtr,		/* Points to the CompileEnv from which to
				 * fetch the registered literal value. */
    Tcl_Size index)		/* Index of the desired literal, as returned
				 * by prior call to TclRegisterLiteral() */
{
    if (index >= envPtr->literalArrayNext) {
	return NULL;
    }
    return envPtr->literalArrayPtr[index].objPtr;
}
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
 *	is set directly from string, otherwise the string is freed. Typically,
 *	a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
 *	buffer holding the result of backslash substitutions.
 *
 *----------------------------------------------------------------------
 */

size_t
TclRegisterLiteral(
    void *ePtr,		/* Points to the CompileEnv in whose object
				 * array an object is found or created. */
    const char *bytes,	/* Points to string for which to find or
				 * create an object in CompileEnv's object
				 * array. */
    size_t length,			/* Number of bytes in the string. If -1, the
				 * string consists of all bytes up to the
				 * first null character. */
    int flags)			/* If LITERAL_ON_HEAP then the caller already
				 * malloc'd bytes and ownership is passed to
				 * this function. If LITERAL_CMD_NAME then
				 * the literal should not be shared across
				 * namespaces. */
{
    CompileEnv *envPtr = (CompileEnv *)ePtr;
    Interp *iPtr = envPtr->iPtr;
    LiteralTable *localTablePtr = &envPtr->localLitTable;
    LiteralEntry *globalPtr, *localPtr;
    Tcl_Obj *objPtr;
    size_t hash, localHash, objIndex;
    int isNew;
    Namespace *nsPtr;

    if (length == TCL_INDEX_NONE) {
	length = (bytes ? strlen(bytes) : 0);
    }
    hash = HashString(bytes, length);

    /*
     * Is the literal already in the CompileEnv's local literal array? If so,
     * just return its index.







|






|

















|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
 *	is set directly from string, otherwise the string is freed. Typically,
 *	a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
 *	buffer holding the result of backslash substitutions.
 *
 *----------------------------------------------------------------------
 */

int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/
TclRegisterLiteral(
    void *ePtr,		/* Points to the CompileEnv in whose object
				 * array an object is found or created. */
    const char *bytes,	/* Points to string for which to find or
				 * create an object in CompileEnv's object
				 * array. */
    Tcl_Size length,			/* Number of bytes in the string. If -1, the
				 * string consists of all bytes up to the
				 * first null character. */
    int flags)			/* If LITERAL_ON_HEAP then the caller already
				 * malloc'd bytes and ownership is passed to
				 * this function. If LITERAL_CMD_NAME then
				 * the literal should not be shared across
				 * namespaces. */
{
    CompileEnv *envPtr = (CompileEnv *)ePtr;
    Interp *iPtr = envPtr->iPtr;
    LiteralTable *localTablePtr = &envPtr->localLitTable;
    LiteralEntry *globalPtr, *localPtr;
    Tcl_Obj *objPtr;
    size_t hash, localHash, objIndex;
    int isNew;
    Namespace *nsPtr;

    if (length < 0) {
	length = (bytes ? strlen(bytes) : 0);
    }
    hash = HashString(bytes, length);

    /*
     * Is the literal already in the CompileEnv's local literal array? If so,
     * just return its index.
433
434
435
436
437
438
439



440
441
442
443
444
445
446
		Tcl_Free((void *)bytes);
	    }
	    objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
	    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/




	    return objIndex;
	}
    }

    /*
     * The literal is new to this CompileEnv. If it is a command name, avoid
     * sharing it across namespaces, and try not to share it with non-cmd







>
>
>







433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
		Tcl_Free((void *)bytes);
	    }
	    objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
	    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/

	    if (objIndex > INT_MAX) {
		Tcl_Panic("Literal table index too large. Cannot be handled by TclEmitPush");
	    }
	    return objIndex;
	}
    }

    /*
     * The literal is new to this CompileEnv. If it is a command name, avoid
     * sharing it across namespaces, and try not to share it with non-cmd
471
472
473
474
475
476
477




478
479
480
481
482
483
484
    if (globalPtr != NULL && (globalPtr->refCount + 1 < 2)) {
	Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
		"TclRegisterLiteral", (length>60? 60 : (int)length), bytes,
		globalPtr->refCount);
    }
    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/




    return objIndex;
}

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *







>
>
>
>







474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
    if (globalPtr != NULL && (globalPtr->refCount + 1 < 2)) {
	Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
		"TclRegisterLiteral", (length>60? 60 : (int)length), bytes,
		globalPtr->refCount);
    }
    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
    if (objIndex > INT_MAX) {
	Tcl_Panic(
	    "Literal table index too large. Cannot be handled by TclEmitPush");
    }
    return objIndex;
}

#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626




627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
 * Side effects:
 *	Expands the literal array if necessary. Increments the refcount on the
 *	literal object.
 *
 *----------------------------------------------------------------------
 */

size_t
TclAddLiteralObj(
    CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
				 * the object is to be inserted. */
    Tcl_Obj *objPtr,		/* The object to insert into the array. */
    LiteralEntry **litPtrPtr)	/* The location where the pointer to the new
				 * literal entry should be stored. May be
				 * NULL. */
{
    LiteralEntry *lPtr;
    size_t objIndex;

    if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
	ExpandLocalLiteralArray(envPtr);
    }
    objIndex = envPtr->literalArrayNext;
    envPtr->literalArrayNext++;





    lPtr = &envPtr->literalArrayPtr[objIndex];
    lPtr->objPtr = objPtr;
    Tcl_IncrRefCount(objPtr);
    lPtr->refCount = TCL_INDEX_NONE;	/* i.e., unused */
    lPtr->nextPtr = NULL;

    if (litPtrPtr) {
	*litPtrPtr = lPtr;
    }

    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * AddLocalLiteralEntry --







|
















>
>
>
>










|







610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
 * Side effects:
 *	Expands the literal array if necessary. Increments the refcount on the
 *	literal object.
 *
 *----------------------------------------------------------------------
 */

int
TclAddLiteralObj(
    CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
				 * the object is to be inserted. */
    Tcl_Obj *objPtr,		/* The object to insert into the array. */
    LiteralEntry **litPtrPtr)	/* The location where the pointer to the new
				 * literal entry should be stored. May be
				 * NULL. */
{
    LiteralEntry *lPtr;
    size_t objIndex;

    if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
	ExpandLocalLiteralArray(envPtr);
    }
    objIndex = envPtr->literalArrayNext;
    envPtr->literalArrayNext++;
    if (objIndex > INT_MAX) {
	Tcl_Panic(
	    "Literal table index too large. Cannot be handled by TclEmitPush");
    }

    lPtr = &envPtr->literalArrayPtr[objIndex];
    lPtr->objPtr = objPtr;
    Tcl_IncrRefCount(objPtr);
    lPtr->refCount = TCL_INDEX_NONE;	/* i.e., unused */
    lPtr->nextPtr = NULL;

    if (litPtrPtr) {
	*litPtrPtr = lPtr;
    }
    
    return objIndex;
}

/*
 *----------------------------------------------------------------------
 *
 * AddLocalLiteralEntry --

Changes to generic/tclLoad.c.

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
	prefix = TclGetString(objv[2]);
	if (prefix[0] == '\0') {
	    prefix = NULL;
	}
    }
    if ((fullFileName[0] == 0) && (prefix == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must specify either file name or prefix", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
		NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*







|







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
	prefix = TclGetString(objv[2]);
	if (prefix[0] == '\0') {
	    prefix = NULL;
	}
    }
    if ((fullFileName[0] == 0) && (prefix == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must specify either file name or prefix", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
		NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

    defaultPtr = NULL;
    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
	if (prefix == NULL) {
	    namesMatch = 0;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, TCL_INDEX_NONE);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, TCL_INDEX_NONE);
	    if (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0) {
		namesMatch = 1;
	    } else {
		namesMatch = 0;
	    }
	}







|

|







228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

    defaultPtr = NULL;
    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
	if (prefix == NULL) {
	    namesMatch = 0;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, -1);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
	    if (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0) {
		namesMatch = 1;
	    } else {
		namesMatch = 0;
	    }
	}
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
	}

	/*
	 * Figure out the prefix if it wasn't provided explicitly.
	 */

	if (prefix != NULL) {
	    Tcl_DStringAppend(&pfx, prefix, TCL_INDEX_NONE);
	} else {
	    Tcl_Obj *splitPtr, *pkgGuessPtr;
	    size_t pElements;
	    const char *pkgGuess;

	    /*
	     * Threading note - this call used to be protected by a mutex.
	     */

	    /*







|


|







303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
	}

	/*
	 * Figure out the prefix if it wasn't provided explicitly.
	 */

	if (prefix != NULL) {
	    Tcl_DStringAppend(&pfx, prefix, -1);
	} else {
	    Tcl_Obj *splitPtr, *pkgGuessPtr;
	    Tcl_Size pElements;
	    const char *pkgGuess;

	    /*
	     * Threading note - this call used to be protected by a mutex.
	     */

	    /*
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
	Interp *iPtr = (Interp *) target;
	if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) {
	    /*
	     * A call to Tcl_InitStubs() determined the caller extension and
	     * this interp are incompatible in their stubs mechanisms, and
	     * recorded the error in the oldest legacy place we have to do so.
	     */
	    Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, TCL_INDEX_NONE));
	    iPtr->legacyResult = NULL;
	    iPtr->legacyFreeProc = (void (*) (void))-1;
	}
	Tcl_TransferResult(target, code, interp);
	goto done;
    }








|







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
	Interp *iPtr = (Interp *) target;
	if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) {
	    /*
	     * A call to Tcl_InitStubs() determined the caller extension and
	     * this interp are incompatible in their stubs mechanisms, and
	     * recorded the error in the oldest legacy place we have to do so.
	     */
	    Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1));
	    iPtr->legacyResult = NULL;
	    iPtr->legacyFreeProc = (void (*) (void))-1;
	}
	Tcl_TransferResult(target, code, interp);
	goto done;
    }

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
	prefix = TclGetString(objv[i+1]);
	if (prefix[0] == '\0') {
	    prefix = NULL;
	}
    }
    if ((fullFileName[0] == 0) && (prefix == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must specify either file name or prefix", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
		NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*







|







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
	prefix = TclGetString(objv[i+1]);
	if (prefix[0] == '\0') {
	    prefix = NULL;
	}
    }
    if ((fullFileName[0] == 0) && (prefix == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must specify either file name or prefix", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
		NULL);
	code = TCL_ERROR;
	goto done;
    }

    /*
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
	int namesMatch, filesMatch;

	if (prefix == NULL) {
	    namesMatch = 0;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, TCL_INDEX_NONE);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, TCL_INDEX_NONE);
	    if (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0) {
		namesMatch = 1;
	    } else {
		namesMatch = 0;
	    }
	}







|

|







661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
	int namesMatch, filesMatch;

	if (prefix == NULL) {
	    namesMatch = 0;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, -1);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
	    if (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0) {
		namesMatch = 1;
	    } else {
		namesMatch = 0;
	    }
	}
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
    Tcl_Obj *resultObj, *pkgDesc[2];

    if (targetName == NULL) {
	TclNewObj(resultObj);
	Tcl_MutexLock(&libraryMutex);
	for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
		libraryPtr = libraryPtr->nextPtr) {
	    pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, TCL_INDEX_NONE);
	    pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, TCL_INDEX_NONE);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewListObj(2, pkgDesc));
	}
	Tcl_MutexUnlock(&libraryMutex);
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;
    }







|
|







1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
    Tcl_Obj *resultObj, *pkgDesc[2];

    if (targetName == NULL) {
	TclNewObj(resultObj);
	Tcl_MutexLock(&libraryMutex);
	for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
		libraryPtr = libraryPtr->nextPtr) {
	    pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1);
	    pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1);
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewListObj(2, pkgDesc));
	}
	Tcl_MutexUnlock(&libraryMutex);
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;
    }
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
    if (prefix) {
	resultObj = NULL;

	for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    libraryPtr = ipPtr->libraryPtr;

	    if (!strcmp(prefix, libraryPtr->prefix)) {
		resultObj = Tcl_NewStringObj(libraryPtr->fileName, TCL_INDEX_NONE);
		break;
	    }
	}

	if (resultObj) {
	    Tcl_SetObjResult(interp, resultObj);
	}
	return TCL_OK;
    }

    /*
     * Return information about only the libraries that are loaded in a given
     * interpreter.
     */

    TclNewObj(resultObj);
    for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	libraryPtr = ipPtr->libraryPtr;
	pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, TCL_INDEX_NONE);
	pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, TCL_INDEX_NONE);
	Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*







|


















|
|







1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
    if (prefix) {
	resultObj = NULL;

	for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    libraryPtr = ipPtr->libraryPtr;

	    if (!strcmp(prefix, libraryPtr->prefix)) {
		resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1);
		break;
	    }
	}

	if (resultObj) {
	    Tcl_SetObjResult(interp, resultObj);
	}
	return TCL_OK;
    }

    /*
     * Return information about only the libraries that are loaded in a given
     * interpreter.
     */

    TclNewObj(resultObj);
    for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	libraryPtr = ipPtr->libraryPtr;
	pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1);
	pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1);
	Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*

Changes to generic/tclLoadNone.c.

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    TCL_UNUSED(int),
    TCL_UNUSED(Tcl_LoadHandle *),
    TCL_UNUSED(Tcl_FSUnloadFileProc **),
    TCL_UNUSED(int))
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
		"is not available on this system", TCL_INDEX_NONE));
    }
    return TCL_ERROR;
}

#endif /* TCL_LOAD_FROM_MEMORY */

/*







|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    TCL_UNUSED(int),
    TCL_UNUSED(Tcl_LoadHandle *),
    TCL_UNUSED(Tcl_FSUnloadFileProc **),
    TCL_UNUSED(int))
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
		"is not available on this system", -1));
    }
    return TCL_ERROR;
}

#endif /* TCL_LOAD_FROM_MEMORY */

/*

Changes to generic/tclMain.c.

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
 *	interpreted.
 *
 *----------------------------------------------------------------------
 */

TCL_NORETURN void
Tcl_MainEx(
    size_t argc,			/* Number of arguments. */
    TCHAR **argv,		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc,
				/* Application-specific initialization
				 * function to call after most initialization
				 * but before starting to execute commands. */
    Tcl_Interp *interp)
{
    size_t i=0;			/* argv[i] index */
    Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
    const char *encodingName = NULL;
    int code, exitCode = 0;
    Tcl_MainLoopProc *mainLoopProc;
    Tcl_Channel chan;
    InteractiveState is;

    TclpSetInitialEncodings();
    if (argc + 1 > 1) {
	--argc;			/* consume argv[0] */
	++i;
    }
    TclpFindExecutable ((const char *)argv [0]);	/* nb: this could be NULL
							 * w/ (eg) an empty argv
							 * supplied to execve() */








|







|








|







276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
 *	interpreted.
 *
 *----------------------------------------------------------------------
 */

TCL_NORETURN void
Tcl_MainEx(
    Tcl_Size argc,			/* Number of arguments. */
    TCHAR **argv,		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc,
				/* Application-specific initialization
				 * function to call after most initialization
				 * but before starting to execute commands. */
    Tcl_Interp *interp)
{
    Tcl_Size i=0;		/* argv[i] index */
    Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
    const char *encodingName = NULL;
    int code, exitCode = 0;
    Tcl_MainLoopProc *mainLoopProc;
    Tcl_Channel chan;
    InteractiveState is;

    TclpSetInitialEncodings();
    if (argc > 0) {
	--argc;			/* consume argv[0] */
	++i;
    }
    TclpFindExecutable ((const char *)argv [0]);	/* nb: this could be NULL
							 * w/ (eg) an empty argv
							 * supplied to execve() */

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
	 * Check whether first 3 args (argv[1] - argv[3]) look like
	 *  -encoding ENCODING FILENAME
	 * or like
	 *  FILENAME
	 */

	/* mind argc is being adjusted as we proceed */
	if ((argc >= 3) && argv[1] && argv[2] && argv[3] && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
		&& ('-' != argv[3][0])) {
	    Tcl_Obj *value = NewNativeObj(argv[2]);
	    Tcl_SetStartupScript(NewNativeObj(argv[3]),
		    TclGetString(value));
	    Tcl_DecrRefCount(value);
	    argc -= 3;
	    i += 3;
	} else if ((argc >= 1) && argv[1] && ('-' != argv[1][0])) {
	    Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
	    argc--;
	    i++;
	}
    }

    path = Tcl_GetStartupScript(&encodingName);
    if (path != NULL) {
	appName = path;
    } else if (argv[0]) {
	appName = NewNativeObj(argv[0]);
    } else {
    	appName = Tcl_NewStringObj("tclsh", -1);
    }
    Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);

    Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY);

    argvPtr = Tcl_NewListObj(0, NULL);
    while (argc-- && argv[i]) {
	Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++]));
    }
    Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);

    /*
     * Set the "tcl_interactive" variable.
     */







|







|



















|







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
	 * Check whether first 3 args (argv[1] - argv[3]) look like
	 *  -encoding ENCODING FILENAME
	 * or like
	 *  FILENAME
	 */

	/* mind argc is being adjusted as we proceed */
	if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
		&& ('-' != argv[3][0])) {
	    Tcl_Obj *value = NewNativeObj(argv[2]);
	    Tcl_SetStartupScript(NewNativeObj(argv[3]),
		    TclGetString(value));
	    Tcl_DecrRefCount(value);
	    argc -= 3;
	    i += 3;
	} else if ((argc >= 1) && ('-' != argv[1][0])) {
	    Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
	    argc--;
	    i++;
	}
    }

    path = Tcl_GetStartupScript(&encodingName);
    if (path != NULL) {
	appName = path;
    } else if (argv[0]) {
	appName = NewNativeObj(argv[0]);
    } else {
    	appName = Tcl_NewStringObj("tclsh", -1);
    }
    Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);

    Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY);

    argvPtr = Tcl_NewListObj(0, NULL);
    while (argc--) {
	Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++]));
    }
    Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);

    /*
     * Set the "tcl_interactive" variable.
     */
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
     */

    Tcl_LinkVar(interp, "tcl_interactive", &is.tty, TCL_LINK_BOOLEAN);
    is.input = Tcl_GetStdChannel(TCL_STDIN);
    while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
	mainLoopProc = TclGetMainLoop();
	if (mainLoopProc == NULL) {
	    size_t length;

	    if (is.tty) {
		Prompt(interp, &is);
		if (Tcl_InterpDeleted(interp)) {
		    break;
		}
		if (Tcl_LimitExceeded(interp)) {
		    break;
		}
		is.input = Tcl_GetStdChannel(TCL_STDIN);
		if (is.input == NULL) {
		    break;
		}
	    }
	    if (Tcl_IsShared(is.commandPtr)) {
		Tcl_DecrRefCount(is.commandPtr);
		is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
		Tcl_IncrRefCount(is.commandPtr);
	    }
	    length = Tcl_GetsObj(is.input, is.commandPtr);
	    if (length == TCL_INDEX_NONE) {
		if (Tcl_InputBlocked(is.input)) {
		    /*
		     * This can only happen if stdin has been set to
		     * non-blocking. In that case cycle back and try again.
		     * This sets up a tight polling loop (since we have no
		     * event loop running). If this causes bad CPU hogging, we
		     * might try toggling the blocking on stdin instead.







|




















|







450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
     */

    Tcl_LinkVar(interp, "tcl_interactive", &is.tty, TCL_LINK_BOOLEAN);
    is.input = Tcl_GetStdChannel(TCL_STDIN);
    while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
	mainLoopProc = TclGetMainLoop();
	if (mainLoopProc == NULL) {
	    Tcl_Size length;

	    if (is.tty) {
		Prompt(interp, &is);
		if (Tcl_InterpDeleted(interp)) {
		    break;
		}
		if (Tcl_LimitExceeded(interp)) {
		    break;
		}
		is.input = Tcl_GetStdChannel(TCL_STDIN);
		if (is.input == NULL) {
		    break;
		}
	    }
	    if (Tcl_IsShared(is.commandPtr)) {
		Tcl_DecrRefCount(is.commandPtr);
		is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
		Tcl_IncrRefCount(is.commandPtr);
	    }
	    length = Tcl_GetsObj(is.input, is.commandPtr);
	    if (length < 0) {
		if (Tcl_InputBlocked(is.input)) {
		    /*
		     * This can only happen if stdin has been set to
		     * non-blocking. In that case cycle back and try again.
		     * This sets up a tight polling loop (since we have no
		     * event loop running). If this causes bad CPU hogging, we
		     * might try toggling the blocking on stdin instead.
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762

static void
StdinProc(
    void *clientData,	/* The state of interactive cmd line */
    TCL_UNUSED(int) /*mask*/)
{
    int code;
    size_t length;
    InteractiveState *isPtr = (InteractiveState *)clientData;
    Tcl_Channel chan = isPtr->input;
    Tcl_Obj *commandPtr = isPtr->commandPtr;
    Tcl_Interp *interp = isPtr->interp;

    if (Tcl_IsShared(commandPtr)) {
	Tcl_DecrRefCount(commandPtr);
	commandPtr = Tcl_DuplicateObj(commandPtr);
	Tcl_IncrRefCount(commandPtr);
    }
    length = Tcl_GetsObj(chan, commandPtr);
    if (length == TCL_INDEX_NONE) {
	if (Tcl_InputBlocked(chan)) {
	    return;
	}
	if (isPtr->tty) {
	    /*
	     * Would be better to find a way to exit the mainLoop? Or perhaps
	     * evaluate [exit]? Leaving as is for now due to compatibility







|











|







736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762

static void
StdinProc(
    void *clientData,	/* The state of interactive cmd line */
    TCL_UNUSED(int) /*mask*/)
{
    int code;
    Tcl_Size length;
    InteractiveState *isPtr = (InteractiveState *)clientData;
    Tcl_Channel chan = isPtr->input;
    Tcl_Obj *commandPtr = isPtr->commandPtr;
    Tcl_Interp *interp = isPtr->interp;

    if (Tcl_IsShared(commandPtr)) {
	Tcl_DecrRefCount(commandPtr);
	commandPtr = Tcl_DuplicateObj(commandPtr);
	Tcl_IncrRefCount(commandPtr);
    }
    length = Tcl_GetsObj(chan, commandPtr);
    if (length < 0) {
	if (Tcl_InputBlocked(chan)) {
	    return;
	}
	if (isPtr->tty) {
	    /*
	     * Would be better to find a way to exit the mainLoop? Or perhaps
	     * evaluate [exit]? Leaving as is for now due to compatibility

Changes to generic/tclNamesp.c.

406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
    /*
     * Decrement the namespace's count of active call frames. If the namespace
     * is "dying" and there are no more active call frames, call
     * Tcl_DeleteNamespace to destroy it.
     */

    nsPtr = framePtr->nsPtr;
    if ((--nsPtr->activationCount <= (unsigned)(nsPtr == iPtr->globalNsPtr))
	    && (nsPtr->flags & NS_DYING)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;

    if (framePtr->tailcallPtr) {
	/* Reusing the existing reference count from framePtr->tailcallPtr, so







|







406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
    /*
     * Decrement the namespace's count of active call frames. If the namespace
     * is "dying" and there are no more active call frames, call
     * Tcl_DeleteNamespace to destroy it.
     */

    nsPtr = framePtr->nsPtr;
    if ((--nsPtr->activationCount <= (nsPtr == iPtr->globalNsPtr))
	    && (nsPtr->flags & NS_DYING)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;

    if (framePtr->tailcallPtr) {
	/* Reusing the existing reference count from framePtr->tailcallPtr, so
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
     * Ensure that there are no trailing colons as that causes chaos when a
     * deleteProc is specified. [Bug d614d63989]
     */

    if (deleteProc != NULL) {
	nameStr = name + strlen(name) - 2;
	if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') {
	    Tcl_DStringAppend(&tmpBuffer, name, TCL_INDEX_NONE);
	    while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0
		    && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') {
		Tcl_DStringSetLength(&tmpBuffer, nameLen-1);
	    }
	    name = Tcl_DStringValue(&tmpBuffer);
	}
    }

    /*
     * If we've ended up with an empty string now, we're attempting to create
     * the global namespace despite the global namespace existing. That's
     * naughty!
     */

    if (*name == '\0') {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
                " \"\": only global namespace can have empty name", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
		"CREATEGLOBAL", NULL);
	Tcl_DStringFree(&tmpBuffer);
	return NULL;
    }

    /*







|
















|







694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
     * Ensure that there are no trailing colons as that causes chaos when a
     * deleteProc is specified. [Bug d614d63989]
     */

    if (deleteProc != NULL) {
	nameStr = name + strlen(name) - 2;
	if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') {
	    Tcl_DStringAppend(&tmpBuffer, name, -1);
	    while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0
		    && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') {
		Tcl_DStringSetLength(&tmpBuffer, nameLen-1);
	    }
	    name = Tcl_DStringValue(&tmpBuffer);
	}
    }

    /*
     * If we've ended up with an empty string now, we're attempting to create
     * the global namespace despite the global namespace existing. That's
     * naughty!
     */

    if (*name == '\0') {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
                " \"\": only global namespace can have empty name", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
		"CREATEGLOBAL", NULL);
	Tcl_DStringFree(&tmpBuffer);
	return NULL;
    }

    /*
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
    buffPtr = &buffer2;
    for (ancestorPtr = nsPtr; ancestorPtr != NULL;
	    ancestorPtr = ancestorPtr->parentPtr) {
	if (ancestorPtr != globalNsPtr) {
	    Tcl_DString *tempPtr = namePtr;

	    TclDStringAppendLiteral(buffPtr, "::");
	    Tcl_DStringAppend(buffPtr, ancestorPtr->name, TCL_INDEX_NONE);
	    TclDStringAppendDString(buffPtr, namePtr);

	    /*
	     * Clear the unwanted buffer or we end up appending to previous
	     * results, making the namespace fullNames of nested namespaces
	     * very wrong (and strange).
	     */







|







829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
    buffPtr = &buffer2;
    for (ancestorPtr = nsPtr; ancestorPtr != NULL;
	    ancestorPtr = ancestorPtr->parentPtr) {
	if (ancestorPtr != globalNsPtr) {
	    Tcl_DString *tempPtr = namePtr;

	    TclDStringAppendLiteral(buffPtr, "::");
	    Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
	    TclDStringAppendDString(buffPtr, namePtr);

	    /*
	     * Clear the unwanted buffer or we end up appending to previous
	     * results, making the namespace fullNames of nested namespaces
	     * very wrong (and strange).
	     */
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
	 * nonzero, the namespace's commands and variables are deleted but the
	 * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
	 * flags to allow the namespace resolution code to recognize that the
	 * namespace is "deleted".  The structure's storage is freed by
	 * FreeNsNameInternalRep when its refCount reaches 0.
     */

    if (nsPtr->activationCount > (unsigned)(nsPtr == globalNsPtr)) {
	nsPtr->flags |= NS_DYING;
	if (nsPtr->parentPtr != NULL) {
	    entryPtr = Tcl_FindHashEntry(
		    TclGetNamespaceChildTable((Tcl_Namespace *)
			    nsPtr->parentPtr), nsPtr->name);
	    if (entryPtr != NULL) {
		Tcl_DeleteHashEntry(entryPtr);







|







1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
	 * nonzero, the namespace's commands and variables are deleted but the
	 * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
	 * flags to allow the namespace resolution code to recognize that the
	 * namespace is "deleted".  The structure's storage is freed by
	 * FreeNsNameInternalRep when its refCount reaches 0.
     */

    if (nsPtr->activationCount > (nsPtr == globalNsPtr)) {
	nsPtr->flags |= NS_DYING;
	if (nsPtr->parentPtr != NULL) {
	    entryPtr = Tcl_FindHashEntry(
		    TclGetNamespaceChildTable((Tcl_Namespace *)
			    nsPtr->parentPtr), nsPtr->name);
	    if (entryPtr != NULL) {
		Tcl_DeleteHashEntry(entryPtr);
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
TclTeardownNamespace(
    Namespace *nsPtr)	/* Points to the namespace to be dismantled
				 * and unlinked from its parent. */
{
    Interp *iPtr = (Interp *) nsPtr->interp;
    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    size_t i;

    /*
     * Start by destroying the namespace's variable table, since variables
     * might trigger traces. Variable table should be cleared but not freed!
     * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards.
     */

    TclDeleteNamespaceVars(nsPtr);
    TclInitVarHashTable(&nsPtr->varTable, nsPtr);

    /*
     * Delete all commands in this namespace. Be careful when traversing the
     * hash table: when each command is deleted, it removes itself from the
     * command table. Because of traces (and the desire to avoid the quadratic
     * problems of just using Tcl_FirstHashEntry over and over, [Bug
     * f97d4ee020]) we copy to a temporary array and then delete all those
     * commands.
     */

    while (nsPtr->cmdTable.numEntries > 0) {
	size_t length = nsPtr->cmdTable.numEntries;
	Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr,
		sizeof(Command *) * length);

	i = 0;
	for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
		entryPtr != NULL;
		entryPtr = Tcl_NextHashEntry(&search)) {







|




















|







1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
TclTeardownNamespace(
    Namespace *nsPtr)	/* Points to the namespace to be dismantled
				 * and unlinked from its parent. */
{
    Interp *iPtr = (Interp *) nsPtr->interp;
    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_Size i;

    /*
     * Start by destroying the namespace's variable table, since variables
     * might trigger traces. Variable table should be cleared but not freed!
     * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards.
     */

    TclDeleteNamespaceVars(nsPtr);
    TclInitVarHashTable(&nsPtr->varTable, nsPtr);

    /*
     * Delete all commands in this namespace. Be careful when traversing the
     * hash table: when each command is deleted, it removes itself from the
     * command table. Because of traces (and the desire to avoid the quadratic
     * problems of just using Tcl_FirstHashEntry over and over, [Bug
     * f97d4ee020]) we copy to a temporary array and then delete all those
     * commands.
     */

    while (nsPtr->cmdTable.numEntries > 0) {
	Tcl_Size length = nsPtr->cmdTable.numEntries;
	Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr,
		sizeof(Command *) * length);

	i = 0;
	for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
		entryPtr != NULL;
		entryPtr = Tcl_NextHashEntry(&search)) {
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
				 * list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
    Namespace *nsPtr, *exportNsPtr, *dummyPtr;
    Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    const char *simplePattern;
    char *patternCpy;
    size_t neededElems, len, i;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) currNsPtr;







|







1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
				 * list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
    Namespace *nsPtr, *exportNsPtr, *dummyPtr;
    Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    const char *simplePattern;
    char *patternCpy;
    Tcl_Size neededElems, len, i;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) currNsPtr;
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
    Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
				 * pattern list is appended onto objPtr. NULL
				 * for the current namespace. */
    Tcl_Obj *objPtr)		/* Points to the Tcl object onto which the
				 * export pattern list is appended. */
{
    Namespace *nsPtr;
    size_t i;
    int result;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * Append the export pattern list onto objPtr.
     */

    for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
	result = Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj(nsPtr->exportArrayPtr[i], TCL_INDEX_NONE));
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}








|


















|







1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
    Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
				 * pattern list is appended onto objPtr. NULL
				 * for the current namespace. */
    Tcl_Obj *objPtr)		/* Points to the Tcl object onto which the
				 * export pattern list is appended. */
{
    Namespace *nsPtr;
    Tcl_Size i;
    int result;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * Append the export pattern list onto objPtr.
     */

    for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
	result = Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}

1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
     */

    if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
	Tcl_Obj *objv[2];
	int result;

	TclNewLiteralStringObj(objv[0], "auto_import");
	objv[1] = Tcl_NewStringObj(pattern, TCL_INDEX_NONE);

	Tcl_IncrRefCount(objv[0]);
	Tcl_IncrRefCount(objv[1]);
	result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(objv[0]);
	Tcl_DecrRefCount(objv[1]);








|







1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
     */

    if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
	Tcl_Obj *objv[2];
	int result;

	TclNewLiteralStringObj(objv[0], "auto_import");
	objv[1] = Tcl_NewStringObj(pattern, -1);

	Tcl_IncrRefCount(objv[0]);
	Tcl_IncrRefCount(objv[1]);
	result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(objv[0]);
	Tcl_DecrRefCount(objv[1]);

1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
    Namespace *nsPtr,
    Tcl_HashEntry *hPtr,
    const char *cmdName,
    const char *pattern,
    Namespace *importNsPtr,
    int allowOverwrite)
{
    size_t i = 0, exported = 0;
    Tcl_HashEntry *found;

    /*
     * The command cmdName in the source namespace matches the pattern. Check
     * whether it was exported. If it wasn't, we ignore it.
     */








|







1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
    Namespace *nsPtr,
    Tcl_HashEntry *hPtr,
    const char *cmdName,
    const char *pattern,
    Namespace *importNsPtr,
    int allowOverwrite)
{
    Tcl_Size i = 0, exported = 0;
    Tcl_HashEntry *found;

    /*
     * The command cmdName in the source namespace matches the pattern. Check
     * whether it was exported. If it wasn't, we ignore it.
     */

1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
	Tcl_DString ds;
	Tcl_Command importedCmd;
	ImportedCmdData *dataPtr;
	Command *cmdPtr;
	ImportRef *refPtr;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, nsPtr->fullName, TCL_INDEX_NONE);
	if (nsPtr != ((Interp *) interp)->globalNsPtr) {
	    TclDStringAppendLiteral(&ds, "::");
	}
	Tcl_DStringAppend(&ds, cmdName, TCL_INDEX_NONE);

	/*
	 * Check whether creating the new imported command in the current
	 * namespace would create a cycle of imported command references.
	 */

	cmdPtr = (Command *)Tcl_GetHashValue(hPtr);







|



|







1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
	Tcl_DString ds;
	Tcl_Command importedCmd;
	ImportedCmdData *dataPtr;
	Command *cmdPtr;
	ImportRef *refPtr;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	if (nsPtr != ((Interp *) interp)->globalNsPtr) {
	    TclDStringAppendLiteral(&ds, "::");
	}
	Tcl_DStringAppend(&ds, cmdName, -1);

	/*
	 * Check whether creating the new imported command in the current
	 * namespace would create a cycle of imported command references.
	 */

	cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
    /*
     * Find the namespace(s) that contain the command.
     */

    cmdPtr = NULL;
    if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
	    && !(flags & TCL_NAMESPACE_ONLY)) {
	size_t i;
	Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;

	(void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
		TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		&simpleName);
	if ((realNsPtr != NULL) && (simpleName != NULL)) {
	    if ((cxtNsPtr == realNsPtr)







|







2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
    /*
     * Find the namespace(s) that contain the command.
     */

    cmdPtr = NULL;
    if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
	    && !(flags & TCL_NAMESPACE_ONLY)) {
	Tcl_Size i;
	Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;

	(void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
		TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		&simpleName);
	if ((realNsPtr != NULL) && (simpleName != NULL)) {
	    if ((cxtNsPtr == realNsPtr)
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
    Tcl_DStringInit(&buffer);
    if (objc == 3) {
	const char *name = TclGetString(objv[2]);

	if ((*name == ':') && (*(name+1) == ':')) {
	    pattern = name;
	} else {
	    Tcl_DStringAppend(&buffer, nsPtr->fullName, TCL_INDEX_NONE);
	    if (nsPtr != globalNsPtr) {
		TclDStringAppendLiteral(&buffer, "::");
	    }
	    Tcl_DStringAppend(&buffer, name, TCL_INDEX_NONE);
	    pattern = Tcl_DStringValue(&buffer);
	}
    }

    /*
     * Create a list containing the full names of all child namespaces whose
     * names match the specified pattern, if any.







|



|







3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
    Tcl_DStringInit(&buffer);
    if (objc == 3) {
	const char *name = TclGetString(objv[2]);

	if ((*name == ':') && (*(name+1) == ':')) {
	    pattern = name;
	} else {
	    Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
	    if (nsPtr != globalNsPtr) {
		TclDStringAppendLiteral(&buffer, "::");
	    }
	    Tcl_DStringAppend(&buffer, name, -1);
	    pattern = Tcl_DStringValue(&buffer);
	}
    }

    /*
     * Create a list containing the full names of all child namespaces whose
     * names match the specified pattern, if any.
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
	    Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL
#else
	    nsPtr->childTablePtr != NULL &&
	    Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL
#endif
	) {
	    Tcl_ListObjAppendElement(interp, listPtr,
		    Tcl_NewStringObj(pattern, TCL_INDEX_NONE));
	}
	goto searchDone;
    }
#ifndef BREAK_NAMESPACE_COMPAT
    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
#else
    if (nsPtr->childTablePtr == NULL) {
	goto searchDone;
    }
    entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
    while (entryPtr != NULL) {
	childNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
	if ((pattern == NULL)
		|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
	    elemPtr = Tcl_NewStringObj(childNsPtr->fullName, TCL_INDEX_NONE);
	    Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
	}
	entryPtr = Tcl_NextHashEntry(&search);
    }

  searchDone:
    Tcl_SetObjResult(interp, listPtr);







|















|







3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
	    Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL
#else
	    nsPtr->childTablePtr != NULL &&
	    Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL
#endif
	) {
	    Tcl_ListObjAppendElement(interp, listPtr,
		    Tcl_NewStringObj(pattern, -1));
	}
	goto searchDone;
    }
#ifndef BREAK_NAMESPACE_COMPAT
    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
#else
    if (nsPtr->childTablePtr == NULL) {
	goto searchDone;
    }
    entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
    while (entryPtr != NULL) {
	childNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
	if ((pattern == NULL)
		|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
	    elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
	    Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
	}
	entryPtr = Tcl_NextHashEntry(&search);
    }

  searchDone:
    Tcl_SetObjResult(interp, listPtr);
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
    TclNewLiteralStringObj(objPtr, "inscope");
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
	TclNewLiteralStringObj(objPtr, "::");
    } else {
	objPtr = Tcl_NewStringObj(currNsPtr->fullName, TCL_INDEX_NONE);
    }
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    Tcl_ListObjAppendElement(interp, listPtr, objv[1]);

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;







|







3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
    TclNewLiteralStringObj(objPtr, "inscope");
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
	TclNewLiteralStringObj(objPtr, "::");
    } else {
	objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
    }
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    Tcl_ListObjAppendElement(interp, listPtr, objv[1]);

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
     *    namespace [namespace current]::bar { ... }
     */

    currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, TCL_INDEX_NONE));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
     *    namespace [namespace current]::bar { ... }
     */

    currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009

    /*
     * Report the parent of the specified namespace.
     */

    if (nsPtr->parentPtr != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		nsPtr->parentPtr->fullName, TCL_INDEX_NONE));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009

    /*
     * Report the parent of the specified namespace.
     */

    if (nsPtr->parentPtr != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		nsPtr->parentPtr->fullName, -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
NamespacePathCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    size_t nsObjc, i;
    int result = TCL_ERROR;
    Tcl_Obj **nsObjv;
    Tcl_Namespace **namespaceList = NULL;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
	return TCL_ERROR;
    }

    /*
     * If no path is given, return the current path.
     */

    if (objc == 1) {
	Tcl_Obj *resultObj;

	TclNewObj(resultObj);
	for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	    if (nsPtr->commandPathArray[i].nsPtr != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
			nsPtr->commandPathArray[i].nsPtr->fullName, TCL_INDEX_NONE));
	    }
	}
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;
    }

    /*







|




















|







4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
NamespacePathCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    Tcl_Size nsObjc, i;
    int result = TCL_ERROR;
    Tcl_Obj **nsObjv;
    Tcl_Namespace **namespaceList = NULL;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
	return TCL_ERROR;
    }

    /*
     * If no path is given, return the current path.
     */

    if (objc == 1) {
	Tcl_Obj *resultObj;

	TclNewObj(resultObj);
	for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	    if (nsPtr->commandPathArray[i].nsPtr != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
			nsPtr->commandPathArray[i].nsPtr->fullName, -1));
	    }
	}
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;
    }

    /*
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
 *
 *----------------------------------------------------------------------
 */

void
TclSetNsPath(
    Namespace *nsPtr,		/* Namespace whose path is to be set. */
    size_t pathLength,		/* Length of pathAry. */
    Tcl_Namespace *pathAry[])	/* Array of namespaces that are the path. */
{
    if (pathLength != 0) {
	NamespacePathEntry *tmpPathArray =
		(NamespacePathEntry *)Tcl_Alloc(sizeof(NamespacePathEntry) * pathLength);
	size_t i;

	for (i=0 ; i<pathLength ; i++) {
	    tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
	    tmpPathArray[i].creatorNsPtr = nsPtr;
	    tmpPathArray[i].prevPtr = NULL;
	    tmpPathArray[i].nextPtr =
		    tmpPathArray[i].nsPtr->commandPathSourceList;







|





|







4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
 *
 *----------------------------------------------------------------------
 */

void
TclSetNsPath(
    Namespace *nsPtr,		/* Namespace whose path is to be set. */
    Tcl_Size pathLength,	/* Length of pathAry. */
    Tcl_Namespace *pathAry[])	/* Array of namespaces that are the path. */
{
    if (pathLength != 0) {
	NamespacePathEntry *tmpPathArray =
		(NamespacePathEntry *)Tcl_Alloc(sizeof(NamespacePathEntry) * pathLength);
	Tcl_Size i;

	for (i=0 ; i<pathLength ; i++) {
	    tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
	    tmpPathArray[i].creatorNsPtr = nsPtr;
	    tmpPathArray[i].prevPtr = NULL;
	    tmpPathArray[i].nextPtr =
		    tmpPathArray[i].nsPtr->commandPathSourceList;
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
 *----------------------------------------------------------------------
 */

static void
UnlinkNsPath(
    Namespace *nsPtr)
{
    size_t i;
    for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];

	if (nsPathPtr->prevPtr != NULL) {
	    nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
	}
	if (nsPathPtr->nextPtr != NULL) {







|







4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
 *----------------------------------------------------------------------
 */

static void
UnlinkNsPath(
    Namespace *nsPtr)
{
    Tcl_Size i;
    for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];

	if (nsPathPtr->prevPtr != NULL) {
	    nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
	}
	if (nsPathPtr->nextPtr != NULL) {
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
int
Tcl_SetNamespaceUnknownHandler(
    Tcl_Interp *interp,		/* Interpreter in which the namespace
				 * exists. */
    Tcl_Namespace *nsPtr,	/* Namespace which is being updated. */
    Tcl_Obj *handlerPtr)	/* The new handler, or NULL to reset. */
{
    size_t lstlen = 0;
    Namespace *currNsPtr = (Namespace *) nsPtr;

    /*
     * Ensure that we check for errors *first* before we change anything.
     */

    if (handlerPtr != NULL) {







|







4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
int
Tcl_SetNamespaceUnknownHandler(
    Tcl_Interp *interp,		/* Interpreter in which the namespace
				 * exists. */
    Tcl_Namespace *nsPtr,	/* Namespace which is being updated. */
    Tcl_Obj *handlerPtr)	/* The new handler, or NULL to reset. */
{
    Tcl_Size lstlen = 0;
    Namespace *currNsPtr = (Namespace *) nsPtr;

    /*
     * Ensure that we check for errors *first* before we change anything.
     */

    if (handlerPtr != NULL) {
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
	if ((*p == ':') && (*(p-1) == ':')) {
	    p++;			/* Just after the last "::" */
	    break;
	}
    }

    if (p >= name) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(p, TCL_INDEX_NONE));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
	if ((*p == ':') && (*(p-1) == ':')) {
	    p++;			/* Just after the last "::" */
	    break;
	}
    }

    if (p >= name) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
void
TclLogCommandInfo(
    Tcl_Interp *interp,		/* Interpreter in which to log information. */
    const char *script,		/* First character in script containing
				 * command (must be <= command). */
    const char *command,	/* First character in command that generated
				 * the error. */
    size_t length,		/* Number of bytes in command (TCL_INDEX_NONE
				 * means use all bytes up to first null byte).
				*/
    const unsigned char *pc,    /* Current pc of bytecode execution context */
    Tcl_Obj **tosPtr)		/* Current stack of bytecode execution
				 * context */
{
    const char *p;
    Interp *iPtr = (Interp *) interp;







|
|







4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
void
TclLogCommandInfo(
    Tcl_Interp *interp,		/* Interpreter in which to log information. */
    const char *script,		/* First character in script containing
				 * command (must be <= command). */
    const char *command,	/* First character in command that generated
				 * the error. */
    Tcl_Size length,		/* Number of bytes in command (< 0 means use
				 * all bytes up to first null byte).
				*/
    const unsigned char *pc,    /* Current pc of bytecode execution context */
    Tcl_Obj **tosPtr)		/* Current stack of bytecode execution
				 * context */
{
    const char *p;
    Interp *iPtr = (Interp *) interp;
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
	iPtr->errorLine = 1;
	for (p = script; p != command; p++) {
	    if (*p == '\n') {
		iPtr->errorLine++;
	    }
	}

	if (length == TCL_INDEX_NONE) {
	    length = strlen(command);
	}
	overflow = (length > (size_t)limit);
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
		? "while executing" : "invoked from within"),
		(overflow ? limit : (int)length), command,
		(overflow ? "..." : "")));

	varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,







|


|







4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
	iPtr->errorLine = 1;
	for (p = script; p != command; p++) {
	    if (*p == '\n') {
		iPtr->errorLine++;
	    }
	}

	if (length < 0) {
	    length = strlen(command);
	}
	overflow = (length > limit);
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
		? "while executing" : "invoked from within"),
		(overflow ? limit : (int)length), command,
		(overflow ? "..." : "")));

	varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023

	newObj = Tcl_DuplicateObj(iPtr->errorStack);
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	size_t len;

	iPtr->resetErrorStack = 0;
	TclListObjLengthM(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */







|







5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023

	newObj = Tcl_DuplicateObj(iPtr->errorStack);
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	Tcl_Size len;

	iPtr->resetErrorStack = 0;
	TclListObjLengthM(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
 *----------------------------------------------------------------------
 */

void
TclErrorStackResetIf(
    Tcl_Interp *interp,
    const char *msg,
    size_t length)
{
    Interp *iPtr = (Interp *) interp;

    if (Tcl_IsShared(iPtr->errorStack)) {
	Tcl_Obj *newObj;

	newObj = Tcl_DuplicateObj(iPtr->errorStack);
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	size_t len;

	iPtr->resetErrorStack = 0;
	TclListObjLengthM(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */







|












|







5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
 *----------------------------------------------------------------------
 */

void
TclErrorStackResetIf(
    Tcl_Interp *interp,
    const char *msg,
    Tcl_Size length)
{
    Interp *iPtr = (Interp *) interp;

    if (Tcl_IsShared(iPtr->errorStack)) {
	Tcl_Obj *newObj;

	newObj = Tcl_DuplicateObj(iPtr->errorStack);
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	Tcl_Size len;

	iPtr->resetErrorStack = 0;
	TclListObjLengthM(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
void
Tcl_LogCommandInfo(
    Tcl_Interp *interp,		/* Interpreter in which to log information. */
    const char *script,		/* First character in script containing
				 * command (must be <= command). */
    const char *command,	/* First character in command that generated
				 * the error. */
    size_t length)		/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    TclLogCommandInfo(interp, script, command, length, NULL, NULL);
}


/*







|







5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
void
Tcl_LogCommandInfo(
    Tcl_Interp *interp,		/* Interpreter in which to log information. */
    const char *script,		/* First character in script containing
				 * command (must be <= command). */
    const char *command,	/* First character in command that generated
				 * the error. */
    Tcl_Size length)		/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    TclLogCommandInfo(interp, script, command, length, NULL, NULL);
}


/*

Changes to generic/tclOO.c.

348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i = 0 ; defineCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::define::");
	Tcl_DStringAppend(&buffer, defineCmds[i].name, TCL_INDEX_NONE);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }
    for (i = 0 ; objdefCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
	Tcl_DStringAppend(&buffer, objdefCmds[i].name, TCL_INDEX_NONE);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }

    Tcl_CallWhenDeleted(interp, KillFoundation, NULL);








|






|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i = 0 ; defineCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::define::");
	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }
    for (i = 0 ; objdefCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }

    Tcl_CallWhenDeleted(interp, KillFoundation, NULL);

956
957
958
959
960
961
962
963
964
965
966
967
968
969
970

void
TclOOReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    size_t i;
    Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
    Method *mPtr;
    Foundation *fPtr = oPtr->fPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVariable;

    /*







|







956
957
958
959
960
961
962
963
964
965
966
967
968
969
970

void
TclOOReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    Tcl_Size i;
    Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
    Method *mPtr;
    Foundation *fPtr = oPtr->fPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVariable;

    /*
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    size_t i;

    if (Destructing(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
	 * this guard could be removed.
	 */








|







1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    Tcl_Size i;

    if (Destructing(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
	 * this guard could be removed.
	 */

1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372

int
TclOORemoveFromInstances(
    Object *oPtr,		/* The instance to remove. */
    Class *clsPtr)		/* The class (possibly) containing the
				 * reference to the instance. */
{
    size_t i;
    int res = 0;
    Object *instPtr;

    FOREACH(instPtr, clsPtr->instances) {
	if (oPtr == instPtr) {
	    RemoveItem(Object, clsPtr->instances, i);
	    TclOODecrRefCount(oPtr);







|







1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372

int
TclOORemoveFromInstances(
    Object *oPtr,		/* The instance to remove. */
    Class *clsPtr)		/* The class (possibly) containing the
				 * reference to the instance. */
{
    Tcl_Size i;
    int res = 0;
    Object *instPtr;

    FOREACH(instPtr, clsPtr->instances) {
	if (oPtr == instPtr) {
	    RemoveItem(Object, clsPtr->instances, i);
	    TclOODecrRefCount(oPtr);
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435

int
TclOORemoveFromMixins(
    Class *mixinPtr,		/* The mixin to remove. */
    Object *oPtr)		/* The object (possibly) containing the
				 * reference to the mixin. */
{
    size_t i;
    int res = 0;
    Class *mixPtr;

    FOREACH(mixPtr, oPtr->mixins) {
	if (mixinPtr == mixPtr) {
	    RemoveItem(Class, oPtr->mixins, i);
	    TclOODecrRefCount(mixPtr->thisPtr);







|







1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435

int
TclOORemoveFromMixins(
    Class *mixinPtr,		/* The mixin to remove. */
    Object *oPtr)		/* The object (possibly) containing the
				 * reference to the mixin. */
{
    Tcl_Size i;
    int res = 0;
    Class *mixPtr;

    FOREACH(mixPtr, oPtr->mixins) {
	if (mixinPtr == mixPtr) {
	    RemoveItem(Class, oPtr->mixins, i);
	    TclOODecrRefCount(mixPtr->thisPtr);
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471

int
TclOORemoveFromSubclasses(
    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    size_t i;
    int res = 0;
    Class *subclsPtr;

    FOREACH(subclsPtr, superPtr->subclasses) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->subclasses, i);
	    TclOODecrRefCount(subPtr->thisPtr);







|







1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471

int
TclOORemoveFromSubclasses(
    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    Tcl_Size i;
    int res = 0;
    Class *subclsPtr;

    FOREACH(subclsPtr, superPtr->subclasses) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->subclasses, i);
	    TclOODecrRefCount(subPtr->thisPtr);
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536

int
TclOORemoveFromMixinSubs(
    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    size_t i;
    int res = 0;
    Class *subclsPtr;

    FOREACH(subclsPtr, superPtr->mixinSubs) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->mixinSubs, i);
	    TclOODecrRefCount(subPtr->thisPtr);







|







1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536

int
TclOORemoveFromMixinSubs(
    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    Tcl_Size i;
    int res = 0;
    Class *subclsPtr;

    FOREACH(subclsPtr, superPtr->mixinSubs) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->mixinSubs, i);
	    TclOODecrRefCount(subPtr->thisPtr);
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
    Tcl_Interp *interp,		/* Interpreter context. */
    Tcl_Class cls,		/* Class to create an instance of. */
    const char *nameStr,	/* Name of object to create, or NULL to ask
				 * the code to pick its own unique name. */
    const char *nsNameStr,	/* Name of namespace to create inside object,
				 * or NULL to ask the code to pick its own
				 * unique name. */
    size_t objc,			/* Number of arguments. Negative value means
				 * do not call constructor. */
    Tcl_Obj *const *objv,	/* Argument list. */
    size_t skip)			/* Number of arguments to _not_ pass to the
				 * constructor. */
{
    Class *classPtr = (Class *) cls;
    Object *oPtr;
    void *clientData[4];

    oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);







|


|







1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
    Tcl_Interp *interp,		/* Interpreter context. */
    Tcl_Class cls,		/* Class to create an instance of. */
    const char *nameStr,	/* Name of object to create, or NULL to ask
				 * the code to pick its own unique name. */
    const char *nsNameStr,	/* Name of namespace to create inside object,
				 * or NULL to ask the code to pick its own
				 * unique name. */
    Tcl_Size objc,			/* Number of arguments. Negative value means
				 * do not call constructor. */
    Tcl_Obj *const *objv,	/* Argument list. */
    Tcl_Size skip)			/* Number of arguments to _not_ pass to the
				 * constructor. */
{
    Class *classPtr = (Class *) cls;
    Object *oPtr;
    void *clientData[4];

    oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
    Tcl_Interp *interp,		/* Interpreter context. */
    Tcl_Class cls,		/* Class to create an instance of. */
    const char *nameStr,	/* Name of object to create, or NULL to ask
				 * the code to pick its own unique name. */
    const char *nsNameStr,	/* Name of namespace to create inside object,
				 * or NULL to ask the code to pick its own
				 * unique name. */
    size_t objc,			/* Number of arguments. Negative value means
				 * do not call constructor. */
    Tcl_Obj *const *objv,	/* Argument list. */
    size_t skip,			/* Number of arguments to _not_ pass to the
				 * constructor. */
    Tcl_Object *objectPtr)	/* Place to write the object reference upon
				 * successful allocation. */
{
    Class *classPtr = (Class *) cls;
    CallContext *contextPtr;
    Tcl_InterpState state;
    Object *oPtr;

    oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Run constructors, except when objc == TCL_INDEX_NONE (a special flag case used for
     * object cloning only). If there aren't any constructors, we do nothing.
     */

    if (objc == TCL_INDEX_NONE) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;
    }
    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
    if (contextPtr == NULL) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;







|


|



















|







1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
    Tcl_Interp *interp,		/* Interpreter context. */
    Tcl_Class cls,		/* Class to create an instance of. */
    const char *nameStr,	/* Name of object to create, or NULL to ask
				 * the code to pick its own unique name. */
    const char *nsNameStr,	/* Name of namespace to create inside object,
				 * or NULL to ask the code to pick its own
				 * unique name. */
    Tcl_Size objc,			/* Number of arguments. Negative value means
				 * do not call constructor. */
    Tcl_Obj *const *objv,	/* Argument list. */
    Tcl_Size skip,			/* Number of arguments to _not_ pass to the
				 * constructor. */
    Tcl_Object *objectPtr)	/* Place to write the object reference upon
				 * successful allocation. */
{
    Class *classPtr = (Class *) cls;
    CallContext *contextPtr;
    Tcl_InterpState state;
    Object *oPtr;

    oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Run constructors, except when objc == TCL_INDEX_NONE (a special flag case used for
     * object cloning only). If there aren't any constructors, we do nothing.
     */

    if (objc < 0) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;
    }
    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
    if (contextPtr == NULL) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
    /*
     * Ensure an error if the object was deleted in the constructor. Don't
     * want to lose errors by accident. [Bug 2903011]
     */

    if (result != TCL_ERROR && Destructing(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object deleted in constructor", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
	result = TCL_ERROR;
    }
    if (result != TCL_OK) {
	Tcl_DiscardInterpState(state);

	/*







|







1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
    /*
     * Ensure an error if the object was deleted in the constructor. Don't
     * want to lose errors by accident. [Bug 2903011]
     */

    if (result != TCL_ERROR && Destructing(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object deleted in constructor", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
	result = TCL_ERROR;
    }
    if (result != TCL_OK) {
	Tcl_DiscardInterpState(state);

	/*
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
    Object *oPtr = (Object *) sourceObject, *o2Ptr;
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Class *mixinPtr;
    CallContext *contextPtr;
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    PrivateVariableMapping *privateVariable;
    size_t i;
    int result;

    /*
     * Sanity check.
     */

    if (IsRootClass(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not clone the class of classes", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
     */

    o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
	    (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, TCL_INDEX_NONE,
	    NULL, TCL_INDEX_NONE);
    if (o2Ptr == NULL) {
	return NULL;
    }

    /*
     * Copy the object-local methods to the new object.
     */







|








|










|







1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
    Object *oPtr = (Object *) sourceObject, *o2Ptr;
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Class *mixinPtr;
    CallContext *contextPtr;
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    PrivateVariableMapping *privateVariable;
    Tcl_Size i;
    int result;

    /*
     * Sanity check.
     */

    if (IsRootClass(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not clone the class of classes", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
     */

    o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
	    (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, TCL_INDEX_NONE,
	    NULL, -1);
    if (o2Ptr == NULL) {
	return NULL;
    }

    /*
     * Copy the object-local methods to the new object.
     */
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
				 * invoke from, or NULL to traverse the whole
				 * chain including filters. */
    int publicPrivate,		/* Whether this is an invoke from a public
				 * context (PUBLIC_METHOD), a private context
				 * (PRIVATE_METHOD), or a *really* private
				 * context (any other value; conventionally
				 * 0). */
    size_t objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Array of argument objects. It is assumed
				 * that the name of the method to invoke will
				 * be at index 1. */
{
    switch (publicPrivate) {
    case PUBLIC_METHOD:
	return TclOOObjectCmdCore((Object *) object, interp, objc, objv,







|







2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
				 * invoke from, or NULL to traverse the whole
				 * chain including filters. */
    int publicPrivate,		/* Whether this is an invoke from a public
				 * context (PUBLIC_METHOD), a private context
				 * (PRIVATE_METHOD), or a *really* private
				 * context (any other value; conventionally
				 * 0). */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Array of argument objects. It is assumed
				 * that the name of the method to invoke will
				 * be at index 1. */
{
    switch (publicPrivate) {
    case PUBLIC_METHOD:
	return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
 * ----------------------------------------------------------------------
 */

int
TclOOObjectCmdCore(
    Object *oPtr,		/* The object being invoked. */
    Tcl_Interp *interp,		/* The interpreter containing the object. */
    size_t objc,			/* How many arguments are being passed in. */
    Tcl_Obj *const *objv,	/* The array of arguments. */
    int flags,			/* Whether this is an invocation through the
				 * public or the private command interface. */
    Class *startCls)		/* Where to start in the call chain, or NULL
				 * if we are to start at the front with
				 * filters and the object's methods (which is
				 * the normal case). */
{
    CallContext *contextPtr;
    Tcl_Obj *methodNamePtr;
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    Object *callerObjPtr = NULL;
    Class *callerClsPtr = NULL;
    int result;

    /*
     * If we've no method name, throw this directly into the unknown
     * processing.
     */

    if (objc + 1 < 3) {
	flags |= FORCE_UNKNOWN;
	methodNamePtr = NULL;
	goto noMapping;
    }

    /*
     * Determine if we're in a context that can see the extra, private methods







|




















|







2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
 * ----------------------------------------------------------------------
 */

int
TclOOObjectCmdCore(
    Object *oPtr,		/* The object being invoked. */
    Tcl_Interp *interp,		/* The interpreter containing the object. */
    Tcl_Size objc,			/* How many arguments are being passed in. */
    Tcl_Obj *const *objv,	/* The array of arguments. */
    int flags,			/* Whether this is an invocation through the
				 * public or the private command interface. */
    Class *startCls)		/* Where to start in the call chain, or NULL
				 * if we are to start at the front with
				 * filters and the object's methods (which is
				 * the normal case). */
{
    CallContext *contextPtr;
    Tcl_Obj *methodNamePtr;
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    Object *callerObjPtr = NULL;
    Class *callerClsPtr = NULL;
    int result;

    /*
     * If we've no method name, throw this directly into the unknown
     * processing.
     */

    if (objc < 2) {
	flags |= FORCE_UNKNOWN;
	methodNamePtr = NULL;
	goto noMapping;
    }

    /*
     * Determine if we're in a context that can see the extra, private methods
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
	    }
	    if (miPtr->mPtr->declaringClassPtr == startCls) {
		break;
	    }
	}
	if (contextPtr->index >= contextPtr->callPtr->numChain) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "no valid method implementation", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(methodNamePtr), NULL);
	    TclOODeleteContext(contextPtr);
	    return TCL_ERROR;
	}
    }








|







2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
	    }
	    if (miPtr->mPtr->declaringClassPtr == startCls) {
		break;
	    }
	}
	if (contextPtr->index >= contextPtr->callPtr->numChain) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "no valid method implementation", -1));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(methodNamePtr), NULL);
	    TclOODeleteContext(contextPtr);
	    return TCL_ERROR;
	}
    }

2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
 * ----------------------------------------------------------------------
 */

int
Tcl_ObjectContextInvokeNext(
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    size_t objc,
    Tcl_Obj *const *objv,
    size_t skip)
{
    CallContext *contextPtr = (CallContext *) context;
    size_t savedIndex = contextPtr->index;
    size_t savedSkip = contextPtr->skip;
    int result;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {







|

|







2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
 * ----------------------------------------------------------------------
 */

int
Tcl_ObjectContextInvokeNext(
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    Tcl_Size objc,
    Tcl_Obj *const *objv,
    Tcl_Size skip)
{
    CallContext *contextPtr = (CallContext *) context;
    size_t savedIndex = contextPtr->index;
    size_t savedSkip = contextPtr->skip;
    int result;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
    return result;
}

int
TclNRObjectContextInvokeNext(
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    size_t objc,
    Tcl_Obj *const *objv,
    size_t skip)
{
    CallContext *contextPtr = (CallContext *) context;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting







|

|







2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
    return result;
}

int
TclNRObjectContextInvokeNext(
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    Tcl_Size objc,
    Tcl_Obj *const *objv,
    Tcl_Size skip)
{
    CallContext *contextPtr = (CallContext *) context;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
 */

int
TclOOIsReachable(
    Class *targetPtr,
    Class *startPtr)
{
    size_t i;
    Class *superPtr;

  tailRecurse:
    if (startPtr == targetPtr) {
	return 1;
    }
    if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {







|







2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
 */

int
TclOOIsReachable(
    Class *targetPtr,
    Class *startPtr)
{
    Tcl_Size i;
    Class *superPtr;

  tailRecurse:
    if (startPtr == targetPtr) {
	return 1;
    }
    if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
Tcl_Object
Tcl_ObjectContextObject(
    Tcl_ObjectContext context)
{
    return (Tcl_Object) ((CallContext *)context)->oPtr;
}

size_t
Tcl_ObjectContextSkippedArgs(
    Tcl_ObjectContext context)
{
    return ((CallContext *)context)->skip;
}

Tcl_Namespace *







|







3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
Tcl_Object
Tcl_ObjectContextObject(
    Tcl_ObjectContext context)
{
    return (Tcl_Object) ((CallContext *)context)->oPtr;
}

Tcl_Size
Tcl_ObjectContextSkippedArgs(
    Tcl_ObjectContext context)
{
    return ((CallContext *)context)->skip;
}

Tcl_Namespace *

Changes to generic/tclOO.h.

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
 * implementation. These are used to implement custom types of method calls
 * and to allow the attachment of arbitrary data to objects and classes.
 */

typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
	Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
	Tcl_ObjectContext objectContext, size_t objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
	void **newClientData);
typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData);
typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
	Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj);








|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
 * implementation. These are used to implement custom types of method calls
 * and to allow the attachment of arbitrary data to objects and classes.
 */

typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
	Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
	Tcl_ObjectContext objectContext, ptrdiff_t objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
	void **newClientData);
typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData);
typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
	Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj);


Changes to generic/tclOOBasic.c.

96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     */

    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, TCL_INDEX_NONE);
    Tcl_AppendToObj(nameObj, ":: oo ::delegate", TCL_INDEX_NONE);
    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
	    TclGetString(nameObj), NULL, TCL_INDEX_NONE, NULL, TCL_INDEX_NONE);
    Tcl_DecrRefCount(nameObj);

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *));







|
|

|







96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     */

    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
    Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
	    TclGetString(nameObj), NULL, -1, NULL, -1);
    Tcl_DecrRefCount(nameObj);

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *));
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
    Object *oPtr = (Object *)data[1];
    Tcl_InterpState saved;
    int code;

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", TCL_INDEX_NONE);
    invoke[1] = TclOOObjectName(interp, oPtr);
    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    saved = Tcl_SaveInterpState(interp, result);
    code = Tcl_EvalObjv(interp, 2, invoke, 0);
    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);







|







144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
    Object *oPtr = (Object *)data[1];
    Tcl_InterpState saved;
    int code;

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
    invoke[1] = TclOOObjectName(interp, oPtr);
    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    saved = Tcl_SaveInterpState(interp, result);
    code = Tcl_EvalObjv(interp, 2, invoke, 0);
    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
	return TCL_ERROR;
    }

    /*
     * Check we have the right number of (sensible) arguments.
     */

    if ((size_t)objc < 1 + Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"objectName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */







|








|







201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
	return TCL_ERROR;
    }

    /*
     * Check we have the right number of (sensible) arguments.
     */

    if (objc < 1 + Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"objectName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
	return TCL_ERROR;
    }

    /*
     * Check we have the right number of (sensible) arguments.
     */

    if ((size_t)objc + 1 < Tcl_ObjectContextSkippedArgs(context) + 3) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"objectName namespaceName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
	return TCL_ERROR;
    }
    nsName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"namespace name must not be empty", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */







|








|







|







266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
	return TCL_ERROR;
    }

    /*
     * Check we have the right number of (sensible) arguments.
     */

    if (objc + 1 < Tcl_ObjectContextSkippedArgs(context) + 3) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"objectName namespaceName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
	return TCL_ERROR;
    }
    nsName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"namespace name must not be empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
	return TCL_ERROR;
    }

    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
	    TclGetString(objv[skip]));
    for (i=0 ; i<numMethodNames-1 ; i++) {
	if (i) {
	    Tcl_AppendToObj(errorMsg, ", ", TCL_INDEX_NONE);
	}
	Tcl_AppendToObj(errorMsg, methodNames[i], TCL_INDEX_NONE);
    }
    if (i) {
	Tcl_AppendToObj(errorMsg, " or ", TCL_INDEX_NONE);
    }
    Tcl_AppendToObj(errorMsg, methodNames[i], TCL_INDEX_NONE);
    Tcl_Free((void *)methodNames);
    Tcl_SetObjResult(interp, errorMsg);
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[skip]), NULL);
    return TCL_ERROR;
}








|

|


|

|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
	return TCL_ERROR;
    }

    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
	    TclGetString(objv[skip]));
    for (i=0 ; i<numMethodNames-1 ; i++) {
	if (i) {
	    Tcl_AppendToObj(errorMsg, ", ", -1);
	}
	Tcl_AppendToObj(errorMsg, methodNames[i], -1);
    }
    if (i) {
	Tcl_AppendToObj(errorMsg, " or ", -1);
    }
    Tcl_AppendToObj(errorMsg, methodNames[i], -1);
    Tcl_Free((void *)methodNames);
    Tcl_SetObjResult(interp, errorMsg);
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[skip]), NULL);
    return TCL_ERROR;
}

633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
    Tcl_ObjectContext context,	/* The object/call context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Object object = Tcl_ObjectContextObject(context);
    Namespace *savedNsPtr;
    size_t i;

    if ((size_t)objc < Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?varName ...?");
	return TCL_ERROR;
    }

    /*
     * A sanity check. Shouldn't ever happen. (This is all that remains of a
     * more complex check inherited from [global] after we have applied the
     * fix for [Bug 2903811]; note that the fix involved *removing* code.)
     */

    if (iPtr->varFramePtr == NULL) {
	return TCL_OK;
    }

    for (i = Tcl_ObjectContextSkippedArgs(context) ; i < (size_t)objc ; i++) {
	Var *varPtr, *aryPtr;
	const char *varName = TclGetString(objv[i]);

	/*
	 * The variable name must not contain a '::' since that's illegal in
	 * local names.
	 */







|

|















|







633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
    Tcl_ObjectContext context,	/* The object/call context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Object object = Tcl_ObjectContextObject(context);
    Namespace *savedNsPtr;
    Tcl_Size i;

    if (objc < Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?varName ...?");
	return TCL_ERROR;
    }

    /*
     * A sanity check. Shouldn't ever happen. (This is all that remains of a
     * more complex check inherited from [global] after we have applied the
     * fix for [Bug 2903811]; note that the fix involved *removing* code.)
     */

    if (iPtr->varFramePtr == NULL) {
	return TCL_OK;
    }

    for (i = Tcl_ObjectContextSkippedArgs(context) ; i < objc ; i++) {
	Var *varPtr, *aryPtr;
	const char *varName = TclGetString(objv[i]);

	/*
	 * The variable name must not contain a '::' since that's illegal in
	 * local names.
	 */
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790

	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
	    CallContext *callerContext = (CallContext *)framePtr->clientData;
	    Method *mPtr = callerContext->callPtr->chain[
		    callerContext->index].mPtr;
	    PrivateVariableMapping *pvPtr;
	    size_t i;

	    if (mPtr->declaringObjectPtr == oPtr) {
		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
		    if (!strcmp(TclGetString(pvPtr->variableObj),
			    TclGetString(argPtr))) {
			argPtr = pvPtr->fullNameObj;
			break;







|







776
777
778
779
780
781
782
783
784
785
786
787
788
789
790

	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
	    CallContext *callerContext = (CallContext *)framePtr->clientData;
	    Method *mPtr = callerContext->callPtr->chain[
		    callerContext->index].mPtr;
	    PrivateVariableMapping *pvPtr;
	    Tcl_Size i;

	    if (mPtr->declaringObjectPtr == oPtr) {
		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
		    if (!strcmp(TclGetString(pvPtr->variableObj),
			    TclGetString(argPtr))) {
			argPtr = pvPtr->fullNameObj;
			break;
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
			    break;
			}
		    }
		}
	    }
	}

	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, TCL_INDEX_NONE);
	Tcl_AppendToObj(varNamePtr, "::", 2);
	Tcl_AppendObjToObj(varNamePtr, argPtr);
    }
    Tcl_IncrRefCount(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
    Tcl_DecrRefCount(varNamePtr);







|







812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
			    break;
			}
		    }
		}
	    }
	}

	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
	Tcl_AppendToObj(varNamePtr, "::", 2);
	Tcl_AppendObjToObj(varNamePtr, argPtr);
    }
    Tcl_IncrRefCount(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
    Tcl_DecrRefCount(varNamePtr);
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
    if (aryVar != NULL) {
	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);

	/*
	 * WARNING! This code pokes inside the implementation of hash tables!
	 */

	Tcl_AppendToObj(varNamePtr, "(", TCL_INDEX_NONE);
	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
		varPtr)->entry.key.objPtr);
	Tcl_AppendToObj(varNamePtr, ")", TCL_INDEX_NONE);
    } else {
	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
    }
    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}








|


|







838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
    if (aryVar != NULL) {
	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);

	/*
	 * WARNING! This code pokes inside the implementation of hash tables!
	 */

	Tcl_AppendToObj(varNamePtr, "(", -1);
	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
		varPtr)->entry.key.objPtr);
	Tcl_AppendToObj(varNamePtr, ")", -1);
    } else {
	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
    }
    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}

908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    Class *classPtr;
    CallContext *contextPtr;
    size_t i;
    Tcl_Object object;
    const char *methodType;

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.







|







908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    Class *classPtr;
    CallContext *contextPtr;
    Tcl_Size i;
    Tcl_Object object;
    const char *methodType;

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
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
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174

    switch (index) {
    case SELF_OBJECT:
	Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
	return TCL_OK;
    case SELF_NS:
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		contextPtr->oPtr->namespacePtr->fullName, TCL_INDEX_NONE));
	return TCL_OK;
    case SELF_CLASS: {
	Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;

	if (clsPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "method not defined by a class", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	}

	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
	return TCL_OK;
    }
    case SELF_METHOD:
	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	    Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
	    Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
	} else {
	    Tcl_SetObjResult(interp,
		    CurrentlyInvoked(contextPtr).mPtr->namePtr);
	}
	return TCL_OK;
    case SELF_FILTER:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	} else {
	    struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
	    Object *oPtr;
	    const char *type;

	    if (miPtr->filterDeclarer != NULL) {
		oPtr = miPtr->filterDeclarer->thisPtr;
		type = "class";
	    } else {
		oPtr = contextPtr->oPtr;
		type = "object";
	    }

	    result[0] = TclOOObjectName(interp, oPtr);
	    result[1] = Tcl_NewStringObj(type, TCL_INDEX_NONE);
	    result[2] = miPtr->mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_CALLER:
	if ((framePtr->callerVarPtr == NULL) ||
		!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "caller is not an object", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
	    return TCL_ERROR;
	} else {
	    CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
	    Object *declarerPtr;

	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", TCL_INDEX_NONE));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = TclOOObjectName(interp, callerPtr->oPtr);
	    if (callerPtr->callPtr->flags & CONSTRUCTOR) {
		result[2] = declarerPtr->fPtr->constructorName;







|






|




















|
















|








|

















|







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
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174

    switch (index) {
    case SELF_OBJECT:
	Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
	return TCL_OK;
    case SELF_NS:
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		contextPtr->oPtr->namespacePtr->fullName, -1));
	return TCL_OK;
    case SELF_CLASS: {
	Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;

	if (clsPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "method not defined by a class", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	}

	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
	return TCL_OK;
    }
    case SELF_METHOD:
	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	    Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
	    Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
	} else {
	    Tcl_SetObjResult(interp,
		    CurrentlyInvoked(contextPtr).mPtr->namePtr);
	}
	return TCL_OK;
    case SELF_FILTER:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	} else {
	    struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
	    Object *oPtr;
	    const char *type;

	    if (miPtr->filterDeclarer != NULL) {
		oPtr = miPtr->filterDeclarer->thisPtr;
		type = "class";
	    } else {
		oPtr = contextPtr->oPtr;
		type = "object";
	    }

	    result[0] = TclOOObjectName(interp, oPtr);
	    result[1] = Tcl_NewStringObj(type, -1);
	    result[2] = miPtr->mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_CALLER:
	if ((framePtr->callerVarPtr == NULL) ||
		!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "caller is not an object", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
	    return TCL_ERROR;
	} else {
	    CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
	    Object *declarerPtr;

	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", -1));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = TclOOObjectName(interp, callerPtr->oPtr);
	    if (callerPtr->callPtr->flags & CONSTRUCTOR) {
		result[2] = declarerPtr->fPtr->constructorName;
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", TCL_INDEX_NONE));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
		result[1] = declarerPtr->fPtr->constructorName;
	    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
		result[1] = declarerPtr->fPtr->destructorName;
	    } else {
		result[1] = mPtr->namePtr;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	}
	return TCL_OK;
    case SELF_TARGET:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	} else {
	    Method *mPtr;
	    Object *declarerPtr;
	    size_t i;

	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
		if (!contextPtr->callPtr->chain[i].isFilter) {
		    break;
		}
	    }
	    if (i == contextPtr->callPtr->numChain) {
		Tcl_Panic("filtering call chain without terminal non-filter");
	    }
	    mPtr = contextPtr->callPtr->chain[i].mPtr;
	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", TCL_INDEX_NONE));
		return TCL_ERROR;
	    }
	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	    return TCL_OK;
	}







|

















|





|




















|







1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", -1));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
		result[1] = declarerPtr->fPtr->constructorName;
	    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
		result[1] = declarerPtr->fPtr->destructorName;
	    } else {
		result[1] = mPtr->namePtr;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	}
	return TCL_OK;
    case SELF_TARGET:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	} else {
	    Method *mPtr;
	    Object *declarerPtr;
	    Tcl_Size i;

	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
		if (!contextPtr->callPtr->chain[i].isFilter) {
		    break;
		}
	    }
	    if (i == contextPtr->callPtr->numChain) {
		Tcl_Panic("filtering call chain without terminal non-filter");
	    }
	    mPtr = contextPtr->callPtr->chain[i].mPtr;
	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", -1));
		return TCL_ERROR;
	    }
	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	    return TCL_OK;
	}

Changes to generic/tclOOCall.c.

323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
    /*
     * If this is the first step along the chain, we preserve the method
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	size_t i;

	for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
	 * Ensure that the method name itself is part of the arguments when







|







323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
    /*
     * If this is the first step along the chain, we preserve the method
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	Tcl_Size i;

	for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
	 * Ensure that the method name itself is part of the arguments when
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
static int
FinalizeMethodRefs(
    void *data[],
    TCL_UNUSED(Tcl_Interp *),
    int result)
{
    CallContext *contextPtr = (CallContext *)data[0];
    size_t i;

    for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
    }
    return result;
}








|







405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
static int
FinalizeMethodRefs(
    void *data[],
    TCL_UNUSED(Tcl_Interp *),
    int result)
{
    CallContext *contextPtr = (CallContext *)data[0];
    Tcl_Size i;

    for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
    }
    return result;
}

446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
    Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
				 * mapping. */
    Tcl_HashTable examinedClasses;
				/* Used to track what classes have been looked
				 * at. Is set-like in nature and keyed by
				 * pointer to class. */
    FOREACH_HASH_DECLS;
    size_t i, numStrings;
    Class *mixinPtr;
    Tcl_Obj *namePtr;
    Method *mPtr;

    Tcl_InitObjHashTable(&names);
    Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);








|







446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
    Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
				 * mapping. */
    Tcl_HashTable examinedClasses;
				/* Used to track what classes have been looked
				 * at. Is set-like in nature and keyed by
				 * pointer to class. */
    FOREACH_HASH_DECLS;
    Tcl_Size i, numStrings;
    Class *mixinPtr;
    Tcl_Obj *namePtr;
    Method *mPtr;

    Tcl_InitObjHashTable(&names);
    Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);

687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
				 * semantics are handled correctly. */
    Tcl_HashTable *const examinedClassesPtr)
				/* Hash table that tracks what classes have
				 * already been looked at. The keys are the
				 * pointers to the classes, and the values are
				 * immaterial. */
{
    size_t i;

    /*
     * If we've already started looking at this class, stop working on it now
     * to prevent repeated work.
     */

    if (Tcl_FindHashEntry(examinedClassesPtr, clsPtr)) {







|







687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
				 * semantics are handled correctly. */
    Tcl_HashTable *const examinedClassesPtr)
				/* Hash table that tracks what classes have
				 * already been looked at. The keys are the
				 * pointers to the classes, and the values are
				 * immaterial. */
{
    Tcl_Size i;

    /*
     * If we've already started looking at this class, stop working on it now
     * to prevent repeated work.
     */

    if (Tcl_FindHashEntry(examinedClassesPtr, clsPtr)) {
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    size_t i;
    int foundPrivate = 0, blockedUnexported = 0;
    Tcl_HashEntry *hPtr;
    Method *mPtr;

    if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);








|







878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    Tcl_Size i;
    int foundPrivate = 0, blockedUnexported = 0;
    Tcl_HashEntry *hPtr;
    Method *mPtr;

    if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);

971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
				 * only. Mixin-consistent means that either
				 * we're looking to add things from a mixin
				 * and we have passed a mixin, or we're not
				 * looking to add things from a mixin and have
				 * not passed a mixin. */
{
    CallChain *callPtr = cbPtr->callChainPtr;
    size_t i;

    /*
     * Return if this is just an entry used to record whether this is a public
     * method. If so, there's nothing real to call and so nothing to add to
     * the call chain.
     *
     * This is also where we enforce mixin-consistency.







|







971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
				 * only. Mixin-consistent means that either
				 * we're looking to add things from a mixin
				 * and we have passed a mixin, or we're not
				 * looking to add things from a mixin and have
				 * not passed a mixin. */
{
    CallChain *callPtr = cbPtr->callChainPtr;
    Tcl_Size i;

    /*
     * Return if this is just an entry used to record whether this is a public
     * method. If so, there's nothing real to call and so nothing to add to
     * the call chain.
     *
     * This is also where we enforce mixin-consistency.
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
    Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
				 * to be in the same object as the
				 * methodNameObj. */
{
    CallContext *contextPtr;
    CallChain *callPtr;
    struct ChainBuilder cb;
    size_t i, count;
    int doFilters, donePrivate = 0;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;

    if (cacheInThisObj == NULL) {
	cacheInThisObj = methodNameObj;
    }







|







1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
    Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
				 * to be in the same object as the
				 * methodNameObj. */
{
    CallContext *contextPtr;
    CallChain *callPtr;
    struct ChainBuilder cb;
    Tcl_Size i, count;
    int doFilters, donePrivate = 0;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;

    if (cacheInThisObj == NULL) {
	cacheInThisObj = methodNameObj;
    }
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
    int flags)			/* What sort of context are we looking for.
				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
				 * PRIVATE_METHOD, DESTRUCTOR and
				 * FILTER_HANDLING are useful. */
{
    CallChain *callPtr;
    struct ChainBuilder cb;
    size_t count;
    Foundation *fPtr = clsPtr->thisPtr->fPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;
    Object obj;

    /*
     * Synthesize a temporary stereotypical object so that we can use existing







|







1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
    int flags)			/* What sort of context are we looking for.
				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
				 * PRIVATE_METHOD, DESTRUCTOR and
				 * FILTER_HANDLING are useful. */
{
    CallChain *callPtr;
    struct ChainBuilder cb;
    Tcl_Size count;
    Foundation *fPtr = clsPtr->thisPtr->fPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;
    Object obj;

    /*
     * Synthesize a temporary stereotypical object so that we can use existing
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
    Tcl_HashTable *const doneFilters,
				/* Where to record what filters have been
				 * processed. Keys are objects, values are
				 * ignored. */
    int flags)			/* Whether we've gone along a mixin link
				 * yet. */
{
    size_t i;
    int clearedFlags =
	    flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS);
    Class *superPtr, *mixinPtr;
    Tcl_Obj *filterObj;

  tailRecurse:
    if (clsPtr == NULL) {







|







1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
    Tcl_HashTable *const doneFilters,
				/* Where to record what filters have been
				 * processed. Keys are objects, values are
				 * ignored. */
    int flags)			/* Whether we've gone along a mixin link
				 * yet. */
{
    Tcl_Size i;
    int clearedFlags =
	    flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS);
    Class *superPtr, *mixinPtr;
    Tcl_Obj *filterObj;

  tailRecurse:
    if (clsPtr == NULL) {
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    size_t i;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     *
     * Note that mixins must be processed before the main class hierarchy.







|







1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    Tcl_Size i;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     *
     * Note that mixins must be processed before the main class hierarchy.
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    size_t i;
    int privateDanger = 0;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     *







|







1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    Tcl_Size i;
    int privateDanger = 0;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     *
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
TclOORenderCallChain(
    Tcl_Interp *interp,
    CallChain *callPtr)
{
    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral;
    Tcl_Obj *resultObj, *descObjs[4], **objv;
    Foundation *fPtr = TclOOGetFoundation(interp);
    size_t i;

    /*
     * Allocate the literals (potentially) used in our description.
     */

    TclNewLiteralStringObj(filterLiteral, "filter");
    Tcl_IncrRefCount(filterLiteral);







|







1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
TclOORenderCallChain(
    Tcl_Interp *interp,
    CallChain *callPtr)
{
    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral;
    Tcl_Obj *resultObj, *descObjs[4], **objv;
    Foundation *fPtr = TclOOGetFoundation(interp);
    Tcl_Size i;

    /*
     * Allocate the literals (potentially) used in our description.
     */

    TclNewLiteralStringObj(filterLiteral, "filter");
    Tcl_IncrRefCount(filterLiteral);
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i = 0 ; i < (size_t)callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] =
	    miPtr->isFilter ? filterLiteral :
	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
		    methodLiteral;
	descObjs[1] =
	    callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
	    callPtr->flags & DESTRUCTOR ? fPtr->destructorName :
		    miPtr->mPtr->namePtr;
	descObjs[2] = miPtr->mPtr->declaringClassPtr
		? Tcl_GetObjectName(interp,
			(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
		: objectLiteral;
	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, TCL_INDEX_NONE);

	objv[i] = Tcl_NewListObj(4, descObjs);
    }

    /*
     * Drop the local references to the literals; if they're actually used,
     * they'll live on the description itself.







|















|







1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i = 0 ; i < callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] =
	    miPtr->isFilter ? filterLiteral :
	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
		    methodLiteral;
	descObjs[1] =
	    callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
	    callPtr->flags & DESTRUCTOR ? fPtr->destructorName :
		    miPtr->mPtr->namePtr;
	descObjs[2] = miPtr->mPtr->declaringClassPtr
		? Tcl_GetObjectName(interp,
			(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
		: objectLiteral;
	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1);

	objv[i] = Tcl_NewListObj(4, descObjs);
    }

    /*
     * Drop the local references to the literals; if they're actually used,
     * they'll live on the description itself.
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
    Object *const oPtr,		/* Object to add define chain entries for. */
    DefineChain *const definePtr,
				/* Where to add the define chain entries. */
    int flags)			/* What sort of define chain are we
				 * building. */
{
    Class *mixinPtr;
    size_t i;

    FOREACH(mixinPtr, oPtr->mixins) {
	AddSimpleClassDefineNamespaces(mixinPtr, definePtr,
		flags | TRAVERSED_MIXIN);
    }

    AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags);







|







1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
    Object *const oPtr,		/* Object to add define chain entries for. */
    DefineChain *const definePtr,
				/* Where to add the define chain entries. */
    int flags)			/* What sort of define chain are we
				 * building. */
{
    Class *mixinPtr;
    Tcl_Size i;

    FOREACH(mixinPtr, oPtr->mixins) {
	AddSimpleClassDefineNamespaces(mixinPtr, definePtr,
		flags | TRAVERSED_MIXIN);
    }

    AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags);
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
AddSimpleClassDefineNamespaces(
    Class *classPtr,		/* Class to add the define chain entries for. */
    DefineChain *const definePtr,
				/* Where to add the define chain entries. */
    int flags)			/* What sort of define chain are we
				 * building. */
{
    size_t i;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     */








|







1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
AddSimpleClassDefineNamespaces(
    Class *classPtr,		/* Class to add the define chain entries for. */
    DefineChain *const definePtr,
				/* Where to add the define chain entries. */
    int flags)			/* What sort of define chain are we
				 * building. */
{
    Tcl_Size i;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     */

Changes to generic/tclOODefineCmds.c.

245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
 *
 * ----------------------------------------------------------------------
 */

void
TclOOObjectSetFilters(
    Object *oPtr,
    size_t numFilters,
    Tcl_Obj *const *filters)
{
    size_t i;

    if (oPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, oPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}







|


|







245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
 *
 * ----------------------------------------------------------------------
 */

void
TclOOObjectSetFilters(
    Object *oPtr,
    Tcl_Size numFilters,
    Tcl_Obj *const *filters)
{
    Tcl_Size i;

    if (oPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, oPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
 * ----------------------------------------------------------------------
 */

void
TclOOClassSetFilters(
    Tcl_Interp *interp,
    Class *classPtr,
    size_t numFilters,
    Tcl_Obj *const *filters)
{
    size_t i;

    if (classPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, classPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}







|


|







305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
 * ----------------------------------------------------------------------
 */

void
TclOOClassSetFilters(
    Tcl_Interp *interp,
    Class *classPtr,
    Tcl_Size numFilters,
    Tcl_Obj *const *filters)
{
    Tcl_Size i;

    if (classPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, classPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
 *
 * ----------------------------------------------------------------------
 */

void
TclOOObjectSetMixins(
    Object *oPtr,
    size_t numMixins,
    Class *const *mixins)
{
    Class *mixinPtr;
    size_t i;

    if (numMixins == 0) {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		TclOORemoveFromInstances(oPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }







|



|







367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
 *
 * ----------------------------------------------------------------------
 */

void
TclOOObjectSetMixins(
    Object *oPtr,
    Tcl_Size numMixins,
    Class *const *mixins)
{
    Class *mixinPtr;
    Tcl_Size i;

    if (numMixins == 0) {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		TclOORemoveFromInstances(oPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
 * ----------------------------------------------------------------------
 */

void
TclOOClassSetMixins(
    Tcl_Interp *interp,
    Class *classPtr,
    size_t numMixins,
    Class *const *mixins)
{
    Class *mixinPtr;
    size_t i;

    if (numMixins == 0) {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }







|



|







428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
 * ----------------------------------------------------------------------
 */

void
TclOOClassSetMixins(
    Tcl_Interp *interp,
    Class *classPtr,
    Tcl_Size numMixins,
    Class *const *mixins)
{
    Class *mixinPtr;
    Tcl_Size i;

    if (numMixins == 0) {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
 *	Helpers for installing standard and private variable maps.
 *
 * ----------------------------------------------------------------------
 */
static inline void
InstallStandardVariableMapping(
    VariableNameList *vnlPtr,
    size_t varc,
    Tcl_Obj *const *varv)
{
    Tcl_Obj *variableObj;
    size_t i, n;
    int created;
    Tcl_HashTable uniqueTable;

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH(variableObj, *vnlPtr) {







|



|







481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
 *	Helpers for installing standard and private variable maps.
 *
 * ----------------------------------------------------------------------
 */
static inline void
InstallStandardVariableMapping(
    VariableNameList *vnlPtr,
    Tcl_Size varc,
    Tcl_Obj *const *varv)
{
    Tcl_Obj *variableObj;
    Tcl_Size i, n;
    int created;
    Tcl_HashTable uniqueTable;

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH(variableObj, *vnlPtr) {
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

static inline void
InstallPrivateVariableMapping(
    PrivateVariableList *pvlPtr,
    size_t varc,
    Tcl_Obj *const *varv,
    int creationEpoch)
{
    PrivateVariableMapping *privatePtr;
    size_t i, n;
    int created;
    Tcl_HashTable uniqueTable;

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH_STRUCT(privatePtr, *pvlPtr) {







|




|







531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

static inline void
InstallPrivateVariableMapping(
    PrivateVariableList *pvlPtr,
    Tcl_Size varc,
    Tcl_Obj *const *varv,
    int creationEpoch)
{
    PrivateVariableMapping *privatePtr;
    Tcl_Size i, n;
    int created;
    Tcl_HashTable uniqueTable;

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH_STRUCT(privatePtr, *pvlPtr) {
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
	}
	if (toPtr) {
	    newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr,
		    &isNew);
	    if (hPtr == newHPtr) {
	    renameToSelf:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot rename method to itself", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
		return TCL_ERROR;
	    } else if (!isNew) {
	    renameToExisting:
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"method called %s already exists",
			TclGetString(toPtr)));







|







629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
	}
	if (toPtr) {
	    newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr,
		    &isNew);
	    if (hPtr == newHPtr) {
	    renameToSelf:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot rename method to itself", -1));
		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
		return TCL_ERROR;
	    } else if (!isNew) {
	    renameToExisting:
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"method called %s already exists",
			TclGetString(toPtr)));
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    size_t soughtLen;
    const char *soughtStr, *matchedStr = NULL;

    if (objc < 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad call of unknown handler", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
	return TCL_ERROR;
    }
    if (TclOOGetDefineCmdContext(interp) == NULL) {
	return TCL_ERROR;
    }








|







705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    size_t soughtLen;
    const char *soughtStr, *matchedStr = NULL;

    if (objc < 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad call of unknown handler", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
	return TCL_ERROR;
    }
    if (TclOOGetDefineCmdContext(interp) == NULL) {
	return TCL_ERROR;
    }

739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
	 * Got one match, and only one match!
	 */

	Tcl_Obj **newObjv = (Tcl_Obj **)
		TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
	int result;

	newObjv[0] = Tcl_NewStringObj(matchedStr, TCL_INDEX_NONE);
	Tcl_IncrRefCount(newObjv[0]);
	if (objc > 2) {
	    memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
	}
	result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
	Tcl_DecrRefCount(newObjv[0]);
	TclStackFree(interp, newObjv);







|







739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
	 * Got one match, and only one match!
	 */

	Tcl_Obj **newObjv = (Tcl_Obj **)
		TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
	int result;

	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
	Tcl_IncrRefCount(newObjv[0]);
	if (objc > 2) {
	    memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
	}
	result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
	Tcl_DecrRefCount(newObjv[0]);
	TclStackFree(interp, newObjv);
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
    int objc,
    Tcl_Obj *const objv[])
{
    CallFrame *framePtr, **framePtrPtr = &framePtr;

    if (namespacePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"no definition namespace available", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
     */







|







842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
    int objc,
    Tcl_Obj *const objv[])
{
    CallFrame *framePtr, **framePtrPtr = &framePtr;

    if (namespacePtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"no definition namespace available", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
     */
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
    Tcl_Object object;

    if ((iPtr->varFramePtr == NULL)
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
	    && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command may only be called from within the context of"
		" an ::oo::define or ::oo::objdefine command", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return NULL;
    }
    object = (Tcl_Object)iPtr->varFramePtr->clientData;
    if (Tcl_ObjectDeleted(object)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command cannot be called when the object has been"
		" deleted", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return NULL;
    }
    return object;
}

/*







|







|







883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
    Tcl_Object object;

    if ((iPtr->varFramePtr == NULL)
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
	    && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command may only be called from within the context of"
		" an ::oo::define or ::oo::objdefine command", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return NULL;
    }
    object = (Tcl_Object)iPtr->varFramePtr->clientData;
    if (Tcl_ObjectDeleted(object)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command cannot be called when the object has been"
		" deleted", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return NULL;
    }
    return object;
}

/*
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
    iPtr->varFramePtr = savedFramePtr;
    if (oPtr == NULL) {
	return NULL;
    }
    if (oPtr->classPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		TclGetString(className), NULL);
	return NULL;
    }
    return oPtr->classPtr;
}








|







934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
    iPtr->varFramePtr = savedFramePtr;
    if (oPtr == NULL) {
	return NULL;
    }
    if (oPtr->classPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		TclGetString(className), NULL);
	return NULL;
    }
    return oPtr->classPtr;
}

1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
    int cmdIndex,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *objPtr, *obj2Ptr, **objs;
    Tcl_Command cmd;
    int isRoot, result, offset = cmdIndex + 1;
    size_t dummy;

    /*
     * More than one argument: fire them through the ensemble processing
     * engine so that everything appears to be good and proper in error
     * messages. Note that we cannot just concatenate and send through
     * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go
     * through Tcl_EvalObjv without the extra work to pre-find the command, as







|







1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
    int cmdIndex,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *objPtr, *obj2Ptr, **objs;
    Tcl_Command cmd;
    int isRoot, result, offset = cmdIndex + 1;
    Tcl_Size dummy;

    /*
     * More than one argument: fire them through the ensemble processing
     * engine so that everything appears to be good and proper in error
     * messages. Note that we cannot just concatenate and send through
     * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go
     * through Tcl_EvalObjv without the extra work to pre-find the command, as
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_OBJECT) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the root object class", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_CLASS) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the class of classes", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * Parse the argument to get the class to set the object's class to.
     */

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassInOuterContext(interp, objv[1],
	    "the class of an object must be a class");
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    if (oPtr == clsPtr->thisPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not change classes into an instance of themselves", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * Set the object's class.
     */







|





|



















|







1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_OBJECT) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the root object class", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_CLASS) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the class of classes", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * Parse the argument to get the class to set the object's class to.
     */

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassInOuterContext(interp, objv[1],
	    "the class of an object must be a class");
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    if (oPtr == clsPtr->thisPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not change classes into an instance of themselves", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * Set the object's class.
     */
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the definition namespace of the root classes",
		-1));







|







1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the definition namespace of the root classes",
		-1));
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
    if (!TclGetString(objv[objc - 1])[0]) {
	nsNamePtr = NULL;
    } else {
	nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
	if (nsPtr == NULL) {
	    return TCL_ERROR;
	}
	nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
	Tcl_IncrRefCount(nsNamePtr);
    }

    /*
     * Update the correct field of the class definition.
     */








|







1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
    if (!TclGetString(objv[objc - 1])[0]) {
	nsNamePtr = NULL;
    } else {
	nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
	if (nsPtr == NULL) {
	    return TCL_ERROR;
	}
	nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1);
	Tcl_IncrRefCount(nsNamePtr);
    }

    /*
     * Update the correct field of the class definition.
     */

1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Delete the method structure from the appropriate hash table.







|







1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Delete the method structure from the appropriate hash table.
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Exporting is done by adding the PUBLIC_METHOD flag to the method







|







1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Exporting is done by adding the PUBLIC_METHOD flag to the method
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;







|







1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    if (objc == 5) {
	if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
		0, &exportMode) != TCL_OK) {
	    return TCL_ERROR;







|







1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    if (objc == 5) {
	if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
		0, &exportMode) != TCL_OK) {
	    return TCL_ERROR;
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceRenameMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * Delete the method entry from the appropriate hash table, and transfer
     * the thing it points to to its new entry. To do this, we first need to







|







2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (!isInstanceRenameMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    /*
     * Delete the method entry from the appropriate hash table, and transfer
     * the thing it points to to its new entry. To do this, we first need to
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from the







|







2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
 */

int
TclOODefineSlots(
    Foundation *fPtr)
{
    const struct DeclaredSlot *slotInfoPtr;
    Tcl_Obj *getName = Tcl_NewStringObj("Get", TCL_INDEX_NONE);
    Tcl_Obj *setName = Tcl_NewStringObj("Set", TCL_INDEX_NONE);
    Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", TCL_INDEX_NONE);
    Class *slotCls;

    slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0))->classPtr;
    if (slotCls == NULL) {
	return TCL_ERROR;
    }







|
|
|







2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
 */

int
TclOODefineSlots(
    Foundation *fPtr)
{
    const struct DeclaredSlot *slotInfoPtr;
    Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
    Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
    Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
    Class *slotCls;

    slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0))->classPtr;
    if (slotCls == NULL) {
	return TCL_ERROR;
    }
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    size_t i;

    if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(filterObj, oPtr->classPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);







|

|








|







2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(filterObj, oPtr->classPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    size_t filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &filterc,
	    &filterv) != TCL_OK) {
	return TCL_ERROR;
    }








|


|










|







2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &filterc,
	    &filterv) != TCL_OK) {
	return TCL_ERROR;
    }

2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    size_t i;

    if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(mixinPtr, oPtr->classPtr->mixins) {
	Tcl_ListObjAppendElement(NULL, resultObj,







|

|








|







2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(mixinPtr, oPtr->classPtr->mixins) {
	Tcl_ListObjAppendElement(NULL, resultObj,
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    size_t mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}
    }

    TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
    TclStackFree(interp, mixins);







|



|










|


















|







2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}
    }

    TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *superPtr;
    size_t i;

    if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	Tcl_ListObjAppendElement(NULL, resultObj,







|

|








|







2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *superPtr;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	Tcl_ListObjAppendElement(NULL, resultObj,
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    size_t superc, j;
    size_t i;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the superclass of the root object", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &superc,
	    &superv) != TCL_OK) {
	return TCL_ERROR;
    }








|
|



|










|




|







2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size superc, j;
    Tcl_Size i;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the superclass of the root object", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &superc,
	    &superv) != TCL_OK) {
	return TCL_ERROR;
    }

2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
			    -1));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
		    goto failedAfterAlloc;
		}
	    }
	    if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"attempt to form circular dependency graph", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
	    failedAfterAlloc:
		for (; i-- > 0 ;) {
		    TclOODecrRefCount(superclasses[i]->thisPtr);
		}
		Tcl_Free(superclasses);
		return TCL_ERROR;







|







2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
			    -1));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
		    goto failedAfterAlloc;
		}
	    }
	    if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"attempt to form circular dependency graph", -1));
		Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
	    failedAfterAlloc:
		for (; i-- > 0 ;) {
		    TclOODecrRefCount(superclasses[i]->thisPtr);
		}
		Tcl_Free(superclasses);
		return TCL_ERROR;
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    size_t i;

    if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    if (IsPrivateDefine(interp)) {
	PrivateVariableMapping *privatePtr;







|

|








|







2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    if (IsPrivateDefine(interp)) {
	PrivateVariableMapping *privatePtr;
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    size_t i;
    size_t varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }








|
|


|










|







2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size i;
    Tcl_Size varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElementsM(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    size_t i;

    if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }








|

|







2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    size_t filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);







|


|







2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    size_t i;

    if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }








|

|







2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    size_t i;
    size_t mixinc;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);







|
|



|







2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size i;
    Tcl_Size mixinc;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    size_t i;

    if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }








|

|







2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    size_t varc, i;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);







|


|







2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Size varc, i;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

Changes to generic/tclOOInfo.c.

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
    /*
     * Install into the [info] ensemble.
     */

    infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
    if (infoCmd) {
	Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
	Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", TCL_INDEX_NONE),
		Tcl_NewStringObj("::oo::InfoObject", TCL_INDEX_NONE));
	Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", TCL_INDEX_NONE),
		Tcl_NewStringObj("::oo::InfoClass", TCL_INDEX_NONE));
	Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
    }
}

/*
 * ----------------------------------------------------------------------
 *







|
|
|
|







116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
    /*
     * Install into the [info] ensemble.
     */

    infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
    if (infoCmd) {
	Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
	Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),
		Tcl_NewStringObj("::oo::InfoObject", -1));
	Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1),
		Tcl_NewStringObj("::oo::InfoClass", -1));
	Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
    }
}

/*
 * ----------------------------------------------------------------------
 *
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

    if (objc == 2) {
	Tcl_SetObjResult(interp,
		TclOOObjectName(interp, oPtr->selfCls->thisPtr));
	return TCL_OK;
    } else {
	Class *mixinPtr, *o2clsPtr;
	size_t i;

	o2clsPtr = GetClassFromObj(interp, objv[2]);
	if (o2clsPtr == NULL) {
	    return TCL_ERROR;
	}

	FOREACH(mixinPtr, oPtr->mixins) {







|







190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

    if (objc == 2) {
	Tcl_SetObjResult(interp,
		TclOOObjectName(interp, oPtr->selfCls->thisPtr));
	return TCL_OK;
    } else {
	Class *mixinPtr, *o2clsPtr;
	Tcl_Size i;

	o2clsPtr = GetClassFromObj(interp, objv[2]);
	if (o2clsPtr == NULL) {
	    return TCL_ERROR;
	}

	FOREACH(mixinPtr, oPtr->mixins) {
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }
    procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, TCL_INDEX_NONE));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));







|













|







260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }
    procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, -1));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
static int
InfoObjectFiltersCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    size_t i;
    Tcl_Obj *filterObj, *resultObj;
    Object *oPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }







|







303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
static int
InfoObjectFiltersCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Size i;
    Tcl_Obj *filterObj, *resultObj;
    Object *oPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
	"class", "metaclass", "mixin", "object", "typeof", NULL
    };
    enum IsACats {
	IsClass, IsMetaclass, IsMixin, IsObject, IsType
    } idx;
    Object *oPtr, *o2Ptr;
    int result = 0;
    size_t i;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
	    &idx) != TCL_OK) {







|







407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
	"class", "metaclass", "mixin", "object", "typeof", NULL
    };
    enum IsACats {
	IsClass, IsMetaclass, IsMixin, IsObject, IsType
    } idx;
    Object *oPtr, *o2Ptr;
    int result = 0;
    Tcl_Size i;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
	    &idx) != TCL_OK) {
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
    if (recurse) {
	const char **names;
	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
		&names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], TCL_INDEX_NONE));
	}
	if (numNames > 0) {
	    Tcl_Free((void *)names);
	}
    } else if (oPtr->methodsPtr) {
	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {







|







606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
    if (recurse) {
	const char **names;
	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
		&names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], -1));
	}
	if (numNames > 0) {
	    Tcl_Free((void *)names);
	}
    } else if (oPtr->methodsPtr) {
	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, TCL_INDEX_NONE));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectMixinsCmd --







|







675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectMixinsCmd --
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *mixinPtr;
    Object *oPtr;
    Tcl_Obj *resultObj;
    size_t i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {







|







699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *mixinPtr;
    Object *oPtr;
    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj(oPtr->namespacePtr->fullName, TCL_INDEX_NONE));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectVariablesCmd --







|







783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectVariablesCmd --
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_Obj *resultObj;
    size_t i;
    int isPrivate = 0;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {







|







806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_Obj *resultObj;
    Tcl_Size i;
    int isPrivate = 0;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
    }
    if (clsPtr->constructorPtr == NULL) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, TCL_INDEX_NONE));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);







|












|







939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
    }
    if (clsPtr->constructorPtr == NULL) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, -1));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }
    procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, TCL_INDEX_NONE));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));







|













|







1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }
    procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, -1));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131

    if (clsPtr->destructorPtr == NULL) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
    return TCL_OK;
}







|







1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131

    if (clsPtr->destructorPtr == NULL) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
    if (procPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
    return TCL_OK;
}
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
static int
InfoClassFiltersCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    size_t i;
    Tcl_Obj *filterObj, *resultObj;
    Class *clsPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }







|







1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
static int
InfoClassFiltersCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Size i;
    Tcl_Obj *filterObj, *resultObj;
    Class *clsPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Class *clsPtr;
    size_t i;
    const char *pattern = NULL;
    Tcl_Obj *resultObj;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
	return TCL_ERROR;
    }







|







1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Class *clsPtr;
    Tcl_Size i;
    const char *pattern = NULL;
    Tcl_Obj *resultObj;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
	return TCL_ERROR;
    }
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
	    break;
	}
    }

    TclNewObj(resultObj);
    if (recurse) {
	const char **names;
	size_t i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], TCL_INDEX_NONE));
	}
	if (numNames > 0) {
	    Tcl_Free((void *)names);
	}
    } else {
	FOREACH_HASH_DECLS;








|



|







1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
	    break;
	}
    }

    TclNewObj(resultObj);
    if (recurse) {
	const char **names;
	Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], -1));
	}
	if (numNames > 0) {
	    Tcl_Free((void *)names);
	}
    } else {
	FOREACH_HASH_DECLS;

1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
	/*
	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, TCL_INDEX_NONE));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoClassMixinsCmd --







|







1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
	/*
	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoClassMixinsCmd --
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *mixinPtr;
    Tcl_Obj *resultObj;
    size_t i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {







|







1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *mixinPtr;
    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *subclassPtr;
    Tcl_Obj *resultObj;
    size_t i;
    const char *pattern = NULL;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);







|







1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *subclassPtr;
    Tcl_Obj *resultObj;
    Tcl_Size i;
    const char *pattern = NULL;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *superPtr;
    Tcl_Obj *resultObj;
    size_t i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {







|







1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *superPtr;
    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    Tcl_Obj *resultObj;
    size_t i;
    int isPrivate = 0;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {







|







1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    Tcl_Obj *resultObj;
    Tcl_Size i;
    int isPrivate = 0;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
     * Get the call context and render its call chain.
     */

    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
	    NULL);
    if (contextPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", TCL_INDEX_NONE));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp,
	    TclOORenderCallChain(interp, contextPtr->callPtr));
    TclOODeleteContext(contextPtr);
    return TCL_OK;
}







|







1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
     * Get the call context and render its call chain.
     */

    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
	    NULL);
    if (contextPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp,
	    TclOORenderCallChain(interp, contextPtr->callPtr));
    TclOODeleteContext(contextPtr);
    return TCL_OK;
}
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
    /*
     * Get an render the stereotypical call chain.
     */

    callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
    if (callPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", TCL_INDEX_NONE));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    TclOODeleteChain(callPtr);
    return TCL_OK;
}








|







1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
    /*
     * Get an render the stereotypical call chain.
     */

    callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
    if (callPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    TclOODeleteChain(callPtr);
    return TCL_OK;
}


Changes to generic/tclOOInt.h.

349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
    Tcl_Namespace *objdefNs;	/* Namespace containing special commands for
				 * manipulating objects and classes. The
				 * "oo::objdefine" command acts as a special
				 * kind of ensemble for this namespace. */
    Tcl_Namespace *helpersNs;	/* Namespace containing the commands that are
				 * only valid when executing inside a
				 * procedural method. */
    Tcl_Size epoch;			/* Used to invalidate method chains when the
				 * class structure changes. */
    ThreadLocalData *tsdPtr;	/* Counter so we can allocate a unique
				 * namespace to each object. */
    Tcl_Obj *unknownMethodNameObj;
				/* Shared object containing the name of the
				 * unknown method handler method. */
    Tcl_Obj *constructorName;	/* Shared object containing the "name" of a







|







349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
    Tcl_Namespace *objdefNs;	/* Namespace containing special commands for
				 * manipulating objects and classes. The
				 * "oo::objdefine" command acts as a special
				 * kind of ensemble for this namespace. */
    Tcl_Namespace *helpersNs;	/* Namespace containing the commands that are
				 * only valid when executing inside a
				 * procedural method. */
    Tcl_Size epoch;		/* Used to invalidate method chains when the
				 * class structure changes. */
    ThreadLocalData *tsdPtr;	/* Counter so we can allocate a unique
				 * namespace to each object. */
    Tcl_Obj *unknownMethodNameObj;
				/* Shared object containing the name of the
				 * unknown method handler method. */
    Tcl_Obj *constructorName;	/* Shared object containing the "name" of a
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
				 * record. */
    int isFilter;		/* Whether this is a filter invocation. */
    Class *filterDeclarer;	/* What class decided to add the filter; if
				 * NULL, it was added by the object. */
};

typedef struct CallChain {
    Tcl_Size objectCreationEpoch;	/* The object's creation epoch. Note that the
				 * object reference is not stored in the call
				 * chain; it is in the call context. */
    Tcl_Size objectEpoch;		/* Local (object structure) epoch counter
				 * snapshot. */
    Tcl_Size epoch;			/* Global (class structure) epoch counter
				 * snapshot. */
    int flags;			/* Assorted flags, see below. */
    Tcl_Size refCount;		/* Reference count. */
    Tcl_Size numChain;		/* Size of the call chain. */
    struct MInvoke *chain;	/* Array of call chain entries. May point to
				 * staticChain if the number of entries is
				 * small. */
    struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
} CallChain;

typedef struct CallContext {
    Object *oPtr;		/* The object associated with this call. */
    Tcl_Size index;			/* Index into the call chain of the currently
				 * executing method implementation. */
    Tcl_Size skip;			/* Current number of arguments to skip; can
				 * vary depending on whether it is a direct
				 * method call or a continuation via the
				 * [next] command. */
    CallChain *callPtr;		/* The actual call chain. */
} CallContext;

/*







|


|

|












|

|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
				 * record. */
    int isFilter;		/* Whether this is a filter invocation. */
    Class *filterDeclarer;	/* What class decided to add the filter; if
				 * NULL, it was added by the object. */
};

typedef struct CallChain {
    Tcl_Size objectCreationEpoch;/* The object's creation epoch. Note that the
				 * object reference is not stored in the call
				 * chain; it is in the call context. */
    Tcl_Size objectEpoch;	/* Local (object structure) epoch counter
				 * snapshot. */
    Tcl_Size epoch;		/* Global (class structure) epoch counter
				 * snapshot. */
    int flags;			/* Assorted flags, see below. */
    Tcl_Size refCount;		/* Reference count. */
    Tcl_Size numChain;		/* Size of the call chain. */
    struct MInvoke *chain;	/* Array of call chain entries. May point to
				 * staticChain if the number of entries is
				 * small. */
    struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
} CallChain;

typedef struct CallContext {
    Object *oPtr;		/* The object associated with this call. */
    Tcl_Size index;		/* Index into the call chain of the currently
				 * executing method implementation. */
    Tcl_Size skip;		/* Current number of arguments to skip; can
				 * vary depending on whether it is a direct
				 * method call or a continuation via the
				 * [next] command. */
    CallChain *callPtr;		/* The actual call chain. */
} CallContext;

/*
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
                        void *clientData);
MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
                        Tcl_Obj *nameObj, int flags,
                        const Tcl_MethodType *typePtr,
                        void *clientData);
MODULE_SCOPE int	TclNRNewObjectInstance(Tcl_Interp *interp,
			    Tcl_Class cls, const char *nameStr,
			    const char *nsNameStr, size_t objc,
			    Tcl_Obj *const *objv, size_t skip,
			    Tcl_Object *objectPtr);
MODULE_SCOPE Object *	TclNewObjectInstanceCommon(Tcl_Interp *interp,
			    Class *classPtr,
			    const char *nameStr,
			    const char *nsNameStr);
MODULE_SCOPE int	TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int	TclOOObjectDestroyed(Object *oPtr);







|
|







501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
                        void *clientData);
MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
                        Tcl_Obj *nameObj, int flags,
                        const Tcl_MethodType *typePtr,
                        void *clientData);
MODULE_SCOPE int	TclNRNewObjectInstance(Tcl_Interp *interp,
			    Tcl_Class cls, const char *nameStr,
			    const char *nsNameStr, Tcl_Size objc,
			    Tcl_Obj *const *objv, Tcl_Size skip,
			    Tcl_Object *objectPtr);
MODULE_SCOPE Object *	TclNewObjectInstanceCommon(Tcl_Interp *interp,
			    Class *classPtr,
			    const char *nameStr,
			    const char *nsNameStr);
MODULE_SCOPE int	TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int	TclOOObjectDestroyed(Object *oPtr);
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
			    const char ***stringsPtr);
MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int	TclOOInvokeContext(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
			    Tcl_ObjectContext context, size_t objc,
			    Tcl_Obj *const *objv, size_t skip);
MODULE_SCOPE void	TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
			    const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOOReleaseClassContents(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE int	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE int	TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr);







|
|







540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
			    const char ***stringsPtr);
MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int	TclOOInvokeContext(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
			    Tcl_ObjectContext context, Tcl_Size objc,
			    Tcl_Obj *const *objv, Tcl_Size skip);
MODULE_SCOPE void	TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
			    const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOOReleaseClassContents(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE int	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE int	TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr);

Changes to generic/tclOOMethod.c.

383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
TclOONewBasicMethod(
    Tcl_Interp *interp,
    Class *clsPtr,		/* Class to attach the method to. */
    const DeclaredClassMethod *dcm)
				/* Name of the method, whether it is public,
				 * and the function to implement it. */
{
    Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, TCL_INDEX_NONE);

    Tcl_IncrRefCount(namePtr);
    TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
	    (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
    Tcl_DecrRefCount(namePtr);
}








|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
TclOONewBasicMethod(
    Tcl_Interp *interp,
    Class *clsPtr,		/* Class to attach the method to. */
    const DeclaredClassMethod *dcm)
				/* Name of the method, whether it is public,
				 * and the function to implement it. */
{
    Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);

    Tcl_IncrRefCount(namePtr);
    TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
	    (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
    Tcl_DecrRefCount(namePtr);
}

417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
    Tcl_Obj *bodyObj,		/* The body of the method, which must not be
				 * NULL. */
    ProcedureMethod **pmPtrPtr)	/* Place to write pointer to procedure method
				 * structure to allow for deeper tuning of the
				 * structure's contents. NULL if caller is not
				 * interested. */
{
    size_t argsLen;
    ProcedureMethod *pmPtr;
    Tcl_Method method;

    if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
	return NULL;
    }
    pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod));







|







417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
    Tcl_Obj *bodyObj,		/* The body of the method, which must not be
				 * NULL. */
    ProcedureMethod **pmPtrPtr)	/* Place to write pointer to procedure method
				 * structure to allow for deeper tuning of the
				 * structure's contents. NULL if caller is not
				 * interested. */
{
    Tcl_Size argsLen;
    ProcedureMethod *pmPtr;
    Tcl_Method method;

    if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
	return NULL;
    }
    pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod));
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
    Tcl_Obj *bodyObj,		/* The body of the method, which must not be
				 * NULL. */
    ProcedureMethod **pmPtrPtr)	/* Place to write pointer to procedure method
				 * structure to allow for deeper tuning of the
				 * structure's contents. NULL if caller is not
				 * interested. */
{
    size_t argsLen;		/* TCL_INDEX_NONE => delete argsObj before exit */
    ProcedureMethod *pmPtr;
    const char *procName;
    Tcl_Method method;

    if (argsObj == NULL) {
	argsLen = TCL_INDEX_NONE;
	TclNewObj(argsObj);







|







469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
    Tcl_Obj *bodyObj,		/* The body of the method, which must not be
				 * NULL. */
    ProcedureMethod **pmPtrPtr)	/* Place to write pointer to procedure method
				 * structure to allow for deeper tuning of the
				 * structure's contents. NULL if caller is not
				 * interested. */
{
    Tcl_Size argsLen;		/* TCL_INDEX_NONE => delete argsObj before exit */
    ProcedureMethod *pmPtr;
    const char *procName;
    Tcl_Method method;

    if (argsObj == NULL) {
	argsLen = TCL_INDEX_NONE;
	TclNewObj(argsObj);
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVar;
    Tcl_HashEntry *hPtr;
    int isNew, cacheIt;
    size_t i, varLen, len;
    const char *match, *varName;

    /*
     * Check that the variable is being requested in a context that is also a
     * method call; if not (i.e. we're evaluating in the object's namespace or
     * in a procedure of that namespace) then we do nothing.
     */







|







1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVar;
    Tcl_HashEntry *hPtr;
    int isNew, cacheIt;
    Tcl_Size i, varLen, len;
    const char *match, *varName;

    /*
     * Check that the variable is being requested in a context that is also a
     * method call; if not (i.e. we're evaluating in the object's namespace or
     * in a procedure of that namespace) then we do nothing.
     */
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
    Tcl_Free(infoPtr);
}

static int
ProcedureMethodCompiledVarResolver(
    TCL_UNUSED(Tcl_Interp *),
    const char *varName,
    size_t length,
    TCL_UNUSED(Tcl_Namespace *),
    Tcl_ResolvedVarInfo **rPtrPtr)
{
    OOResVarInfo *infoPtr;
    Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);

    /*







|







1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
    Tcl_Free(infoPtr);
}

static int
ProcedureMethodCompiledVarResolver(
    TCL_UNUSED(Tcl_Interp *),
    const char *varName,
    Tcl_Size length,
    TCL_UNUSED(Tcl_Namespace *),
    Tcl_ResolvedVarInfo **rPtrPtr)
{
    OOResVarInfo *infoPtr;
    Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);

    /*
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279

static void
MethodErrorHandler(
    Tcl_Interp *interp,
    TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
	/* We pull the method name out of context instead of from argument */
{
    size_t nameLen, objectNameLen;
    CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    const char *objectName, *kindName, *methodName =
	    Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
    Object *declarerPtr;

    if (mPtr->declaringObjectPtr != NULL) {







|







1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279

static void
MethodErrorHandler(
    Tcl_Interp *interp,
    TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
	/* We pull the method name out of context instead of from argument */
{
    Tcl_Size nameLen, objectNameLen;
    CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    const char *objectName, *kindName, *methodName =
	    Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
    Object *declarerPtr;

    if (mPtr->declaringObjectPtr != NULL) {
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
    TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
		/* Ignore. We know it is the constructor. */
{
    CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    size_t objectNameLen;

    if (mPtr->declaringObjectPtr != NULL) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (mPtr->declaringClassPtr == NULL) {
	    Tcl_Panic("method not declared in class or object");







|







1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
    TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
		/* Ignore. We know it is the constructor. */
{
    CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    Tcl_Size objectNameLen;

    if (mPtr->declaringObjectPtr != NULL) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (mPtr->declaringClassPtr == NULL) {
	    Tcl_Panic("method not declared in class or object");
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
    TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
		/* Ignore. We know it is the destructor. */
{
    CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    size_t objectNameLen;

    if (mPtr->declaringObjectPtr != NULL) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (mPtr->declaringClassPtr == NULL) {
	    Tcl_Panic("method not declared in class or object");







|







1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
    TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
		/* Ignore. We know it is the destructor. */
{
    CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    Tcl_Size objectNameLen;

    if (mPtr->declaringObjectPtr != NULL) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (mPtr->declaringClassPtr == NULL) {
	    Tcl_Panic("method not declared in class or object");
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
    for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, TCL_INDEX_NONE));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
	}
    }








|







1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
    for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, -1));
	    if (localPtr->defValuePtr != NULL) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
	}
    }

1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    Object *oPtr,		/* The object to attach the method to. */
    int flags,			/* Whether the method is public or not. */
    Tcl_Obj *nameObj,		/* The name of the method. */
    Tcl_Obj *prefixObj)		/* List of arguments that form the command
				 * prefix to forward to. */
{
    size_t prefixLen;
    ForwardMethod *fmPtr;

    if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
	return NULL;
    }

    fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_IncrRefCount(prefixObj);







|







|







1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    Object *oPtr,		/* The object to attach the method to. */
    int flags,			/* Whether the method is public or not. */
    Tcl_Obj *nameObj,		/* The name of the method. */
    Tcl_Obj *prefixObj)		/* List of arguments that form the command
				 * prefix to forward to. */
{
    Tcl_Size prefixLen;
    ForwardMethod *fmPtr;

    if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
	return NULL;
    }

    fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_IncrRefCount(prefixObj);
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    Class *clsPtr,		/* The class to attach the method to. */
    int flags,			/* Whether the method is public or not. */
    Tcl_Obj *nameObj,		/* The name of the method. */
    Tcl_Obj *prefixObj)		/* List of arguments that form the command
				 * prefix to forward to. */
{
    size_t prefixLen;
    ForwardMethod *fmPtr;

    if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
	return NULL;
    }

    fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_IncrRefCount(prefixObj);







|







|







1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    Class *clsPtr,		/* The class to attach the method to. */
    int flags,			/* Whether the method is public or not. */
    Tcl_Obj *nameObj,		/* The name of the method. */
    Tcl_Obj *prefixObj)		/* List of arguments that form the command
				 * prefix to forward to. */
{
    Tcl_Size prefixLen;
    ForwardMethod *fmPtr;

    if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
	return NULL;
    }

    fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_IncrRefCount(prefixObj);
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
    Tcl_ObjectContext context,	/* The method calling context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
{
    CallContext *contextPtr = (CallContext *) context;
    ForwardMethod *fmPtr = (ForwardMethod *)clientData;
    Tcl_Obj **argObjs, **prefixObjs;
    size_t numPrefixes, skip = contextPtr->skip;
    int len;

    /*
     * Build the real list of arguments to use. Note that we know that the
     * prefixObj field of the ForwardMethod structure holds a reference to a
     * non-empty list, so there's a whole class of failures ("not a list") we
     * can ignore here.







|







1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
    Tcl_ObjectContext context,	/* The method calling context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
{
    CallContext *contextPtr = (CallContext *) context;
    ForwardMethod *fmPtr = (ForwardMethod *)clientData;
    Tcl_Obj **argObjs, **prefixObjs;
    Tcl_Size numPrefixes, skip = contextPtr->skip;
    int len;

    /*
     * Build the real list of arguments to use. Note that we know that the
     * prefixObj field of the ForwardMethod structure holds a reference to a
     * non-empty list, so there's a whole class of failures ("not a list") we
     * can ignore here.

Changes to generic/tclObj.c.

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
				 * the referenced command). NULL if the name
				 * is fully qualified.*/
    size_t refNsId;		/* refNsPtr's unique namespace id. Used to
				 * verify that refNsPtr is still valid (e.g.,
				 * it's possible that the cmd's containing
				 * namespace was deleted and a new one created
				 * at the same address). */
    size_t refNsCmdEpoch;	/* Value of the referencing namespace's
				 * cmdRefEpoch when the pointer was cached.
				 * Before using the cached pointer, we check
				 * if the namespace's epoch was incremented;
				 * if so, this cached pointer is invalid. */
    size_t cmdEpoch;		/* Value of the command's cmdEpoch when this
				 * pointer was cached. Before using the cached
				 * pointer, we check if the cmd's epoch was
				 * incremented; if so, the cmd was renamed,
				 * deleted, hidden, or exposed, and so the
				 * pointer is invalid. */
    size_t refCount;		/* Reference count: 1 for each cmdName object
				 * that has a pointer to this ResolvedCmdName







|




|







325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
				 * the referenced command). NULL if the name
				 * is fully qualified.*/
    size_t refNsId;		/* refNsPtr's unique namespace id. Used to
				 * verify that refNsPtr is still valid (e.g.,
				 * it's possible that the cmd's containing
				 * namespace was deleted and a new one created
				 * at the same address). */
    Tcl_Size refNsCmdEpoch;	/* Value of the referencing namespace's
				 * cmdRefEpoch when the pointer was cached.
				 * Before using the cached pointer, we check
				 * if the namespace's epoch was incremented;
				 * if so, this cached pointer is invalid. */
    Tcl_Size cmdEpoch;		/* Value of the command's cmdEpoch when this
				 * pointer was cached. Before using the cached
				 * pointer, we check if the cmd's epoch was
				 * incremented; if so, the cmd was renamed,
				 * deleted, hidden, or exposed, and so the
				 * pointer is invalid. */
    size_t refCount;		/* Reference count: 1 for each cmdName object
				 * that has a pointer to this ResolvedCmdName
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
 * TIP #280
 *----------------------------------------------------------------------
 */

ContLineLoc *
TclContinuationsEnter(
    Tcl_Obj *objPtr,
    size_t num,
    int *loc)
{
    int newEntry;
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
	    Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
    ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(int));







|







546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
 * TIP #280
 *----------------------------------------------------------------------
 */

ContLineLoc *
TclContinuationsEnter(
    Tcl_Obj *objPtr,
    Tcl_Size num,
    int *loc)
{
    int newEntry;
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
	    Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
    ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(int));
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
    Tcl_Interp *interp,		/* Interpreter used for error reporting. */
    Tcl_Obj *objPtr)		/* Points to the Tcl object onto which the
				 * name of each registered type is appended as
				 * a list element. */
{
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    size_t numElems;

    /*
     * Get the test for a valid list out of the way first.
     */

    if (TclListObjLengthM(interp, objPtr, &numElems) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Type names are NUL-terminated, not counted strings. This code relies on
     * that.
     */

    Tcl_MutexLock(&tableMutex);
    for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), TCL_INDEX_NONE));
    }
    Tcl_MutexUnlock(&tableMutex);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|


















|







856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
    Tcl_Interp *interp,		/* Interpreter used for error reporting. */
    Tcl_Obj *objPtr)		/* Points to the Tcl object onto which the
				 * name of each registered type is appended as
				 * a list element. */
{
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_Size numElems;

    /*
     * Get the test for a valid list out of the way first.
     */

    if (TclListObjLengthM(interp, objPtr, &numElems) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Type names are NUL-terminated, not counted strings. This code relies on
     * that.
     */

    Tcl_MutexLock(&tableMutex);
    for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1));
    }
    Tcl_MutexUnlock(&tableMutex);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
#endif /* !defined(TCL_NO_DEPRECATED) */

#undef Tcl_GetStringFromObj
char *
Tcl_GetStringFromObj(
    Tcl_Obj *objPtr,	/* Object whose string rep byte pointer should
				 * be returned. */
    size_t *lengthPtr)	/* If non-NULL, the location where the string
				 * rep's byte array length should * be stored.
				 * If NULL, no length is stored. */
{
    if (objPtr->bytes == NULL) {
	/*
	 * Note we do not check for objPtr->typePtr == NULL.  An invariant
	 * of a properly maintained Tcl_Obj is that at least  one of







|







1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
#endif /* !defined(TCL_NO_DEPRECATED) */

#undef Tcl_GetStringFromObj
char *
Tcl_GetStringFromObj(
    Tcl_Obj *objPtr,	/* Object whose string rep byte pointer should
				 * be returned. */
    Tcl_Size *lengthPtr)	/* If non-NULL, the location where the string
				 * rep's byte array length should * be stored.
				 * If NULL, no length is stored. */
{
    if (objPtr->bytes == NULL) {
	/*
	 * Note we do not check for objPtr->typePtr == NULL.  An invariant
	 * of a properly maintained Tcl_Obj is that at least  one of
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168

    if (ParseBoolean(objPtr) == TCL_OK) {
	return TCL_OK;
    }

  badBoolean:
    if (interp != NULL) {
	size_t length;
	const char *str = Tcl_GetStringFromObj(objPtr, &length);
	Tcl_Obj *msg;

	TclNewLiteralStringObj(msg, "expected boolean value but got \"");
	Tcl_AppendLimitedToObj(msg, str, length, 50, "");
	Tcl_AppendToObj(msg, "\"", TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, msg);
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
    }
    return TCL_ERROR;
}

static int
ParseBoolean(
    Tcl_Obj *objPtr)	/* The object to parse/convert. */
{
    int newBool;
    char lowerCase[6];
    size_t i, length;
    const char *str = Tcl_GetStringFromObj(objPtr, &length);

    if ((length == 0) || (length > 5)) {
	/*
         * Longest valid boolean string rep. is "false".
         */








|





|












|







2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168

    if (ParseBoolean(objPtr) == TCL_OK) {
	return TCL_OK;
    }

  badBoolean:
    if (interp != NULL) {
	Tcl_Size length;
	const char *str = Tcl_GetStringFromObj(objPtr, &length);
	Tcl_Obj *msg;

	TclNewLiteralStringObj(msg, "expected boolean value but got \"");
	Tcl_AppendLimitedToObj(msg, str, length, 50, "");
	Tcl_AppendToObj(msg, "\"", -1);
	Tcl_SetObjResult(interp, msg);
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
    }
    return TCL_ERROR;
}

static int
ParseBoolean(
    Tcl_Obj *objPtr)	/* The object to parse/convert. */
{
    int newBool;
    char lowerCase[6];
    Tcl_Size i, length;
    const char *str = Tcl_GetStringFromObj(objPtr, &length);

    if ((length == 0) || (length > 5)) {
	/*
         * Longest valid boolean string rep. is "false".
         */

2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
    double *dblPtr)	/* Place to store resulting double. */
{
    do {
	if (objPtr->typePtr == &tclDoubleType.objType) {
	    if (isnan(objPtr->internalRep.doubleValue)) {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "floating point value is Not a Number", TCL_INDEX_NONE));
                    Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
                            NULL);
		}
		return TCL_ERROR;
	    }
	    *dblPtr = (double) objPtr->internalRep.doubleValue;
	    return TCL_OK;







|







2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
    double *dblPtr)	/* Place to store resulting double. */
{
    do {
	if (objPtr->typePtr == &tclDoubleType.objType) {
	    if (isnan(objPtr->internalRep.doubleValue)) {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "floating point value is Not a Number", -1));
                    Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
                            NULL);
		}
		return TCL_ERROR;
	    }
	    *dblPtr = (double) objPtr->internalRep.doubleValue;
	    return TCL_OK;
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
    if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
	return TCL_ERROR;
    }
    if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
	if (interp != NULL) {
	    const char *s =
		    "integer value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	}
	return TCL_ERROR;
    }
    *intPtr = (int) l;
    return TCL_OK;
#endif







|







2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
    if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
	return TCL_ERROR;
    }
    if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
	if (interp != NULL) {
	    const char *s =
		    "integer value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	}
	return TCL_ERROR;
    }
    *intPtr = (int) l;
    return TCL_OK;
#endif
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
	    }
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	tooLarge:
#endif
	    if (interp != NULL) {
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, TCL_INDEX_NONE);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,







|







2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
	    }
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	tooLarge:
#endif
	    if (interp != NULL) {
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, -1);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
			*wideIntPtr = (Tcl_WideInt)value;
			return TCL_OK;
		    }
		}
	    }
	    if (interp != NULL) {
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, TCL_INDEX_NONE);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,







|







2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
			*wideIntPtr = (Tcl_WideInt)value;
			return TCL_OK;
		    }
		}
	    }
	    if (interp != NULL) {
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, -1);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
		}
		*wideUIntPtr = (Tcl_WideUInt)value;
		return TCL_OK;
	    }

	    if (interp != NULL) {
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, TCL_INDEX_NONE);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,







|







3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
		}
		*wideUIntPtr = (Tcl_WideUInt)value;
		return TCL_OK;
	    }

	    if (interp != NULL) {
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, -1);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
3127
3128
3129
3130
3131
3132
3133

























3134
3135
3136
3137
3138
3139
3140
	    mp_clear(&big);
	    return TCL_OK;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}


























/*
 *----------------------------------------------------------------------
 *
 * FreeBignum --
 *
 *	This function frees the internal rep of a bignum.







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







3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
	    mp_clear(&big);
	    return TCL_OK;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetSizeIntFromObj --
 *
 *	Attempt to return a Tcl_Size from the Tcl object "objPtr".
 *
 * Results:
 *  TCL_OK - the converted Tcl_Size value is stored in *sizePtr
 *  TCL_ERROR - the error message is stored in interp
 *
 * Side effects:
 *	The function may free up any existing internal representation.
 *
 *----------------------------------------------------------------------
 */
int
Tcl_GetSizeIntFromObj(
    Tcl_Interp *interp, /* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,	/* The object from which to get a int. */
    Tcl_Size *sizePtr)  /* Place to store resulting int. */
{
    return TclGetSizeIntFromObj(interp, objPtr, sizePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeBignum --
 *
 *	This function frees the internal rep of a bignum.
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
    return TCL_ERROR;
}

int
Tcl_GetNumber(
    Tcl_Interp *interp,
    const char *bytes,
    size_t numBytes,
    void **clientDataPtr,
    int *typePtr)
{
    static Tcl_ThreadDataKey numberCacheKey;
    Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetThreadData(&numberCacheKey,
	    sizeof(Tcl_Obj));

    Tcl_FreeInternalRep(objPtr);

    if (bytes == NULL) {
	bytes = &tclEmptyString;
	numBytes = 0;
    }
    if (numBytes == (size_t)TCL_INDEX_NONE) {
	numBytes = strlen(bytes);
    }
    if (numBytes > INT_MAX) {
	if (interp) {
            Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);







|













|







3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
    return TCL_ERROR;
}

int
Tcl_GetNumber(
    Tcl_Interp *interp,
    const char *bytes,
    Tcl_Size numBytes,
    void **clientDataPtr,
    int *typePtr)
{
    static Tcl_ThreadDataKey numberCacheKey;
    Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetThreadData(&numberCacheKey,
	    sizeof(Tcl_Obj));

    Tcl_FreeInternalRep(objPtr);

    if (bytes == NULL) {
	bytes = &tclEmptyString;
	numBytes = 0;
    }
    if (numBytes < 0) {
	numBytes = strlen(bytes);
    }
    if (numBytes > INT_MAX) {
	if (interp) {
            Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130

TCL_HASH_TYPE
TclHashObjKey(
    TCL_UNUSED(Tcl_HashTable *),
    void *keyPtr)		/* Key from which to compute hash value. */
{
    Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
    size_t length;
    const char *string = Tcl_GetStringFromObj(objPtr, &length);
    TCL_HASH_TYPE result = 0;

    /*
     * I tried a zillion different hash functions and asked many other people
     * for advice. Many people had their own favorite functions, all
     * different, but no-one had much idea why they were good ones. I chose







|







4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155

TCL_HASH_TYPE
TclHashObjKey(
    TCL_UNUSED(Tcl_HashTable *),
    void *keyPtr)		/* Key from which to compute hash value. */
{
    Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
    Tcl_Size length;
    const char *string = Tcl_GetStringFromObj(objPtr, &length);
    TCL_HASH_TYPE result = 0;

    /*
     * I tried a zillion different hash functions and asked many other people
     * for advice. Many people had their own favorite functions, all
     * different, but no-one had much idea why they were good ones. I chose
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
	    Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
		    (void *) objv[1]->internalRep.twoPtrValue.ptr1,
		    (void *) objv[1]->internalRep.twoPtrValue.ptr2);
	}
    }

    if (objv[1]->bytes) {
        Tcl_AppendToObj(descObj, ", string representation \"", TCL_INDEX_NONE);
	Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
                16, "...");
	Tcl_AppendToObj(descObj, "\"", TCL_INDEX_NONE);
    } else {
	Tcl_AppendToObj(descObj, ", no string representation", TCL_INDEX_NONE);
    }

    Tcl_SetObjResult(interp, descObj);
    return TCL_OK;
}

/*







|


|

|







4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
	    Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
		    (void *) objv[1]->internalRep.twoPtrValue.ptr1,
		    (void *) objv[1]->internalRep.twoPtrValue.ptr2);
	}
    }

    if (objv[1]->bytes) {
        Tcl_AppendToObj(descObj, ", string representation \"", -1);
	Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
                16, "...");
	Tcl_AppendToObj(descObj, "\"", -1);
    } else {
	Tcl_AppendToObj(descObj, ", no string representation", -1);
    }

    Tcl_SetObjResult(interp, descObj);
    return TCL_OK;
}

/*

Changes to generic/tclOptimize.c.

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
static void
LocateTargetAddresses(
    CompileEnv *envPtr,
    Tcl_HashTable *tablePtr)
{
    unsigned char *currentInstPtr, *targetInstPtr;
    int isNew;
    size_t i;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;

    Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);

    /*
     * The starts of commands represent target addresses.







|







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
static void
LocateTargetAddresses(
    CompileEnv *envPtr,
    Tcl_HashTable *tablePtr)
{
    unsigned char *currentInstPtr, *targetInstPtr;
    int isNew;
    Tcl_Size i;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;

    Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);

    /*
     * The starts of commands represent target addresses.

Changes to generic/tclParse.c.

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

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

static int	CommandComplete(const char *script, size_t numBytes);
static size_t		ParseComment(const char *src, size_t numBytes,
			    Tcl_Parse *parsePtr);
static int		ParseTokens(const char *src, size_t numBytes, int mask,
			    int flags, Tcl_Parse *parsePtr);
static size_t		ParseWhiteSpace(const char *src, size_t numBytes,
			    int *incompletePtr, char *typePtr);
static size_t		ParseAllWhiteSpace(const char *src, size_t numBytes,
			    int *incompletePtr);
static int		ParseHex(const char *src, size_t numBytes,
			    int *resultPtr);

/*
 *----------------------------------------------------------------------
 *
 * TclParseInit --
 *







|
|

|

|

|

|







116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

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

static int	CommandComplete(const char *script, Tcl_Size numBytes);
static Tcl_Size		ParseComment(const char *src, Tcl_Size numBytes,
			    Tcl_Parse *parsePtr);
static int		ParseTokens(const char *src, Tcl_Size numBytes, int mask,
			    int flags, Tcl_Parse *parsePtr);
static Tcl_Size		ParseWhiteSpace(const char *src, Tcl_Size numBytes,
			    int *incompletePtr, char *typePtr);
static Tcl_Size		ParseAllWhiteSpace(const char *src, Tcl_Size numBytes,
			    int *incompletePtr);
static int		ParseHex(const char *src, Tcl_Size numBytes,
			    int *resultPtr);

/*
 *----------------------------------------------------------------------
 *
 * TclParseInit --
 *
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
 *----------------------------------------------------------------------
 */

void
TclParseInit(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting */
    const char *start,		/* Start of string to be parsed. */
    size_t numBytes,		/* Total number of bytes in string. If -1,
				 * the script consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr)	/* Points to struct to initialize */
{
    parsePtr->numWords = 0;
    parsePtr->tokenPtr = parsePtr->staticTokens;
    parsePtr->numTokens = 0;







|







148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
 *----------------------------------------------------------------------
 */

void
TclParseInit(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting */
    const char *start,		/* Start of string to be parsed. */
    Tcl_Size numBytes,		/* Total number of bytes in string. If -1,
				 * the script consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr)	/* Points to struct to initialize */
{
    parsePtr->numWords = 0;
    parsePtr->tokenPtr = parsePtr->staticTokens;
    parsePtr->numTokens = 0;
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238

int
Tcl_ParseCommand(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* First character of string containing one or
				 * more Tcl commands. */
    size_t numBytes,		/* Total number of bytes in string. If -1,
				 * the script consists of all bytes up to the
				 * first null character. */
    int nested,			/* Non-zero means this is a nested command:
				 * close bracket should be considered a
				 * command terminator. If zero, then close
				 * bracket has no special meaning. */
    Tcl_Parse *parsePtr)
				/* Structure to fill in with information about
				 * the parsed command; any previous
				 * information in the structure is ignored. */
{
    const char *src;		/* Points to current character in the
				 * command. */
    char type;			/* Result returned by CHAR_TYPE(*src). */
    Tcl_Token *tokenPtr;	/* Pointer to token being filled in. */
    int wordIndex;		/* Index of word token for current word. */
    int terminators;		/* CHAR_TYPE bits that indicate the end of a
				 * command. */
    const char *termPtr;	/* Set by Tcl_ParseBraces/QuotedString to
				 * point to char after terminating one. */
    size_t scanned;

    if (numBytes == TCL_INDEX_NONE && start) {
	numBytes = strlen(start);
    }
    TclParseInit(interp, start, numBytes, parsePtr);
    if ((start == NULL) && (numBytes != 0)) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "can't parse a NULL pointer", TCL_INDEX_NONE));
	}
	return TCL_ERROR;
    }
    parsePtr->commentStart = NULL;
    parsePtr->commentSize = 0;
    parsePtr->commandStart = NULL;
    parsePtr->commandSize = 0;







|




















|

|






|







194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238

int
Tcl_ParseCommand(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* First character of string containing one or
				 * more Tcl commands. */
    Tcl_Size numBytes,		/* Total number of bytes in string. If -1,
				 * the script consists of all bytes up to the
				 * first null character. */
    int nested,			/* Non-zero means this is a nested command:
				 * close bracket should be considered a
				 * command terminator. If zero, then close
				 * bracket has no special meaning. */
    Tcl_Parse *parsePtr)
				/* Structure to fill in with information about
				 * the parsed command; any previous
				 * information in the structure is ignored. */
{
    const char *src;		/* Points to current character in the
				 * command. */
    char type;			/* Result returned by CHAR_TYPE(*src). */
    Tcl_Token *tokenPtr;	/* Pointer to token being filled in. */
    int wordIndex;		/* Index of word token for current word. */
    int terminators;		/* CHAR_TYPE bits that indicate the end of a
				 * command. */
    const char *termPtr;	/* Set by Tcl_ParseBraces/QuotedString to
				 * point to char after terminating one. */
    Tcl_Size scanned;

    if (numBytes < 0 && start) {
	numBytes = strlen(start);
    }
    TclParseInit(interp, start, numBytes, parsePtr);
    if ((start == NULL) && (numBytes != 0)) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "can't parse a NULL pointer", -1));
	}
	return TCL_ERROR;
    }
    parsePtr->commentStart = NULL;
    parsePtr->commentSize = 0;
    parsePtr->commandStart = NULL;
    parsePtr->commandSize = 0;
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298

	/* Are we missing white space after previous word? */

	if (scanned == 0) {
	    if (src[-1] == '"') {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "extra characters after close-quote", TCL_INDEX_NONE));
		}
		parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
	    } else {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "extra characters after close-brace", TCL_INDEX_NONE));
		}
		parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
	    }
	    parsePtr->term = src;
	error:
	    Tcl_FreeParse(parsePtr);
	    parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;







|





|







278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298

	/* Are we missing white space after previous word? */

	if (scanned == 0) {
	    if (src[-1] == '"') {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "extra characters after close-quote", -1));
		}
		parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
	    } else {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "extra characters after close-brace", -1));
		}
		parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
	    }
	    parsePtr->term = src;
	error:
	    Tcl_FreeParse(parsePtr);
	    parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
	 * case of a word consisting of a single range of literal text.
	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = (int)parsePtr->numTokens - (wordIndex + 1);
	if (expandWord) {
	    size_t i;
	    int isLiteral = 1;

	    /*
	     * When a command includes a word that is an expanded literal; for
	     * example, {*}{1 2 3}, the parser performs that expansion
	     * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
	     * of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()







|







378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
	 * case of a word consisting of a single range of literal text.
	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = (int)parsePtr->numTokens - (wordIndex + 1);
	if (expandWord) {
	    Tcl_Size i;
	    int isLiteral = 1;

	    /*
	     * When a command includes a word that is an expanded literal; for
	     * example, {*}{1 2 3}, the parser performs that expansion
	     * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
	     * of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439

		/*
		 * Step through the literal string, parsing and counting list
		 * elements.
		 */

		while (nextElem < listEnd) {
		    size_t size;

		    code = TclFindElement(NULL, nextElem, listEnd - nextElem,
			    &elemStart, &nextElem, &size, &literal);
		    if ((code != TCL_OK) || !literal) {
			break;
		    }
		    if (elemStart < listEnd) {







|







425
426
427
428
429
430
431
432
433
434
435
436
437
438
439

		/*
		 * Step through the literal string, parsing and counting list
		 * elements.
		 */

		while (nextElem < listEnd) {
		    Tcl_Size size;

		    code = TclFindElement(NULL, nextElem, listEnd - nextElem,
			    &elemStart, &nextElem, &size, &literal);
		    if ((code != TCL_OK) || !literal) {
			break;
		    }
		    if (elemStart < listEnd) {
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static size_t
ParseWhiteSpace(
    const char *src,		/* First character to parse. */
    size_t numBytes,		/* Max number of bytes to scan. */
    int *incompletePtr,		/* Set this boolean memory to true if parsing
				 * indicates an incomplete command. */
    char *typePtr)		/* Points to location to store character type
				 * of character that ends run of whitespace */
{
    char type = TYPE_NORMAL;
    const char *p = src;







|


|







617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Size
ParseWhiteSpace(
    const char *src,		/* First character to parse. */
    Tcl_Size numBytes,		/* Max number of bytes to scan. */
    int *incompletePtr,		/* Set this boolean memory to true if parsing
				 * indicates an incomplete command. */
    char *typePtr)		/* Points to location to store character type
				 * of character that ends run of whitespace */
{
    char type = TYPE_NORMAL;
    const char *p = src;
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
 *
 * Results:
 *	Returns the number of bytes recognized as white space.
 *
 *----------------------------------------------------------------------
 */

static size_t
ParseAllWhiteSpace(
    const char *src,		/* First character to parse. */
    size_t numBytes,		/* Max number of byes to scan */
    int *incompletePtr)		/* Set true if parse is incomplete. */
{
    char type;
    const char *p = src;

    do {
	size_t scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type);

	p += scanned;
	numBytes -= scanned;
    } while (numBytes && (*p == '\n') && (p++, --numBytes));
    return (p-src);
}

size_t
TclParseAllWhiteSpace(
    const char *src,		/* First character to parse. */
    size_t numBytes)		/* Max number of byes to scan */
{
    int dummy;
    return ParseAllWhiteSpace(src, numBytes, &dummy);
}

/*
 *----------------------------------------------------------------------







|


|






|







|


|







671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
 *
 * Results:
 *	Returns the number of bytes recognized as white space.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Size
ParseAllWhiteSpace(
    const char *src,		/* First character to parse. */
    Tcl_Size numBytes,		/* Max number of byes to scan */
    int *incompletePtr)		/* Set true if parse is incomplete. */
{
    char type;
    const char *p = src;

    do {
	Tcl_Size scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type);

	p += scanned;
	numBytes -= scanned;
    } while (numBytes && (*p == '\n') && (p++, --numBytes));
    return (p-src);
}

Tcl_Size
TclParseAllWhiteSpace(
    const char *src,		/* First character to parse. */
    Tcl_Size numBytes)		/* Max number of byes to scan */
{
    int dummy;
    return ParseAllWhiteSpace(src, numBytes, &dummy);
}

/*
 *----------------------------------------------------------------------
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
 *
 *----------------------------------------------------------------------
 */

int
ParseHex(
    const char *src,		/* First character to parse. */
    size_t numBytes,		/* Max number of byes to scan */
    int *resultPtr)		/* Points to storage provided by caller where
				 * the character resulting from the
				 * conversion is to be written. */
{
    int result = 0;
    const char *p = src;








|







723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
 *
 *----------------------------------------------------------------------
 */

int
ParseHex(
    const char *src,		/* First character to parse. */
    Tcl_Size numBytes,		/* Max number of byes to scan */
    int *resultPtr)		/* Points to storage provided by caller where
				 * the character resulting from the
				 * conversion is to be written. */
{
    int result = 0;
    const char *p = src;

779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
 *----------------------------------------------------------------------
 */

int
TclParseBackslash(
    const char *src,		/* Points to the backslash character of a
				 * backslash sequence. */
    size_t numBytes,		/* Max number of bytes to scan. */
    size_t *readPtr,		/* NULL, or points to storage where the number
				 * of bytes scanned should be written. */
    char *dst)			/* NULL, or points to buffer where the UTF-8
				 * encoding of the backslash sequence is to be
				 * written. At most 4 bytes will be written there. */
{
    const char *p = src+1;
    int unichar;
    int result;
    size_t count;
    char buf[4] = "";

    if (numBytes == 0) {
	if (readPtr != NULL) {
	    *readPtr = 0;
	}
	return 0;







|
|








|







779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
 *----------------------------------------------------------------------
 */

int
TclParseBackslash(
    const char *src,		/* Points to the backslash character of a
				 * backslash sequence. */
    Tcl_Size numBytes,		/* Max number of bytes to scan. */
    Tcl_Size *readPtr,		/* NULL, or points to storage where the number
				 * of bytes scanned should be written. */
    char *dst)			/* NULL, or points to buffer where the UTF-8
				 * encoding of the backslash sequence is to be
				 * written. At most 4 bytes will be written there. */
{
    const char *p = src+1;
    int unichar;
    int result;
    Tcl_Size count;
    char buf[4] = "";

    if (numBytes == 0) {
	if (readPtr != NULL) {
	    *readPtr = 0;
	}
	return 0;
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static size_t
ParseComment(
    const char *src,		/* First character to parse. */
    size_t numBytes,		/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr)	/* Information about parse in progress.
				 * Updated if parsing indicates an incomplete
				 * command. */
{
    const char *p = src;
    int incomplete = parsePtr->incomplete;

    while (numBytes) {
	size_t scanned = ParseAllWhiteSpace(p, numBytes, &incomplete);
	p += scanned;
	numBytes -= scanned;

	if ((numBytes == 0) || (*p != '#')) {
	    break;
	}
	if (parsePtr->commentStart == NULL) {







|


|








|







977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Size
ParseComment(
    const char *src,		/* First character to parse. */
    Tcl_Size numBytes,		/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr)	/* Information about parse in progress.
				 * Updated if parsing indicates an incomplete
				 * command. */
{
    const char *p = src;
    int incomplete = parsePtr->incomplete;

    while (numBytes) {
	Tcl_Size scanned = ParseAllWhiteSpace(p, numBytes, &incomplete);
	p += scanned;
	numBytes -= scanned;

	if ((numBytes == 0) || (*p != '#')) {
	    break;
	}
	if (parsePtr->commentStart == NULL) {
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(
    const char *src,	/* First character to parse. */
    size_t numBytes,		/* Max number of bytes to scan. */
    int mask,			/* Specifies when to stop parsing. The parse
				 * stops at the first unquoted character whose
				 * CHAR_TYPE contains any of the bits in
				 * mask. */
    int flags,			/* OR-ed bits indicating what substitutions to
				 * perform: TCL_SUBST_COMMANDS,
				 * TCL_SUBST_VARIABLES, and







|







1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(
    const char *src,	/* First character to parse. */
    Tcl_Size numBytes,		/* Max number of bytes to scan. */
    int mask,			/* Specifies when to stop parsing. The parse
				 * stops at the first unquoted character whose
				 * CHAR_TYPE contains any of the bits in
				 * mask. */
    int flags,			/* OR-ed bits indicating what substitutions to
				 * perform: TCL_SUBST_COMMANDS,
				 * TCL_SUBST_VARIABLES, and
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
			&& (*(nestedPtr->term) == ']')
			&& !(nestedPtr->incomplete)) {
		    break;
		}
		if (numBytes == 0) {
		    if (parsePtr->interp != NULL) {
			Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
				"missing close-bracket", TCL_INDEX_NONE));
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = 1;
		    TclStackFree(parsePtr->interp, nestedPtr);
		    return TCL_ERROR;
		}







|







1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
			&& (*(nestedPtr->term) == ']')
			&& !(nestedPtr->incomplete)) {
		    break;
		}
		if (numBytes == 0) {
		    if (parsePtr->interp != NULL) {
			Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
				"missing close-bracket", -1));
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = 1;
		    TclStackFree(parsePtr->interp, nestedPtr);
		    return TCL_ERROR;
		}
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360

int
Tcl_ParseVarName(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* Start of variable substitution string.
				 * First character must be "$". */
    size_t numBytes,		/* Total number of bytes in string. If -1,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr,	/* Structure to fill in with information about
				 * the variable name. */
    int append)			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
{
    Tcl_Token *tokenPtr;
    const char *src;
    int varIndex;
    unsigned array;

    if (numBytes == TCL_INDEX_NONE && start) {
	numBytes = strlen(start);
    }
    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }
    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;







|














|







1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360

int
Tcl_ParseVarName(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* Start of variable substitution string.
				 * First character must be "$". */
    Tcl_Size numBytes,		/* Total number of bytes in string. If -1,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr,	/* Structure to fill in with information about
				 * the variable name. */
    int append)			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
{
    Tcl_Token *tokenPtr;
    const char *src;
    int varIndex;
    unsigned array;

    if (numBytes < 0 && start) {
	numBytes = strlen(start);
    }
    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }
    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
	    numBytes--;
	    src++;
	    ch= *src;
	}
	if (numBytes == 0) {
	    if (parsePtr->interp != NULL) {
		Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			"missing close-brace for variable name", TCL_INDEX_NONE));
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
	    parsePtr->term = tokenPtr->start-1;
	    parsePtr->incomplete = 1;
	    goto error;
	}
	tokenPtr->size = src - tokenPtr->start;







|







1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
	    numBytes--;
	    src++;
	    ch= *src;
	}
	if (numBytes == 0) {
	    if (parsePtr->interp != NULL) {
		Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			"missing close-brace for variable name", -1));
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
	    parsePtr->term = tokenPtr->start-1;
	    parsePtr->incomplete = 1;
	    goto error;
	}
	tokenPtr->size = src - tokenPtr->start;
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
	    if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_BAD_ARRAY_INDEX,
		    TCL_SUBST_ALL, parsePtr)) {
		goto error;
	    }
	    if (parsePtr->term == src+numBytes){
		if (parsePtr->interp != NULL) {
		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			    "missing )", TCL_INDEX_NONE));
		}
		parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
		parsePtr->term = src;
		parsePtr->incomplete = 1;
		goto error;
	    } else if ((*parsePtr->term != ')')){
		if (parsePtr->interp != NULL) {
		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			    "invalid character in array index", TCL_INDEX_NONE));
		}
		parsePtr->errorType = TCL_PARSE_SYNTAX;
		parsePtr->term = src;
		goto error;
	    }
	    src = parsePtr->term + 1;
	}







|








|







1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
	    if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_BAD_ARRAY_INDEX,
		    TCL_SUBST_ALL, parsePtr)) {
		goto error;
	    }
	    if (parsePtr->term == src+numBytes){
		if (parsePtr->interp != NULL) {
		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			    "missing )", -1));
		}
		parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
		parsePtr->term = src;
		parsePtr->incomplete = 1;
		goto error;
	    } else if ((*parsePtr->term != ')')){
		if (parsePtr->interp != NULL) {
		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			    "invalid character in array index", -1));
		}
		parsePtr->errorType = TCL_PARSE_SYNTAX;
		parsePtr->term = src;
		goto error;
	    }
	    src = parsePtr->term + 1;
	}
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663

int
Tcl_ParseBraces(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* Start of string enclosed in braces. The
				 * first character must be {'. */
    size_t numBytes,		/* Total number of bytes in string. If -1,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr,
				/* Structure to fill in with information about
				 * the string. */
    int append,			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
    const char **termPtr)	/* If non-NULL, points to word in which to
				 * store a pointer to the character just after
				 * the terminating '}' if the parse was
				 * successful. */
{
    Tcl_Token *tokenPtr;
    const char *src;
    int startIndex, level;
    size_t length;

    if (numBytes == TCL_INDEX_NONE && start) {
	numBytes = strlen(start);
    }
    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }
    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;







|

















|

|







1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663

int
Tcl_ParseBraces(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* Start of string enclosed in braces. The
				 * first character must be {'. */
    Tcl_Size numBytes,		/* Total number of bytes in string. If -1,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr,
				/* Structure to fill in with information about
				 * the string. */
    int append,			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
    const char **termPtr)	/* If non-NULL, points to word in which to
				 * store a pointer to the character just after
				 * the terminating '}' if the parse was
				 * successful. */
{
    Tcl_Token *tokenPtr;
    const char *src;
    int startIndex, level;
    Tcl_Size length;

    if (numBytes < 0 && start) {
	numBytes = strlen(start);
    }
    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }
    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
	 * error message in.
	 */

	goto error;
    }

    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
	    "missing close-brace", TCL_INDEX_NONE));

    /*
     * Guess if the problem is due to comments by searching the source string
     * for a possible open brace within the context of a comment. Since we
     * aren't performing a full Tcl parse, just look for an open brace
     * preceded by a '<whitespace>#' on the same line.
     */







|







1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
	 * error message in.
	 */

	goto error;
    }

    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
	    "missing close-brace", -1));

    /*
     * Guess if the problem is due to comments by searching the source string
     * for a possible open brace within the context of a comment. Since we
     * aren't performing a full Tcl parse, just look for an open brace
     * preceded by a '<whitespace>#' on the same line.
     */
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
		break;
	    case '\n':
		openBrace = 0;
		break;
	    case '#' :
		if (openBrace && TclIsSpaceProcM(src[-1])) {
		    Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
			    ": possible unbalanced brace in comment", TCL_INDEX_NONE);
		    goto error;
		}
		break;
	    }
	}
    }








|







1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
		break;
	    case '\n':
		openBrace = 0;
		break;
	    case '#' :
		if (openBrace && TclIsSpaceProcM(src[-1])) {
		    Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
			    ": possible unbalanced brace in comment", -1);
		    goto error;
		}
		break;
	    }
	}
    }

1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877

int
Tcl_ParseQuotedString(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* Start of the quoted string. The first
				 * character must be '"'. */
    size_t numBytes,		/* Total number of bytes in string. If -1,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr,
				/* Structure to fill in with information about
				 * the string. */
    int append,			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
    const char **termPtr)	/* If non-NULL, points to word in which to
				 * store a pointer to the character just after
				 * the quoted string's terminating close-quote
				 * if the parse succeeds. */
{
    if (numBytes == TCL_INDEX_NONE && start) {
	numBytes = strlen(start);
    }
    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }
    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;
    }

    if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
	    parsePtr)) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (parsePtr->interp != NULL) {
	    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
		    "missing \"", TCL_INDEX_NONE));
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = start;
	parsePtr->incomplete = 1;
	goto error;
    }
    if (termPtr != NULL) {







|














|
















|







1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877

int
Tcl_ParseQuotedString(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting; if
				 * NULL, then no error message is provided. */
    const char *start,		/* Start of the quoted string. The first
				 * character must be '"'. */
    Tcl_Size numBytes,		/* Total number of bytes in string. If -1,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr,
				/* Structure to fill in with information about
				 * the string. */
    int append,			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and
				 * reinitialize it. */
    const char **termPtr)	/* If non-NULL, points to word in which to
				 * store a pointer to the character just after
				 * the quoted string's terminating close-quote
				 * if the parse succeeds. */
{
    if (numBytes < 0 && start) {
	numBytes = strlen(start);
    }
    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }
    if ((numBytes == 0) || (start == NULL)) {
	return TCL_ERROR;
    }

    if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
	    parsePtr)) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (parsePtr->interp != NULL) {
	    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
		    "missing \"", -1));
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = start;
	parsePtr->incomplete = 1;
	goto error;
    }
    if (termPtr != NULL) {
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
 *----------------------------------------------------------------------
 */

void
TclSubstParse(
    Tcl_Interp *interp,
    const char *bytes,
    size_t numBytes,
    int flags,
    Tcl_Parse *parsePtr,
    Tcl_InterpState *statePtr)
{
    size_t length = numBytes;
    const char *p = bytes;

    TclParseInit(interp, p, length, parsePtr);

    /*
     * First parse the string rep of objPtr, as if it were enclosed as a
     * "-quoted word in a normal Tcl command. Honor flags that selectively







|




|







1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
 *----------------------------------------------------------------------
 */

void
TclSubstParse(
    Tcl_Interp *interp,
    const char *bytes,
    Tcl_Size numBytes,
    int flags,
    Tcl_Parse *parsePtr,
    Tcl_InterpState *statePtr)
{
    Tcl_Size length = numBytes;
    const char *p = bytes;

    TclParseInit(interp, p, length, parsePtr);

    /*
     * First parse the string rep of objPtr, as if it were enclosed as a
     * "-quoted word in a normal Tcl command. Honor flags that selectively
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
int
TclSubstTokens(
    Tcl_Interp *interp,		/* Interpreter in which to lookup variables,
				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    size_t count,			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    int *tokensLeftPtr,		/* If not NULL, points to memory where an
				 * integer representing the number of tokens
				 * left to be substituted will be written */
    size_t line,			/* The line the script starts on. */
    int *clNextOuter,		/* Information about an outer context for */
    const char *outerScript)	/* continuation line data. This is set by
				 * EvalEx() to properly handle [...]-nested
				 * commands. The 'outerScript' refers to the
				 * most-outer script containing the embedded
				 * command, which is refered to by 'script'.
				 * The 'clNextOuter' refers to the current







|




|







2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
int
TclSubstTokens(
    Tcl_Interp *interp,		/* Interpreter in which to lookup variables,
				 * execute nested commands, and report
				 * errors. */
    Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
				 * evaluate and concatenate. */
    Tcl_Size count,		/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    int *tokensLeftPtr,		/* If not NULL, points to memory where an
				 * integer representing the number of tokens
				 * left to be substituted will be written */
    Tcl_Size line,		/* The line the script starts on. */
    int *clNextOuter,		/* Information about an outer context for */
    const char *outerScript)	/* continuation line data. This is set by
				 * EvalEx() to properly handle [...]-nested
				 * commands. The 'outerScript' refers to the
				 * most-outer script containing the embedded
				 * command, which is refered to by 'script'.
				 * The 'clNextOuter' refers to the current
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
				 * for the places generating arguments for
				 * which this is true. */
{
    Tcl_Obj *result;
    int code = TCL_OK;
#define NUM_STATIC_POS 20
    int isLiteral;
    size_t i, maxNumCL, numCL, adjust;
    int *clPosition = NULL;
    Interp *iPtr = (Interp *) interp;
    int inFile = iPtr->evalFlags & TCL_EVAL_FILE;

    /*
     * Each pass through this loop will substitute one token, and its
     * components, if any. The only thing tricky here is that we go to some







|







2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
				 * for the places generating arguments for
				 * which this is true. */
{
    Tcl_Obj *result;
    int code = TCL_OK;
#define NUM_STATIC_POS 20
    int isLiteral;
    Tcl_Size i, maxNumCL, numCL, adjust;
    int *clPosition = NULL;
    Interp *iPtr = (Interp *) interp;
    int inFile = iPtr->evalFlags & TCL_EVAL_FILE;

    /*
     * Each pass through this loop will substitute one token, and its
     * components, if any. The only thing tricky here is that we go to some
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
	     * everything, just the number of lines we have to add as
	     * correction.
	     */

	    if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
		    && (tokenPtr->start[1] == '\n')) {
		if (isLiteral) {
		    size_t clPos;

		    if (result == 0) {
			clPos = 0;
		    } else {
			(void)Tcl_GetStringFromObj(result, &clPos);
		    }








|







2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
	     * everything, just the number of lines we have to add as
	     * correction.
	     */

	    if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
		    && (tokenPtr->start[1] == '\n')) {
		if (isLiteral) {
		    Tcl_Size clPos;

		    if (result == 0) {
			clPos = 0;
		    } else {
			(void)Tcl_GetStringFromObj(result, &clPos);
		    }

2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
	    iPtr->numLevels++;
	    code = TclInterpReady(interp);
	    if (code == TCL_OK) {
		/*
		 * Test cases: info-30.{6,8,9}
		 */

		size_t theline;

		TclAdvanceContinuations(&line, &clNextOuter,
			tokenPtr->start - outerScript);
		theline = line + adjust;
		code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
			0, theline, clNextOuter, outerScript);








|







2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
	    iPtr->numLevels++;
	    code = TclInterpReady(interp);
	    if (code == TCL_OK) {
		/*
		 * Test cases: info-30.{6,8,9}
		 */

		Tcl_Size theline;

		TclAdvanceContinuations(&line, &clNextOuter,
			tokenPtr->start - outerScript);
		theline = line + adjust;
		code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
			0, theline, clNextOuter, outerScript);

2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
 *
 *----------------------------------------------------------------------
 */

static int
CommandComplete(
    const char *script,		/* Script to check. */
    size_t numBytes)		/* Number of bytes in script. */
{
    Tcl_Parse parse;
    const char *p, *end;
    int result;

    p = script;
    end = p + numBytes;







|







2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
 *
 *----------------------------------------------------------------------
 */

static int
CommandComplete(
    const char *script,		/* Script to check. */
    Tcl_Size numBytes)		/* Number of bytes in script. */
{
    Tcl_Parse parse;
    const char *p, *end;
    int result;

    p = script;
    end = p + numBytes;
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
 */

int
TclObjCommandComplete(
    Tcl_Obj *objPtr)		/* Points to object holding script to
				 * check. */
{
    size_t length;
    const char *script = Tcl_GetStringFromObj(objPtr, &length);

    return CommandComplete(script, length);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|












2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
 */

int
TclObjCommandComplete(
    Tcl_Obj *objPtr)		/* Points to object holding script to
				 * check. */
{
    Tcl_Size length;
    const char *script = Tcl_GetStringFromObj(objPtr, &length);

    return CommandComplete(script, length);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclPathObj.c.

473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSGetPathType(
    Tcl_Obj *pathPtr,
    const Tcl_Filesystem **filesystemPtrPtr,
    size_t *driveNameLengthPtr)
{
    FsPath *fsPathPtr;

    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
		NULL);
    }







|







473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclFSGetPathType(
    Tcl_Obj *pathPtr,
    const Tcl_Filesystem **filesystemPtrPtr,
    Tcl_Size *driveNameLengthPtr)
{
    FsPath *fsPathPtr;

    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
		NULL);
    }
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
	    /* Relative path */
	    goto standardPath;
	} else {
	    /* Absolute path */
	    goto standardPath;
	}
    } else {
	size_t splitElements;
	Tcl_Obj *splitPtr, *resultPtr;

    standardPath:
	resultPtr = NULL;
	if (portion == TCL_PATH_EXTENSION) {
	    return GetExtension(pathPtr);
	} else if (portion == TCL_PATH_ROOT) {







|







663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
	    /* Relative path */
	    goto standardPath;
	} else {
	    /* Absolute path */
	    goto standardPath;
	}
    } else {
	Tcl_Size splitElements;
	Tcl_Obj *splitPtr, *resultPtr;

    standardPath:
	resultPtr = NULL;
	if (portion == TCL_PATH_EXTENSION) {
	    return GetExtension(pathPtr);
	} else if (portion == TCL_PATH_ROOT) {
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
    Tcl_Obj *ret;

    tail = TclGetString(pathPtr);
    extension = TclGetExtension(tail);
    if (extension == NULL) {
	TclNewObj(ret);
    } else {
	ret = Tcl_NewStringObj(extension, TCL_INDEX_NONE);
    }
    Tcl_IncrRefCount(ret);
    return ret;
}

/*
 *---------------------------------------------------------------------------







|







747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
    Tcl_Obj *ret;

    tail = TclGetString(pathPtr);
    extension = TclGetExtension(tail);
    if (extension == NULL) {
	TclNewObj(ret);
    } else {
	ret = Tcl_NewStringObj(extension, -1);
    }
    Tcl_IncrRefCount(ret);
    return ret;
}

/*
 *---------------------------------------------------------------------------
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSJoinPath(
    Tcl_Obj *listObj,		/* Path elements to join, may have a zero
				 * reference count. */
    size_t elements)		/* Number of elements to use (-1 = all) */
{
    Tcl_Obj *res;
    size_t objc;
    Tcl_Obj **objv;

    if (TclListObjLengthM(NULL, listObj, &objc) != TCL_OK) {
	return NULL;
    }

    elements = ((elements != TCL_INDEX_NONE) && (elements <= objc)) ? elements : objc;
    TclListObjGetElementsM(NULL, listObj, &objc, &objv);
    res = TclJoinPath(elements, objv, 0);
    return res;
}

Tcl_Obj *
TclJoinPath(
    size_t elements,		/* Number of elements to use */
    Tcl_Obj * const objv[],	/* Path elements to join */
    int forceRelative)		/* If non-zero, assume all more paths are
				 * relative (e.g. simple normalization) */
{
    Tcl_Obj *res = NULL;
    size_t i;
    const Tcl_Filesystem *fsPtr = NULL;

    if (elements == 0) {
	TclNewObj(res);
	return res;
    }








|


|






|







|





|







791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSJoinPath(
    Tcl_Obj *listObj,		/* Path elements to join, may have a zero
				 * reference count. */
    Tcl_Size elements)		/* Number of elements to use (-1 = all) */
{
    Tcl_Obj *res;
    Tcl_Size objc;
    Tcl_Obj **objv;

    if (TclListObjLengthM(NULL, listObj, &objc) != TCL_OK) {
	return NULL;
    }

    elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
    TclListObjGetElementsM(NULL, listObj, &objc, &objv);
    res = TclJoinPath(elements, objv, 0);
    return res;
}

Tcl_Obj *
TclJoinPath(
    Tcl_Size elements,		/* Number of elements to use */
    Tcl_Obj * const objv[],	/* Path elements to join */
    int forceRelative)		/* If non-zero, assume all more paths are
				 * relative (e.g. simple normalization) */
{
    Tcl_Obj *res = NULL;
    Tcl_Size i;
    const Tcl_Filesystem *fsPtr = NULL;

    if (elements == 0) {
	TclNewObj(res);
	return res;
    }

852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
	    Tcl_PathType type;

	    /* if forceRelative - second path is relative */
	    type = forceRelative ? TCL_PATH_RELATIVE :
		    TclGetPathType(tailObj, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		const char *str;
		size_t len;

		str = Tcl_GetStringFromObj(tailObj, &len);
		if (len == 0) {
		    /*
		     * This happens if we try to handle the root volume '/'.
		     * There's no need to return a special path object, when
		     * the base itself is just fine!







|







852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
	    Tcl_PathType type;

	    /* if forceRelative - second path is relative */
	    type = forceRelative ? TCL_PATH_RELATIVE :
		    TclGetPathType(tailObj, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		const char *str;
		Tcl_Size len;

		str = Tcl_GetStringFromObj(tailObj, &len);
		if (len == 0) {
		    /*
		     * This happens if we try to handle the root volume '/'.
		     * There's no need to return a special path object, when
		     * the base itself is just fine!
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
	    }
	}
    }

    assert ( res == NULL );

    for (i = 0; i < elements; i++) {
	size_t driveNameLength;
	size_t strEltLen, length;
	Tcl_PathType type;
	char *strElt, *ptr;
	Tcl_Obj *driveName = NULL;
	Tcl_Obj *elt = objv[i];

	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	driveNameLength = 0;







|
|







919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
	    }
	}
    }

    assert ( res == NULL );

    for (i = 0; i < elements; i++) {
	Tcl_Size driveNameLength;
	Tcl_Size strEltLen, length;
	Tcl_PathType type;
	char *strElt, *ptr;
	Tcl_Obj *driveName = NULL;
	Tcl_Obj *elt = objv[i];

	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	driveNameLength = 0;
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclNewFSPathObj(
    Tcl_Obj *dirPtr,
    const char *addStrRep,
    size_t len)
{
    FsPath *fsPathPtr;
    Tcl_Obj *pathPtr;
    const char *p;
    int state = 0, count = 0;

    /*







|







1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclNewFSPathObj(
    Tcl_Obj *dirPtr,
    const char *addStrRep,
    Tcl_Size len)
{
    FsPath *fsPathPtr;
    Tcl_Obj *pathPtr;
    const char *p;
    int state = 0, count = 0;

    /*
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283

    /*
     * Look for path components made up of only "."
     * This is overly conservative analysis to keep simple. It may mark some
     * things as needing more aggressive normalization that don't actually
     * need it. No harm done.
     */
    for (p = addStrRep; len+1 > 1; p++, len--) {
	switch (state) {
	case 0:		/* So far only "." since last dirsep or start */
	    switch (*p) {
	    case '.':
		count = 1;
		break;
	    case '/':







|







1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283

    /*
     * Look for path components made up of only "."
     * This is overly conservative analysis to keep simple. It may mark some
     * things as needing more aggressive normalization that don't actually
     * need it. No harm done.
     */
    for (p = addStrRep; len > 0; p++, len--) {
	switch (state) {
	case 0:		/* So far only "." since last dirsep or start */
	    switch (*p) {
	    case '.':
		count = 1;
		break;
	    case '/':
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
static Tcl_Obj *
AppendPath(
    Tcl_Obj *head,
    Tcl_Obj *tail)
{
    const char *bytes;
    Tcl_Obj *copy = Tcl_DuplicateObj(head);
    size_t length;

    /*
     * This is likely buggy when dealing with virtual filesystem drivers
     * that use some character other than "/" as a path separator.  I know
     * of no evidence that such a foolish thing exists.  This solution was
     * chosen so that "JoinPath" operations that pass through either path
     * internalrep produce the same results; that is, bugward compatibility.  If







|







1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
static Tcl_Obj *
AppendPath(
    Tcl_Obj *head,
    Tcl_Obj *tail)
{
    const char *bytes;
    Tcl_Obj *copy = Tcl_DuplicateObj(head);
    Tcl_Size length;

    /*
     * This is likely buggy when dealing with virtual filesystem drivers
     * that use some character other than "/" as a path separator.  I know
     * of no evidence that such a foolish thing exists.  This solution was
     * chosen so that "JoinPath" operations that pass through either path
     * internalrep produce the same results; that is, bugward compatibility.  If
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclResolveTildePathList(
    Tcl_Obj *pathsObj)
{
    Tcl_Obj **objv;
    size_t objc;
    size_t i;
    Tcl_Obj *resolvedPaths;
    const char *path;

    if (pathsObj == NULL) {
        return NULL;
    }
    if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) {







|
|







2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
 *----------------------------------------------------------------------
 */
Tcl_Obj *
TclResolveTildePathList(
    Tcl_Obj *pathsObj)
{
    Tcl_Obj **objv;
    Tcl_Size objc;
    Tcl_Size i;
    Tcl_Obj *resolvedPaths;
    const char *path;

    if (pathsObj == NULL) {
        return NULL;
    }
    if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) {

Changes to generic/tclPipe.c.

175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DetachPids(
    size_t numPids,		/* Number of pids to detach: gives size of
				 * array pointed to by pidPtr. */
    Tcl_Pid *pidPtr)		/* Array of pids to detach. */
{
    Detached *detPtr;
    size_t i;

    Tcl_MutexLock(&pipeMutex);
    for (i = 0; i < numPids; i++) {
	detPtr = (Detached *)Tcl_Alloc(sizeof(Detached));
	detPtr->pid = pidPtr[i];
	detPtr->nextPtr = detList;
	detList = detPtr;







|




|







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DetachPids(
    Tcl_Size numPids,		/* Number of pids to detach: gives size of
				 * array pointed to by pidPtr. */
    Tcl_Pid *pidPtr)		/* Array of pids to detach. */
{
    Detached *detPtr;
    Tcl_Size i;

    Tcl_MutexLock(&pipeMutex);
    for (i = 0; i < numPids; i++) {
	detPtr = (Detached *)Tcl_Alloc(sizeof(Detached));
	detPtr->pid = pidPtr[i];
	detPtr->nextPtr = detList;
	detList = detPtr;
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
 *
 *----------------------------------------------------------------------
 */

int
TclCleanupChildren(
    Tcl_Interp *interp,		/* Used for error messages. */
    size_t numPids,		/* Number of entries in pidPtr array. */
    Tcl_Pid *pidPtr,		/* Array of process ids of children. */
    Tcl_Channel errorChan)	/* Channel for file containing stderr output
				 * from pipeline. NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK;
    int code, abnormalExit, anyErrorInfo;
    TclProcessWaitStatus waitStatus;
    size_t i;
    Tcl_Obj *msg, *error;

    abnormalExit = 0;
    for (i = 0; i < numPids; i++) {
	waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
	if (waitStatus == TCL_PROCESS_ERROR) {
	    result = TCL_ERROR;







|








|







265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
 *
 *----------------------------------------------------------------------
 */

int
TclCleanupChildren(
    Tcl_Interp *interp,		/* Used for error messages. */
    Tcl_Size numPids,		/* Number of entries in pidPtr array. */
    Tcl_Pid *pidPtr,		/* Array of process ids of children. */
    Tcl_Channel errorChan)	/* Channel for file containing stderr output
				 * from pipeline. NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK;
    int code, abnormalExit, anyErrorInfo;
    TclProcessWaitStatus waitStatus;
    Tcl_Size i;
    Tcl_Obj *msg, *error;

    abnormalExit = 0;
    for (i = 0; i < numPids; i++) {
	waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
	if (waitStatus == TCL_PROCESS_ERROR) {
	    result = TCL_ERROR;
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
    /*
     * If a child exited abnormally but didn't output any error information at
     * all, generate an error message here.
     */

    if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"child process exited abnormally", TCL_INDEX_NONE));
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *







|







357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
    /*
     * If a child exited abnormally but didn't output any error information at
     * all, generate an error message here.
     */

    if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"child process exited abnormally", -1));
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
 *
 * Side effects:
 *	Processes and pipes are created.
 *
 *----------------------------------------------------------------------
 */

size_t
TclCreatePipeline(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    size_t argc,			/* Number of entries in argv. */
    const char **argv,		/* Array of strings describing commands in
				 * pipeline plus I/O redirection with <, <<,
				 * >, etc. Argv[argc] must be NULL. */
    Tcl_Pid **pidArrayPtr,	/* Word at *pidArrayPtr gets filled in with
				 * address of array of pids for processes in
				 * pipeline (first pid is first process in
				 * pipeline). */







|


|







391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
 *
 * Side effects:
 *	Processes and pipes are created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
TclCreatePipeline(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    Tcl_Size argc,		/* Number of entries in argv. */
    const char **argv,		/* Array of strings describing commands in
				 * pipeline plus I/O redirection with <, <<,
				 * >, etc. Argv[argc] must be NULL. */
    Tcl_Pid **pidArrayPtr,	/* Word at *pidArrayPtr gets filled in with
				 * address of array of pids for processes in
				 * pipeline (first pid is first process in
				 * pipeline). */
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
				 * this is NULL, then all stderr output goes
				 * to our stderr. If the pipeline specifies
				 * redirection then the file will still be
				 * created but it will never get any data. */
{
    Tcl_Pid *pidPtr = NULL;	/* Points to malloc-ed array holding all the
				 * pids of child processes. */
    size_t numPids;		/* Actual number of processes that exist at
				 * *pidPtr right now. */
    size_t cmdCount;		/* Count of number of distinct commands found
				 * in argc/argv. */
    const char *inputLiteral = NULL;
				/* If non-null, then this points to a string
				 * containing input data (specified via <<) to
				 * be piped to the first process in the
				 * pipeline. */
    TclFile inputFile = NULL;	/* If != NULL, gives file to use as input for







|

|







427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
				 * this is NULL, then all stderr output goes
				 * to our stderr. If the pipeline specifies
				 * redirection then the file will still be
				 * created but it will never get any data. */
{
    Tcl_Pid *pidPtr = NULL;	/* Points to malloc-ed array holding all the
				 * pids of child processes. */
    Tcl_Size numPids;		/* Actual number of processes that exist at
				 * *pidPtr right now. */
    Tcl_Size cmdCount;		/* Count of number of distinct commands found
				 * in argc/argv. */
    const char *inputLiteral = NULL;
				/* If non-null, then this points to a string
				 * containing input data (specified via <<) to
				 * be piped to the first process in the
				 * pipeline. */
    TclFile inputFile = NULL;	/* If != NULL, gives file to use as input for
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
				 * stderr. */
    int errorClose = 0;		/* If non-zero, then errorFile should be
				 * closed when cleaning up. */
    int errorRelease = 0;
    const char *p;
    const char *nextArg;
    int skip, atOK, flags, needCmd, errorToOutput = 0;
    size_t i, j, lastArg, lastBar;
    Tcl_DString execBuffer;
    TclFile pipeIn;
    TclFile curInFile, curOutFile, curErrFile;
    Tcl_Channel channel;

    if (inPipePtr != NULL) {
	*inPipePtr = NULL;







|







457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
				 * stderr. */
    int errorClose = 0;		/* If non-zero, then errorFile should be
				 * closed when cleaning up. */
    int errorRelease = 0;
    const char *p;
    const char *nextArg;
    int skip, atOK, flags, needCmd, errorToOutput = 0;
    Tcl_Size i, j, lastArg, lastBar;
    Tcl_DString execBuffer;
    TclFile pipeIn;
    TclFile curInFile, curOutFile, curErrFile;
    Tcl_Channel channel;

    if (inPipePtr != NULL) {
	*inPipePtr = NULL;
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
     * second pass to separate the individual child processes. Cannot start
     * the child processes in this pass because the redirection symbols may
     * appear anywhere in the command line - e.g., the '<' that specifies the
     * input to the entire pipe may appear at the very end of the argument
     * list.
     */

    lastBar = TCL_INDEX_NONE;
    cmdCount = 1;
    needCmd = 1;
    for (i = 0; i < argc; i++) {
	errorToOutput = 0;
	skip = 0;
	p = argv[i];
	switch (*p++) {
	case '|':
	    if (*p == '&') {
		p++;
	    }
	    if (*p == '\0') {
		if ((i == (lastBar + 1)) || (i == (argc - 1))) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "illegal use of | or |& in command", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
			    "PIPESYNTAX", NULL);
		    goto error;
		}
	    }
	    lastBar = i;
	    cmdCount++;







|














|







493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
     * second pass to separate the individual child processes. Cannot start
     * the child processes in this pass because the redirection symbols may
     * appear anywhere in the command line - e.g., the '<' that specifies the
     * input to the entire pipe may appear at the very end of the argument
     * list.
     */

    lastBar = -1;
    cmdCount = 1;
    needCmd = 1;
    for (i = 0; i < argc; i++) {
	errorToOutput = 0;
	skip = 0;
	p = argv[i];
	switch (*p++) {
	case '|':
	    if (*p == '&') {
		p++;
	    }
	    if (*p == '\0') {
		if ((i == (lastBar + 1)) || (i == (argc - 1))) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "illegal use of | or |& in command", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
			    "PIPESYNTAX", NULL);
		    goto error;
		}
	    }
	    lastBar = i;
	    cmdCount++;
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710

    if (needCmd) {
	/*
	 * We had a bar followed only by redirections.
	 */

	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"illegal use of | or |& in command", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
		NULL);
	goto error;
    }

    if (inputFile == NULL) {
	if (inputLiteral != NULL) {







|







696
697
698
699
700
701
702
703
704
705
706
707
708
709
710

    if (needCmd) {
	/*
	 * We had a bar followed only by redirections.
	 */

	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"illegal use of | or |& in command", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
		NULL);
	goto error;
    }

    if (inputFile == NULL) {
	if (inputLiteral != NULL) {
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenCommandChannel(
    Tcl_Interp *interp,		/* Interpreter for error reporting. Can NOT be
				 * NULL. */
    size_t argc,			/* How many arguments. */
    const char **argv,		/* Array of arguments for command pipe. */
    int flags)			/* Or'ed combination of TCL_STDIN, TCL_STDOUT,
				 * TCL_STDERR, and TCL_ENFORCE_MODE. */
{
    TclFile *inPipePtr, *outPipePtr, *errFilePtr;
    TclFile inPipe, outPipe, errFile;
    size_t numPids;
    Tcl_Pid *pidPtr = NULL;
    Tcl_Channel channel;

    inPipe = outPipe = errFile = NULL;

    inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL;
    outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL;
    errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL;

    numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr,
	    outPipePtr, errFilePtr);

    if (numPids == TCL_INDEX_NONE) {
	goto error;
    }

    /*
     * Verify that the pipes that were created satisfy the readable/writable
     * constraints.
     */

    if (flags & TCL_ENFORCE_MODE) {
	if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "can't read output from command:"
		    " standard output was redirected", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
		    "BADREDIRECT", NULL);
	    goto error;
	}
	if ((flags & TCL_STDIN) && (inPipe == NULL)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "can't write input to command:"
		    " standard input was redirected", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
		    "BADREDIRECT", NULL);
	    goto error;
	}
    }

    channel = TclpCreateCommandChannel(outPipe, inPipe, errFile,
	    numPids, pidPtr);

    if (channel == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"pipe for command could not be created", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
	goto error;
    }
    return channel;

  error:
    if (pidPtr) {







|






|












|












|







|











|







1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_OpenCommandChannel(
    Tcl_Interp *interp,		/* Interpreter for error reporting. Can NOT be
				 * NULL. */
    Tcl_Size argc,			/* How many arguments. */
    const char **argv,		/* Array of arguments for command pipe. */
    int flags)			/* Or'ed combination of TCL_STDIN, TCL_STDOUT,
				 * TCL_STDERR, and TCL_ENFORCE_MODE. */
{
    TclFile *inPipePtr, *outPipePtr, *errFilePtr;
    TclFile inPipe, outPipe, errFile;
    Tcl_Size numPids;
    Tcl_Pid *pidPtr = NULL;
    Tcl_Channel channel;

    inPipe = outPipe = errFile = NULL;

    inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL;
    outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL;
    errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL;

    numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr,
	    outPipePtr, errFilePtr);

    if (numPids < 0) {
	goto error;
    }

    /*
     * Verify that the pipes that were created satisfy the readable/writable
     * constraints.
     */

    if (flags & TCL_ENFORCE_MODE) {
	if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "can't read output from command:"
		    " standard output was redirected", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
		    "BADREDIRECT", NULL);
	    goto error;
	}
	if ((flags & TCL_STDIN) && (inPipe == NULL)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "can't write input to command:"
		    " standard input was redirected", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
		    "BADREDIRECT", NULL);
	    goto error;
	}
    }

    channel = TclpCreateCommandChannel(outPipe, inPipe, errFile,
	    numPids, pidPtr);

    if (channel == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"pipe for command could not be created", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
	goto error;
    }
    return channel;

  error:
    if (pidPtr) {

Changes to generic/tclPkg.c.

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
{
    Package *pkgPtr;
    char *pvi, *vi;
    int res;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = Tcl_NewStringObj(version, TCL_INDEX_NONE);
	Tcl_IncrRefCount(pkgPtr->version);
	pkgPtr->clientData = clientData;
	return TCL_OK;
    }

    if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
	    NULL) != TCL_OK) {







|







161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
{
    Package *pkgPtr;
    char *pvi, *vi;
    int res;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = Tcl_NewStringObj(version, -1);
	Tcl_IncrRefCount(pkgPtr->version);
	pkgPtr->clientData = clientData;
	return TCL_OK;
    }

    if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
	    NULL) != TCL_OK) {
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	if (isNew) {
	    TclNewObj(list);
	    Tcl_SetHashValue(entry, list);
	    Tcl_IncrRefCount(list);
	} else {
	    list = (Tcl_Obj *)Tcl_GetHashValue(entry);
	}
	Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, TCL_INDEX_NONE));
    }
}

#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
    Tcl_Interp *interp,		/* Interpreter in which package is now







|







287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	if (isNew) {
	    TclNewObj(list);
	    Tcl_SetHashValue(entry, list);
	    Tcl_IncrRefCount(list);
	} else {
	    list = (Tcl_Obj *)Tcl_GetHashValue(entry);
	}
	Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
    }
}

#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
    Tcl_Interp *interp,		/* Interpreter in which package is now
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
	    Tcl_ResetResult(interp);
	}
    } else {
	if (exact && TCL_OK
		!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
	    return NULL;
	}
	ov = Tcl_NewStringObj(version, TCL_INDEX_NONE);
	if (exact) {
	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	}
	Tcl_IncrRefCount(ov);
	if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
	    result = Tcl_GetStringResult(interp);
	    Tcl_ResetResult(interp);
	}
	TclDecrRefCount(ov);
    }
    return result;
}

int
Tcl_PkgRequireProc(
    Tcl_Interp *interp,		/* Interpreter in which package is now
				 * available. */
    const char *name,		/* Name of desired package. */
    size_t reqc,			/* Requirements constraining the desired
				 * version. */
    Tcl_Obj *const reqv[],	/* 0 means to use the latest version
				 * available. */
    void *clientDataPtr)
{
    RequireProcArgs args;








|


















|







403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
	    Tcl_ResetResult(interp);
	}
    } else {
	if (exact && TCL_OK
		!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
	    return NULL;
	}
	ov = Tcl_NewStringObj(version, -1);
	if (exact) {
	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	}
	Tcl_IncrRefCount(ov);
	if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
	    result = Tcl_GetStringResult(interp);
	    Tcl_ResetResult(interp);
	}
	TclDecrRefCount(ov);
    }
    return result;
}

int
Tcl_PkgRequireProc(
    Tcl_Interp *interp,		/* Interpreter in which package is now
				 * available. */
    const char *name,		/* Name of desired package. */
    Tcl_Size reqc,		/* Requirements constraining the desired
				 * version. */
    Tcl_Obj *const reqv[],	/* 0 means to use the latest version
				 * available. */
    void *clientDataPtr)
{
    RequireProcArgs args;

527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
    }

    /*
     * Invoke the "package unknown" script synchronously.
     */

    Tcl_DStringInit(&command);
    Tcl_DStringAppend(&command, script, TCL_INDEX_NONE);
    Tcl_DStringAppendElement(&command, name);
    AddRequirementsToDString(&command, reqc, reqv);

    Tcl_NRAddCallback(interp,
	    PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
    Tcl_NREvalObj(interp,
	    Tcl_NewStringObj(Tcl_DStringValue(&command),







|







527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
    }

    /*
     * Invoke the "package unknown" script synchronously.
     */

    Tcl_DStringInit(&command);
    Tcl_DStringAppend(&command, script, -1);
    Tcl_DStringAppendElement(&command, name);
    AddRequirementsToDString(&command, reqc, reqv);

    Tcl_NRAddCallback(interp,
	    PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
    Tcl_NREvalObj(interp,
	    Tcl_NewStringObj(Tcl_DStringValue(&command),
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
	if (bestPtr->pkgIndex) {
	    TclPkgFileSeen(interp, bestPtr->pkgIndex);
	}
	reqPtr->versionToProvide = versionToProvide;
	Tcl_NRAddCallback(interp,
		SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv,
		data[3]);
	Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, TCL_INDEX_NONE),
		TCL_EVAL_GLOBAL);
    }
    return TCL_OK;
}

static int
SelectPackageFinal(







|







835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
	if (bestPtr->pkgIndex) {
	    TclPkgFileSeen(interp, bestPtr->pkgIndex);
	}
	reqPtr->versionToProvide = versionToProvide;
	Tcl_NRAddCallback(interp,
		SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv,
		data[3]);
	Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1),
		TCL_EVAL_GLOBAL);
    }
    return TCL_OK;
}

static int
SelectPackageFinal(
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
    enum pkgOptionsEnum {
	PKG_FILES,  PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,
	PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE,
	PKG_VERSIONS, PKG_VSATISFIES
    } optionIndex;
    Interp *iPtr = (Interp *) interp;
    int exact, satisfies;
    size_t i, newobjc;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    const char *version;
    const char *argv2, *argv3, *argv4;







|







1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
    enum pkgOptionsEnum {
	PKG_FILES,  PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,
	PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE,
	PKG_VERSIONS, PKG_VSATISFIES
    } optionIndex;
    Interp *iPtr = (Interp *) interp;
    int exact, satisfies;
    Tcl_Size i, newobjc;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    const char *version;
    const char *argv2, *argv3, *argv4;
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
	break;
    }
    case PKG_FORGET: {
	const char *keyString;
	PkgFiles *pkgFiles = (PkgFiles *)
		Tcl_GetAssocData(interp, "tclPkgFiles", NULL);

	for (i = 2; i < (size_t)objc; i++) {
	    keyString = TclGetString(objv[i]);
	    if (pkgFiles) {
		hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
		if (hPtr) {
		    Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
		    Tcl_DeleteHashEntry(hPtr);
		    Tcl_DecrRefCount(obj);







|







1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
	break;
    }
    case PKG_FORGET: {
	const char *keyString;
	PkgFiles *pkgFiles = (PkgFiles *)
		Tcl_GetAssocData(interp, "tclPkgFiles", NULL);

	for (i = 2; i < objc; i++) {
	    keyString = TclGetString(objv[i]);
	    if (pkgFiles) {
		hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
		if (hPtr) {
		    Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
		    Tcl_DeleteHashEntry(hPtr);
		    Tcl_DecrRefCount(obj);
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
	    res = CompareVersions(avi, argv3i, NULL);
	    Tcl_Free(avi);

	    if (res == 0) {
		if (objc == 4) {
		    Tcl_Free(argv3i);
		    Tcl_SetObjResult(interp,
			    Tcl_NewStringObj(availPtr->script, TCL_INDEX_NONE));
		    return TCL_OK;
		}
		Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
		if (availPtr->pkgIndex) {
		    Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
		    availPtr->pkgIndex = NULL;
		}







|







1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
	    res = CompareVersions(avi, argv3i, NULL);
	    Tcl_Free(avi);

	    if (res == 0) {
		if (objc == 4) {
		    Tcl_Free(argv3i);
		    Tcl_SetObjResult(interp,
			    Tcl_NewStringObj(availPtr->script, -1));
		    return TCL_OK;
		}
		Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
		if (availPtr->pkgIndex) {
		    Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
		    availPtr->pkgIndex = NULL;
		}
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
	    TclNewObj(resultObj);
	    tablePtr = &iPtr->packageTable;
	    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
		    hPtr = Tcl_NextHashEntry(&search)) {
		pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
		if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
		    Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
			    (char *)Tcl_GetHashKey(tablePtr, hPtr), TCL_INDEX_NONE));
		}
	    }
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case PKG_PRESENT: {
	const char *name;







|







1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
	    TclNewObj(resultObj);
	    tablePtr = &iPtr->packageTable;
	    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
		    hPtr = Tcl_NextHashEntry(&search)) {
		pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
		if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
		    Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
			    (char *)Tcl_GetHashKey(tablePtr, hPtr), -1));
		}
	    }
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case PKG_PRESENT: {
	const char *name;
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
		return TCL_ERROR;
	    }

	    /*
	     * Create a new-style requirement for the exact version.
	     */

	    ov = Tcl_NewStringObj(version, TCL_INDEX_NONE);
	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	    version = NULL;
	    argv3 = TclGetString(objv[3]);
	    Tcl_IncrRefCount(objv[3]);

	    objvListPtr = Tcl_NewListObj(0, NULL);
	    Tcl_IncrRefCount(objvListPtr);







|







1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
		return TCL_ERROR;
	    }

	    /*
	     * Create a new-style requirement for the exact version.
	     */

	    ov = Tcl_NewStringObj(version, -1);
	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	    version = NULL;
	    argv3 = TclGetString(objv[3]);
	    Tcl_IncrRefCount(objv[3]);

	    objvListPtr = Tcl_NewListObj(0, NULL);
	    Tcl_IncrRefCount(objvListPtr);
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
	break;
    case PKG_UNKNOWN: {
	size_t length;

	if (objc == 2) {
	    if (iPtr->packageUnknown != NULL) {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj(iPtr->packageUnknown, TCL_INDEX_NONE));
	    }
	} else if (objc == 3) {
	    if (iPtr->packageUnknown != NULL) {
		Tcl_Free(iPtr->packageUnknown);
	    }
	    argv2 = Tcl_GetStringFromObj(objv[2], &length);
	    if (argv2[0] == 0) {







|







1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
	break;
    case PKG_UNKNOWN: {
	size_t length;

	if (objc == 2) {
	    if (iPtr->packageUnknown != NULL) {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj(iPtr->packageUnknown, -1));
	    }
	} else if (objc == 3) {
	    if (iPtr->packageUnknown != NULL) {
		Tcl_Free(iPtr->packageUnknown);
	    }
	    argv2 = Tcl_GetStringFromObj(objv[2], &length);
	    if (argv2[0] == 0) {
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
	}

	/*
	 * Always return current value.
	 */

	Tcl_SetObjResult(interp,
		Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], TCL_INDEX_NONE));
	break;
    }
    case PKG_VCOMPARE:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
	    return TCL_ERROR;
	}







|







1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
	}

	/*
	 * Always return current value.
	 */

	Tcl_SetObjResult(interp,
		Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1));
	break;
    }
    case PKG_VCOMPARE:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
	    return TCL_ERROR;
	}
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
	    argv2 = TclGetString(objv[2]);
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr != NULL) {
		pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
		for (availPtr = pkgPtr->availPtr; availPtr != NULL;
			availPtr = availPtr->nextPtr) {
		    Tcl_ListObjAppendElement(NULL, resultObj,
			    Tcl_NewStringObj(availPtr->version, TCL_INDEX_NONE));
		}
	    }
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case PKG_VSATISFIES: {
	char *argv2i = NULL;







|







1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
	    argv2 = TclGetString(objv[2]);
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr != NULL) {
		pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
		for (availPtr = pkgPtr->availPtr; availPtr != NULL;
			availPtr = availPtr->nextPtr) {
		    Tcl_ListObjAppendElement(NULL, resultObj,
			    Tcl_NewStringObj(availPtr->version, -1));
		}
	    }
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case PKG_VSATISFIES: {
	char *argv2i = NULL;

Changes to generic/tclProc.c.

520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
	result = TclListObjGetElementsM(interp, argArray[i], &fieldCount,
		&fieldValues);
	if (result != TCL_OK) {
	    goto procError;
	}
	if (fieldCount > 2) {
	    Tcl_Obj *errorObj = Tcl_NewStringObj(
		"too many fields in argument specifier \"", TCL_INDEX_NONE);
	    Tcl_AppendObjToObj(errorObj, argArray[i]);
	    Tcl_AppendToObj(errorObj, "\"", TCL_INDEX_NONE);
	    Tcl_SetObjResult(interp, errorObj);
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}
	if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "argument with no name", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}

	argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);








|

|







|







520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
	result = TclListObjGetElementsM(interp, argArray[i], &fieldCount,
		&fieldValues);
	if (result != TCL_OK) {
	    goto procError;
	}
	if (fieldCount > 2) {
	    Tcl_Obj *errorObj = Tcl_NewStringObj(
		"too many fields in argument specifier \"", -1);
	    Tcl_AppendObjToObj(errorObj, argArray[i]);
	    Tcl_AppendToObj(errorObj, "\"", -1);
	    Tcl_SetObjResult(interp, errorObj);
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}
	if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "argument with no name", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}

	argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);

556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
			    TclGetString(fieldValues[0])));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "FORMALARGUMENTFORMAT", NULL);
		    goto procError;
		}
	    } else if (*argnamei == ':' && *(argnamei+1) == ':') {
		Tcl_Obj *errorObj = Tcl_NewStringObj(
		    "formal parameter \"", TCL_INDEX_NONE);
		Tcl_AppendObjToObj(errorObj, fieldValues[0]);
		Tcl_AppendToObj(errorObj, "\" is not a simple name", TCL_INDEX_NONE);
		Tcl_SetObjResult(interp, errorObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"FORMALARGUMENTFORMAT", NULL);
		goto procError;
	    }
	    argnamei++;
	}







|

|







556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
			    TclGetString(fieldValues[0])));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "FORMALARGUMENTFORMAT", NULL);
		    goto procError;
		}
	    } else if (*argnamei == ':' && *(argnamei+1) == ':') {
		Tcl_Obj *errorObj = Tcl_NewStringObj(
		    "formal parameter \"", -1);
		Tcl_AppendObjToObj(errorObj, fieldValues[0]);
		Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
		Tcl_SetObjResult(interp, errorObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"FORMALARGUMENTFORMAT", NULL);
		goto procError;
	    }
	    argnamei++;
	}
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
		if ((valueLength != tmpLength)
		     || memcmp(value, tmpPtr, tmpLength) != 0
		) {
		    Tcl_Obj *errorObj = Tcl_ObjPrintf(
			    "procedure \"%s\": formal parameter \"", procName);
		    Tcl_AppendObjToObj(errorObj, fieldValues[0]);
		    Tcl_AppendToObj(errorObj, "\" has "
			"default value inconsistent with precompiled body", TCL_INDEX_NONE);
		    Tcl_SetObjResult(interp, errorObj);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "BYTECODELIES", NULL);
		    goto procError;
		}
	    }
	    if ((i == numArgs - 1)







|







609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
		if ((valueLength != tmpLength)
		     || memcmp(value, tmpPtr, tmpLength) != 0
		) {
		    Tcl_Obj *errorObj = Tcl_ObjPrintf(
			    "procedure \"%s\": formal parameter \"", procName);
		    Tcl_AppendObjToObj(errorObj, fieldValues[0]);
		    Tcl_AppendToObj(errorObj, "\" has "
			"default value inconsistent with precompiled body", -1);
		    Tcl_SetObjResult(interp, errorObj);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "BYTECODELIES", NULL);
		    goto procError;
		}
	    }
	    if ((i == numArgs - 1)
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
     */

    numArgs = framePtr->procPtr->numArgs;
    desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
	    sizeof(Tcl_Obj *) * (numArgs+1));

    if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
	desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", TCL_INDEX_NONE);
    } else {
	desiredObjs[0] = framePtr->objv[skip-1];
    }
    Tcl_IncrRefCount(desiredObjs[0]);

    if (localCt > 0) {
	Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt);







|







1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
     */

    numArgs = framePtr->procPtr->numArgs;
    desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
	    sizeof(Tcl_Obj *) * (numArgs+1));

    if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
	desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
    } else {
	desiredObjs[0] = framePtr->objv[skip-1];
    }
    Tcl_IncrRefCount(desiredObjs[0]);

    if (localCt > 0) {
	Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt);
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517

int
TclPushProcCallFrame(
    void *clientData,	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    Tcl_Size objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[],	/* Argument value objects. */
    int isLambda)		/* 1 if this is a call by ApplyObjCmd: it
				 * needs special rules for error msg */
{
    Proc *procPtr = (Proc *)clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;







|







1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517

int
TclPushProcCallFrame(
    void *clientData,	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    Tcl_Size objc,		/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[],	/* Argument value objects. */
    int isLambda)		/* 1 if this is a call by ApplyObjCmd: it
				 * needs special rules for error msg */
{
    Proc *procPtr = (Proc *)clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

static int
NRInterpProc2(
    void *clientData,	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    size_t objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);

    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

static int
ObjInterpProc2(
    void *clientData,	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    size_t objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    /*
     * Not used much in the core; external interface for iTcl
     */








|

|

|














|

|

|







1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

static int
NRInterpProc2(
    void *clientData,		/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp, 	/* Interpreter in which procedure was
				 * invoked. */
    Tcl_Size objc,		/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);

    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

static int
ObjInterpProc2(
    void *clientData,		/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,		/* Interpreter in which procedure was
				 * invoked. */
    Tcl_Size objc,		/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    /*
     * Not used much in the core; external interface for iTcl
     */

1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
	) {
	    return TCL_OK;
	}

	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
	    if ((Interp *) *codePtr->interpHandle != iPtr) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"a precompiled script jumped interps", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"CROSSINTERPBYTECODE", NULL);
		return TCL_ERROR;
	    }
	    codePtr->compileEpoch = iPtr->compileEpoch;
	    codePtr->nsPtr = nsPtr;
	} else {







|







1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
	) {
	    return TCL_OK;
	}

	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
	    if ((Interp *) *codePtr->interpHandle != iPtr) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"a precompiled script jumped interps", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"CROSSINTERPBYTECODE", NULL);
		return TCL_ERROR;
	    }
	    codePtr->compileEpoch = iPtr->compileEpoch;
	    codePtr->nsPtr = nsPtr;
	} else {

Changes to generic/tclProcess.c.

229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327

	    msg = "child process lost (is SIGCHLD ignored or trapped?)";
	}
	if (codePtr) *codePtr = errno;
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"error waiting for process to exit: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("POSIX", TCL_INDEX_NONE);
	    errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), TCL_INDEX_NONE);
	    errorStrings[2] = Tcl_NewStringObj(msg, TCL_INDEX_NONE);
	    *errorObjPtr = Tcl_NewListObj(3, errorStrings);
	}
	return TCL_PROCESS_ERROR;
    } else if (WIFEXITED(waitStatus)) {
	if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
	if (!WEXITSTATUS(waitStatus)) {
	    /*
	     * Normal exit.
	     */

	    if (msgObjPtr) *msgObjPtr = NULL;
	    if (errorObjPtr) *errorObjPtr = NULL;
	} else {
	    /*
	     * CHILDSTATUS pid code
	     *
	     * Child exited with a non-zero exit status.
	     */

	    if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
		    "child process exited abnormally", TCL_INDEX_NONE);
	    if (errorObjPtr) {
		errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", TCL_INDEX_NONE);
		TclNewIntObj(errorStrings[1], resolvedPid);
		TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus));
		*errorObjPtr = Tcl_NewListObj(3, errorStrings);
	    }
	}
	return TCL_PROCESS_EXITED;
    } else if (WIFSIGNALED(waitStatus)) {
	/*
	 * CHILDKILLED pid sigName msg
	 *
	 * Child killed because of a signal.
	 */

	msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
	if (codePtr) *codePtr = WTERMSIG(waitStatus);
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"child killed: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", TCL_INDEX_NONE);
	    TclNewIntObj(errorStrings[1], resolvedPid);
	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), TCL_INDEX_NONE);
	    errorStrings[3] = Tcl_NewStringObj(msg, TCL_INDEX_NONE);
	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
	}
	return TCL_PROCESS_SIGNALED;
    } else if (WIFSTOPPED(waitStatus)) {
	/*
	 * CHILDSUSP pid sigName msg
	 *
	 * Child suspended because of a signal.
	 */

	msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
	if (codePtr) *codePtr = WSTOPSIG(waitStatus);
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"child suspended: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", TCL_INDEX_NONE);
	    TclNewIntObj(errorStrings[1], resolvedPid);
	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), TCL_INDEX_NONE);
	    errorStrings[3] = Tcl_NewStringObj(msg, TCL_INDEX_NONE);
	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
	}
	return TCL_PROCESS_STOPPED;
    } else {
	/*
	 * TCL OPERATION EXEC ODDWAITRESULT
	 *
	 * Child wait status didn't make sense.
	 */

	if (codePtr) *codePtr = waitStatus;
	if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
		"child wait status didn't make sense\n", TCL_INDEX_NONE);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("TCL", TCL_INDEX_NONE);
	    errorStrings[1] = Tcl_NewStringObj("OPERATION", TCL_INDEX_NONE);
	    errorStrings[2] = Tcl_NewStringObj("EXEC", TCL_INDEX_NONE);
	    errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", TCL_INDEX_NONE);
	    TclNewIntObj(errorStrings[4], resolvedPid);
	    *errorObjPtr = Tcl_NewListObj(5, errorStrings);
	}
	return TCL_PROCESS_UNKNOWN_STATUS;
    }
}








|
|
|




















|

|


















|

|
|















|

|
|












|

|
|
|
|







229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327

	    msg = "child process lost (is SIGCHLD ignored or trapped?)";
	}
	if (codePtr) *codePtr = errno;
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"error waiting for process to exit: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
	    errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
	    errorStrings[2] = Tcl_NewStringObj(msg, -1);
	    *errorObjPtr = Tcl_NewListObj(3, errorStrings);
	}
	return TCL_PROCESS_ERROR;
    } else if (WIFEXITED(waitStatus)) {
	if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
	if (!WEXITSTATUS(waitStatus)) {
	    /*
	     * Normal exit.
	     */

	    if (msgObjPtr) *msgObjPtr = NULL;
	    if (errorObjPtr) *errorObjPtr = NULL;
	} else {
	    /*
	     * CHILDSTATUS pid code
	     *
	     * Child exited with a non-zero exit status.
	     */

	    if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
		    "child process exited abnormally", -1);
	    if (errorObjPtr) {
		errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
		TclNewIntObj(errorStrings[1], resolvedPid);
		TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus));
		*errorObjPtr = Tcl_NewListObj(3, errorStrings);
	    }
	}
	return TCL_PROCESS_EXITED;
    } else if (WIFSIGNALED(waitStatus)) {
	/*
	 * CHILDKILLED pid sigName msg
	 *
	 * Child killed because of a signal.
	 */

	msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
	if (codePtr) *codePtr = WTERMSIG(waitStatus);
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"child killed: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
	    TclNewIntObj(errorStrings[1], resolvedPid);
	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
	}
	return TCL_PROCESS_SIGNALED;
    } else if (WIFSTOPPED(waitStatus)) {
	/*
	 * CHILDSUSP pid sigName msg
	 *
	 * Child suspended because of a signal.
	 */

	msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
	if (codePtr) *codePtr = WSTOPSIG(waitStatus);
	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
		"child suspended: %s", msg);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
	    TclNewIntObj(errorStrings[1], resolvedPid);
	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
	}
	return TCL_PROCESS_STOPPED;
    } else {
	/*
	 * TCL OPERATION EXEC ODDWAITRESULT
	 *
	 * Child wait status didn't make sense.
	 */

	if (codePtr) *codePtr = waitStatus;
	if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
		"child wait status didn't make sense\n", -1);
	if (errorObjPtr) {
	    errorStrings[0] = Tcl_NewStringObj("TCL", -1);
	    errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
	    errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
	    errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
	    TclNewIntObj(errorStrings[4], resolvedPid);
	    *errorObjPtr = Tcl_NewListObj(5, errorStrings);
	}
	return TCL_PROCESS_UNKNOWN_STATUS;
    }
}

451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *dict;
    int options = WNOHANG;
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    ProcessInfo *info;
    size_t i, numPids;
    Tcl_Obj **pidObjs;
    int result;
    int pid;
    Tcl_Obj *const *savedobjv = objv;
    static const char *const switches[] = {
	"-wait", "--", NULL
    };







|







451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *dict;
    int options = WNOHANG;
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    ProcessInfo *info;
    Tcl_Size i, numPids;
    Tcl_Obj **pidObjs;
    int result;
    int pid;
    Tcl_Obj *const *savedobjv = objv;
    static const char *const switches[] = {
	"-wait", "--", NULL
    };
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    ProcessInfo *info;
    size_t i, numPids;
    Tcl_Obj **pidObjs;
    int result, pid;

    if (objc != 1 && objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
	return TCL_ERROR;
    }







|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch search;
    ProcessInfo *info;
    Tcl_Size i, numPids;
    Tcl_Obj **pidObjs;
    int result, pid;

    if (objc != 1 && objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
	return TCL_ERROR;
    }

Changes to generic/tclRegexp.c.

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
 *---------------------------------------------------------------------------
 */

void
Tcl_RegExpRange(
    Tcl_RegExp re,		/* Compiled regular expression that has been
				 * passed to Tcl_RegExpExec. */
    size_t index,			/* 0 means give the range of the entire match,
				 * > 0 means give the range of a matching
				 * subrange. */
    const char **startPtr,	/* Store address of first character in
				 * (sub-)range here. */
    const char **endPtr)	/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    const char *string;

    if (index > regexpPtr->re.re_nsub) {
	*startPtr = *endPtr = NULL;
    } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) {
	*startPtr = *endPtr = NULL;
    } else {
	if (regexpPtr->objPtr) {
	    string = TclGetString(regexpPtr->objPtr);
	} else {
	    string = regexpPtr->string;
	}







|










|

|







249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
 *---------------------------------------------------------------------------
 */

void
Tcl_RegExpRange(
    Tcl_RegExp re,		/* Compiled regular expression that has been
				 * passed to Tcl_RegExpExec. */
    Tcl_Size index,		/* 0 means give the range of the entire match,
				 * > 0 means give the range of a matching
				 * subrange. */
    const char **startPtr,	/* Store address of first character in
				 * (sub-)range here. */
    const char **endPtr)	/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    const char *string;

    if (index < 0 || (size_t) index > regexpPtr->re.re_nsub) {
	*startPtr = *endPtr = NULL;
    } else if (regexpPtr->matches[index].rm_so == (size_t) -1) {
	*startPtr = *endPtr = NULL;
    } else {
	if (regexpPtr->objPtr) {
	    string = TclGetString(regexpPtr->objPtr);
	} else {
	    string = regexpPtr->string;
	}
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
 *---------------------------------------------------------------------------
 */

void
TclRegExpRangeUniChar(
    Tcl_RegExp re,		/* Compiled regular expression that has been
				 * passed to Tcl_RegExpExec. */
    size_t index,			/* 0 means give the range of the entire match,
				 * > 0 means give the range of a matching
				 * subrange, TCL_INDEX_NONE means the range of the
				 * rm_extend field. */
    size_t *startPtr,		/* Store address of first character in
				 * (sub-)range here. */
    size_t *endPtr)		/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;

    if ((regexpPtr->flags&REG_EXPECT) && (index == TCL_INDEX_NONE)) {
	*startPtr = regexpPtr->details.rm_extend.rm_so;
	*endPtr = regexpPtr->details.rm_extend.rm_eo;
    } else if (index + 1 > regexpPtr->re.re_nsub + 1) {
	*startPtr = TCL_INDEX_NONE;
	*endPtr = TCL_INDEX_NONE;
    } else {
	*startPtr = regexpPtr->matches[index].rm_so;
	*endPtr = regexpPtr->matches[index].rm_eo;
    }
}

/*







|

|

|

|




|


|
|
|







359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
 *---------------------------------------------------------------------------
 */

void
TclRegExpRangeUniChar(
    Tcl_RegExp re,		/* Compiled regular expression that has been
				 * passed to Tcl_RegExpExec. */
    Tcl_Size index,		/* 0 means give the range of the entire match,
				 * > 0 means give the range of a matching
				 * subrange, -1 means the range of the
				 * rm_extend field. */
    Tcl_Size *startPtr,	/* Store address of first character in
				 * (sub-)range here. */
    Tcl_Size *endPtr)	/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;

    if ((regexpPtr->flags&REG_EXPECT) && (index == -1)) {
	*startPtr = regexpPtr->details.rm_extend.rm_so;
	*endPtr = regexpPtr->details.rm_extend.rm_eo;
    } else if (index < 0 || (size_t) index > regexpPtr->re.re_nsub + 1) {
	*startPtr = -1;
	*endPtr = -1;
    } else {
	*startPtr = regexpPtr->matches[index].rm_so;
	*endPtr = regexpPtr->matches[index].rm_eo;
    }
}

/*
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
int
Tcl_RegExpExecObj(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    Tcl_RegExp re,		/* Compiled regular expression; must have been
				 * returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    Tcl_Obj *textObj,		/* Text against which to match re. */
    size_t offset,			/* Character index that marks where matching
				 * should begin. */
    size_t nmatches,		/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means all of them. */
    int flags)			/* Regular expression execution flags. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    Tcl_UniChar *udata;
    size_t length;
    int reflags = regexpPtr->flags;
#define TCL_REG_GLOBOK_FLAGS \
	(TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)

    /*
     * Take advantage of the equivalent glob pattern, if one exists.
     * This is possible based only on the right mix of incoming flags (0)







|

|






|







439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
int
Tcl_RegExpExecObj(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    Tcl_RegExp re,		/* Compiled regular expression; must have been
				 * returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    Tcl_Obj *textObj,		/* Text against which to match re. */
    Tcl_Size offset,		/* Character index that marks where matching
				 * should begin. */
    Tcl_Size nmatches,	/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means all of them. */
    int flags)			/* Regular expression execution flags. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    Tcl_UniChar *udata;
    Tcl_Size length;
    int reflags = regexpPtr->flags;
#define TCL_REG_GLOBOK_FLAGS \
	(TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)

    /*
     * Take advantage of the equivalent glob pattern, if one exists.
     * This is possible based only on the right mix of incoming flags (0)
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
     * Now append a list of all the bit-flags set for the RE.
     */

    TclNewObj(infoObj);
    for (inf=infonames ; inf->bit != 0 ; inf++) {
	if (regexpPtr->re.re_info & inf->bit) {
	    Tcl_ListObjAppendElement(NULL, infoObj,
		    Tcl_NewStringObj(inf->text, TCL_INDEX_NONE));
	}
    }
    Tcl_ListObjAppendElement(NULL, resultObj, infoObj);
    Tcl_SetObjResult(interp, resultObj);

    return 0;
}







|







685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
     * Now append a list of all the bit-flags set for the RE.
     */

    TclNewObj(infoObj);
    for (inf=infonames ; inf->bit != 0 ; inf++) {
	if (regexpPtr->re.re_info & inf->bit) {
	    Tcl_ListObjAppendElement(NULL, infoObj,
		    Tcl_NewStringObj(inf->text, -1));
	}
    }
    Tcl_ListObjAppendElement(NULL, resultObj, infoObj);
    Tcl_SetObjResult(interp, resultObj);

    return 0;
}

Changes to generic/tclResult.c.

310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
    }
    while (1) {
	const char *bytes = va_arg(argList, char *);

	if (bytes == NULL) {
	    break;
	}
	Tcl_AppendToObj(objPtr, bytes, TCL_INDEX_NONE);
    }
    Tcl_SetObjResult(interp, objPtr);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------







|







310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
    }
    while (1) {
	const char *bytes = va_arg(argList, char *);

	if (bytes == NULL) {
	    break;
	}
	Tcl_AppendToObj(objPtr, bytes, -1);
    }
    Tcl_SetObjResult(interp, objPtr);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
Tcl_AppendElement(
    Tcl_Interp *interp,		/* Interpreter whose result is to be
				 * extended. */
    const char *element)	/* String to convert to list element and add
				 * to result. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *elementPtr = Tcl_NewStringObj(element, TCL_INDEX_NONE);
    Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
    const char *bytes;
    size_t length;

    if (Tcl_IsShared(iPtr->objResultPtr)) {
	Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
    }







|







347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
Tcl_AppendElement(
    Tcl_Interp *interp,		/* Interpreter whose result is to be
				 * extended. */
    const char *element)	/* String to convert to list element and add
				 * to result. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1);
    Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
    const char *bytes;
    size_t length;

    if (Tcl_IsShared(iPtr->objResultPtr)) {
	Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
    }
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

    while (1) {
	char *elem = va_arg(argList, char *);

	if (elem == NULL) {
	    break;
	}
	Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, TCL_INDEX_NONE));
    }
    Tcl_SetObjErrorCode(interp, errorObj);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------







|







504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

    while (1) {
	char *elem = va_arg(argList, char *);

	if (elem == NULL) {
	    break;
	}
	Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1));
    }
    Tcl_SetObjErrorCode(interp, errorObj);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
		Tcl_IncrRefCount(iPtr->errorInfo);
		iPtr->flags |= ERR_ALREADY_LOGGED;
	    }
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
                &valuePtr);
	if (valuePtr != NULL) {
            size_t len, valueObjc;
            Tcl_Obj **valueObjv;

            if (Tcl_IsShared(iPtr->errorStack)) {
                Tcl_Obj *newObj;

                newObj = Tcl_DuplicateObj(iPtr->errorStack);
                Tcl_DecrRefCount(iPtr->errorStack);







|







726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
		Tcl_IncrRefCount(iPtr->errorInfo);
		iPtr->flags |= ERR_ALREADY_LOGGED;
	    }
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
                &valuePtr);
	if (valuePtr != NULL) {
            Tcl_Size len, valueObjc;
            Tcl_Obj **valueObjv;

            if (Tcl_IsShared(iPtr->errorStack)) {
                Tcl_Obj *newObj;

                newObj = Tcl_DuplicateObj(iPtr->errorStack);
                Tcl_DecrRefCount(iPtr->errorStack);
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917

    /*
     * Check for bogus -errorcode value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
    if (valuePtr != NULL) {
	size_t length;

	if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) {
	    /*
	     * Value is not a list, which is illegal for -errorcode.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(







|







903
904
905
906
907
908
909
910
911
912
913
914
915
916
917

    /*
     * Check for bogus -errorcode value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
    if (valuePtr != NULL) {
	Tcl_Size length;

	if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) {
	    /*
	     * Value is not a list, which is illegal for -errorcode.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939

    /*
     * Check for bogus -errorstack value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
    if (valuePtr != NULL) {
	size_t length;

	if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length)) {
	    /*
	     * Value is not a list, which is illegal for -errorstack.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(







|







925
926
927
928
929
930
931
932
933
934
935
936
937
938
939

    /*
     * Check for bogus -errorstack value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
    if (valuePtr != NULL) {
	Tcl_Size length;

	if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length)) {
	    /*
	     * Value is not a list, which is illegal for -errorstack.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
 */

int
Tcl_SetReturnOptions(
    Tcl_Interp *interp,
    Tcl_Obj *options)
{
    size_t objc;
    int level, code;
    Tcl_Obj **objv, *mergedOpts;

    Tcl_IncrRefCount(options);
    if (TCL_ERROR == TclListObjGetElementsM(interp, options, &objc, &objv)
	    || (objc % 2)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(







|







1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
 */

int
Tcl_SetReturnOptions(
    Tcl_Interp *interp,
    Tcl_Obj *options)
{
    Tcl_Size objc;
    int level, code;
    Tcl_Obj **objv, *mergedOpts;

    Tcl_IncrRefCount(options);
    if (TCL_ERROR == TclListObjGetElementsM(interp, options, &objc, &objv)
	    || (objc % 2)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(

Changes to generic/tclScan.c.

393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
	    /* FALLTHRU */
	case 'n':
	case 's':
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
	    invalidFieldSize:
		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		errorMsg = Tcl_NewStringObj(
			"field size modifier may not be specified in %", TCL_INDEX_NONE);
		Tcl_AppendToObj(errorMsg, buf, TCL_INDEX_NONE);
		Tcl_AppendToObj(errorMsg, " conversion", TCL_INDEX_NONE);
		Tcl_SetObjResult(interp, errorMsg);
		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */







|
|
|







393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
	    /* FALLTHRU */
	case 'n':
	case 's':
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
	    invalidFieldSize:
		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		errorMsg = Tcl_NewStringObj(
			"field size modifier may not be specified in %", -1);
		Tcl_AppendToObj(errorMsg, buf, -1);
		Tcl_AppendToObj(errorMsg, " conversion", -1);
		Tcl_SetObjResult(interp, errorMsg);
		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
		    goto badSet;
		}
		format += TclUtfToUniChar(format, &ch);
	    }
	    break;
	badSet:
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unmatched [ in format string", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
	    goto error;
	default:
	    buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	    errorMsg = Tcl_NewStringObj(
		    "bad scan conversion character \"", TCL_INDEX_NONE);
	    Tcl_AppendToObj(errorMsg, buf, TCL_INDEX_NONE);
	    Tcl_AppendToObj(errorMsg, "\"", TCL_INDEX_NONE);
	    Tcl_SetObjResult(interp, errorMsg);
	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
	    goto error;
	}
	if (!(flags & SCAN_SUPPRESS)) {
	    if (objIndex >= nspace) {
		/*







|





|
|
|







448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
		    goto badSet;
		}
		format += TclUtfToUniChar(format, &ch);
	    }
	    break;
	badSet:
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unmatched [ in format string", -1));
	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
	    goto error;
	default:
	    buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	    errorMsg = Tcl_NewStringObj(
		    "bad scan conversion character \"", -1);
	    Tcl_AppendToObj(errorMsg, buf, -1);
	    Tcl_AppendToObj(errorMsg, "\"", -1);
	    Tcl_SetObjResult(interp, errorMsg);
	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
	    goto error;
	}
	if (!(flags & SCAN_SUPPRESS)) {
	    if (objIndex >= nspace) {
		/*
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541

    TclStackFree(interp, nassign);
    return TCL_OK;

  badIndex:
    if (gotXpg) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"\"%n$\" argument index out of range", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"different numbers of variable names and field specifiers",
		-1));
	Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
    }







|







527
528
529
530
531
532
533
534
535
536
537
538
539
540
541

    TclStackFree(interp, nassign);
    return TCL_OK;

  badIndex:
    if (gotXpg) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"\"%n$\" argument index out of range", -1));
	Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"different numbers of variable names and field specifiers",
		-1));
	Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
    }
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
			wideValue = WIDE_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
		    mp_int big;
		    if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"insufficient memory to create bignum", TCL_INDEX_NONE));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
			return TCL_ERROR;
		    } else {
			Tcl_SetBignumObj(objPtr, &big);
		    }
		} else {
		    TclSetIntObj(objPtr, wideValue);







|







922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
			wideValue = WIDE_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
		    mp_int big;
		    if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"insufficient memory to create bignum", -1));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
			return TCL_ERROR;
		    } else {
			Tcl_SetBignumObj(objPtr, &big);
		    }
		} else {
		    TclSetIntObj(objPtr, wideValue);
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982

		    if (res == TCL_ERROR) {
			if (objs != NULL) {
			    Tcl_Free(objs);
			}
			Tcl_DecrRefCount(objPtr);
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"unsigned bignum scans are invalid", TCL_INDEX_NONE));
			Tcl_SetErrorCode(interp, "TCL", "FORMAT",
				"BADUNSIGNED",NULL);
			return TCL_ERROR;
		    }
		}
	    } else {
		if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (TclGetString(objPtr)[0] == '-') {
			value = LONG_MIN;
		    } else {
			value = LONG_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
		    mp_int big;
		    if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"insufficient memory to create bignum", TCL_INDEX_NONE));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
			return TCL_ERROR;
		    } else {
			Tcl_SetBignumObj(objPtr, &big);
		    }
#else
		    Tcl_SetWideIntObj(objPtr, (unsigned long)value);







|


















|







949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982

		    if (res == TCL_ERROR) {
			if (objs != NULL) {
			    Tcl_Free(objs);
			}
			Tcl_DecrRefCount(objPtr);
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"unsigned bignum scans are invalid", -1));
			Tcl_SetErrorCode(interp, "TCL", "FORMAT",
				"BADUNSIGNED",NULL);
			return TCL_ERROR;
		    }
		}
	    } else {
		if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (TclGetString(objPtr)[0] == '-') {
			value = LONG_MIN;
		    } else {
			value = LONG_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
		    mp_int big;
		    if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"insufficient memory to create bignum", -1));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
			return TCL_ERROR;
		    } else {
			Tcl_SetBignumObj(objPtr, &big);
		    }
#else
		    Tcl_SetWideIntObj(objPtr, (unsigned long)value);

Changes to generic/tclStrToD.c.

480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
    Tcl_Interp *interp,		/* Used for error reporting. May be NULL. */
    Tcl_Obj *objPtr,		/* Object to receive the internal rep. */
    const char *expected,	/* Description of the type of number the
				 * caller expects to be able to parse
				 * ("integer", "boolean value", etc.). */
    const char *bytes,		/* Pointer to the start of the string to
				 * scan. */
    size_t numBytes,		/* Maximum number of bytes to scan, see
				 * above. */
    const char **endPtrPtr,	/* Place to store pointer to the character
				 * that terminated the scan. */
    int flags)			/* Flags governing the parse. */
{
    enum State {
	INITIAL, SIGNUM, ZERO, ZERO_X,







|







480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
    Tcl_Interp *interp,		/* Used for error reporting. May be NULL. */
    Tcl_Obj *objPtr,		/* Object to receive the internal rep. */
    const char *expected,	/* Description of the type of number the
				 * caller expects to be able to parse
				 * ("integer", "boolean value", etc.). */
    const char *bytes,		/* Pointer to the start of the string to
				 * scan. */
    Tcl_Size numBytes,		/* Maximum number of bytes to scan, see
				 * above. */
    const char **endPtrPtr,	/* Place to store pointer to the character
				 * that terminated the scan. */
    int flags)			/* Flags governing the parse. */
{
    enum State {
	INITIAL, SIGNUM, ZERO, ZERO_X,
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
				 * point in the parse. */
    int numDigitsAfterDp = 0;	/* Number of digits scanned after the decimal
				 * point. */
    int exponentSignum = 0;	/* Signum of the exponent of a floating point
				 * number. */
    long exponent = 0;		/* Exponent of a floating point number. */
    const char *p;		/* Pointer to next character to scan. */
    size_t len;			/* Number of characters remaining after p. */
    const char *acceptPoint;	/* Pointer to position after last character in
				 * an acceptable number. */
    size_t acceptLen;		/* Number of characters following that
				 * point. */
    int status = TCL_OK;	/* Status to return to caller. */
    char d = 0;			/* Last hexadecimal digit scanned; initialized
				 * to avoid a compiler warning. */
    int shift = 0;		/* Amount to shift when accumulating binary */
    mp_err err = MP_OKAY;
    int under = 0;              /* Flag trailing '_' as error if true once







|


|







525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
				 * point in the parse. */
    int numDigitsAfterDp = 0;	/* Number of digits scanned after the decimal
				 * point. */
    int exponentSignum = 0;	/* Signum of the exponent of a floating point
				 * number. */
    long exponent = 0;		/* Exponent of a floating point number. */
    const char *p;		/* Pointer to next character to scan. */
    Tcl_Size len;		/* Number of characters remaining after p. */
    const char *acceptPoint;	/* Pointer to position after last character in
				 * an acceptable number. */
    Tcl_Size acceptLen;		/* Number of characters following that
				 * point. */
    int status = TCL_OK;	/* Status to return to caller. */
    char d = 0;			/* Last hexadecimal digit scanned; initialized
				 * to avoid a compiler warning. */
    int shift = 0;		/* Amount to shift when accumulating binary */
    mp_err err = MP_OKAY;
    int under = 0;              /* Flag trailing '_' as error if true once
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
    if (bytes == NULL) {
	if (interp == NULL && endPtrPtr == NULL) {
	    if (TclHasInternalRep(objPtr, &tclDictType)) {
		/* A dict can never be a (single) number */
		return TCL_ERROR;
	    }
	    if (TclHasInternalRep(objPtr, &tclListType.objType)) {
		size_t length;
		/* A list can only be a (single) number if its length == 1 */
		TclListObjLengthM(NULL, objPtr, &length);
		if (length != 1) {
		    return TCL_ERROR;
		}
	    }
	}







|







552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
    if (bytes == NULL) {
	if (interp == NULL && endPtrPtr == NULL) {
	    if (TclHasInternalRep(objPtr, &tclDictType)) {
		/* A dict can never be a (single) number */
		return TCL_ERROR;
	    }
	    if (TclHasInternalRep(objPtr, &tclListType.objType)) {
		Tcl_Size length;
		/* A list can only be a (single) number if its length == 1 */
		TclListObjLengthM(NULL, objPtr, &length);
		if (length != 1) {
		    return TCL_ERROR;
		}
	    }
	}
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533

    if (status != TCL_OK) {
	if (interp != NULL) {
	    Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"",
		    expected);

	    Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, "");
	    Tcl_AppendToObj(msg, "\"", TCL_INDEX_NONE);
	    Tcl_SetObjResult(interp, msg);
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
	}
    }

    /*
     * Free memory.







|







1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533

    if (status != TCL_OK) {
	if (interp != NULL) {
	    Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"",
		    expected);

	    Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, "");
	    Tcl_AppendToObj(msg, "\"", -1);
	    Tcl_SetObjResult(interp, msg);
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
	}
    }

    /*
     * Free memory.
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
     * Infinite values can't convert to bignum.
     */

    if (isinf(d)) {
	if (interp != NULL) {
	    const char *s = "integer value too large to represent";

	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	}
	return TCL_ERROR;
    }

    fract = frexp(d, &expt);
    if (expt <= 0) {







|







4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
     * Infinite values can't convert to bignum.
     */

    if (isinf(d)) {
	if (interp != NULL) {
	    const char *s = "integer value too large to represent";

	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	}
	return TCL_ERROR;
    }

    fract = frexp(d, &expt);
    if (expt <= 0) {

Changes to generic/tclStringObj.c.

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
/*
 * Prototypes for functions defined later in this file:
 */

static void		AppendPrintfToObjVA(Tcl_Obj *objPtr,
			    const char *format, va_list argList);
static void		AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, size_t appendNumChars);
static void		AppendUnicodeToUtfRep(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, size_t numChars);
static void		AppendUtfToUnicodeRep(Tcl_Obj *objPtr,
			    const char *bytes, size_t numBytes);
static void		AppendUtfToUtfRep(Tcl_Obj *objPtr,
			    const char *bytes, size_t numBytes);
static void		DupStringInternalRep(Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr);
static size_t		ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, size_t numChars);
static void		ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
			    const char *bytes, size_t numBytes,
			    size_t numAppendChars);
static void		FillUnicodeRep(Tcl_Obj *objPtr);
static void		FreeStringInternalRep(Tcl_Obj *objPtr);
static void		GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag);
static void		GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed);
static int		SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		SetUnicodeObj(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, size_t numChars);
static size_t		UnicodeLength(const Tcl_UniChar *unicode);
static void		UpdateStringOfString(Tcl_Obj *objPtr);

#if TCL_UTF_MAX > 3
#define ISCONTINUATION(bytes) (\
	((bytes)[0] & 0xC0) == 0x80)
#else
#define ISCONTINUATION(bytes) (\







|

|

|

|


|
|

|
|






|
|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
/*
 * Prototypes for functions defined later in this file:
 */

static void		AppendPrintfToObjVA(Tcl_Obj *objPtr,
			    const char *format, va_list argList);
static void		AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, Tcl_Size appendNumChars);
static void		AppendUnicodeToUtfRep(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, Tcl_Size numChars);
static void		AppendUtfToUnicodeRep(Tcl_Obj *objPtr,
			    const char *bytes, Tcl_Size numBytes);
static void		AppendUtfToUtfRep(Tcl_Obj *objPtr,
			    const char *bytes, Tcl_Size numBytes);
static void		DupStringInternalRep(Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr);
static Tcl_Size		ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, Tcl_Size numChars);
static void		ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
			    const char *bytes, Tcl_Size numBytes,
			    Tcl_Size numAppendChars);
static void		FillUnicodeRep(Tcl_Obj *objPtr);
static void		FreeStringInternalRep(Tcl_Obj *objPtr);
static void		GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag);
static void		GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed);
static int		SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		SetUnicodeObj(Tcl_Obj *objPtr,
			    const Tcl_UniChar *unicode, Tcl_Size numChars);
static Tcl_Size		UnicodeLength(const Tcl_UniChar *unicode);
static void		UpdateStringOfString(Tcl_Obj *objPtr);

#if TCL_UTF_MAX > 3
#define ISCONTINUATION(bytes) (\
	((bytes)[0] & 0xC0) == 0x80)
#else
#define ISCONTINUATION(bytes) (\
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    size_t length)			/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If
				 * TCL_INDEX_NONE, use bytes up to the first NUL
				 * byte. */
{
    return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    size_t length)		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If -1,
				 * use bytes up to the first NUL byte. */
{
    Tcl_Obj *objPtr;

    if (length == TCL_INDEX_NONE) {
	length = (bytes? strlen(bytes) : 0);
    }
    TclNewStringObj(objPtr, bytes, length);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */








|











|





|







253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    Tcl_Size length)		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If
				 * TCL_INDEX_NONE, use bytes up to the first NUL
				 * byte. */
{
    return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    Tcl_Size length)		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If -1,
				 * use bytes up to the first NUL byte. */
{
    Tcl_Obj *objPtr;

    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }
    TclNewStringObj(objPtr, bytes, length);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
 */

#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    size_t length,		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If -1,
				 * use bytes up to the first NUL byte. */
    const char *file,		/* The name of the source file calling this
				 * function; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{







|







313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
 */

#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    Tcl_Size length,		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If -1,
				 * use bytes up to the first NUL byte. */
    const char *file,		/* The name of the source file calling this
				 * function; used for debugging. */
    int line)			/* Line number in the source file; used for
				 * debugging. */
{
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
    return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    size_t length,		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If -1,
				 * use bytes up to the first NUL byte. */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    return Tcl_NewStringObj(bytes, length);
}







|







335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
    return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    Tcl_Size length,		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If -1,
				 * use bytes up to the first NUL byte. */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    return Tcl_NewStringObj(bytes, length);
}
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_NewUnicodeObj(
    const Tcl_UniChar *unicode,	/* The unicode string used to initialize the
				 * new object. */
    size_t numChars)		/* Number of characters in the unicode
				 * string. */
{
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    SetUnicodeObj(objPtr, unicode, numChars);
    return objPtr;







|







368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_NewUnicodeObj(
    const Tcl_UniChar *unicode,	/* The unicode string used to initialize the
				 * new object. */
    Tcl_Size numChars)		/* Number of characters in the unicode
				 * string. */
{
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    SetUnicodeObj(objPtr, unicode, numChars);
    return objPtr;
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
 * Side effects:
 *	Frees old internal rep. Allocates memory for new "String" internal
 *	rep.
 *
 *----------------------------------------------------------------------
 */

size_t
Tcl_GetCharLength(
    Tcl_Obj *objPtr)		/* The String object to get the num chars
				 * of. */
{
    String *stringPtr;
    size_t numChars = 0;

    /*
     * Quick, no-shimmer return for short string reps.
     */

    if ((objPtr->bytes) && (objPtr->length < 2)) {
	/* 0 bytes -> 0 chars; 1 byte -> 1 char */







|





|







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
 * Side effects:
 *	Frees old internal rep. Allocates memory for new "String" internal
 *	rep.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_GetCharLength(
    Tcl_Obj *objPtr)		/* The String object to get the num chars
				 * of. */
{
    String *stringPtr;
    Tcl_Size numChars = 0;

    /*
     * Quick, no-shimmer return for short string reps.
     */

    if ((objPtr->bytes) && (objPtr->length < 2)) {
	/* 0 bytes -> 0 chars; 1 byte -> 1 char */
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    stringPtr = GET_STRING(objPtr);
    numChars = stringPtr->numChars;

    /*
     * If numChars is unknown, compute it.
     */

    if (numChars == TCL_INDEX_NONE) {
	TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length);
	stringPtr->numChars = numChars;
    }
    return numChars;
}

size_t
TclGetCharLength(
    Tcl_Obj *objPtr)		/* The String object to get the num chars
				 * of. */
{
    size_t numChars = 0;

    /*
     * Quick, no-shimmer return for short string reps.
     */

    if ((objPtr->bytes) && (objPtr->length < 2)) {
	/* 0 bytes -> 0 chars; 1 byte -> 1 char */







|






|




|







440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    stringPtr = GET_STRING(objPtr);
    numChars = stringPtr->numChars;

    /*
     * If numChars is unknown, compute it.
     */

    if (numChars < 0) {
	TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length);
	stringPtr->numChars = numChars;
    }
    return numChars;
}

Tcl_Size
TclGetCharLength(
    Tcl_Obj *objPtr)		/* The String object to get the num chars
				 * of. */
{
    Tcl_Size numChars = 0;

    /*
     * Quick, no-shimmer return for short string reps.
     */

    if ((objPtr->bytes) && (objPtr->length < 2)) {
	/* 0 bytes -> 0 chars; 1 byte -> 1 char */
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
 *
 *----------------------------------------------------------------------
 */
int
TclCheckEmptyString(
    Tcl_Obj *objPtr)
{
    size_t length = TCL_INDEX_NONE;

    if (objPtr->bytes == &tclEmptyString) {
	return TCL_EMPTYSTRING_YES;
    }

    if (TclListObjIsCanonical(objPtr)) {
	TclListObjLengthM(NULL, objPtr, &length);







|







505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
 *
 *----------------------------------------------------------------------
 */
int
TclCheckEmptyString(
    Tcl_Obj *objPtr)
{
    Tcl_Size length = TCL_INDEX_NONE;

    if (objPtr->bytes == &tclEmptyString) {
	return TCL_EMPTYSTRING_YES;
    }

    if (TclListObjIsCanonical(objPtr)) {
	TclListObjLengthM(NULL, objPtr, &length);
549
550
551
552
553
554
555
556
557
558
559




560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
 *----------------------------------------------------------------------
 */

int
Tcl_GetUniChar(
    Tcl_Obj *objPtr,		/* The object to get the Unicode charater
				 * from. */
    size_t index)		/* Get the index'th Unicode character. */
{
    String *stringPtr;
    int ch;





    /*
     * Optimize the case where we're really dealing with a ByteArray object
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	size_t length = 0;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return -1;
	}

	return bytes[index];
    }







|



>
>
>
>







|







549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
 *----------------------------------------------------------------------
 */

int
Tcl_GetUniChar(
    Tcl_Obj *objPtr,		/* The object to get the Unicode charater
				 * from. */
    Tcl_Size index)		/* Get the index'th Unicode character. */
{
    String *stringPtr;
    int ch;

    if (index < 0) {
	return -1;
    }

    /*
     * Optimize the case where we're really dealing with a ByteArray object
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	Tcl_Size length = 0;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return -1;
	}

	return bytes[index];
    }
618
619
620
621
622
623
624
625
626
627




628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
    return ch;
}

int
TclGetUniChar(
    Tcl_Obj *objPtr,		/* The object to get the Unicode charater
				 * from. */
    size_t index)		/* Get the index'th Unicode character. */
{
    int ch = 0;





    /*
	 * Optimize the ByteArray case:  N need need to convert to a string to
	 * perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	size_t length = 0;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return -1;
	}

	return bytes[index];
    }

    size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);

    if (index >= numChars) {
	return -1;
    }
    const char *begin = TclUtfAtIndex(objPtr->bytes, index);
#undef Tcl_UtfToUniChar
    Tcl_UtfToUniChar(begin, &ch);







|


>
>
>
>







|








|







622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
    return ch;
}

int
TclGetUniChar(
    Tcl_Obj *objPtr,		/* The object to get the Unicode charater
				 * from. */
    Tcl_Size index)		/* Get the index'th Unicode character. */
{
    int ch = 0;

    if (index < 0) {
	return -1;
    }

    /*
	 * Optimize the ByteArray case:  N need need to convert to a string to
	 * perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	Tcl_Size length = 0;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return -1;
	}

	return bytes[index];
    }

    Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);

    if (index >= numChars) {
	return -1;
    }
    const char *begin = TclUtfAtIndex(objPtr->bytes, index);
#undef Tcl_UtfToUniChar
    Tcl_UtfToUniChar(begin, &ch);
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	if (stringPtr->numChars > INT_MAX) {
	    Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr"
		    " cannot handle such long strings. Please use 'size_t'");
	}
	*lengthPtr = (int)stringPtr->numChars;
    }
    return stringPtr->unicode;
}
#endif /* !defined(TCL_NO_DEPRECATED) */

Tcl_UniChar *
Tcl_GetUnicodeFromObj(
    Tcl_Obj *objPtr,		/* The object to find the unicode string
				 * for. */
    size_t *lengthPtr)		/* If non-NULL, the location where the string
				 * rep's unichar length should be stored. If
				 * NULL, no length is stored. */
{
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);







|











|







698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	if (stringPtr->numChars > INT_MAX) {
	    Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr"
		    " cannot handle such long strings. Please use 'Tcl_Size'");
	}
	*lengthPtr = (int)stringPtr->numChars;
    }
    return stringPtr->unicode;
}
#endif /* !defined(TCL_NO_DEPRECATED) */

Tcl_UniChar *
Tcl_GetUnicodeFromObj(
    Tcl_Obj *objPtr,		/* The object to find the unicode string
				 * for. */
    Tcl_Size *lengthPtr)	/* If non-NULL, the location where the string
				 * rep's unichar length should be stored. If
				 * NULL, no length is stored. */
{
    String *stringPtr;

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetRange(
    Tcl_Obj *objPtr,		/* The Tcl object to find the range of. */
    size_t first,			/* First index of the range. */
    size_t last)			/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    String *stringPtr;
    size_t length = 0;

    if (first == TCL_INDEX_NONE) {
	first = TCL_INDEX_START;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the substring operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);

	if (last >= length) {
	    last = length - 1;
	}
	if (last + 1 < first + 1) {
	    TclNewObj(newObjPtr);
	    return newObjPtr;
	}
	return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
    }

    /*







|
|



|

|











|


|







753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetRange(
    Tcl_Obj *objPtr,		/* The Tcl object to find the range of. */
    Tcl_Size first,			/* First index of the range. */
    Tcl_Size last)			/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    String *stringPtr;
    Tcl_Size length = 0;

    if (first < 0) {
	first = TCL_INDEX_START;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the substring operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);

	if (last < 0 || last >= length) {
	    last = length - 1;
	}
	if (last < first) {
	    TclNewObj(newObjPtr);
	    return newObjPtr;
	}
	return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
    }

    /*
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
	 * If numChars is unknown, compute it.
	 */

	if (stringPtr->numChars == TCL_INDEX_NONE) {
	    TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
	}
	if (stringPtr->numChars == objPtr->length) {
	    if (last >= stringPtr->numChars) {
		last = stringPtr->numChars - 1;
	    }
	    if (last + 1 < first + 1) {
		TclNewObj(newObjPtr);
		return newObjPtr;
	    }
	    newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last - first + 1);

	    /*
	     * Since we know the char length of the result, store it.
	     */

	    SetStringFromAny(NULL, newObjPtr);
	    stringPtr = GET_STRING(newObjPtr);
	    stringPtr->numChars = newObjPtr->length;
	    return newObjPtr;
	}
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }
    if (last >= stringPtr->numChars) {
	last = stringPtr->numChars - 1;
    }
    if (last + 1 < first + 1) {
	TclNewObj(newObjPtr);
	return newObjPtr;
    }
#if TCL_UTF_MAX < 4
    /* See: bug [11ae2be95dac9417] */
    if ((first + 1 > 1) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
	    && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
	++first;
    }
    if ((last + 2 < stringPtr->numChars + 1)
	    && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
	    && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
	++last;
    }
#endif
    return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
}

Tcl_Obj *
TclGetRange(
    Tcl_Obj *objPtr,		/* The Tcl object to find the range of. */
    size_t first,			/* First index of the range. */
    size_t last)			/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    size_t length = 0;

    if (first == TCL_INDEX_NONE) {
	first = TCL_INDEX_START;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the substring operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);

	if (last >= length) {
	    last = length - 1;
	}
	if (last + 1 < first + 1) {
	    TclNewObj(newObjPtr);
	    return newObjPtr;
	}
	return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
    }

    size_t numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);

    if (last >= numChars) {
	last = numChars - 1;
    }
    if (last + 1 < first + 1) {
	TclNewObj(newObjPtr);
	return newObjPtr;
    }
    const char *begin = TclUtfAtIndex(objPtr->bytes, first);
    const char *end = TclUtfAtIndex(objPtr->bytes, last + 1);
    return Tcl_NewStringObj(begin, end - begin);
}







|


|

















|


|





|



|











|
|


|

|











|


|






|

|


|







798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
	 * If numChars is unknown, compute it.
	 */

	if (stringPtr->numChars == TCL_INDEX_NONE) {
	    TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
	}
	if (stringPtr->numChars == objPtr->length) {
	    if (last < 0 || last >= stringPtr->numChars) {
		last = stringPtr->numChars - 1;
	    }
	    if (last < first) {
		TclNewObj(newObjPtr);
		return newObjPtr;
	    }
	    newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last - first + 1);

	    /*
	     * Since we know the char length of the result, store it.
	     */

	    SetStringFromAny(NULL, newObjPtr);
	    stringPtr = GET_STRING(newObjPtr);
	    stringPtr->numChars = newObjPtr->length;
	    return newObjPtr;
	}
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }
    if (last < 0 || last >= stringPtr->numChars) {
	last = stringPtr->numChars - 1;
    }
    if (last < first) {
	TclNewObj(newObjPtr);
	return newObjPtr;
    }
#if TCL_UTF_MAX < 4
    /* See: bug [11ae2be95dac9417] */
    if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
	    && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
	++first;
    }
    if ((last + 1 < stringPtr->numChars)
	    && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
	    && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
	++last;
    }
#endif
    return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
}

Tcl_Obj *
TclGetRange(
    Tcl_Obj *objPtr,		/* The Tcl object to find the range of. */
    Tcl_Size first,		/* First index of the range. */
    Tcl_Size last)		/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    Tcl_Size length = 0;

    if (first < 0) {
	first = TCL_INDEX_START;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the substring operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);

	if (last < 0 || last >= length) {
	    last = length - 1;
	}
	if (last < first) {
	    TclNewObj(newObjPtr);
	    return newObjPtr;
	}
	return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
    }

    Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);

    if (last < 0 || last >= numChars) {
	last = numChars - 1;
    }
    if (last < first) {
	TclNewObj(newObjPtr);
	return newObjPtr;
    }
    const char *begin = TclUtfAtIndex(objPtr->bytes, first);
    const char *end = TclUtfAtIndex(objPtr->bytes, last + 1);
    return Tcl_NewStringObj(begin, end - begin);
}
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
 */

void
Tcl_SetStringObj(
    Tcl_Obj *objPtr,		/* Object whose internal rep to init. */
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the object. */
    size_t length)		/* The number of bytes to copy from "bytes"
				 * when initializing the object. If -1,
				 * use bytes up to the first NUL byte.*/
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetStringObj");
    }








|







912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
 */

void
Tcl_SetStringObj(
    Tcl_Obj *objPtr,		/* Object whose internal rep to init. */
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the object. */
    Tcl_Size length)		/* The number of bytes to copy from "bytes"
				 * when initializing the object. If -1,
				 * use bytes up to the first NUL byte.*/
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetStringObj");
    }

956
957
958
959
960
961
962
963
964
965
966
967
968




969
970
971
972
973
974
975
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjLength(
    Tcl_Obj *objPtr,		/* Pointer to object. This object must not
				 * currently be shared. */
    size_t length)		/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;





    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
    }

    if (objPtr->bytes && objPtr->length == length) {
	return;
    }







|





>
>
>
>







964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjLength(
    Tcl_Obj *objPtr,		/* Pointer to object. This object must not
				 * currently be shared. */
    Tcl_Size length)		/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;

    if (length < 0) {
	Tcl_Panic("Tcl_SetObjLength: length requested is negative: "
		"%" TCL_SIZE_MODIFIER "d (integer overflow?)", length);
    }
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
    }

    if (objPtr->bytes && objPtr->length == length) {
	return;
    }
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058





1059
1060
1061
1062
1063
1064
1065
 *----------------------------------------------------------------------
 */

int
Tcl_AttemptSetObjLength(
    Tcl_Obj *objPtr,		/* Pointer to object. This object must not
				 * currently be shared. */
    size_t length)		/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;






    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
    }
    if (objPtr->bytes && objPtr->length == length) {
	return 1;
    }







|




>
>
>
>
>







1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
 *----------------------------------------------------------------------
 */

int
Tcl_AttemptSetObjLength(
    Tcl_Obj *objPtr,		/* Pointer to object. This object must not
				 * currently be shared. */
    Tcl_Size length)		/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    String *stringPtr;

    if (length < 0) {
	/* Negative lengths => most likely integer overflow */
	return 0;
    }

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
    }
    if (objPtr->bytes && objPtr->length == length) {
	return 1;
    }
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169

1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182

1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
 */

void
Tcl_SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
				 * object. */
    size_t numChars)		/* Number of characters in the Unicode
				 * string. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
    }
    TclFreeInternalRep(objPtr);
    SetUnicodeObj(objPtr, unicode, numChars);
}

static size_t
UnicodeLength(
    const Tcl_UniChar *unicode)
{
    size_t numChars = 0;

    if (unicode) {

	while ((numChars != TCL_INDEX_NONE) && (unicode[numChars] != 0)) {
	    numChars++;
	}
    }
    return numChars;
}

static void
SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
				 * object. */
    size_t numChars)		/* Number of characters in unicode. */

{
    String *stringPtr;

    if (numChars == TCL_INDEX_NONE) {
	numChars = UnicodeLength(unicode);
    }

    /*
     * Allocate enough space for the String structure + Unicode string.
     */








|









|



|


>
|











|
>



|







1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
 */

void
Tcl_SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
				 * object. */
    Tcl_Size numChars)		/* Number of characters in the Unicode
				 * string. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
    }
    TclFreeInternalRep(objPtr);
    SetUnicodeObj(objPtr, unicode, numChars);
}

static Tcl_Size
UnicodeLength(
    const Tcl_UniChar *unicode)
{
    Tcl_Size numChars = 0;

    if (unicode) {
	/* TODO - is this overflow check really necessary? */
	while ((numChars >= 0) && (unicode[numChars] != 0)) {
	    numChars++;
	}
    }
    return numChars;
}

static void
SetUnicodeObj(
    Tcl_Obj *objPtr,		/* The object to set the string of. */
    const Tcl_UniChar *unicode,	/* The Unicode string used to initialize the
				 * object. */
    Tcl_Size numChars)		/* Number of characters in the Unicode
				 * string. */
{
    String *stringPtr;

    if (numChars < 0) {
	numChars = UnicodeLength(unicode);
    }

    /*
     * Allocate enough space for the String structure + Unicode string.
     */

1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
 */

void
Tcl_AppendLimitedToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* Points to the bytes to append to the
				 * object. */
    size_t length,		/* The number of bytes available to be
				 * appended from "bytes". If -1, then
				 * all bytes up to a NUL byte are available. */
    size_t limit,		/* The maximum number of bytes to append to
				 * the object. */
    const char *ellipsis)	/* Ellipsis marker string, appended to the
				 * object to indicate not all available bytes
				 * at "bytes" were appended. */
{
    String *stringPtr;
    size_t toCopy = 0;
    size_t eLen = 0;

    if (length == TCL_INDEX_NONE) {
	length = (bytes ? strlen(bytes) : 0);
    }
    if (length == 0) {
	return;
    }
    if (limit <= 0) {
	return;







|


|






|
|

|







1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
 */

void
Tcl_AppendLimitedToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* Points to the bytes to append to the
				 * object. */
    Tcl_Size length,		/* The number of bytes available to be
				 * appended from "bytes". If -1, then
				 * all bytes up to a NUL byte are available. */
    Tcl_Size limit,		/* The maximum number of bytes to append to
				 * the object. */
    const char *ellipsis)	/* Ellipsis marker string, appended to the
				 * object to indicate not all available bytes
				 * at "bytes" were appended. */
{
    String *stringPtr;
    Tcl_Size toCopy = 0;
    Tcl_Size eLen = 0;

    if (length < 0) {
	length = (bytes ? strlen(bytes) : 0);
    }
    if (length == 0) {
	return;
    }
    if (limit <= 0) {
	return;
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356

1357
1358
1359
1360
1361
1362
1363
 */

void
Tcl_AppendToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* Points to the bytes to append to the
				 * object. */
    size_t length)		/* The number of bytes to append from "bytes".
				 * If TCL_INDEX_NONE, then append all bytes up to NUL
				 * byte. */
{
    Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_INDEX_NONE, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendUnicodeToObj --
 *
 *	This function appends a Unicode string to an object in the most
 *	efficient manner possible. Length must be >= 0.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Invalidates the string rep and creates a new Unicode string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendUnicodeToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* The Unicode string to append to the
				 * object. */
    size_t length)		/* Number of chars in unicode. */

{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
    }








|



|








|















|
>







1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
 */

void
Tcl_AppendToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* Points to the bytes to append to the
				 * object. */
    Tcl_Size length)		/* The number of bytes to append from "bytes".
				 * If TCL_INDEX_NONE, then append all bytes up to NUL
				 * byte. */
{
    Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_SIZE_MAX, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendUnicodeToObj --
 *
 *	This function appends a Unicode string to an object in the most
 *	efficient manner possible.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Invalidates the string rep and creates a new Unicode string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendUnicodeToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* The Unicode string to append to the
				 * object. */
    Tcl_Size length)		/* Number of chars in Unicode. Negative
    				 * lengths means nul terminated */
{
    String *stringPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
    }

1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418

void
Tcl_AppendObjToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    Tcl_Obj *appendObjPtr)	/* Object to append. */
{
    String *stringPtr;
    size_t length = 0, numChars;
    size_t appendNumChars = TCL_INDEX_NONE;
    const char *bytes;

    /*
     * Special case: second object is standard-empty is fast case. We know
     * that appending nothing to anything leaves that starting anything...
     */








|
|







1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438

void
Tcl_AppendObjToObj(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    Tcl_Obj *appendObjPtr)	/* Object to append. */
{
    String *stringPtr;
    Tcl_Size length = 0, numChars;
    Tcl_Size appendNumChars = TCL_INDEX_NONE;
    const char *bytes;

    /*
     * Special case: second object is standard-empty is fast case. We know
     * that appending nothing to anything leaves that starting anything...
     */

1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
	 * Write!). For the sake of extensions that go off into that realm,
	 * though, here's a more complex approach that can handle all the
	 * cases.
	 *
	 * First, get the lengths.
	 */

	size_t lengthSrc = 0;

	(void) Tcl_GetByteArrayFromObj(objPtr, &length);
	(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);

	/*
	 * Grow buffer enough for the append.
	 */







|







1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
	 * Write!). For the sake of extensions that go off into that realm,
	 * though, here's a more complex approach that can handle all the
	 * cases.
	 *
	 * First, get the lengths.
	 */

	Tcl_Size lengthSrc = 0;

	(void) Tcl_GetByteArrayFromObj(objPtr, &length);
	(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);

	/*
	 * Grow buffer enough for the append.
	 */
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481

	/*
	 * Now do the append knowing that buffer growth cannot cause any
	 * trouble.
	 */

	TclAppendBytesToByteArray(objPtr,
		Tcl_GetByteArrayFromObj(appendObjPtr, (size_t *)NULL), lengthSrc);
	return;
    }

    /*
     * Must append as strings.
     */








|







1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501

	/*
	 * Now do the append knowing that buffer growth cannot cause any
	 * trouble.
	 */

	TclAppendBytesToByteArray(objPtr,
		Tcl_GetByteArrayFromObj(appendObjPtr, (Tcl_Size *) NULL), lengthSrc);
	return;
    }

    /*
     * Must append as strings.
     */

1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
     * in both objects before appending, then set the combined number of
     * characters in the final (appended-to) object.
     */

    bytes = Tcl_GetStringFromObj(appendObjPtr, &length);

    numChars = stringPtr->numChars;
    if ((numChars != TCL_INDEX_NONE) && TclHasInternalRep(appendObjPtr, &tclStringType)) {
	String *appendStringPtr = GET_STRING(appendObjPtr);

	appendNumChars = appendStringPtr->numChars;
    }

    AppendUtfToUtfRep(objPtr, bytes, length);

    if ((numChars != TCL_INDEX_NONE) && (appendNumChars != TCL_INDEX_NONE)) {
	stringPtr->numChars = numChars + appendNumChars;
    }
}

/*
 *----------------------------------------------------------------------
 *







|







|







1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
     * in both objects before appending, then set the combined number of
     * characters in the final (appended-to) object.
     */

    bytes = Tcl_GetStringFromObj(appendObjPtr, &length);

    numChars = stringPtr->numChars;
    if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) {
	String *appendStringPtr = GET_STRING(appendObjPtr);

	appendNumChars = appendStringPtr->numChars;
    }

    AppendUtfToUtfRep(objPtr, bytes, length);

    if ((numChars >= 0) && (appendNumChars >= 0)) {
	stringPtr->numChars = numChars + appendNumChars;
    }
}

/*
 *----------------------------------------------------------------------
 *
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUnicodeRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* String to append. */
    size_t appendNumChars)		/* Number of chars of "unicode" to append. */
{
    String *stringPtr;
    size_t numChars;

    if (appendNumChars == TCL_INDEX_NONE) {
	appendNumChars = UnicodeLength(unicode);
    }
    if (appendNumChars == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If not enough space has been allocated for the Unicode rep, reallocate
     * the internal rep object with additional space. First try to double the
     * required allocation; if that fails, try a more modest increase. See the
     * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
     * explanation of this growth algorithm.
     */

    numChars = stringPtr->numChars + appendNumChars;

    if (numChars > stringPtr->maxChars) {
	size_t index = TCL_INDEX_NONE;

	/*
	 * Protect against case where Unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (unicode && unicode >= stringPtr->unicode
		&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
	    index = unicode - stringPtr->unicode;
	}

	GrowUnicodeBuffer(objPtr, numChars);
	stringPtr = GET_STRING(objPtr);

	/*
	 * Relocate Unicode if needed; see above.
	 */

	if (index != TCL_INDEX_NONE) {
	    unicode = stringPtr->unicode + index;
	}
    }

    /*
     * Copy the new string onto the end of the old string, then add the
     * trailing null.
     */







|


|

|




















|









|









|
|







1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUnicodeRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* String to append. */
    Tcl_Size appendNumChars)	/* Number of chars of "unicode" to append. */
{
    String *stringPtr;
    Tcl_Size numChars;

    if (appendNumChars < 0) {
	appendNumChars = UnicodeLength(unicode);
    }
    if (appendNumChars == 0) {
	return;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    /*
     * If not enough space has been allocated for the Unicode rep, reallocate
     * the internal rep object with additional space. First try to double the
     * required allocation; if that fails, try a more modest increase. See the
     * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
     * explanation of this growth algorithm.
     */

    numChars = stringPtr->numChars + appendNumChars;

    if (numChars > stringPtr->maxChars) {
	Tcl_Size offset = -1;

	/*
	 * Protect against case where Unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

	if (unicode && unicode >= stringPtr->unicode
		&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
	    offset = unicode - stringPtr->unicode;
	}

	GrowUnicodeBuffer(objPtr, numChars);
	stringPtr = GET_STRING(objPtr);

	/*
	 * Relocate Unicode if needed; see above.
	 */

	if (offset >= 0) {
	    unicode = stringPtr->unicode + offset;
	}
    }

    /*
     * Copy the new string onto the end of the old string, then add the
     * trailing null.
     */
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUtfRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* String to convert to UTF. */
    size_t numChars)		/* Number of chars of unicode to convert. */
{
    String *stringPtr = GET_STRING(objPtr);

    numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);

    if (stringPtr->numChars != TCL_INDEX_NONE) {
	stringPtr->numChars += numChars;







|







1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
 *----------------------------------------------------------------------
 */

static void
AppendUnicodeToUtfRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const Tcl_UniChar *unicode,	/* String to convert to UTF. */
    Tcl_Size numChars)		/* Number of chars of Unicode to convert. */
{
    String *stringPtr = GET_STRING(objPtr);

    numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);

    if (stringPtr->numChars != TCL_INDEX_NONE) {
	stringPtr->numChars += numChars;
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUnicodeRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* String to convert to Unicode. */
    size_t numBytes)		/* Number of bytes of "bytes" to convert. */
{
    String *stringPtr;

    if (numBytes == 0) {
	return;
    }

    ExtendUnicodeRepWithString(objPtr, bytes, numBytes, TCL_INDEX_NONE);
    TclInvalidateStringRep(objPtr);
    stringPtr = GET_STRING(objPtr);
    stringPtr->allocated = 0;
}

/*
 *----------------------------------------------------------------------







|







|







1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUnicodeRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* String to convert to Unicode. */
    Tcl_Size numBytes)		/* Number of bytes of "bytes" to convert. */
{
    String *stringPtr;

    if (numBytes == 0) {
	return;
    }

    ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1);
    TclInvalidateStringRep(objPtr);
    stringPtr = GET_STRING(objPtr);
    stringPtr->allocated = 0;
}

/*
 *----------------------------------------------------------------------
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731



1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUtfRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* String to append. */
    size_t numBytes)		/* Number of bytes of "bytes" to append. */
{
    String *stringPtr;
    size_t newLength, oldLength;

    if (numBytes == 0) {
	return;
    }

    /*
     * Copy the new string onto the end of the old string, then add the
     * trailing null.
     */

    if (objPtr->bytes == NULL) {
	objPtr->length = 0;
    }
    oldLength = objPtr->length;



    newLength = numBytes + oldLength;

    stringPtr = GET_STRING(objPtr);
    if (newLength > stringPtr->allocated) {
	size_t offset = TCL_INDEX_NONE;

	/*
	 * Protect against case where unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */








|


|














>
>
>




|







1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
 *----------------------------------------------------------------------
 */

static void
AppendUtfToUtfRep(
    Tcl_Obj *objPtr,		/* Points to the object to append to. */
    const char *bytes,		/* String to append. */
    Tcl_Size numBytes)		/* Number of bytes of "bytes" to append. */
{
    String *stringPtr;
    Tcl_Size newLength, oldLength;

    if (numBytes == 0) {
	return;
    }

    /*
     * Copy the new string onto the end of the old string, then add the
     * trailing null.
     */

    if (objPtr->bytes == NULL) {
	objPtr->length = 0;
    }
    oldLength = objPtr->length;
    if (numBytes > TCL_SIZE_MAX - oldLength) {
	Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX);
    }
    newLength = numBytes + oldLength;

    stringPtr = GET_STRING(objPtr);
    if (newLength > stringPtr->allocated) {
	Tcl_Size offset = -1;

	/*
	 * Protect against case where unicode points into the existing
	 * stringPtr->unicode array. Force it to follow any relocations due to
	 * the reallocs below.
	 */

1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776

	GrowStringBuffer(objPtr, newLength, 0);

	/*
	 * Relocate bytes if needed; see above.
	 */

	if (offset != TCL_INDEX_NONE) {
	    bytes = objPtr->bytes + offset;
	}
    }

    /*
     * Invalidate the unicode data.
     */

    stringPtr->numChars = TCL_INDEX_NONE;
    stringPtr->hasUnicode = 0;

    if (bytes) {
	memmove(objPtr->bytes + oldLength, bytes, numBytes);
    }
    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;







|








|







1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799

	GrowStringBuffer(objPtr, newLength, 0);

	/*
	 * Relocate bytes if needed; see above.
	 */

	if (offset >= 0) {
	    bytes = objPtr->bytes + offset;
	}
    }

    /*
     * Invalidate the unicode data.
     */

    stringPtr->numChars = -1;
    stringPtr->hasUnicode = 0;

    if (bytes) {
	memmove(objPtr->bytes + oldLength, bytes, numBytes);
    }
    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822

    while (1) {
	const char *bytes = va_arg(argList, char *);

	if (bytes == NULL) {
	    break;
	}
	Tcl_AppendToObj(objPtr, bytes, TCL_INDEX_NONE);
    }
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *







|







1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845

    while (1) {
	const char *bytes = va_arg(argList, char *);

	if (bytes == NULL) {
	    break;
	}
	Tcl_AppendToObj(objPtr, bytes, -1);
    }
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873

1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
 */

int
Tcl_AppendFormatToObj(
    Tcl_Interp *interp,
    Tcl_Obj *appendObj,
    const char *format,
    size_t objc,
    Tcl_Obj *const objv[])
{
    const char *span = format, *msg, *errCode;
    int gotXpg = 0, gotSequential = 0;
    size_t objIndex = 0, originalLength, limit, numBytes = 0;
    Tcl_UniChar ch = 0;
    static const char *mixedXPG =
	    "cannot mix \"%\" and \"%n$\" conversion specifiers";
    static const char *const badIndex[2] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
    };
    static const char *overflow = "max size for a Tcl value exceeded";

    if (Tcl_IsShared(appendObj)) {
	Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
    }
    (void)Tcl_GetStringFromObj(appendObj, &originalLength);
    limit = (size_t)INT_MAX - originalLength;

    /*
     * Format string is NUL-terminated.
     */

    while (*format != '\0') {
	char *end;
	int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
	int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0;

#ifndef TCL_WIDE_INT_IS_LONG
	int useWide = 0;
#endif
	int newXpg, numChars, allocSegment = 0, segmentLimit;
	size_t segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
	    numBytes += step;
	    continue;







|




|













|








|
>



|
|







1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
 */

int
Tcl_AppendFormatToObj(
    Tcl_Interp *interp,
    Tcl_Obj *appendObj,
    const char *format,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    const char *span = format, *msg, *errCode;
    int gotXpg = 0, gotSequential = 0;
    Tcl_Size objIndex = 0, originalLength, limit, numBytes = 0;
    Tcl_UniChar ch = 0;
    static const char *mixedXPG =
	    "cannot mix \"%\" and \"%n$\" conversion specifiers";
    static const char *const badIndex[2] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
    };
    static const char *overflow = "max size for a Tcl value exceeded";

    if (Tcl_IsShared(appendObj)) {
	Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
    }
    (void)Tcl_GetStringFromObj(appendObj, &originalLength);
    limit = TCL_SIZE_MAX - originalLength;

    /*
     * Format string is NUL-terminated.
     */

    while (*format != '\0') {
	char *end;
	int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
	int gotPrecision, sawFlag, useShort = 0, useBig = 0;
	Tcl_Size width, precision;
#ifndef TCL_WIDE_INT_IS_LONG
	int useWide = 0;
#endif
	int newXpg, allocSegment = 0;
	Tcl_Size numChars, segmentLimit, segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
	    numBytes += step;
	    continue;
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
	    if (gotXpg) {
		msg = mixedXPG;
		errCode = "MIXEDSPECTYPES";
		goto errorMsg;
	    }
	    gotSequential = 1;
	}
	if (objIndex >= objc) {
	    msg = badIndex[gotXpg];
	    errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
	    goto errorMsg;
	}

	/*
	 * Step 2. Set of flags.







|







1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
	    if (gotXpg) {
		msg = mixedXPG;
		errCode = "MIXEDSPECTYPES";
		goto errorMsg;
	    }
	    gotSequential = 1;
	}
	if (objIndex < 0 || objIndex >= objc) {
	    msg = badIndex[gotXpg];
	    errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
	    goto errorMsg;
	}

	/*
	 * Step 2. Set of flags.
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
	    }
	    if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
		goto error;
	    }
	    if (width < 0) {
		width = -width;
		gotMinus = 1;
	    }
	    objIndex++;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	}
	if (width > (int) limit) {
	    msg = overflow;
	    errCode = "OVERFLOW";
	    goto errorMsg;
	}

	/*
	 * Step 4. Precision.







|










|







2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
	    }
	    if (TclGetSizeIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
		goto error;
	    }
	    if (width < 0) {
		width = -width;
		gotMinus = 1;
	    }
	    objIndex++;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	}
	if (width > limit) {
	    msg = overflow;
	    errCode = "OVERFLOW";
	    goto errorMsg;
	}

	/*
	 * Step 4. Precision.
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
	    }
	    if (TclGetIntFromObj(interp, objv[objIndex], &precision)
		    != TCL_OK) {
		goto error;
	    }

	    /*
	     * TODO: Check this truncation logic.
	     */







|







2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
	    }
	    if (TclGetSizeIntFromObj(interp, objv[objIndex], &precision)
		    != TCL_OK) {
		goto error;
	    }

	    /*
	     * TODO: Check this truncation logic.
	     */
2155
2156
2157
2158
2159
2160
2161
2162

2163
2164
2165
2166
2167
2168
2169
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */
	    long l;
	    Tcl_WideInt w;
	    mp_int big;
	    int toAppend, isNegative = 0;


#ifndef TCL_WIDE_INT_IS_LONG
	    if (ch == 'p') {
		useWide = 1;
	    }
#endif
	    if (useBig) {







|
>







2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */
	    long l;
	    Tcl_WideInt w;
	    mp_int big;
	    int isNegative = 0;
	    Tcl_Size toAppend;

#ifndef TCL_WIDE_INT_IS_LONG
	    if (ch == 'p') {
		useWide = 1;
	    }
#endif
	    if (useBig) {
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
	    } else {
		isNegative = (l < (long) 0);
		if (l == (long) 0) gotHash = 0;
	    }

	    TclNewObj(segment);
	    allocSegment = 1;
	    segmentLimit = INT_MAX;
	    Tcl_IncrRefCount(segment);

	    if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) {
		Tcl_AppendToObj(segment,
			(isNegative ? "-" : gotPlus ? "+" : " "), 1);
		segmentLimit -= 1;
	    }







|







2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
	    } else {
		isNegative = (l < (long) 0);
		if (l == (long) 0) gotHash = 0;
	    }

	    TclNewObj(segment);
	    allocSegment = 1;
	    segmentLimit = TCL_SIZE_MAX;
	    Tcl_IncrRefCount(segment);

	    if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) {
		Tcl_AppendToObj(segment,
			(isNegative ? "-" : gotPlus ? "+" : " "), 1);
		segmentLimit -= 1;
	    }
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
		    segmentLimit -= 2;
		    break;
		}
	    }

	    switch (ch) {
	    case 'd': {
		size_t length;
		Tcl_Obj *pure;
		const char *bytes;

		if (useShort) {
		    TclNewIntObj(pure, s);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (useWide) {







|







2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
		    segmentLimit -= 2;
		    break;
		}
	    }

	    switch (ch) {
	    case 'd': {
		Tcl_Size length;
		Tcl_Obj *pure;
		const char *bytes;

		if (useShort) {
		    TclNewIntObj(pure, s);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (useWide) {
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
		/*
		 * Canonical decimal string reps for integers are composed
		 * entirely of one-byte encoded characters, so "length" is the
		 * number of chars.
		 */

		if (gotPrecision) {
		    if (length < (size_t)precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < (size_t)precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < (size_t)width) {
			segmentLimit -= width - length;
		    }
		    while (length < (size_t)width) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		}
		if (toAppend > segmentLimit) {
		    msg = overflow;
		    errCode = "OVERFLOW";







|


|







|


|







2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
		/*
		 * Canonical decimal string reps for integers are composed
		 * entirely of one-byte encoded characters, so "length" is the
		 * number of chars.
		 */

		if (gotPrecision) {
		    if (length < precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < width) {
			segmentLimit -= width - length;
		    }
		    while (length < width) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		}
		if (toAppend > segmentLimit) {
		    msg = overflow;
		    errCode = "OVERFLOW";
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
	    case 'p':
	    case 'x':
	    case 'X':
	    case 'b': {
		Tcl_WideUInt bits = 0;
		Tcl_WideInt numDigits = 0;
		int numBits = 4, base = 16, index = 0, shift = 0;
		size_t length;
		Tcl_Obj *pure;
		char *bytes;

		if (ch == 'u') {
		    base = 10;
		} else if (ch == 'o') {
		    base = 8;







|







2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
	    case 'p':
	    case 'x':
	    case 'X':
	    case 'b': {
		Tcl_WideUInt bits = 0;
		Tcl_WideInt numDigits = 0;
		int numBits = 4, base = 16, index = 0, shift = 0;
		Tcl_Size length;
		Tcl_Obj *pure;
		char *bytes;

		if (ch == 'u') {
		    base = 10;
		} else if (ch == 'o') {
		    base = 8;
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
		    }
		    bits /= base;
		}
		if (useBig) {
		    mp_clear(&big);
		}
		if (gotPrecision) {
		    if (length < (size_t)precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < (size_t)precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < (size_t)width) {
			segmentLimit -= width - length;
		    }
		    while (length < (size_t)width) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		}
		if (toAppend > segmentLimit) {
		    msg = overflow;
		    errCode = "OVERFLOW";







|


|







|


|







2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
		    }
		    bits /= base;
		}
		if (useBig) {
		    mp_clear(&big);
		}
		if (gotPrecision) {
		    if (length < precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < width) {
			segmentLimit -= width - length;
		    }
		    while (length < width) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		}
		if (toAppend > segmentLimit) {
		    msg = overflow;
		    errCode = "OVERFLOW";
2477
2478
2479
2480
2481
2482
2483
2484

2485
2486
2487
2488
2489
2490
2491

2492
2493
2494
2495
2496
2497
2498
2499
	    if (gotSpace) {
		*p++ = ' ';
	    }
	    if (gotPlus) {
		*p++ = '+';
	    }
	    if (width) {
		p += snprintf(p, TCL_INTEGER_SPACE, "%d", width);

		if (width > length) {
		    length = width;
		}
	    }
	    if (gotPrecision) {
		*p++ = '.';
		p += snprintf(p, TCL_INTEGER_SPACE, "%d", precision);

		if (precision > INT_MAX - length) {
		    msg = overflow;
		    errCode = "OVERFLOW";
		    goto errorMsg;
		}
		length += precision;
	    }








|
>






|
>
|







2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
	    if (gotSpace) {
		*p++ = ' ';
	    }
	    if (gotPlus) {
		*p++ = '+';
	    }
	    if (width) {
		p += snprintf(
		    p, TCL_INTEGER_SPACE, "%" TCL_SIZE_MODIFIER "d", width);
		if (width > length) {
		    length = width;
		}
	    }
	    if (gotPrecision) {
		*p++ = '.';
		p += snprintf(
		    p, TCL_INTEGER_SPACE, "%" TCL_SIZE_MODIFIER "d", precision);
		if (precision > TCL_SIZE_MAX - length) {
		    msg = overflow;
		    errCode = "OVERFLOW";
		    goto errorMsg;
		}
		length += precision;
	    }

2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
	    allocSegment = 1;
	    if (!Tcl_AttemptSetObjLength(segment, length)) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    bytes = TclGetString(segment);
	    if (!Tcl_AttemptSetObjLength(segment, snprintf(bytes, segment->length, spec, d))) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    if (ch == 'A') {
		char *q = TclGetString(segment) + 1;
		*q = 'x';







|







2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
	    allocSegment = 1;
	    if (!Tcl_AttemptSetObjLength(segment, length)) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    bytes = TclGetString(segment);
	    if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    if (ch == 'A') {
		char *q = TclGetString(segment) + 1;
		*q = 'x';
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
	numBytes = 0;
    }

    return TCL_OK;

  errorMsg:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL);
    }
  error:
    Tcl_SetObjLength(appendObj, originalLength);
    return TCL_ERROR;
}








|







2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
	numBytes = 0;
    }

    return TCL_OK;

  errorMsg:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
	Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL);
    }
  error:
    Tcl_SetObjLength(appendObj, originalLength);
    return TCL_ERROR;
}

2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_Format(
    Tcl_Interp *interp,
    const char *format,
    size_t objc,
    Tcl_Obj *const objv[])
{
    int result;
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv);







|







2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_Format(
    Tcl_Interp *interp,
    const char *format,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    int result;
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv);
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
static void
AppendPrintfToObjVA(
    Tcl_Obj *objPtr,
    const char *format,
    va_list argList)
{
    int code;
    size_t objc;
    Tcl_Obj **objv, *list;
    const char *p;

    TclNewObj(list);
    p = format;
    Tcl_IncrRefCount(list);
    while (*p != '\0') {







|







2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
static void
AppendPrintfToObjVA(
    Tcl_Obj *objPtr,
    const char *format,
    va_list argList)
{
    int code;
    Tcl_Size objc;
    Tcl_Obj **objv, *list;
    const char *p;

    TclNewObj(list);
    p = format;
    Tcl_IncrRefCount(list);
    while (*p != '\0') {
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
 *
 *---------------------------------------------------------------------------
 */

char *
TclGetStringStorage(
    Tcl_Obj *objPtr,
    size_t *sizePtr)
{
    String *stringPtr;

    if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
	return Tcl_GetStringFromObj(objPtr, sizePtr);
    }








|







2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
 *
 *---------------------------------------------------------------------------
 */

char *
TclGetStringStorage(
    Tcl_Obj *objPtr,
    Tcl_Size *sizePtr)
{
    String *stringPtr;

    if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
	return Tcl_GetStringFromObj(objPtr, sizePtr);
    }

2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936

2937

2938
2939
2940
2941
2942
2943
2944
2945
2946
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringRepeat(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    size_t count,
    int flags)
{
    Tcl_Obj *objResultPtr;
    int inPlace = flags & TCL_STRING_IN_PLACE;

    size_t length = 0, unichar = 0, done = 1;

    int binary = TclIsPureByteArray(objPtr);
    size_t maxCount;

    /* assert (count >= 2) */

    /*
     * Analyze to determine what representation result should be.
     * GOALS:	Avoid shimmering & string rep generation.
     * 		Produce pure bytearray when possible.







|




>
|
>

|







2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringRepeat(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Tcl_Size count,
    int flags)
{
    Tcl_Obj *objResultPtr;
    int inPlace = flags & TCL_STRING_IN_PLACE;
    Tcl_Size length = 0;
    int unichar = 0;
    Tcl_Size done = 1;
    int binary = TclIsPureByteArray(objPtr);
    Tcl_Size maxCount;

    /* assert (count >= 2) */

    /*
     * Analyze to determine what representation result should be.
     * GOALS:	Avoid shimmering & string rep generation.
     * 		Produce pure bytearray when possible.
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017

3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
	    }
	}
    }

    if (binary) {
	/* Result will be pure byte array. Pre-size it */
	(void)Tcl_GetByteArrayFromObj(objPtr, &length);
	maxCount = TCL_SIZE_SMAX;
    } else if (unichar) {
	/* Result will be pure Tcl_UniChar array. Pre-size it. */
	(void)Tcl_GetUnicodeFromObj(objPtr, &length);
	maxCount = TCL_SIZE_SMAX/sizeof(Tcl_UniChar);
    } else {
	/* Result will be concat of string reps. Pre-size it. */
	(void)Tcl_GetStringFromObj(objPtr, &length);
	maxCount = TCL_SIZE_SMAX;
    }

    if (length == 0) {
	/* Any repeats of empty is empty. */
	return objPtr;
    }

    /* maxCount includes space for null */
    if (count > (maxCount-1)) {
	if (interp) {
	    Tcl_SetObjResult(
		interp,
		Tcl_ObjPrintf("max size for a Tcl value (%" TCL_Z_MODIFIER
			      "u bytes) exceeded",
			      TCL_SIZE_SMAX));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	}
	return NULL;
    }

    if (binary) {
	/* Efficiently produce a pure byte array result */
	objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ?
		Tcl_DuplicateObj(objPtr) : objPtr;

	/* Allocate count*length space */
	Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */
	Tcl_SetByteArrayLength(objResultPtr, length);
	while (count - done > done) {
	    Tcl_AppendObjToObj(objResultPtr, objResultPtr);
	    done *= 2;
	}
	TclAppendBytesToByteArray(objResultPtr,
		Tcl_GetByteArrayFromObj(objResultPtr, (size_t *)NULL),
		(count - done) * length);
    } else if (unichar) {
	/*
	 * Efficiently produce a pure Tcl_UniChar array result.
	 */

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length);
	} else {
	    TclInvalidateStringRep(objPtr);
	    objResultPtr = objPtr;
	}


        if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"string size overflow: unable to alloc %"
			TCL_Z_MODIFIER "u bytes",
			STRING_SIZE(count*length)));
		Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	    }
	    return NULL;
	}
	Tcl_SetObjLength(objResultPtr, length);
	while (count - done > done) {







|



|



|












|
|
|


















|













>




|







2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
	    }
	}
    }

    if (binary) {
	/* Result will be pure byte array. Pre-size it */
	(void)Tcl_GetByteArrayFromObj(objPtr, &length);
	maxCount = TCL_SIZE_MAX;
    } else if (unichar) {
	/* Result will be pure Tcl_UniChar array. Pre-size it. */
	(void)Tcl_GetUnicodeFromObj(objPtr, &length);
	maxCount = TCL_SIZE_MAX/sizeof(Tcl_UniChar);
    } else {
	/* Result will be concat of string reps. Pre-size it. */
	(void)Tcl_GetStringFromObj(objPtr, &length);
	maxCount = TCL_SIZE_MAX;
    }

    if (length == 0) {
	/* Any repeats of empty is empty. */
	return objPtr;
    }

    /* maxCount includes space for null */
    if (count > (maxCount-1)) {
	if (interp) {
	    Tcl_SetObjResult(
		interp,
		Tcl_ObjPrintf("max size for a Tcl value (%" TCL_SIZE_MODIFIER
			      "d bytes) exceeded",
			      TCL_SIZE_MAX));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	}
	return NULL;
    }

    if (binary) {
	/* Efficiently produce a pure byte array result */
	objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ?
		Tcl_DuplicateObj(objPtr) : objPtr;

	/* Allocate count*length space */
	Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */
	Tcl_SetByteArrayLength(objResultPtr, length);
	while (count - done > done) {
	    Tcl_AppendObjToObj(objResultPtr, objResultPtr);
	    done *= 2;
	}
	TclAppendBytesToByteArray(objResultPtr,
		Tcl_GetByteArrayFromObj(objResultPtr, (Tcl_Size *) NULL),
		(count - done) * length);
    } else if (unichar) {
	/*
	 * Efficiently produce a pure Tcl_UniChar array result.
	 */

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length);
	} else {
	    TclInvalidateStringRep(objPtr);
	    objResultPtr = objPtr;
	}

        /* TODO - overflow check */
        if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"string size overflow: unable to alloc %"
			TCL_SIZE_MODIFIER "d bytes",
			STRING_SIZE(count*length)));
		Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	    }
	    return NULL;
	}
	Tcl_SetObjLength(objResultPtr, length);
	while (count - done > done) {
3039
3040
3041
3042
3043
3044
3045

3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    objResultPtr = Tcl_NewStringObj(TclGetString(objPtr), length);
	} else {
	    TclFreeInternalRep(objPtr);
	    objResultPtr = objPtr;
	}

        if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"string size overflow: unable to alloc %" TCL_Z_MODIFIER "u bytes",
			count*length));
		Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	    }
	    return NULL;
	}
	Tcl_SetObjLength(objResultPtr, length);
	while (count - done > done) {







>



|







3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    objResultPtr = Tcl_NewStringObj(TclGetString(objPtr), length);
	} else {
	    TclFreeInternalRep(objPtr);
	    objResultPtr = objPtr;
	}
        /* TODO - overflow check */
        if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"string size overflow: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
			count*length));
		Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	    }
	    return NULL;
	}
	Tcl_SetObjLength(objResultPtr, length);
	while (count - done > done) {
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj * const objv[],
    int flags)
{
    Tcl_Obj *objResultPtr, * const *ov;
    int oc, binary = 1;
    size_t length = 0;
    int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0;
    int first = objc - 1;	/* Index of first value possibly not empty */
    int last = 0;		/* Index of last value possibly not empty */
    int inPlace = flags & TCL_STRING_IN_PLACE;

    /* assert ( objc >= 0 ) */








|







3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj * const objv[],
    int flags)
{
    Tcl_Obj *objResultPtr, * const *ov;
    int oc, binary = 1;
    Tcl_Size length = 0;
    int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0;
    int first = objc - 1;	/* Index of first value possibly not empty */
    int last = 0;		/* Index of last value possibly not empty */
    int inPlace = flags & TCL_STRING_IN_PLACE;

    /* assert ( objc >= 0 ) */

3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
    } while (--oc && (binary || allowUniChar));

    if (binary) {
	/*
	 * Result will be pure byte array. Pre-size it
	 */

	size_t numBytes = 0;
	ov = objv;
	oc = objc;
	do {
	    Tcl_Obj *objPtr = *ov++;

	    /*
	     * Every argument is either a bytearray with a ("pure")
	     * value we know we can safely use, or it is an empty string.
	     * We don't need to count bytes for the empty strings.
	     */

	    if (TclIsPureByteArray(objPtr)) {
		(void)Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */

		if (numBytes) {
		    last = objc - oc;
		    if (length == 0) {
			first = last;
		    }
		    if (length > (TCL_SIZE_SMAX-numBytes)) {
			goto overflow;
		    }
		    length += numBytes;
		}
	    }
	} while (--oc);
    } else if ((allowUniChar && requestUniChar) || forceUniChar) {
	/*
	 * Result will be pure Tcl_UniChar array. Pre-size it.
	 */

	ov = objv;
	oc = objc;
	do {
	    Tcl_Obj *objPtr = *ov++;

	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
		size_t numChars;

		(void)Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */
		if (numChars) {
		    last = objc - oc;
		    if (length == 0) {
			first = last;
		    }
		    if (length > ((TCL_SIZE_SMAX/sizeof(Tcl_UniChar))-numChars)) {
			goto overflow;
		    }
		    length += numChars;
		}
	    }
	} while (--oc);
    } else {







|



















|

















|







|







3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
    } while (--oc && (binary || allowUniChar));

    if (binary) {
	/*
	 * Result will be pure byte array. Pre-size it
	 */

	Tcl_Size numBytes = 0;
	ov = objv;
	oc = objc;
	do {
	    Tcl_Obj *objPtr = *ov++;

	    /*
	     * Every argument is either a bytearray with a ("pure")
	     * value we know we can safely use, or it is an empty string.
	     * We don't need to count bytes for the empty strings.
	     */

	    if (TclIsPureByteArray(objPtr)) {
		(void)Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */

		if (numBytes) {
		    last = objc - oc;
		    if (length == 0) {
			first = last;
		    }
		    if (length > (TCL_SIZE_MAX-numBytes)) {
			goto overflow;
		    }
		    length += numBytes;
		}
	    }
	} while (--oc);
    } else if ((allowUniChar && requestUniChar) || forceUniChar) {
	/*
	 * Result will be pure Tcl_UniChar array. Pre-size it.
	 */

	ov = objv;
	oc = objc;
	do {
	    Tcl_Obj *objPtr = *ov++;

	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
		Tcl_Size numChars;

		(void)Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */
		if (numChars) {
		    last = objc - oc;
		    if (length == 0) {
			first = last;
		    }
		    if (length > (Tcl_Size) ((TCL_SIZE_MAX/sizeof(Tcl_UniChar))-numChars)) {
			goto overflow;
		    }
		    length += numChars;
		}
	    }
	} while (--oc);
    } else {
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
	     * or (oc == 0) and all values are known empty,
 	     * so first = last = objc - 1 signals the right quick return.
 	     */

	    first = last = objc - oc - 1;

	    if (oc && (length == 0)) {
		size_t numBytes;

		/* assert ( pendingPtr != NULL ) */

		/*
		 * There's a pending value followed by more values.  Loop over
		 * remaining values generating strings until a non-empty value
		 * is found, or the pending value gets its string generated.







|







3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
	     * or (oc == 0) and all values are known empty,
 	     * so first = last = objc - 1 signals the right quick return.
 	     */

	    first = last = objc - oc - 1;

	    if (oc && (length == 0)) {
		Tcl_Size numBytes;

		/* assert ( pendingPtr != NULL ) */

		/*
		 * There's a pending value followed by more values.  Loop over
		 * remaining values generating strings until a non-empty value
		 * is found, or the pending value gets its string generated.
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
		if (oc || numBytes) {
		    (void)Tcl_GetStringFromObj(pendingPtr, &length);
		}
		if (length == 0) {
		    if (numBytes) {
			first = last;
		    }
		} else if (numBytes > (TCL_SIZE_SMAX - length)) {
		    goto overflow;
		}
		length += numBytes;
	    }
	} while (oc && (length == 0));

	while (oc) {
	    size_t numBytes;
	    Tcl_Obj *objPtr = *ov++;

	    /* assert ( length > 0 && pendingPtr == NULL )  */

	    TclGetString(objPtr); /* PANIC? */
	    numBytes = objPtr->length;
	    if (numBytes) {
		last = objc - oc;
		if (numBytes > (TCL_SIZE_SMAX - length)) {
		    goto overflow;
		}
		length += numBytes;
	    }
	    --oc;
	}
    }







|







|








|







3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
		if (oc || numBytes) {
		    (void)Tcl_GetStringFromObj(pendingPtr, &length);
		}
		if (length == 0) {
		    if (numBytes) {
			first = last;
		    }
		} else if (numBytes > (TCL_SIZE_MAX - length)) {
		    goto overflow;
		}
		length += numBytes;
	    }
	} while (oc && (length == 0));

	while (oc) {
	    Tcl_Size numBytes;
	    Tcl_Obj *objPtr = *ov++;

	    /* assert ( length > 0 && pendingPtr == NULL )  */

	    TclGetString(objPtr); /* PANIC? */
	    numBytes = objPtr->length;
	    if (numBytes) {
		last = objc - oc;
		if (numBytes > (TCL_SIZE_MAX - length)) {
		    goto overflow;
		}
		length += numBytes;
	    }
	    --oc;
	}
    }
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349

	/*
	 * Broken interface! Byte array value routines offer no way to handle
	 * failure to allocate enough space. Following stanza may panic.
	 */

	if (inPlace && !Tcl_IsShared(*objv)) {
	    size_t start = 0;

	    objResultPtr = *objv++; objc--;
	    (void)Tcl_GetByteArrayFromObj(objResultPtr, &start);
	    dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
	} else {
	    objResultPtr = Tcl_NewByteArrayObj(NULL, length);
	    dst = Tcl_SetByteArrayLength(objResultPtr, length);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;

	    /*
	     * Every argument is either a bytearray with a ("pure")
	     * value we know we can safely use, or it is an empty string.
	     * We don't need to copy bytes from the empty strings.
	     */

	    if (TclIsPureByteArray(objPtr)) {
		size_t more = 0;
		unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
		memcpy(dst, src, more);
		dst += more;
	    }
	}
    } else if ((allowUniChar && requestUniChar) || forceUniChar) {
	/* Efficiently produce a pure Tcl_UniChar array result */
	Tcl_UniChar *dst;

	if (inPlace && !Tcl_IsShared(*objv)) {
	    size_t start;

	    objResultPtr = *objv++; objc--;

	    /* Ugly interface! Force resize of the unicode array. */
	    (void)Tcl_GetUnicodeFromObj(objResultPtr, &start);
	    Tcl_InvalidateStringRep(objResultPtr);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {







|


















|










|







3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380

	/*
	 * Broken interface! Byte array value routines offer no way to handle
	 * failure to allocate enough space. Following stanza may panic.
	 */

	if (inPlace && !Tcl_IsShared(*objv)) {
	    Tcl_Size start = 0;

	    objResultPtr = *objv++; objc--;
	    (void)Tcl_GetByteArrayFromObj(objResultPtr, &start);
	    dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
	} else {
	    objResultPtr = Tcl_NewByteArrayObj(NULL, length);
	    dst = Tcl_SetByteArrayLength(objResultPtr, length);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;

	    /*
	     * Every argument is either a bytearray with a ("pure")
	     * value we know we can safely use, or it is an empty string.
	     * We don't need to copy bytes from the empty strings.
	     */

	    if (TclIsPureByteArray(objPtr)) {
		Tcl_Size more = 0;
		unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
		memcpy(dst, src, more);
		dst += more;
	    }
	}
    } else if ((allowUniChar && requestUniChar) || forceUniChar) {
	/* Efficiently produce a pure Tcl_UniChar array result */
	Tcl_UniChar *dst;

	if (inPlace && !Tcl_IsShared(*objv)) {
	    Tcl_Size start;

	    objResultPtr = *objv++; objc--;

	    /* Ugly interface! Force resize of the unicode array. */
	    (void)Tcl_GetUnicodeFromObj(objResultPtr, &start);
	    Tcl_InvalidateStringRep(objResultPtr);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
	    }
	    dst = Tcl_GetUnicode(objResultPtr);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;

	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
		size_t more;
		Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more);
		memcpy(dst, src, more * sizeof(Tcl_UniChar));
		dst += more;
	    }
	}
    } else {
	/* Efficiently concatenate string reps */
	char *dst;

	if (inPlace && !Tcl_IsShared(*objv)) {
	    size_t start;

	    objResultPtr = *objv++; objc--;

	    (void)Tcl_GetStringFromObj(objResultPtr, &start);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(







|










|







3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
	    }
	    dst = Tcl_GetUnicode(objResultPtr);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;

	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
		Tcl_Size more;
		Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more);
		memcpy(dst, src, more * sizeof(Tcl_UniChar));
		dst += more;
	    }
	}
    } else {
	/* Efficiently concatenate string reps */
	char *dst;

	if (inPlace && !Tcl_IsShared(*objv)) {
	    Tcl_Size start;

	    objResultPtr = *objv++; objc--;

	    (void)Tcl_GetStringFromObj(objResultPtr, &start);
	    if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
	    }
	    dst = TclGetString(objResultPtr);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;

	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
		size_t more;
		char *src = Tcl_GetStringFromObj(objPtr, &more);

		memcpy(dst, src, more);
		dst += more;
	    }
	}
	/* Must NUL-terminate! */
	*dst = '\0';
    }
    return objResultPtr;

  overflow:
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", TCL_SIZE_SMAX));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
    }
    return NULL;
}

/*
 *---------------------------------------------------------------------------







|














|







3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
	    }
	    dst = TclGetString(objResultPtr);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;

	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
		Tcl_Size more;
		char *src = Tcl_GetStringFromObj(objPtr, &more);

		memcpy(dst, src, more);
		dst += more;
	    }
	}
	/* Must NUL-terminate! */
	*dst = '\0';
    }
    return objResultPtr;

  overflow:
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX));
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
    }
    return NULL;
}

/*
 *---------------------------------------------------------------------------
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484

int
TclStringCmp(
    Tcl_Obj *value1Ptr,
    Tcl_Obj *value2Ptr,
    int checkEq,		/* comparison is only for equality */
    int nocase,			/* comparison is not case sensitive */
    size_t reqlength)		/* requested length in characters;
						 * TCL_INDEX_NONE to compare whole strings */
{
    const char *s1, *s2;
    int empty, match;
    size_t length, s1len = 0, s2len = 0;
    memCmpFn_t memCmpFn;

    if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
	/*
	 * Always match at 0 chars of if it is the same obj.
	 */
	match = 0;







|




|







3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515

int
TclStringCmp(
    Tcl_Obj *value1Ptr,
    Tcl_Obj *value2Ptr,
    int checkEq,		/* comparison is only for equality */
    int nocase,			/* comparison is not case sensitive */
    Tcl_Size reqlength)		/* requested length in characters;
						 * TCL_INDEX_NONE to compare whole strings */
{
    const char *s1, *s2;
    int empty, match;
    Tcl_Size length, s1len = 0, s2len = 0;
    memCmpFn_t memCmpFn;

    if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
	/*
	 * Always match at 0 chars of if it is the same obj.
	 */
	match = 0;
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringFirst(
    Tcl_Obj *needle,
    Tcl_Obj *haystack,
    size_t start)
{
    size_t lh = 0, ln = Tcl_GetCharLength(needle);
    size_t value = TCL_INDEX_NONE;
    Tcl_UniChar *checkStr, *endStr, *uh, *un;
    Tcl_Obj *obj;

    if (start == TCL_INDEX_NONE) {
	start = 0;
    }
    if (ln == 0) {
	/* We don't find empty substrings.  Bizarre!
	 * Whenever this routine is turned into a proper substring
	 * finder, change to `return start` after limits imposed. */
	goto firstEnd;







|

|
|



|







3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringFirst(
    Tcl_Obj *needle,
    Tcl_Obj *haystack,
    Tcl_Size start)
{
    Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle);
    Tcl_Size value = -1;
    Tcl_UniChar *checkStr, *endStr, *uh, *un;
    Tcl_Obj *obj;

    if (start < 0) {
	start = 0;
    }
    if (ln == 0) {
	/* We don't find empty substrings.  Bizarre!
	 * Whenever this routine is turned into a proper substring
	 * finder, change to `return start` after limits imposed. */
	goto firstEnd;
3766
3767
3768
3769
3770
3771
3772
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
3799
3800
3801
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringLast(
    Tcl_Obj *needle,
    Tcl_Obj *haystack,
    size_t last)
{
    size_t lh = 0, ln = Tcl_GetCharLength(needle);
    size_t value = TCL_INDEX_NONE;
    Tcl_UniChar *checkStr, *uh, *un;
    Tcl_Obj *obj;

    if (ln == 0) {
	/*
	 * 	We don't find empty substrings.  Bizarre!
	 *
	 * 	TODO: When we one day make this a true substring
	 * 	finder, change this to "return last", after limitation.
	 */
	goto lastEnd;
    }

    if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
	unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh);
	unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);

	if (last + 1 >= lh + 1) {
	    last = lh - 1;
	}
	if (last + 1 < ln) {
	    /* Don't start the loop if there cannot be a valid answer */
	    goto lastEnd;
	}
	check = bh + last + 1 - ln;







|

|
|

















|







3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringLast(
    Tcl_Obj *needle,
    Tcl_Obj *haystack,
    Tcl_Size last)
{
    Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle);
    Tcl_Size value = -1;
    Tcl_UniChar *checkStr, *uh, *un;
    Tcl_Obj *obj;

    if (ln == 0) {
	/*
	 * 	We don't find empty substrings.  Bizarre!
	 *
	 * 	TODO: When we one day make this a true substring
	 * 	finder, change this to "return last", after limitation.
	 */
	goto lastEnd;
    }

    if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
	unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh);
	unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);

	if (last >= lh) {
	    last = lh - 1;
	}
	if (last + 1 < ln) {
	    /* Don't start the loop if there cannot be a valid answer */
	    goto lastEnd;
	}
	check = bh + last + 1 - ln;
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
	}
	goto lastEnd;
    }

    uh = Tcl_GetUnicodeFromObj(haystack, &lh);
    un = Tcl_GetUnicodeFromObj(needle, &ln);

    if (last + 1 >= lh + 1) {
	last = lh - 1;
    }
    if (last + 1 < ln) {
	/* Don't start the loop if there cannot be a valid answer */
	goto lastEnd;
    }
    checkStr = uh + last + 1 - ln;







|







3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
	}
	goto lastEnd;
    }

    uh = Tcl_GetUnicodeFromObj(haystack, &lh);
    un = Tcl_GetUnicodeFromObj(needle, &ln);

    if (last >= lh) {
	last = lh - 1;
    }
    if (last + 1 < ln) {
	/* Don't start the loop if there cannot be a valid answer */
	goto lastEnd;
    }
    checkStr = uh + last + 1 - ln;
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
 *---------------------------------------------------------------------------
 */

static void
ReverseBytes(
    unsigned char *to,		/* Copy bytes into here... */
    unsigned char *from,	/* ...from here... */
    size_t count)		/* Until this many are copied, */
				/* reversing as you go. */
{
    unsigned char *src = from + count;

    if (to == from) {
	/* Reversing in place */
	while (--src > to) {







|







3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
 *---------------------------------------------------------------------------
 */

static void
ReverseBytes(
    unsigned char *to,		/* Copy bytes into here... */
    unsigned char *from,	/* ...from here... */
    Tcl_Size count)		/* Until this many are copied, */
				/* reversing as you go. */
{
    unsigned char *src = from + count;

    if (to == from) {
	/* Reversing in place */
	while (--src > to) {
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
    Tcl_UniChar ch = 0;
    int inPlace = flags & TCL_STRING_IN_PLACE;
#if TCL_UTF_MAX < 4
    int needFlip = 0;
#endif

    if (TclIsPureByteArray(objPtr)) {
	size_t numBytes = 0;
	unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes);

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    objPtr = Tcl_NewByteArrayObj(NULL, numBytes);
	}
	ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL), from, numBytes);
	return objPtr;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if (stringPtr->hasUnicode) {







|





|







3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
    Tcl_UniChar ch = 0;
    int inPlace = flags & TCL_STRING_IN_PLACE;
#if TCL_UTF_MAX < 4
    int needFlip = 0;
#endif

    if (TclIsPureByteArray(objPtr)) {
	Tcl_Size numBytes = 0;
	unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes);

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    objPtr = Tcl_NewByteArrayObj(NULL, numBytes);
	}
	ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)NULL), from, numBytes);
	return objPtr;
    }

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if (stringPtr->hasUnicode) {
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
		}
	    }
	}
#endif
    }

    if (objPtr->bytes) {
	size_t numChars = stringPtr->numChars;
	size_t numBytes = objPtr->length;
	char *to, *from = objPtr->bytes;

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    TclNewObj(objPtr);
	    Tcl_SetObjLength(objPtr, numBytes);
	}
	to = objPtr->bytes;

	if ((numChars == TCL_INDEX_NONE) || (numChars < numBytes)) {
	    /*
	     * Either numChars == -1 and we don't know how many chars are
	     * represented by objPtr->bytes and we need Pass 1 just in case,
	     * or numChars >= 0 and we know we have fewer chars than bytes, so
	     * we know there's a multibyte character needing Pass 1.
	     *
	     * Pass 1. Reverse the bytes of each multi-byte character.
	     */

	    size_t bytesLeft = numBytes;
	    int chw;

	    while (bytesLeft) {
		/*
		 * NOTE: We know that the from buffer is NUL-terminated. It's
		 * part of the contract for objPtr->bytes values. Thus, we can
		 * skip calling Tcl_UtfCharComplete() here.
		 */

		size_t bytesInChar = TclUtfToUCS4(from, &chw);

		ReverseBytes((unsigned char *)to, (unsigned char *)from,
			bytesInChar);
		to += bytesInChar;
		from += bytesInChar;
		bytesLeft -= bytesInChar;
	    }







|
|








|









|









|







3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
		}
	    }
	}
#endif
    }

    if (objPtr->bytes) {
	Tcl_Size numChars = stringPtr->numChars;
	Tcl_Size numBytes = objPtr->length;
	char *to, *from = objPtr->bytes;

	if (!inPlace || Tcl_IsShared(objPtr)) {
	    TclNewObj(objPtr);
	    Tcl_SetObjLength(objPtr, numBytes);
	}
	to = objPtr->bytes;

	if (numChars < numBytes) {
	    /*
	     * Either numChars == -1 and we don't know how many chars are
	     * represented by objPtr->bytes and we need Pass 1 just in case,
	     * or numChars >= 0 and we know we have fewer chars than bytes, so
	     * we know there's a multibyte character needing Pass 1.
	     *
	     * Pass 1. Reverse the bytes of each multi-byte character.
	     */

	    Tcl_Size bytesLeft = numBytes;
	    int chw;

	    while (bytesLeft) {
		/*
		 * NOTE: We know that the from buffer is NUL-terminated. It's
		 * part of the contract for objPtr->bytes values. Thus, we can
		 * skip calling Tcl_UtfCharComplete() here.
		 */

		int bytesInChar = TclUtfToUCS4(from, &chw);

		ReverseBytes((unsigned char *)to, (unsigned char *)from,
			bytesInChar);
		to += bytesInChar;
		from += bytesInChar;
		bytesLeft -= bytesInChar;
	    }
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066



4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringReplace(
    Tcl_Interp *interp,		/* For error reporting, may be NULL */
    Tcl_Obj *objPtr,		/* String to act upon */
    size_t first,		/* First index to replace */
    size_t count,		/* How many chars to replace */
    Tcl_Obj *insertPtr,		/* Replacement string, may be NULL */
    int flags)			/* TCL_STRING_IN_PLACE => attempt in-place */
{
    int inPlace = flags & TCL_STRING_IN_PLACE;
    Tcl_Obj *result;

    /* Replace nothing with nothing */
    if ((insertPtr == NULL) && (count == 0)) {
	if (inPlace) {
	    return objPtr;
	} else {
	    return Tcl_DuplicateObj(objPtr);
	}



    }

    /*
     * The caller very likely had to call Tcl_GetCharLength() or similar
     * to be able to process index values.  This means it is likely that
     * objPtr is either a proper "bytearray" or a "string" or else it has
     * a known and short string rep.
     */

    if (TclIsPureByteArray(objPtr)) {
	size_t numBytes = 0;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);

	if (insertPtr == NULL) {
	    /* Replace something with nothing. */

	    assert ( first <= numBytes ) ;
	    assert ( count <= numBytes ) ;







|
|







|





>
>
>










|







4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclStringReplace(
    Tcl_Interp *interp,		/* For error reporting, may be NULL */
    Tcl_Obj *objPtr,		/* String to act upon */
    Tcl_Size first,		/* First index to replace */
    Tcl_Size count,		/* How many chars to replace */
    Tcl_Obj *insertPtr,		/* Replacement string, may be NULL */
    int flags)			/* TCL_STRING_IN_PLACE => attempt in-place */
{
    int inPlace = flags & TCL_STRING_IN_PLACE;
    Tcl_Obj *result;

    /* Replace nothing with nothing */
    if ((insertPtr == NULL) && (count <= 0)) {
	if (inPlace) {
	    return objPtr;
	} else {
	    return Tcl_DuplicateObj(objPtr);
	}
    }
    if (first < 0) {
	first = 0;
    }

    /*
     * The caller very likely had to call Tcl_GetCharLength() or similar
     * to be able to process index values.  This means it is likely that
     * objPtr is either a proper "bytearray" or a "string" or else it has
     * a known and short string rep.
     */

    if (TclIsPureByteArray(objPtr)) {
	Tcl_Size numBytes = 0;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);

	if (insertPtr == NULL) {
	    /* Replace something with nothing. */

	    assert ( first <= numBytes ) ;
	    assert ( count <= numBytes ) ;
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126

	/* Replace everything */
	if ((first == 0) && (count == numBytes)) {
	    return insertPtr;
	}

	if (TclIsPureByteArray(insertPtr)) {
	    size_t newBytes = 0;
	    unsigned char *iBytes
		    = Tcl_GetByteArrayFromObj(insertPtr, &newBytes);

	    if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) {
		/*
		 * Removal count and replacement count are equal.
		 * Other conditions permit. Do in-place splice.
		 */

		memcpy(bytes + first, iBytes, count);
		Tcl_InvalidateStringRep(objPtr);
		return objPtr;
	    }

	    if (newBytes > (TCL_SIZE_SMAX - (numBytes - count))) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded",
			    TCL_SIZE_SMAX));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
		}
		return NULL;
	    }
	    result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
								/* PANIC? */
	    Tcl_SetByteArrayLength(result, 0);







|














|


|
|







4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160

	/* Replace everything */
	if ((first == 0) && (count == numBytes)) {
	    return insertPtr;
	}

	if (TclIsPureByteArray(insertPtr)) {
	    Tcl_Size newBytes = 0;
	    unsigned char *iBytes
		    = Tcl_GetByteArrayFromObj(insertPtr, &newBytes);

	    if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) {
		/*
		 * Removal count and replacement count are equal.
		 * Other conditions permit. Do in-place splice.
		 */

		memcpy(bytes + first, iBytes, count);
		Tcl_InvalidateStringRep(objPtr);
		return objPtr;
	    }

	    if (newBytes > (TCL_SIZE_MAX - (numBytes - count))) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded",
			    TCL_SIZE_MAX));
		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
		}
		return NULL;
	    }
	    result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
								/* PANIC? */
	    Tcl_SetByteArrayLength(result, 0);
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
     * TODO: Figure out how not to generate a Tcl_UniChar array rep
     * when it can be determined objPtr->bytes points to a string of
     * all single-byte characters so we can index it directly.
     */

    /* The traditional implementation... */
    {
	size_t numChars;
	Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);

	/* TODO: Is there an in-place option worth pursuing here? */

	result = Tcl_NewUnicodeObj(ustring, first);
	if (insertPtr) {
	    Tcl_AppendObjToObj(result, insertPtr);







|







4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
     * TODO: Figure out how not to generate a Tcl_UniChar array rep
     * when it can be determined objPtr->bytes points to a string of
     * all single-byte characters so we can index it directly.
     */

    /* The traditional implementation... */
    {
	Tcl_Size numChars;
	Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);

	/* TODO: Is there an in-place option worth pursuing here? */

	result = Tcl_NewUnicodeObj(ustring, first);
	if (insertPtr) {
	    Tcl_AppendObjToObj(result, insertPtr);
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
	    stringPtr->numChars);
}

static void
ExtendUnicodeRepWithString(
    Tcl_Obj *objPtr,
    const char *bytes,
    size_t numBytes,
    size_t numAppendChars)
{
    String *stringPtr = GET_STRING(objPtr);
    size_t needed, numOrigChars = 0;
    Tcl_UniChar *dst, unichar = 0;

    if (stringPtr->hasUnicode) {
	numOrigChars = stringPtr->numChars;
    }
    if (numAppendChars == TCL_INDEX_NONE) {
	TclNumUtfCharsM(numAppendChars, bytes, numBytes);







|
|


|







4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
	    stringPtr->numChars);
}

static void
ExtendUnicodeRepWithString(
    Tcl_Obj *objPtr,
    const char *bytes,
    Tcl_Size numBytes,
    Tcl_Size numAppendChars)
{
    String *stringPtr = GET_STRING(objPtr);
    Tcl_Size needed, numOrigChars = 0;
    Tcl_UniChar *dst, unichar = 0;

    if (stringPtr->hasUnicode) {
	numOrigChars = stringPtr->numChars;
    }
    if (numAppendChars == TCL_INDEX_NONE) {
	TclNumUtfCharsM(numAppendChars, bytes, numBytes);
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433

4434
4435



4436
4437
4438
4439
4440
4441
4442
	TclInitStringRep(objPtr, NULL, 0);
    } else {
	(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
		stringPtr->numChars);
    }
}

static size_t
ExtendStringRepWithUnicode(
    Tcl_Obj *objPtr,
    const Tcl_UniChar *unicode,
    size_t numChars)
{
    /*
     * Precondition: this is the "string" Tcl_ObjType.
     */

    size_t i, origLength, size = 0;
    char *dst;
    String *stringPtr = GET_STRING(objPtr);

    if (numChars == TCL_INDEX_NONE) {
	numChars = UnicodeLength(unicode);
    }

    if (numChars == 0) {
	return 0;
    }

    if (objPtr->bytes == NULL) {
	objPtr->length = 0;
    }
    size = origLength = objPtr->length;

    /*
     * Quick cheap check in case we have more than enough room.
     */

    if (numChars <= (INT_MAX - size)/TCL_UTF_MAX
	    && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
	goto copyBytes;
    }

    for (i = 0; i < numChars; i++) {

	size += TclUtfCount(unicode[i]);
    }




    /*
     * Grow space if needed.
     */

    if (size > stringPtr->allocated) {
	GrowStringBuffer(objPtr, size, 1);







|



|





|



|
















|




|
>


>
>
>







4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
	TclInitStringRep(objPtr, NULL, 0);
    } else {
	(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
		stringPtr->numChars);
    }
}

static Tcl_Size
ExtendStringRepWithUnicode(
    Tcl_Obj *objPtr,
    const Tcl_UniChar *unicode,
    Tcl_Size numChars)
{
    /*
     * Precondition: this is the "string" Tcl_ObjType.
     */

    Tcl_Size i, origLength, size = 0;
    char *dst;
    String *stringPtr = GET_STRING(objPtr);

    if (numChars < 0) {
	numChars = UnicodeLength(unicode);
    }

    if (numChars == 0) {
	return 0;
    }

    if (objPtr->bytes == NULL) {
	objPtr->length = 0;
    }
    size = origLength = objPtr->length;

    /*
     * Quick cheap check in case we have more than enough room.
     */

    if (numChars <= (TCL_SIZE_MAX - size)/TCL_UTF_MAX
	    && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
	goto copyBytes;
    }

    for (i = 0; i < numChars && size >= 0; i++) {
	/* TODO - overflow check! I don't think check below at end suffices */
	size += TclUtfCount(unicode[i]);
    }
    if (size < 0) {
	Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX);
    }

    /*
     * Grow space if needed.
     */

    if (size > stringPtr->allocated) {
	GrowStringBuffer(objPtr, size, 1);

Changes to generic/tclStringRep.h.

64
65
66
67
68
69
70




71
72
73
74
75
76
77
    int hasUnicode;		/* Boolean determining whether the string has
				 * a Unicode representation. */
    Tcl_UniChar unicode[TCLFLEXARRAY];	/* The array of Unicode chars. The actual size
				 * of this field depends on the 'maxChars'
				 * field above. */
} String;





#define STRING_SIZE(numChars) \
    (offsetof(String, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar)))
#define stringAttemptAlloc(numChars) \
    (String *) Tcl_AttemptAlloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
    (String *) Tcl_Alloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \







>
>
>
>







64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
    int hasUnicode;		/* Boolean determining whether the string has
				 * a Unicode representation. */
    Tcl_UniChar unicode[TCLFLEXARRAY];	/* The array of Unicode chars. The actual size
				 * of this field depends on the 'maxChars'
				 * field above. */
} String;

/* Limit on string lengths. The -1 because limit does not include the nul */
#define STRING_MAXCHARS \
    ((Tcl_Size)((TCL_SIZE_MAX - offsetof(String, unicode))/sizeof(Tcl_UniChar) - 1))
/* Memory needed to hold a string of length numChars - including NUL */
#define STRING_SIZE(numChars) \
    (offsetof(String, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar)))
#define stringAttemptAlloc(numChars) \
    (String *) Tcl_AttemptAlloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
    (String *) Tcl_Alloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \

Changes to generic/tclStubInit.c.

96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
#define TclUnusedStubEntry 0


#if TCL_UTF_MAX < 4
static void uniCodePanic() {
    Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
#   define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, size_t *))(void *)uniCodePanic
#   define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
#   define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, size_t))(void *)uniCodePanic
#   define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
#   define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
#endif

#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev

#if defined(TCL_NO_DEPRECATED)
# define TclListObjGetElements 0
# define TclListObjLength 0
# define TclDictObjSize 0
# define TclSplitList 0
# define TclSplitPath 0
# define TclFSSplitPath 0
# define TclParseArgsObjv 0
#else /* !defined(TCL_NO_DEPRECATED) */
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
    int *objcPtr, Tcl_Obj ***objvPtr) {
    size_t n = TCL_INDEX_NONE;
    int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
    if (objcPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "List too large to be processed", NULL);
	    }
	    return TCL_ERROR;
	}
	*objcPtr = n;
    }
    return result;
}
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
    int *lengthPtr) {
    size_t n = TCL_INDEX_NONE;
    int result = Tcl_ListObjLength(interp, listPtr, &n);
    if (lengthPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "List too large to be processed", NULL);
	    }
	    return TCL_ERROR;
	}
	*lengthPtr = n;
    }
    return result;
}
int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
    int *sizePtr) {
    size_t n = TCL_INDEX_NONE;
    int result = Tcl_DictObjSize(interp, dictPtr, &n);
    if (sizePtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "Dict too large to be processed", NULL);
	    }
	    return TCL_ERROR;
	}
	*sizePtr = n;
    }
    return result;
}
int TclSplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
	const char ***argvPtr) {
    size_t n = TCL_INDEX_NONE;
    int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
    if (argcPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "List too large to be processed", NULL);
	    }
	    Tcl_Free((void *)*argvPtr);
	    return TCL_ERROR;
	}
	*argcPtr = n;
    }
    return result;
}
void TclSplitPath(const char *path, int *argcPtr, const char ***argvPtr) {
    size_t n = TCL_INDEX_NONE;
    Tcl_SplitPath(path, &n, argvPtr);
    if (argcPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (n > INT_MAX)) {
	    n = TCL_INDEX_NONE; /* No other way to return an error-situation */
	    Tcl_Free((void *)*argvPtr);
	    *argvPtr = NULL;
	}
	*argcPtr = n;
    }
}
Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) {
    size_t n = TCL_INDEX_NONE;
    Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
    if (lenPtr) {
	if ((sizeof(int) != sizeof(size_t)) && result && (n > INT_MAX)) {
	    Tcl_DecrRefCount(result);
	    return NULL;
	}
	*lenPtr = n;
    }
    return result;
}
int TclParseArgsObjv(Tcl_Interp *interp,
	const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv,
	Tcl_Obj ***remObjv) {
    size_t n = (*objcPtr < 0) ? TCL_INDEX_NONE: (size_t)*objcPtr ;
    int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
    *objcPtr = (int)n;
    return result;
}
#endif /* !defined(TCL_NO_DEPRECATED) */

#define TclBN_mp_add mp_add







|

|
|
|

















|














|














|














|














|











|













|







96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
#define TclUnusedStubEntry 0


#if TCL_UTF_MAX < 4
static void uniCodePanic() {
    Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
#   define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, Tcl_Size *))(void *)uniCodePanic
#   define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
#   define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
#   define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
#   define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
#endif

#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev

#if defined(TCL_NO_DEPRECATED)
# define TclListObjGetElements 0
# define TclListObjLength 0
# define TclDictObjSize 0
# define TclSplitList 0
# define TclSplitPath 0
# define TclFSSplitPath 0
# define TclParseArgsObjv 0
#else /* !defined(TCL_NO_DEPRECATED) */
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
    int *objcPtr, Tcl_Obj ***objvPtr) {
    Tcl_Size n = TCL_INDEX_NONE;
    int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
    if (objcPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "List too large to be processed", NULL);
	    }
	    return TCL_ERROR;
	}
	*objcPtr = n;
    }
    return result;
}
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
    int *lengthPtr) {
    Tcl_Size n = TCL_INDEX_NONE;
    int result = Tcl_ListObjLength(interp, listPtr, &n);
    if (lengthPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "List too large to be processed", NULL);
	    }
	    return TCL_ERROR;
	}
	*lengthPtr = n;
    }
    return result;
}
int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
    int *sizePtr) {
    Tcl_Size n = TCL_INDEX_NONE;
    int result = Tcl_DictObjSize(interp, dictPtr, &n);
    if (sizePtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "Dict too large to be processed", NULL);
	    }
	    return TCL_ERROR;
	}
	*sizePtr = n;
    }
    return result;
}
int TclSplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
	const char ***argvPtr) {
    Tcl_Size n = TCL_INDEX_NONE;
    int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
    if (argcPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
	    if (interp) {
		Tcl_AppendResult(interp, "List too large to be processed", NULL);
	    }
	    Tcl_Free((void *)*argvPtr);
	    return TCL_ERROR;
	}
	*argcPtr = n;
    }
    return result;
}
void TclSplitPath(const char *path, int *argcPtr, const char ***argvPtr) {
    Tcl_Size n = TCL_INDEX_NONE;
    Tcl_SplitPath(path, &n, argvPtr);
    if (argcPtr) {
	if ((sizeof(int) != sizeof(size_t)) && (n > INT_MAX)) {
	    n = TCL_INDEX_NONE; /* No other way to return an error-situation */
	    Tcl_Free((void *)*argvPtr);
	    *argvPtr = NULL;
	}
	*argcPtr = n;
    }
}
Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) {
    Tcl_Size n = TCL_INDEX_NONE;
    Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
    if (lenPtr) {
	if ((sizeof(int) != sizeof(size_t)) && result && (n > INT_MAX)) {
	    Tcl_DecrRefCount(result);
	    return NULL;
	}
	*lenPtr = n;
    }
    return result;
}
int TclParseArgsObjv(Tcl_Interp *interp,
	const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv,
	Tcl_Obj ***remObjv) {
    Tcl_Size n = (*objcPtr < 0) ? TCL_INDEX_NONE: *objcPtr ;
    int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
    *objcPtr = (int)n;
    return result;
}
#endif /* !defined(TCL_NO_DEPRECATED) */

#define TclBN_mp_add mp_add
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
    int result = Tcl_ExprLong(interp, expr, &longValue);
    if (result == TCL_OK) {
	    if ((longValue >= (long)(INT_MIN))
		    && (longValue <= (long)(UINT_MAX))) {
	    *ptr = (int)longValue;
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "integer value too large to represent", TCL_INDEX_NONE));
	    result = TCL_ERROR;
	}
    }
    return result;
}
#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt
static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
    long longValue;
    int result = Tcl_ExprLongObj(interp, expr, &longValue);
    if (result == TCL_OK) {
	    if ((longValue >= (long)(INT_MIN))
		    && (longValue <= (long)(UINT_MAX))) {
	    *ptr = (int)longValue;
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "integer value too large to represent", TCL_INDEX_NONE));
	    result = TCL_ERROR;
	}
    }
    return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
static int utfNcmp(const char *s1, const char *s2, unsigned int n){







|















|







351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
    int result = Tcl_ExprLong(interp, expr, &longValue);
    if (result == TCL_OK) {
	    if ((longValue >= (long)(INT_MIN))
		    && (longValue <= (long)(UINT_MAX))) {
	    *ptr = (int)longValue;
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "integer value too large to represent", -1));
	    result = TCL_ERROR;
	}
    }
    return result;
}
#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt
static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
    long longValue;
    int result = Tcl_ExprLongObj(interp, expr, &longValue);
    if (result == TCL_OK) {
	    if ((longValue >= (long)(INT_MIN))
		    && (longValue <= (long)(UINT_MAX))) {
	    *ptr = (int)longValue;
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "integer value too large to represent", -1));
	    result = TCL_ERROR;
	}
    }
    return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
    Tcl_NRCallObjProc2, /* 679 */
    Tcl_GetNumberFromObj, /* 680 */
    Tcl_GetNumber, /* 681 */
    Tcl_RemoveChannelMode, /* 682 */
    Tcl_GetEncodingNulLength, /* 683 */
    Tcl_GetWideUIntFromObj, /* 684 */
    Tcl_DStringToObj, /* 685 */
    0, /* 686 */
    0, /* 687 */
    TclUnusedStubEntry, /* 688 */
};

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







|





1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
    Tcl_NRCallObjProc2, /* 679 */
    Tcl_GetNumberFromObj, /* 680 */
    Tcl_GetNumber, /* 681 */
    Tcl_RemoveChannelMode, /* 682 */
    Tcl_GetEncodingNulLength, /* 683 */
    Tcl_GetWideUIntFromObj, /* 684 */
    Tcl_DStringToObj, /* 685 */
    Tcl_GetSizeIntFromObj, /* 686 */
    0, /* 687 */
    TclUnusedStubEntry, /* 688 */
};

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

Changes to generic/tclTest.c.

916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
	for (asyncPtr = firstHandler; asyncPtr != NULL;
		asyncPtr = asyncPtr->nextPtr) {
	    if (asyncPtr->id == id) {
		Tcl_AsyncMark(asyncPtr->handler);
		break;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], TCL_INDEX_NONE));
	Tcl_MutexUnlock(&asyncTestMutex);
	return code;
    } else if (strcmp(argv[1], "marklater") == 0) {
	if (argc != 3) {
	    goto wrongNumArgs;
	}
	if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {







|







916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
	for (asyncPtr = firstHandler; asyncPtr != NULL;
		asyncPtr = asyncPtr->nextPtr) {
	    if (asyncPtr->id == id) {
		Tcl_AsyncMark(asyncPtr->handler);
		break;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
	Tcl_MutexUnlock(&asyncTestMutex);
	return code;
    } else if (strcmp(argv[1], "marklater") == 0) {
	if (argc != 3) {
	    goto wrongNumArgs;
	}
	if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
}

static void
CmdDelProc1(
    void *clientData)	/* String to save. */
{
    Tcl_DStringInit(&delString);
    Tcl_DStringAppend(&delString, "CmdDelProc1 ", TCL_INDEX_NONE);
    Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}

static void
CmdDelProc2(
    void *clientData)	/* String to save. */
{
    Tcl_DStringInit(&delString);
    Tcl_DStringAppend(&delString, "CmdDelProc2 ", TCL_INDEX_NONE);
    Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}

/*
 *----------------------------------------------------------------------
 *
 * TestcmdtokenCmd --
 *







|
|







|
|







1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
}

static void
CmdDelProc1(
    void *clientData)	/* String to save. */
{
    Tcl_DStringInit(&delString);
    Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
    Tcl_DStringAppend(&delString, (char *) clientData, -1);
}

static void
CmdDelProc2(
    void *clientData)	/* String to save. */
{
    Tcl_DStringInit(&delString);
    Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
    Tcl_DStringAppend(&delString, (char *) clientData, -1);
}

/*
 *----------------------------------------------------------------------
 *
 * TestcmdtokenCmd --
 *
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
    TCL_UNUSED(Tcl_Command),
    TCL_UNUSED(int) /*objc*/,
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *word = Tcl_GetString(objv[0]);

    if (!strcmp(word, "Error")) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(command, TCL_INDEX_NONE));
	return TCL_ERROR;
    } else if (!strcmp(word, "Break")) {
	return TCL_BREAK;
    } else if (!strcmp(word, "Continue")) {
	return TCL_CONTINUE;
    } else if (!strcmp(word, "Return")) {
	return TCL_RETURN;







|







1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
    TCL_UNUSED(Tcl_Command),
    TCL_UNUSED(int) /*objc*/,
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *word = Tcl_GetString(objv[0]);

    if (!strcmp(word, "Error")) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
	return TCL_ERROR;
    } else if (!strcmp(word, "Break")) {
	return TCL_BREAK;
    } else if (!strcmp(word, "Continue")) {
	return TCL_CONTINUE;
    } else if (!strcmp(word, "Return")) {
	return TCL_RETURN;
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
			       TCL_EXACT, &type) != TCL_OK) {
	fprintf(stderr, "bad value? %g\n", d);
	return TCL_ERROR;
    }
    type = types[type];
    if (objc > 4) {
	if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}
	type |= TCL_DD_SHORTEST;
    }
    str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
    strObj = Tcl_NewStringObj(str, endPtr-str);
    Tcl_Free(str);







|







1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
			       TCL_EXACT, &type) != TCL_OK) {
	fprintf(stderr, "bad value? %g\n", d);
	return TCL_ERROR;
    }
    type = types[type];
    if (objc > 4) {
	if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
	    return TCL_ERROR;
	}
	type |= TCL_DD_SHORTEST;
    }
    str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
    strObj = Tcl_NewStringObj(str, endPtr-str);
    Tcl_Free(str);
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
		stringVar = NULL;
	    } else {
		stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
		strcpy(stringVar, argv[5]);
	    }
	}
	if (argv[6][0] != 0) {
	    tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	}
	if (argv[7][0]) {







|







3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
		stringVar = NULL;
	    } else {
		stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
		strcpy(stringVar, argv[5]);
	    }
	}
	if (argv[6][0] != 0) {
	    tmp = Tcl_NewStringObj(argv[6], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	}
	if (argv[7][0]) {
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
	    if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
		return TCL_ERROR;
	    }
	    floatVar = (float) d;
	}
	if (argv[15][0]) {
	    Tcl_WideInt w;
	    tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    uwideVar = (Tcl_WideUInt) w;
	}







|







3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
	    if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
		return TCL_ERROR;
	    }
	    floatVar = (float) d;
	}
	if (argv[15][0]) {
	    Tcl_WideInt w;
	    tmp = Tcl_NewStringObj(argv[15], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    uwideVar = (Tcl_WideUInt) w;
	}
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
	    } else {
		stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
		strcpy(stringVar, argv[5]);
	    }
	    Tcl_UpdateLinkedVar(interp, "string");
	}
	if (argv[6][0] != 0) {
	    tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    Tcl_UpdateLinkedVar(interp, "wide");
	}







|







3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
	    } else {
		stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
		strcpy(stringVar, argv[5]);
	    }
	    Tcl_UpdateLinkedVar(interp, "string");
	}
	if (argv[6][0] != 0) {
	    tmp = Tcl_NewStringObj(argv[6], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    Tcl_UpdateLinkedVar(interp, "wide");
	}
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
		return TCL_ERROR;
	    }
	    floatVar = (float) d;
	    Tcl_UpdateLinkedVar(interp, "float");
	}
	if (argv[15][0]) {
	    Tcl_WideInt w;
	    tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    uwideVar = (Tcl_WideUInt) w;
	    Tcl_UpdateLinkedVar(interp, "uwide");







|







3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
		return TCL_ERROR;
	    }
	    floatVar = (float) d;
	    Tcl_UpdateLinkedVar(interp, "float");
	}
	if (argv[15][0]) {
	    Tcl_WideInt w;
	    tmp = Tcl_NewStringObj(argv[15], -1);
	    if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
		Tcl_DecrRefCount(tmp);
		return TCL_ERROR;
	    }
	    Tcl_DecrRefCount(tmp);
	    uwideVar = (Tcl_WideUInt) w;
	    Tcl_UpdateLinkedVar(interp, "uwide");
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
	    i++;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
 		&typeIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}
	name = Tcl_GetString(objv[i++]);

	/*
	 * If no address is given request one in the underlying function
	 */

	if (i < objc) {
	    if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong address value", TCL_INDEX_NONE));
		return TCL_ERROR;
	    }
	} else {
	    addr = 0;
	}
	return Tcl_LinkArray(interp, name, INT2PTR(addr),
		LinkTypes[typeIndex] | readonly, size);







|











|







3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
	    i++;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
 		&typeIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
	    return TCL_ERROR;
	}
	name = Tcl_GetString(objv[i++]);

	/*
	 * If no address is given request one in the underlying function
	 */

	if (i < objc) {
	    if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong address value", -1));
		return TCL_ERROR;
	    }
	} else {
	    addr = 0;
	}
	return Tcl_LinkArray(interp, name, INT2PTR(addr),
		LinkTypes[typeIndex] | readonly, size);
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
	}
	break;

    case LISTREP_DESCRIBE:
#define APPEND_FIELD(targetObj_, structPtr_, fld_)                        \
    do {                                                                  \
	Tcl_ListObjAppendElement(                                         \
	    interp, (targetObj_), Tcl_NewStringObj(#fld_, TCL_INDEX_NONE));           \
	Tcl_ListObjAppendElement(                                         \
	    interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
    } while (0)
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "object");
	    return TCL_ERROR;
	} else {
	    Tcl_Obj **objs;
	    Tcl_Size nobjs;
	    ListRep listRep;
	    Tcl_Obj *listRepObjs[4];

	    /* Force list representation */
	    if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ListObjGetRep(objv[2], &listRep);
	    listRepObjs[0] = Tcl_NewStringObj("store", TCL_INDEX_NONE);
	    listRepObjs[1] = Tcl_NewListObj(12, NULL);
	    Tcl_ListObjAppendElement(
		interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
	    Tcl_ListObjAppendElement(
		interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
	    if (listRep.spanPtr) {
		listRepObjs[2] = Tcl_NewStringObj("span", TCL_INDEX_NONE);
		listRepObjs[3] = Tcl_NewListObj(8, NULL);
		Tcl_ListObjAppendElement(interp,
					 listRepObjs[3],
					 Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
		Tcl_ListObjAppendElement(
		    interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
		APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
		APPEND_FIELD(
		    listRepObjs[3], listRep.spanPtr, spanLength);
		APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
	    }
	    resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
	}
#undef APPEND_FIELD
	break;

    case LISTREP_CONFIG:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, "object");
	    return TCL_ERROR;
	}
	resultObj = Tcl_NewListObj(2, NULL);
	Tcl_ListObjAppendElement(
	    NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", TCL_INDEX_NONE));
	Tcl_ListObjAppendElement(
	    NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
	break;

    case LISTREP_VALIDATE:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "object");







|

















|


|








|



|



















|







3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
	}
	break;

    case LISTREP_DESCRIBE:
#define APPEND_FIELD(targetObj_, structPtr_, fld_)                        \
    do {                                                                  \
	Tcl_ListObjAppendElement(                                         \
	    interp, (targetObj_), Tcl_NewStringObj(#fld_, -1));           \
	Tcl_ListObjAppendElement(                                         \
	    interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
    } while (0)
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "object");
	    return TCL_ERROR;
	} else {
	    Tcl_Obj **objs;
	    Tcl_Size nobjs;
	    ListRep listRep;
	    Tcl_Obj *listRepObjs[4];

	    /* Force list representation */
	    if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
		return TCL_ERROR;
	    }
	    ListObjGetRep(objv[2], &listRep);
	    listRepObjs[0] = Tcl_NewStringObj("store", -1);
	    listRepObjs[1] = Tcl_NewListObj(12, NULL);
	    Tcl_ListObjAppendElement(
		interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", -1));
	    Tcl_ListObjAppendElement(
		interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
	    APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
	    if (listRep.spanPtr) {
		listRepObjs[2] = Tcl_NewStringObj("span", -1);
		listRepObjs[3] = Tcl_NewListObj(8, NULL);
		Tcl_ListObjAppendElement(interp,
					 listRepObjs[3],
					 Tcl_NewStringObj("memoryAddress", -1));
		Tcl_ListObjAppendElement(
		    interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
		APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
		APPEND_FIELD(
		    listRepObjs[3], listRep.spanPtr, spanLength);
		APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
	    }
	    resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
	}
#undef APPEND_FIELD
	break;

    case LISTREP_CONFIG:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, "object");
	    return TCL_ERROR;
	}
	resultObj = Tcl_NewListObj(2, NULL);
	Tcl_ListObjAppendElement(
	    NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", -1));
	Tcl_ListObjAppendElement(
	    NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
	break;

    case LISTREP_VALIDATE:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "object");
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
    if (objc == 3) {
	locale = Tcl_GetString(objv[2]);
    } else {
	locale = NULL;
    }
    locale = setlocale(lcTypes[index], locale);
    if (locale) {
	Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, TCL_INDEX_NONE);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
    if (objc == 3) {
	locale = Tcl_GetString(objv[2]);
    } else {
	locale = NULL;
    }
    locale = setlocale(lcTypes[index], locale);
    if (locale) {
	Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
	    typeString = "operator";
	    break;
	default:
	    typeString = "??";
	    break;
	}
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewStringObj(typeString, TCL_INDEX_NONE));
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewWideIntObj(tokenPtr->numComponents));
    }
    Tcl_ListObjAppendElement(NULL, objPtr,
	    parsePtr->commandStart ?







|







4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
	    typeString = "operator";
	    break;
	default:
	    typeString = "??";
	    break;
	}
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewStringObj(typeString, -1));
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewWideIntObj(tokenPtr->numComponents));
    }
    Tcl_ListObjAppendElement(NULL, objPtr,
	    parsePtr->commandStart ?
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
    Tcl_GetTime(&stop);
    timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
    fprintf(stderr, "   %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
    Tcl_Free(objv);

    /* TclGetString 100000 times */
    fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
    objPtr = Tcl_NewStringObj("12345", TCL_INDEX_NONE);
    Tcl_GetTime(&start);
    for (i = 0;  i < 100000;  i++) {
	(void) TclGetString(objPtr);
    }
    Tcl_GetTime(&stop);
    timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
    fprintf(stderr, "   %.3f usec per Tcl_GetStringFromObj of \"12345\"\n",







|







5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
    Tcl_GetTime(&stop);
    timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
    fprintf(stderr, "   %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
    Tcl_Free(objv);

    /* TclGetString 100000 times */
    fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
    objPtr = Tcl_NewStringObj("12345", -1);
    Tcl_GetTime(&start);
    for (i = 0;  i < 100000;  i++) {
	(void) TclGetString(objPtr);
    }
    Tcl_GetTime(&stop);
    timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
    fprintf(stderr, "   %.3f usec per Tcl_GetStringFromObj of \"12345\"\n",
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
static int
TestbytestringObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    size_t n = 0;
    const char *p;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
	return TCL_ERROR;
    }








|







5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
static int
TestbytestringObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    Tcl_Size n = 0;
    const char *p;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
	return TCL_ERROR;
    }

5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
    } else {
	statePtr	= NULL;
	chan		= NULL;
    }

    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {

	Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);

	Tcl_IncrRefCount(msg);
	Tcl_SetChannelError(chan, msg);
	Tcl_DecrRefCount(msg);

	Tcl_GetChannelError(chan, &msg);
	Tcl_SetObjResult(interp, msg);
	Tcl_DecrRefCount(msg);
	return TCL_OK;
    }
    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {

	Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);

	Tcl_IncrRefCount(msg);
	Tcl_SetChannelErrorInterp(interp, msg);
	Tcl_DecrRefCount(msg);

	Tcl_GetChannelErrorInterp(interp, &msg);
	Tcl_SetObjResult(interp, msg);







|












|







5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
    } else {
	statePtr	= NULL;
	chan		= NULL;
    }

    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {

	Tcl_Obj *msg = Tcl_NewStringObj(argv[3], -1);

	Tcl_IncrRefCount(msg);
	Tcl_SetChannelError(chan, msg);
	Tcl_DecrRefCount(msg);

	Tcl_GetChannelError(chan, &msg);
	Tcl_SetObjResult(interp, msg);
	Tcl_DecrRefCount(msg);
	return TCL_OK;
    }
    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {

	Tcl_Obj *msg = Tcl_NewStringObj(argv[3], -1);

	Tcl_IncrRefCount(msg);
	Tcl_SetChannelErrorInterp(interp, msg);
	Tcl_DecrRefCount(msg);

	Tcl_GetChannelErrorInterp(interp, &msg);
	Tcl_SetObjResult(interp, msg);
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
	if (strcmp(argv[3], "-command") != 0) {
	    Tcl_AppendResult(interp, "bad argument \"", argv[3],
		    "\": should be \"-command\"", NULL);
	    return TCL_ERROR;
	}

	return TclChannelTransform(interp, chan,
		Tcl_NewStringObj(argv[4], TCL_INDEX_NONE));
    }

    if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
	/*
	 * Syntax: unstack channel
	 */








|







6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
	if (strcmp(argv[3], "-command") != 0) {
	    Tcl_AppendResult(interp, "bad argument \"", argv[3],
		    "\": should be \"-command\"", NULL);
	    return TCL_ERROR;
	}

	return TclChannelTransform(interp, chan,
		Tcl_NewStringObj(argv[4], -1));
    }

    if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
	/*
	 * Syntax: unstack channel
	 */

6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
	esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord));
	esPtr->nextPtr = statePtr->scriptRecordPtr;
	statePtr->scriptRecordPtr = esPtr;

	esPtr->chanPtr = chanPtr;
	esPtr->interp = interp;
	esPtr->mask = mask;
	esPtr->scriptPtr = Tcl_NewStringObj(argv[4], TCL_INDEX_NONE);
	Tcl_IncrRefCount(esPtr->scriptPtr);

	Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
		TclChannelEventScriptInvoker, esPtr);

	return TCL_OK;
    }







|







6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
	esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord));
	esPtr->nextPtr = statePtr->scriptRecordPtr;
	statePtr->scriptRecordPtr = esPtr;

	esPtr->chanPtr = chanPtr;
	esPtr->interp = interp;
	esPtr->mask = mask;
	esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
	Tcl_IncrRefCount(esPtr->scriptPtr);

	Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
		TclChannelEventScriptInvoker, esPtr);

	return TCL_OK;
    }
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
	}
	resultListPtr = Tcl_GetObjResult(interp);
	for (esPtr = statePtr->scriptRecordPtr;
	     esPtr != NULL;
	     esPtr = esPtr->nextPtr) {
	    if (esPtr->mask) {
		Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
		    (esPtr->mask == TCL_READABLE) ? "readable" : "writable", TCL_INDEX_NONE));
	    } else {
		Tcl_ListObjAppendElement(interp, resultListPtr,
			Tcl_NewStringObj("none", TCL_INDEX_NONE));
	    }
	    Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
	}
	Tcl_SetObjResult(interp, resultListPtr);
	return TCL_OK;
    }








|


|







6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
	}
	resultListPtr = Tcl_GetObjResult(interp);
	for (esPtr = statePtr->scriptRecordPtr;
	     esPtr != NULL;
	     esPtr = esPtr->nextPtr) {
	    if (esPtr->mask) {
		Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
		    (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
	    } else {
		Tcl_ListObjAppendElement(interp, resultListPtr,
			Tcl_NewStringObj("none", -1));
	    }
	    Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
	}
	Tcl_SetObjResult(interp, resultListPtr);
	return TCL_OK;
    }

6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
    if (boolVal) {
	res = Tcl_FSRegister(interp, &testReportingFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&testReportingFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
    return res;
}

static int
TestReportInFilesystem(
    Tcl_Obj *pathPtr,
    void **clientDataPtr)







|







6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
    if (boolVal) {
	res = Tcl_FSRegister(interp, &testReportingFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&testReportingFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
    return res;
}

static int
TestReportInFilesystem(
    Tcl_Obj *pathPtr,
    void **clientDataPtr)
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
    if (interp == NULL) {
	/* This is bad, but not much we can do about it */
    } else {
	Tcl_Obj *savedResult;
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, "lappend filesystemReport ", TCL_INDEX_NONE);
	Tcl_DStringStartSublist(&ds);
	Tcl_DStringAppendElement(&ds, cmd);
	if (path != NULL) {
	    Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
	}
	if (arg2 != NULL) {
	    Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));







|







6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
    if (interp == NULL) {
	/* This is bad, but not much we can do about it */
    } else {
	Tcl_Obj *savedResult;
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
	Tcl_DStringStartSublist(&ds);
	Tcl_DStringAppendElement(&ds, cmd);
	if (path != NULL) {
	    Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
	}
	if (arg2 != NULL) {
	    Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
    if (boolVal) {
	res = Tcl_FSRegister(interp, &simpleFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&simpleFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
    return res;
}

/*
 * Treats a file name 'simplefs:/foo' by using the file 'foo' in the current
 * (native) directory.
 */







|







7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
    if (boolVal) {
	res = Tcl_FSRegister(interp, &simpleFilesystem);
	msg = (res == TCL_OK) ? "registered" : "failed";
    } else {
	res = Tcl_FSUnregister(&simpleFilesystem);
	msg = (res == TCL_OK) ? "unregistered" : "failed";
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
    return res;
}

/*
 * Treats a file name 'simplefs:/foo' by using the file 'foo' in the current
 * (native) directory.
 */
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298

    str = Tcl_GetStringFromObj(pathPtr, &len);
    if (len < 10 || strncmp(str, "simplefs:/", 10)) {
	/* Probably shouldn't ever reach here */
	Tcl_IncrRefCount(pathPtr);
	return pathPtr;
    }
    origPtr = Tcl_NewStringObj(str+10, TCL_INDEX_NONE);
    Tcl_IncrRefCount(origPtr);
    return origPtr;
}

static int
SimpleMatchInDirectory(
    Tcl_Interp *interp,		/* Interpreter for error







|







7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298

    str = Tcl_GetStringFromObj(pathPtr, &len);
    if (len < 10 || strncmp(str, "simplefs:/", 10)) {
	/* Probably shouldn't ever reach here */
	Tcl_IncrRefCount(pathPtr);
	return pathPtr;
    }
    origPtr = Tcl_NewStringObj(str+10, -1);
    Tcl_IncrRefCount(origPtr);
    return origPtr;
}

static int
SimpleMatchInDirectory(
    Tcl_Interp *interp,		/* Interpreter for error
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398

static Tcl_Obj *
SimpleListVolumes(void)
{
    /* Add one new volume */
    Tcl_Obj *retVal;

    retVal = Tcl_NewStringObj("simplefs:/", TCL_INDEX_NONE);
    Tcl_IncrRefCount(retVal);
    return retVal;
}

/*
 * Used to check operations of Tcl_UtfNext.
 *







|







7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398

static Tcl_Obj *
SimpleListVolumes(void)
{
    /* Add one new volume */
    Tcl_Obj *retVal;

    retVal = Tcl_NewStringObj("simplefs:/", -1);
    Tcl_IncrRefCount(retVal);
    return retVal;
}

/*
 * Used to check operations of Tcl_UtfNext.
 *
7538
7539
7540
7541
7542
7543
7544
7545
7546
7547
7548
7549
7550
7551
7552
{
    if (objc > 1) {
	int len = -1;

	if (objc > 2) {
	    (void) Tcl_GetIntFromObj(interp, objv[2], &len);
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
    }
    return TCL_OK;
}

/*
 * Used to check correct operation of Tcl_UtfFindLast
 */







|







7538
7539
7540
7541
7542
7543
7544
7545
7546
7547
7548
7549
7550
7551
7552
{
    if (objc > 1) {
	int len = -1;

	if (objc > 2) {
	    (void) Tcl_GetIntFromObj(interp, objv[2], &len);
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1));
    }
    return TCL_OK;
}

/*
 * Used to check correct operation of Tcl_UtfFindLast
 */
7560
7561
7562
7563
7564
7565
7566
7567
7568
7569
7570
7571
7572
7573
7574
{
    if (objc > 1) {
	int len = -1;

	if (objc > 2) {
	    (void) Tcl_GetIntFromObj(interp, objv[2], &len);
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
    }
    return TCL_OK;
}

static int
TestGetIntForIndexCmd(
    TCL_UNUSED(void *),







|







7560
7561
7562
7563
7564
7565
7566
7567
7568
7569
7570
7571
7572
7573
7574
{
    if (objc > 1) {
	int len = -1;

	if (objc > 2) {
	    (void) Tcl_GetIntFromObj(interp, objv[2], &len);
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1));
    }
    return TCL_OK;
}

static int
TestGetIntForIndexCmd(
    TCL_UNUSED(void *),
7638
7639
7640
7641
7642
7643
7644
7645
7646
7647
7648
7649
7650
7651
7652
    }
    if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
	return TCL_ERROR;
    }
    status = TclWinCPUID(index, regs);
    if (status != TCL_OK) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("operation not available", TCL_INDEX_NONE));
	return status;
    }
    for (i=0 ; i<4 ; ++i) {
	regsObjs[i] = Tcl_NewWideIntObj(regs[i]);
    }
    Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
    return TCL_OK;







|







7638
7639
7640
7641
7642
7643
7644
7645
7646
7647
7648
7649
7650
7651
7652
    }
    if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
	return TCL_ERROR;
    }
    status = TclWinCPUID(index, regs);
    if (status != TCL_OK) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("operation not available", -1));
	return status;
    }
    for (i=0 ; i<4 ; ++i) {
	regsObjs[i] = Tcl_NewWideIntObj(regs[i]);
    }
    Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
    return TCL_OK;
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
	return TCL_ERROR;
    }

    for (i=0 ; i<limit ; i++) {
	hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", TCL_INDEX_NONE);
	    Tcl_DeleteHashTable(&hash);
	    return TCL_ERROR;
	}
	Tcl_SetHashValue(hPtr, INT2PTR(i+42));
    }

    if (hash.numEntries != (Tcl_Size)limit) {
	Tcl_AppendResult(interp, "unexpected maximal size", NULL);
	Tcl_DeleteHashTable(&hash);
	return TCL_ERROR;
    }

    for (i=0 ; i<limit ; i++) {
	hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
	if (hPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", TCL_INDEX_NONE);
	    Tcl_DeleteHashTable(&hash);
	    return TCL_ERROR;
	}
	if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", TCL_INDEX_NONE);
	    Tcl_DeleteHashTable(&hash);
	    return TCL_ERROR;
	}
	Tcl_DeleteHashEntry(hPtr);
    }

    if (hash.numEntries != 0) {







|
















|





|







7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
	return TCL_ERROR;
    }

    for (i=0 ; i<limit ; i++) {
	hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", -1);
	    Tcl_DeleteHashTable(&hash);
	    return TCL_ERROR;
	}
	Tcl_SetHashValue(hPtr, INT2PTR(i+42));
    }

    if (hash.numEntries != (Tcl_Size)limit) {
	Tcl_AppendResult(interp, "unexpected maximal size", NULL);
	Tcl_DeleteHashTable(&hash);
	return TCL_ERROR;
    }

    for (i=0 ; i<limit ; i++) {
	hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
	if (hPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", -1);
	    Tcl_DeleteHashTable(&hash);
	    return TCL_ERROR;
	}
	if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", -1);
	    Tcl_DeleteHashTable(&hash);
	    return TCL_ERROR;
	}
	Tcl_DeleteHashEntry(hPtr);
    }

    if (hash.numEntries != 0) {
7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912

    /*
     * Set the start of the error message as obj result; it will be cleared at
     * the end if no errors were found.
     */

    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", TCL_INDEX_NONE));

    emptyPtr = Tcl_NewObj();

    list1Ptr = Tcl_NewStringObj("foo bar sum", TCL_INDEX_NONE);
    Tcl_ListObjLength(NULL, list1Ptr, &len);
    Tcl_InvalidateStringRep(list1Ptr);

    list2Ptr = Tcl_NewStringObj("eeny meeny", TCL_INDEX_NONE);
    Tcl_ListObjLength(NULL, list2Ptr, &len);
    Tcl_InvalidateStringRep(list2Ptr);

    /*
     * Verify that concat'ing a list obj with one or more empty strings does
     * return a fresh Tcl_Obj (see also [Bug 2055782]).
     */







|



|



|







7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912

    /*
     * Set the start of the error message as obj result; it will be cleared at
     * the end if no errors were found.
     */

    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1));

    emptyPtr = Tcl_NewObj();

    list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
    Tcl_ListObjLength(NULL, list1Ptr, &len);
    Tcl_InvalidateStringRep(list1Ptr);

    list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
    Tcl_ListObjLength(NULL, list2Ptr, &len);
    Tcl_InvalidateStringRep(list2Ptr);

    /*
     * Verify that concat'ing a list obj with one or more empty strings does
     * return a fresh Tcl_Obj (see also [Bug 2055782]).
     */
8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
8475
{
    if (*name == 'T') {
 	MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo));

 	resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
 	resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
 	resVarInfo->var = NULL;
 	resVarInfo->nameObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
 	Tcl_IncrRefCount(resVarInfo->nameObj);
 	*rPtr = &resVarInfo->vInfo;
 	return TCL_OK;
    }
    return TCL_CONTINUE;
}








|







8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
8475
{
    if (*name == 'T') {
 	MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo));

 	resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
 	resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
 	resVarInfo->var = NULL;
 	resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
 	Tcl_IncrRefCount(resVarInfo->nameObj);
 	*rPtr = &resVarInfo->vInfo;
 	return TCL_OK;
    }
    return TCL_CONTINUE;
}

8545
8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
    Tcl_Obj *lambdaObjs[2];
    Tcl_Obj *evalObjs[2];
    Tcl_Obj *lambdaObj;
    int result;

    /* Create a lambda {{} {set a 42}} */
    lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
    lambdaObjs[1] = Tcl_NewStringObj("set a 42", TCL_INDEX_NONE); /* Body */
    lambdaObj = Tcl_NewListObj(2, lambdaObjs);
    Tcl_IncrRefCount(lambdaObj);

    /* Create the command "apply {{} {set a 42}" */
    evalObjs[0] = Tcl_NewStringObj("apply", TCL_INDEX_NONE);
    Tcl_IncrRefCount(evalObjs[0]);
    /*
     * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
     * it will get shimmered to a Lambda internal representation but we
     * want to hold on to our list representation.
     */
    evalObjs[1] = Tcl_DuplicateObj(lambdaObj);







|




|







8545
8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
    Tcl_Obj *lambdaObjs[2];
    Tcl_Obj *evalObjs[2];
    Tcl_Obj *lambdaObj;
    int result;

    /* Create a lambda {{} {set a 42}} */
    lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
    lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */
    lambdaObj = Tcl_NewListObj(2, lambdaObjs);
    Tcl_IncrRefCount(lambdaObj);

    /* Create the command "apply {{} {set a 42}" */
    evalObjs[0] = Tcl_NewStringObj("apply", -1);
    Tcl_IncrRefCount(evalObjs[0]);
    /*
     * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
     * it will get shimmered to a Lambda internal representation but we
     * want to hold on to our list representation.
     */
    evalObjs[1] = Tcl_DuplicateObj(lambdaObj);

Changes to generic/tclTestObj.c.

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "var value");
	    return TCL_ERROR;
	}
	string = Tcl_GetString(objv[3]);
	if (mp_init(&bignumValue) != MP_OKAY) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_init", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}
	if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_read_radix", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}

	/*
	 * If the object currently bound to the variable with index varIndex
	 * has ref count 1 (i.e. the object is unshared) we can modify that
	 * object directly.  Otherwise, if RC>1 (i.e. the object is shared),







|





|







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "var value");
	    return TCL_ERROR;
	}
	string = Tcl_GetString(objv[3]);
	if (mp_init(&bignumValue) != MP_OKAY) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_init", -1));
	    return TCL_ERROR;
	}
	if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_read_radix", -1));
	    return TCL_ERROR;
	}

	/*
	 * If the object currently bound to the variable with index varIndex
	 * has ref count 1 (i.e. the object is unshared) we can modify that
	 * object directly.  Otherwise, if RC>1 (i.e. the object is shared),
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_mul_d", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
	}







|







226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_mul_d", -1));
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
	}
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_div_d", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
	}







|







251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_div_d", -1));
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
	}
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_mod_2d", TCL_INDEX_NONE));
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue));
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue)));
	}







|







276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) {
	    mp_clear(&bignumValue);
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("error in mp_mod_2d", -1));
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue));
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue)));
	}
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
	if (result == TCL_OK) {
	    Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)((Tcl_WideUInt)(index + 1U)) - 1);
	}
	return result;
    }

    if (objc < 5) {
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", TCL_INDEX_NONE);
	return TCL_ERROR;
    }

    if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {







|







594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
	if (result == TCL_OK) {
	    Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)((Tcl_WideUInt)(index + 1U)) - 1);
	}
	return result;
    }

    if (objc < 5) {
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
	return TCL_ERROR;
    }

    if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		((wideValue == WIDE_MAX)? "1" : "0"), TCL_INDEX_NONE);
    } else if (strcmp(subCmd, "get") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else if (strcmp(subCmd, "get2") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), TCL_INDEX_NONE);
    } else if (strcmp(subCmd, "inttoobigtest") == 0) {
	/*
	 * If long ints have more bits than ints on this platform, verify that
	 * Tcl_GetIntFromObj returns an error if the long int held in an
	 * integer object's internal representation is too large to fit in an
	 * int.
	 */

	if (objc != 3) {
	    goto wrongNumArgs;
	}
#if (INT_MAX == LONG_MAX)   /* int is same size as long int */
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", TCL_INDEX_NONE);
#else
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX));
	}
	if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", TCL_INDEX_NONE);
	    return TCL_OK;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", TCL_INDEX_NONE);
#endif
    } else if (strcmp(subCmd, "mult10") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;







|















|












|








|


|







734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		((wideValue == WIDE_MAX)? "1" : "0"), -1);
    } else if (strcmp(subCmd, "get") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else if (strcmp(subCmd, "get2") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
    } else if (strcmp(subCmd, "inttoobigtest") == 0) {
	/*
	 * If long ints have more bits than ints on this platform, verify that
	 * Tcl_GetIntFromObj returns an error if the long int held in an
	 * integer object's internal representation is too large to fit in an
	 * int.
	 */

	if (objc != 3) {
	    goto wrongNumArgs;
	}
#if (INT_MAX == LONG_MAX)   /* int is same size as long int */
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX));
	}
	if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
	    return TCL_OK;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
#endif
    } else if (strcmp(subCmd, "mult10") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122

	if (objc != 3) {
	    goto wrongNumArgs;
	} else {
	    const char *typeName;

	    if (objv[2]->typePtr == NULL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj("none", TCL_INDEX_NONE));
	    } else {
		typeName = objv[2]->typePtr->name;
		if (!strcmp(typeName, "utf32string"))
		    typeName = "string";
#ifndef TCL_WIDE_INT_IS_LONG
	    else if (!strcmp(typeName, "wideInt")) typeName = "int";
#endif
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, TCL_INDEX_NONE));
	    }
	}
	return TCL_OK;
    case TESTOBJ_NEWOBJ:
	if (objc != 3) {
	    goto wrongNumArgs;
	}







|







|







1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122

	if (objc != 3) {
	    goto wrongNumArgs;
	} else {
	    const char *typeName;

	    if (objv[2]->typePtr == NULL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
	    } else {
		typeName = objv[2]->typePtr->name;
		if (!strcmp(typeName, "utf32string"))
		    typeName = "string";
#ifndef TCL_WIDE_INT_IS_LONG
	    else if (!strcmp(typeName, "wideInt")) typeName = "int";
#endif
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
	    }
	}
	return TCL_OK;
    case TESTOBJ_NEWOBJ:
	if (objc != 3) {
	    goto wrongNumArgs;
	}
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(varPtr[varIndex]->refCount + 1U)) - 1));
	break;
    case TESTOBJ_TYPE:
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", TCL_INDEX_NONE);
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    "int", TCL_INDEX_NONE);
#endif
	} else {
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    varPtr[varIndex]->typePtr->name, TCL_INDEX_NONE);
	}
	break;
    default:
	break;
    }

    return TCL_OK;







|



|



|







1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(varPtr[varIndex]->refCount + 1U)) - 1));
	break;
    case TESTOBJ_TYPE:
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    "int", -1);
#endif
	} else {
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    varPtr[varIndex]->typePtr->name, -1);
	}
	break;
    default:
	break;
    }

    return TCL_OK;
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
	case 3:				/* get2 */
	    if (objc != 3) {
		goto wrongNumArgs;
	    }
	    if (CheckIfVarUnset(interp, varPtr, varIndex)) {
		return TCL_ERROR;
	    }
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), TCL_INDEX_NONE);
	    break;
	case 4:				/* length */
	    if (objc != 3) {
		goto wrongNumArgs;
	    }
	    Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
		    ? (Tcl_WideInt)varPtr[varIndex]->length : (Tcl_WideInt)-1);







|







1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
	case 3:				/* get2 */
	    if (objc != 3) {
		goto wrongNumArgs;
	    }
	    if (CheckIfVarUnset(interp, varPtr, varIndex)) {
		return TCL_ERROR;
	    }
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
	    break;
	case 4:				/* length */
	    if (objc != 3) {
		goto wrongNumArgs;
	    }
	    Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
		    ? (Tcl_WideInt)varPtr[varIndex]->length : (Tcl_WideInt)-1);
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
	    string = Tcl_GetStringFromObj(varPtr[varIndex], &size);

	    if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (length == TCL_INDEX_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"index value out of range", TCL_INDEX_NONE));
		return TCL_ERROR;
	    }

	    Tcl_AppendToObj(varPtr[varIndex], string + length, size - length);
	    Tcl_SetObjResult(interp, varPtr[varIndex]);
	    break;
	case 12:			/* appendself2 */







|







1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
	    string = Tcl_GetStringFromObj(varPtr[varIndex], &size);

	    if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (length == TCL_INDEX_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"index value out of range", -1));
		return TCL_ERROR;
	    }

	    Tcl_AppendToObj(varPtr[varIndex], string + length, size - length);
	    Tcl_SetObjResult(interp, varPtr[varIndex]);
	    break;
	case 12:			/* appendself2 */
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
	    unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size);

	    if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (length == TCL_INDEX_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"index value out of range", TCL_INDEX_NONE));
		return TCL_ERROR;
	    }

	    Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length);
	    Tcl_SetObjResult(interp, varPtr[varIndex]);
	    break;
	case 13: /* newunicode*/







|







1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
	    unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size);

	    if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (length == TCL_INDEX_NONE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"index value out of range", -1));
		return TCL_ERROR;
	    }

	    Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length);
	    Tcl_SetObjResult(interp, varPtr[varIndex]);
	    break;
	case 13: /* newunicode*/
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
    Tcl_Size index;

    if (Tcl_GetIntForIndex(interp, obj, NUMBER_OF_OBJECT_VARS - 1, &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (index == TCL_INDEX_NONE) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", TCL_INDEX_NONE);
	return TCL_ERROR;
    }

    *indexPtr = index;
    return TCL_OK;
}








|







1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
    Tcl_Size index;

    if (Tcl_GetIntForIndex(interp, obj, NUMBER_OF_OBJECT_VARS - 1, &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (index == TCL_INDEX_NONE) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
	return TCL_ERROR;
    }

    *indexPtr = index;
    return TCL_OK;
}

1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
    Tcl_Size varIndex)		/* Index of the test variable to check. */
{
    if (varPtr[varIndex] == NULL) {
	char buf[32 + TCL_INTEGER_SPACE];

	snprintf(buf, sizeof(buf), "variable %" TCL_Z_MODIFIER "u is unset (NULL)", varIndex);
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, TCL_INDEX_NONE);
	return 1;
    }
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|












1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
    Tcl_Size varIndex)		/* Index of the test variable to check. */
{
    if (varPtr[varIndex] == NULL) {
	char buf[32 + TCL_INTEGER_SPACE];

	snprintf(buf, sizeof(buf), "variable %" TCL_Z_MODIFIER "u is unset (NULL)", varIndex);
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
	return 1;
    }
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclThread.c.

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
 *
 *----------------------------------------------------------------------
 */

void *
Tcl_GetThreadData(
    Tcl_ThreadDataKey *keyPtr,	/* Identifier for the data chunk */
    size_t size)		/* Size of storage block */
{
    void *result;
#if TCL_THREADS
    /*
     * Initialize the key for this thread.
     */








|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
 *
 *----------------------------------------------------------------------
 */

void *
Tcl_GetThreadData(
    Tcl_ThreadDataKey *keyPtr,	/* Identifier for the data chunk */
    Tcl_Size size)		/* Size of storage block */
{
    void *result;
#if TCL_THREADS
    /*
     * Initialize the key for this thread.
     */

Changes to generic/tclThreadTest.c.

651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
    char buf[TCL_DOUBLE_SPACE+1];

    snprintf(buf, sizeof(buf), "%p", Tcl_GetCurrentThread());

    errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
    if (errorProcString == NULL) {
	errChannel = Tcl_GetStdChannel(TCL_STDERR);
	Tcl_WriteChars(errChannel, "Error from thread ", TCL_INDEX_NONE);
	Tcl_WriteChars(errChannel, buf, TCL_INDEX_NONE);
	Tcl_WriteChars(errChannel, "\n", 1);
	Tcl_WriteChars(errChannel, errorInfo, TCL_INDEX_NONE);
	Tcl_WriteChars(errChannel, "\n", 1);
    } else {
	argv[0] = errorProcString;
	argv[1] = buf;
	argv[2] = errorInfo;
	script = Tcl_Merge(3, argv);
	ThreadSend(interp, errorThreadId, script, 0);







|
|

|







651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
    char buf[TCL_DOUBLE_SPACE+1];

    snprintf(buf, sizeof(buf), "%p", Tcl_GetCurrentThread());

    errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
    if (errorProcString == NULL) {
	errChannel = Tcl_GetStdChannel(TCL_STDERR);
	Tcl_WriteChars(errChannel, "Error from thread ", -1);
	Tcl_WriteChars(errChannel, buf, -1);
	Tcl_WriteChars(errChannel, "\n", 1);
	Tcl_WriteChars(errChannel, errorInfo, -1);
	Tcl_WriteChars(errChannel, "\n", 1);
    } else {
	argv[0] = errorProcString;
	argv[1] = buf;
	argv[2] = errorInfo;
	script = Tcl_Merge(3, argv);
	ThreadSend(interp, errorThreadId, script, 0);
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
     * Since Tcl_CancelEval can be safely called from any thread,
     * we do it now.
     */

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ResetResult(interp);
    return Tcl_CancelEval(tsdPtr->interp,
    	(result != NULL) ? Tcl_NewStringObj(result, TCL_INDEX_NONE) : NULL, 0, flags);
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadEventProc --
 *







|







979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
     * Since Tcl_CancelEval can be safely called from any thread,
     * we do it now.
     */

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ResetResult(interp);
    return Tcl_CancelEval(tsdPtr->interp,
    	(result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadEventProc --
 *

Changes to generic/tclTimer.c.

970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
	} else {
	    Tcl_Obj *resultListPtr;

	    TclNewObj(resultListPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr,
		    afterPtr->commandPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
		    (afterPtr->token == NULL) ? "idle" : "timer", TCL_INDEX_NONE));
            Tcl_SetObjResult(interp, resultListPtr);
	}
	break;
    default:
	Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
    }
    return TCL_OK;







|







970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
	} else {
	    Tcl_Obj *resultListPtr;

	    TclNewObj(resultListPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr,
		    afterPtr->commandPtr);
	    Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
		    (afterPtr->token == NULL) ? "idle" : "timer", -1));
            Tcl_SetObjResult(interp, resultListPtr);
	}
	break;
    default:
	Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
    }
    return TCL_OK;

Changes to generic/tclUtf.c.

101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

size_t
TclUtfCount(
    int ch)			/* The Unicode character whose size is returned. */
{
    if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
	return 1;
    }
    if (ch <= 0x7FF) {







|







101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclUtfCount(
    int ch)			/* The Unicode character whose size is returned. */
{
    if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
	return 1;
    }
    if (ch <= 0x7FF) {
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

#undef Tcl_UniCharToUtf
size_t
Tcl_UniCharToUtf(
    int ch,	/* The Tcl_UniChar to be stored in the
		 * buffer. Can be or'ed with flag TCL_COMBINE
		 */
    char *buf)	/* Buffer in which the UTF-8 representation of
		 * ch is stored. Must be large enough to hold the UTF-8
		 * character (at most 4 bytes).







|







201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

#undef Tcl_UniCharToUtf
Tcl_Size
Tcl_UniCharToUtf(
    int ch,	/* The Tcl_UniChar to be stored in the
		 * buffer. Can be or'ed with flag TCL_COMBINE
		 */
    char *buf)	/* Buffer in which the UTF-8 representation of
		 * ch is stored. Must be large enough to hold the UTF-8
		 * character (at most 4 bytes).
314
315
316
317
318
319
320
321

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
 *---------------------------------------------------------------------------
 */

#undef Tcl_UniCharToUtfDString
char *
Tcl_UniCharToUtfDString(
    const int *uniStr,	/* Unicode string to convert to UTF-8. */
    size_t uniLength,		/* Length of Unicode string. */

    Tcl_DString *dsPtr)		/* UTF-8 representation of string is appended
				 * to this previously initialized DString. */
{
    const int *w, *wEnd;
    char *p, *string;
    size_t oldLength;

    /*
     * UTF-8 string length in bytes will be <= Unicode string length * 4.
     */

    if (uniStr == NULL) {
	return NULL;
    }
    if (uniLength == TCL_INDEX_NONE) {
	uniLength = 0;
	w = uniStr;
	while (*w != '\0') {
	    uniLength++;
	    w++;
	}
    }







|
>





|








|







314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
 *---------------------------------------------------------------------------
 */

#undef Tcl_UniCharToUtfDString
char *
Tcl_UniCharToUtfDString(
    const int *uniStr,	/* Unicode string to convert to UTF-8. */
    Tcl_Size uniLength,		/* Length of Unicode string. Negative for nul
    				 * nul terminated string */
    Tcl_DString *dsPtr)		/* UTF-8 representation of string is appended
				 * to this previously initialized DString. */
{
    const int *w, *wEnd;
    char *p, *string;
    Tcl_Size oldLength;

    /*
     * UTF-8 string length in bytes will be <= Unicode string length * 4.
     */

    if (uniStr == NULL) {
	return NULL;
    }
    if (uniLength < 0) {
	uniLength = 0;
	w = uniStr;
	while (*w != '\0') {
	    uniLength++;
	    w++;
	}
    }
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

    return string;
}

char *
Tcl_Char16ToUtfDString(
    const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */
    size_t uniLength,		/* Length of Utf-16 string. */
    Tcl_DString *dsPtr)		/* UTF-8 representation of string is appended
				 * to this previously initialized DString. */
{
    const unsigned short *w, *wEnd;
    char *p, *string;
    size_t oldLength;
    int len = 1;

    /*
     * UTF-8 string length in bytes will be <= Utf16 string length * 3.
     */

    if (uniStr == NULL) {
	return NULL;
    }
    if (uniLength == TCL_INDEX_NONE) {

	uniLength = 0;
	w = uniStr;
	while (*w != '\0') {
	    uniLength++;
	    w++;
	}







|















|







356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386

    return string;
}

char *
Tcl_Char16ToUtfDString(
    const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */
    Tcl_Size uniLength,		/* Length of Utf-16 string. */
    Tcl_DString *dsPtr)		/* UTF-8 representation of string is appended
				 * to this previously initialized DString. */
{
    const unsigned short *w, *wEnd;
    char *p, *string;
    size_t oldLength;
    int len = 1;

    /*
     * UTF-8 string length in bytes will be <= Utf16 string length * 3.
     */

    if (uniStr == NULL) {
	return NULL;
    }
    if (uniLength < 0) {

	uniLength = 0;
	w = uniStr;
	while (*w != '\0') {
	    uniLength++;
	    w++;
	}
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
  0x20AC,   0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
  0x02C6, 0x2030, 0x0160, 0x2039, 0x0152,   0x8D, 0x017D,   0x8F,
    0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
   0x2DC, 0x2122, 0x0161, 0x203A, 0x0153,   0x9D, 0x017E, 0x0178
};

#undef Tcl_UtfToUniChar
size_t
Tcl_UtfToUniChar(
    const char *src,	/* The UTF-8 string. */
    int *chPtr)/* Filled with the Unicode character represented by
				 * the UTF-8 string. */
{
    int byte;








|







450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
  0x20AC,   0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
  0x02C6, 0x2030, 0x0160, 0x2039, 0x0152,   0x8D, 0x017D,   0x8F,
    0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
   0x2DC, 0x2122, 0x0161, 0x203A, 0x0153,   0x9D, 0x017E, 0x0178
};

#undef Tcl_UtfToUniChar
Tcl_Size
Tcl_UtfToUniChar(
    const char *src,	/* The UTF-8 string. */
    int *chPtr)/* Filled with the Unicode character represented by
				 * the UTF-8 string. */
{
    int byte;

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
	 */
    }

    *chPtr = byte;
    return 1;
}

size_t
Tcl_UtfToChar16(
    const char *src,	/* The UTF-8 string. */
    unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
				 * the UTF-8 string. This could be a surrogate too. */
{
    unsigned short byte;








|







533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
	 */
    }

    *chPtr = byte;
    return 1;
}

Tcl_Size
Tcl_UtfToChar16(
    const char *src,	/* The UTF-8 string. */
    unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
				 * the UTF-8 string. This could be a surrogate too. */
{
    unsigned short byte;

653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
 *---------------------------------------------------------------------------
 */

#undef Tcl_UtfToUniCharDString
int *
Tcl_UtfToUniCharDString(
    const char *src,		/* UTF-8 string to convert to Unicode. */
    size_t length,			/* Length of UTF-8 string in bytes, or -1 for
				 * strlen(). */
    Tcl_DString *dsPtr)		/* Unicode representation of string is
				 * appended to this previously initialized
				 * DString. */
{
    int ch = 0, *w, *wString;
    const char *p;
    size_t oldLength;
    /* Pointer to the end of string. Never read endPtr[0] */
    const char *endPtr = src + length;
    /* Pointer to last byte where optimization still can be used */
    const char *optPtr = endPtr - TCL_UTF_MAX;

    if (src == NULL) {
	return NULL;
    }
    if (length == TCL_INDEX_NONE) {
	length = strlen(src);
    }

    /*
     * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
     * bytes.
     */







|







|








|







654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
 *---------------------------------------------------------------------------
 */

#undef Tcl_UtfToUniCharDString
int *
Tcl_UtfToUniCharDString(
    const char *src,		/* UTF-8 string to convert to Unicode. */
    Tcl_Size length,		/* Length of UTF-8 string in bytes, or -1 for
				 * strlen(). */
    Tcl_DString *dsPtr)		/* Unicode representation of string is
				 * appended to this previously initialized
				 * DString. */
{
    int ch = 0, *w, *wString;
    const char *p;
    Tcl_Size oldLength;
    /* Pointer to the end of string. Never read endPtr[0] */
    const char *endPtr = src + length;
    /* Pointer to last byte where optimization still can be used */
    const char *optPtr = endPtr - TCL_UTF_MAX;

    if (src == NULL) {
	return NULL;
    }
    if (length < 0) {
	length = strlen(src);
    }

    /*
     * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
     * bytes.
     */
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741

    return wString;
}

unsigned short *
Tcl_UtfToChar16DString(
    const char *src,		/* UTF-8 string to convert to Unicode. */
    size_t length,			/* Length of UTF-8 string in bytes, or -1 for
				 * strlen(). */
    Tcl_DString *dsPtr)		/* Unicode representation of string is
				 * appended to this previously initialized
				 * DString. */
{
    unsigned short ch = 0, *w, *wString;
    const char *p;
    size_t oldLength;
    /* Pointer to the end of string. Never read endPtr[0] */
    const char *endPtr = src + length;
    /* Pointer to last byte where optimization still can be used */
    const char *optPtr = endPtr - TCL_UTF_MAX;

    if (src == NULL) {
	return NULL;
    }
    if (length == TCL_INDEX_NONE) {
	length = strlen(src);
    }

    /*
     * Unicode string length in WCHARs will be <= UTF-8 string length in
     * bytes.
     */







|







|








|







711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742

    return wString;
}

unsigned short *
Tcl_UtfToChar16DString(
    const char *src,		/* UTF-8 string to convert to Unicode. */
    Tcl_Size length,		/* Length of UTF-8 string in bytes, or -1 for
				 * strlen(). */
    Tcl_DString *dsPtr)		/* Unicode representation of string is
				 * appended to this previously initialized
				 * DString. */
{
    unsigned short ch = 0, *w, *wString;
    const char *p;
    Tcl_Size oldLength;
    /* Pointer to the end of string. Never read endPtr[0] */
    const char *endPtr = src + length;
    /* Pointer to last byte where optimization still can be used */
    const char *optPtr = endPtr - TCL_UTF_MAX;

    if (src == NULL) {
	return NULL;
    }
    if (length < 0) {
	length = strlen(src);
    }

    /*
     * Unicode string length in WCHARs will be <= UTF-8 string length in
     * bytes.
     */
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
 *---------------------------------------------------------------------------
 */

int
Tcl_UtfCharComplete(
    const char *src,		/* String to check if first few bytes contain
				 * a complete UTF-8 character. */
    size_t length)			/* Length of above string in bytes. */
{
    return length >= complete[UCHAR(*src)];
}

/*
 *---------------------------------------------------------------------------
 *







|







789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
 *---------------------------------------------------------------------------
 */

int
Tcl_UtfCharComplete(
    const char *src,		/* String to check if first few bytes contain
				 * a complete UTF-8 character. */
    Tcl_Size length)		/* Length of above string in bytes. */
{
    return length >= complete[UCHAR(*src)];
}

/*
 *---------------------------------------------------------------------------
 *
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

size_t
Tcl_NumUtfChars(
    const char *src,	/* The UTF-8 string to measure. */
    size_t length)	/* The length of the string in bytes, or
			 * TCL_INDEX_NONE for strlen(src). */
{
    Tcl_UniChar ch = 0;
    size_t i = 0;

    if (length == TCL_INDEX_NONE) {
	/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
	while (*src != '\0') {
	    src += TclUtfToUniChar(src, &ch);
	    i++;
	}
    } else {
	/* Will return value between 0 and length. No overflow checks. */







|


|
|


|

|







812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Size
Tcl_NumUtfChars(
    const char *src,	/* The UTF-8 string to measure. */
    Tcl_Size length)	/* The length of the string in bytes, or
			 * negative value for strlen(src). */
{
    Tcl_UniChar ch = 0;
    Tcl_Size i = 0;

    if (length < 0) {
	/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
	while (*src != '\0') {
	    src += TclUtfToUniChar(src, &ch);
	    i++;
	}
    } else {
	/* Will return value between 0 and length. No overflow checks. */
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
	    }
	    i++;
	}
    }
    return i;
}

size_t
TclNumUtfChars(
    const char *src,	/* The UTF-8 string to measure. */
    size_t length)	/* The length of the string in bytes, or
			 * TCL_INDEX_NONE for strlen(src). */
{
    unsigned short ch = 0;
    size_t i = 0;

    if (length == TCL_INDEX_NONE) {
	/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
	while (*src != '\0') {
	    src += Tcl_UtfToChar16(src, &ch);
	    i++;
	}
    } else {
	/* Will return value between 0 and length. No overflow checks. */







|


|
|


|

|







864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
	    }
	    i++;
	}
    }
    return i;
}

Tcl_Size
TclNumUtfChars(
    const char *src,	/* The UTF-8 string to measure. */
    Tcl_Size length)	/* The length of the string in bytes, or
			 * negative for strlen(src). */
{
    unsigned short ch = 0;
    Tcl_Size i = 0;

    if (length < 0) {
	/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
	while (*src != '\0') {
	    src += Tcl_UtfToChar16(src, &ch);
	    i++;
	}
    } else {
	/* Will return value between 0 and length. No overflow checks. */
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_UniCharAtIndex(
    const char *src,	/* The UTF-8 string to dereference. */
    size_t index)		/* The position of the desired character. */
{
    Tcl_UniChar ch = 0;
    int i = 0;

    if (index == TCL_INDEX_NONE) {
	return -1;
    }
    while (index--) {
	i = TclUtfToUniChar(src, &ch);
	src += i;
    }
#if TCL_UTF_MAX < 4







|




|







1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_UniCharAtIndex(
    const char *src,	/* The UTF-8 string to dereference. */
    Tcl_Size index)	/* The position of the desired character. */
{
    Tcl_UniChar ch = 0;
    int i = 0;

    if (index < 0) {
	return -1;
    }
    while (index--) {
	i = TclUtfToUniChar(src, &ch);
	src += i;
    }
#if TCL_UTF_MAX < 4
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
 *
 *---------------------------------------------------------------------------
 */

const char *
Tcl_UtfAtIndex(
    const char *src,	/* The UTF-8 string. */
    size_t index)		/* The position of the desired character. */
{
    int ch = 0;

    if (index != TCL_INDEX_NONE) {
	while (index--) {
	    /* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */
	    src += Tcl_UtfToUniChar(src, &ch);
	}
    }
    return src;
}

const char *
TclUtfAtIndex(
    const char *src,	/* The UTF-8 string. */
    size_t index)		/* The position of the desired character. */
{
    unsigned short ch = 0;
    size_t len = 0;

    if (index != TCL_INDEX_NONE) {
	while (index--) {
	    src += (len = Tcl_UtfToChar16(src, &ch));
	}
	if ((ch >= 0xD800) && (len < 3)) {
	    /* Index points at character following high Surrogate */
	    src += Tcl_UtfToChar16(src, &ch);
	}







|



|











|


|

|







1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
 *
 *---------------------------------------------------------------------------
 */

const char *
Tcl_UtfAtIndex(
    const char *src,	/* The UTF-8 string. */
    Tcl_Size index)	/* The position of the desired character. */
{
    int ch = 0;

    if (index > 0) {
	while (index--) {
	    /* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */
	    src += Tcl_UtfToUniChar(src, &ch);
	}
    }
    return src;
}

const char *
TclUtfAtIndex(
    const char *src,	/* The UTF-8 string. */
    Tcl_Size index)	/* The position of the desired character. */
{
    unsigned short ch = 0;
    Tcl_Size len = 0;

    if (index > 0) {
	while (index--) {
	    src += (len = Tcl_UtfToChar16(src, &ch));
	}
	if ((ch >= 0xD800) && (len < 3)) {
	    /* Index points at character following high Surrogate */
	    src += Tcl_UtfToChar16(src, &ch);
	}
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309

1310
1311
1312
1313
1314
1315
1316
1317
 *	that represent the Unicode character is at least as large as the
 *	source buffer from which the backslashed sequence was extracted, no
 *	buffer overruns should occur.
 *
 *---------------------------------------------------------------------------
 */

size_t
Tcl_UtfBackslash(
    const char *src,		/* Points to the backslash character of a
				 * backslash sequence. */
    int *readPtr,		/* Fill in with number of characters read from
				 * src, unless NULL. */
    char *dst)			/* Filled with the bytes represented by the
				 * backslash sequence. */
{
#define LINE_LENGTH 128

    size_t numRead, result;

    result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);
    if (numRead == LINE_LENGTH) {
	/*
	 * We ate a whole line. Pay the price of a strlen()
	 */








|









>
|







1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
 *	that represent the Unicode character is at least as large as the
 *	source buffer from which the backslashed sequence was extracted, no
 *	buffer overruns should occur.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Size
Tcl_UtfBackslash(
    const char *src,		/* Points to the backslash character of a
				 * backslash sequence. */
    int *readPtr,		/* Fill in with number of characters read from
				 * src, unless NULL. */
    char *dst)			/* Filled with the bytes represented by the
				 * backslash sequence. */
{
#define LINE_LENGTH 128
    Tcl_Size numRead;
    int result;

    result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);
    if (numRead == LINE_LENGTH) {
	/*
	 * We ate a whole line. Pay the price of a strlen()
	 */

1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

size_t
Tcl_UtfToUpper(
    char *str)			/* String to convert in place. */
{
    int ch, upChar;
    char *src, *dst;
    size_t len;

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {







|





|







1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_UtfToUpper(
    char *str)			/* String to convert in place. */
{
    int ch, upChar;
    char *src, *dst;
    Tcl_Size len;

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

size_t
Tcl_UtfToLower(
    char *str)			/* String to convert in place. */
{
    int ch, lowChar;
    char *src, *dst;
    size_t len;

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {







|





|







1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_UtfToLower(
    char *str)			/* String to convert in place. */
{
    int ch, lowChar;
    char *src, *dst;
    Tcl_Size len;

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

size_t
Tcl_UtfToTitle(
    char *str)			/* String to convert in place. */
{
    int ch, titleChar, lowChar;
    char *src, *dst;
    size_t len;

    /*
     * Capitalize the first character and then lowercase the rest of the
     * characters until we get to a null.
     */

    src = dst = str;







|





|







1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
 *
 * Side effects:
 *	Writes a terminating null after the last converted character.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_UtfToTitle(
    char *str)			/* String to convert in place. */
{
    int ch, titleChar, lowChar;
    char *src, *dst;
    Tcl_Size len;

    /*
     * Capitalize the first character and then lowercase the rest of the
     * characters until we get to a null.
     */

    src = dst = str;
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

size_t
Tcl_Char16Len(
    const unsigned short *uniStr)	/* Unicode string to find length of. */
{
    size_t len = 0;

    while (*uniStr != '\0') {
	len++;
	uniStr++;
    }
    return len;
}







|



|







1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_Char16Len(
    const unsigned short *uniStr)	/* Unicode string to find length of. */
{
    Tcl_Size len = 0;

    while (*uniStr != '\0') {
	len++;
	uniStr++;
    }
    return len;
}
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_UniCharLen
size_t
Tcl_UniCharLen(
    const int *uniStr)	/* Unicode string to find length of. */
{
    size_t len = 0;

    while (*uniStr != '\0') {
	len++;
	uniStr++;
    }
    return len;
}







|



|







1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_UniCharLen
Tcl_Size
Tcl_UniCharLen(
    const int *uniStr)	/* Unicode string to find length of. */
{
    Tcl_Size len = 0;

    while (*uniStr != '\0') {
	len++;
	uniStr++;
    }
    return len;
}
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
 *
 *----------------------------------------------------------------------
 */

int
TclUniCharMatch(
    const Tcl_UniChar *string,	/* Unicode String. */
    size_t strLen,			/* Length of String */
    const Tcl_UniChar *pattern,	/* Pattern, which may contain special
				 * characters. */
    size_t ptnLen,			/* Length of Pattern */
    int nocase)			/* 0 for case sensitive, 1 for insensitive */
{
    const Tcl_UniChar *stringEnd, *patternEnd;
    Tcl_UniChar p;

    stringEnd = string + strLen;
    patternEnd = pattern + ptnLen;







|


|







2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
 *
 *----------------------------------------------------------------------
 */

int
TclUniCharMatch(
    const Tcl_UniChar *string,	/* Unicode String. */
    Tcl_Size strLen,		/* Length of String */
    const Tcl_UniChar *pattern,	/* Pattern, which may contain special
				 * characters. */
    Tcl_Size ptnLen,		/* Length of Pattern */
    int nocase)			/* 0 for case sensitive, 1 for insensitive */
{
    const Tcl_UniChar *stringEnd, *patternEnd;
    Tcl_UniChar p;

    stringEnd = string + strLen;
    patternEnd = pattern + ptnLen;

Changes to generic/tclUtil.c.

8
9
10
11
12
13
14

15
16
17
18
19
20
21
 * Copyright © 1994-1998 Sun Microsystems, Inc.
 * Copyright © 2001 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.
 */


#include "tclInt.h"
#include "tclParse.h"
#include "tclStringTrim.h"
#include "tclTomMath.h"
#include <math.h>

/*







>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 * Copyright © 1994-1998 Sun Microsystems, Inc.
 * Copyright © 2001 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.
 */

#include <assert.h>
#include "tclInt.h"
#include "tclParse.h"
#include "tclStringTrim.h"
#include "tclTomMath.h"
#include <math.h>

/*
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
 * Prototypes for functions defined later in this file.
 */

static void		ClearHash(Tcl_HashTable *tablePtr);
static void		FreeProcessGlobalValue(void *clientData);
static void		FreeThreadHash(void *clientData);
static int		GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    Tcl_Size endValue, Tcl_WideInt *indexPtr);
static Tcl_HashTable *	GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int		GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    Tcl_Size endValue, Tcl_WideInt *widePtr);
static int		FindElement(Tcl_Interp *interp, const char *string,
			    Tcl_Size stringLength, const char *typeStr,
			    const char *typeCode, const char **elementPtr,
			    const char **nextPtr, Tcl_Size *sizePtr,
			    int *literalPtr);
/*
 * The following is the Tcl object type definition for an object that







|


|







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
 * Prototypes for functions defined later in this file.
 */

static void		ClearHash(Tcl_HashTable *tablePtr);
static void		FreeProcessGlobalValue(void *clientData);
static void		FreeThreadHash(void *clientData);
static int		GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    Tcl_WideInt endValue, Tcl_WideInt *indexPtr);
static Tcl_HashTable *	GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int		GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    Tcl_WideInt endValue, Tcl_WideInt *widePtr);
static int		FindElement(Tcl_Interp *interp, const char *string,
			    Tcl_Size stringLength, const char *typeStr,
			    const char *typeCode, const char **elementPtr,
			    const char **nextPtr, Tcl_Size *sizePtr,
			    int *literalPtr);
/*
 * The following is the Tcl object type definition for an object that
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
    NULL,				/* updateStringProc */
    NULL,				/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    TclLengthOne
    )}
};

size_t
TclLengthOne(
    TCL_UNUSED(Tcl_Obj *))
{
    return 1;
}

/*







|







130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
    NULL,				/* updateStringProc */
    NULL,				/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    TclLengthOne
    )}
};

Tcl_Size
TclLengthOne(
    TCL_UNUSED(Tcl_Obj *))
{
    return 1;
}

/*
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870

#undef Tcl_SplitList
int
Tcl_SplitList(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If
				 * NULL, no error message is left. */
    const char *list,		/* Pointer to string with list structure. */
    size_t *argcPtr,		/* Pointer to location to fill in with the
				 * number of elements in the list. */
    const char ***argvPtr)	/* Pointer to place to store pointer to array
				 * of pointers to list elements. */
{
    const char **argv, *end, *element;
    char *p;
    int result;







|







857
858
859
860
861
862
863
864
865
866
867
868
869
870
871

#undef Tcl_SplitList
int
Tcl_SplitList(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If
				 * NULL, no error message is left. */
    const char *list,		/* Pointer to string with list structure. */
    Tcl_Size *argcPtr,		/* Pointer to location to fill in with the
				 * number of elements in the list. */
    const char ***argvPtr)	/* Pointer to place to store pointer to array
				 * of pointers to list elements. */
{
    const char **argv, *end, *element;
    char *p;
    int result;
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
	if (*element == 0) {
	    break;
	}
	if (i >= size) {
	    Tcl_Free((void *)argv);
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"internal error in Tcl_SplitList", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
			NULL);
	    }
	    return TCL_ERROR;
	}
	argv[i] = p;
	if (literal) {







|







898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
	if (*element == 0) {
	    break;
	}
	if (i >= size) {
	    Tcl_Free((void *)argv);
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"internal error in Tcl_SplitList", -1));
		Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
			NULL);
	    }
	    return TCL_ERROR;
	}
	argv[i] = p;
	if (literal) {
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
		extra++;	/* Escape newline => '\n', one byte longer */

		/*
		 * Backslash newline sequence.  Brace quoting not permitted.
		 */

		requireEscape = 1;
		length -= (length+1 > 1);
		p++;
		break;
	    }
	    if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) {
		extra++;	/* Escape sequences all one byte longer. */
		length -= (length+1 > 1);
		p++;
	    }
	    forbidNone = 1;
#if COMPAT
	    preferBrace = 1;
#endif /* COMPAT */
	    break;







|





|







1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
		extra++;	/* Escape newline => '\n', one byte longer */

		/*
		 * Backslash newline sequence.  Brace quoting not permitted.
		 */

		requireEscape = 1;
		length -= (length > 0);
		p++;
		break;
	    }
	    if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) {
		extra++;	/* Escape sequences all one byte longer. */
		length -= (length > 0);
		p++;
	    }
	    forbidNone = 1;
#if COMPAT
	    preferBrace = 1;
#endif /* COMPAT */
	    break;
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
#if COMPAT
		preferBrace = 1;
#endif
	    }
	    break;
	}
      }
	length -= (length+1 > 1);
	p++;
    }

  endOfString:
    if (nestingLevel > 0) {
	/*
	 * Unbalanced braces!  Cannot format with brace quoting.







|







1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
#if COMPAT
		preferBrace = 1;
#endif
	    }
	    break;
	}
      }
	length -= (length > 0);
	p++;
    }

  endOfString:
    if (nestingLevel > 0) {
	/*
	 * Unbalanced braces!  Cannot format with brace quoting.
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433

    if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
	if (conversion == CONVERT_ESCAPE) {
	    p[0] = '\\';
	    p[1] = '#';
	    p += 2;
	    src++;
	    length -= (length+1 > 1);
	} else {
	    conversion = CONVERT_BRACE;
	}
    }

    /*
     * No escape or quoting needed.  Copy the literal string value.







|







1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434

    if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
	if (conversion == CONVERT_ESCAPE) {
	    p[0] = '\\';
	    p[1] = '#';
	    p += 2;
	    src++;
	    length -= (length > 0);
	} else {
	    conversion = CONVERT_BRACE;
	}
    }

    /*
     * No escape or quoting needed.  Copy the literal string value.
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
	    }
	} else {
	    memcpy(p, src, length);
	    p += length;
	}
	*p = '}';
	p++;
	return (Tcl_Size)(p - dst);
    }

    /* conversion == CONVERT_ESCAPE or CONVERT_MASK */

    /*
     * Formatted string is original string converted to escape sequences.
     */

    for ( ; length; src++, length -= (length+1 > 1)) {
	switch (*src) {
	case ']':
	case '[':
	case '$':
	case ';':
	case ' ':
	case '\\':







|








|







1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
	    }
	} else {
	    memcpy(p, src, length);
	    p += length;
	}
	*p = '}';
	p++;
	return (p - dst);
    }

    /* conversion == CONVERT_ESCAPE or CONVERT_MASK */

    /*
     * Formatted string is original string converted to escape sequences.
     */

    for ( ; length; src++, length -= (length > 0)) {
	switch (*src) {
	case ']':
	case '[':
	case '$':
	case ';':
	case ' ':
	case '\\':
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
	    *p = '\\';
	    p++;
	    *p = 'v';
	    p++;
	    continue;
	case '\0':
	    if (length == TCL_INDEX_NONE) {
		return (Tcl_Size)(p - dst);
	    }

	    /*
	     * If we reach this point, there's an embedded NULL in the string
	     * range being processed, which should not happen when the
	     * encoding rules for Tcl strings are properly followed.  If the
	     * day ever comes when we stop tolerating such things, this is
	     * where to put the Tcl_Panic().
	     */

	    break;
	}
	*p = *src;
	p++;
    }
    return (Tcl_Size)(p - dst);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Merge --
 *







|















|







1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
	    *p = '\\';
	    p++;
	    *p = 'v';
	    p++;
	    continue;
	case '\0':
	    if (length == TCL_INDEX_NONE) {
		return (p - dst);
	    }

	    /*
	     * If we reach this point, there's an embedded NULL in the string
	     * range being processed, which should not happen when the
	     * encoding rules for Tcl strings are properly followed.  If the
	     * day ever comes when we stop tolerating such things, this is
	     * where to put the Tcl_Panic().
	     */

	    break;
	}
	*p = *src;
	p++;
    }
    return (p - dst);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Merge --
 *
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
    char *result, *dst;

    /*
     * Handle empty list case first, so logic of the general case can be
     * simpler.
     */

    if (argc == 0) {
	result = (char *)Tcl_Alloc(1);
	result[0] = '\0';
	return result;
    }

    /*
     * Pass 1: estimate space, gather flags.







|







1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
    char *result, *dst;

    /*
     * Handle empty list case first, so logic of the general case can be
     * simpler.
     */

    if (argc <= 0) {
	result = (char *)Tcl_Alloc(1);
	result[0] = '\0';
	return result;
    }

    /*
     * Pass 1: estimate space, gather flags.
1874
1875
1876
1877
1878
1879
1880



1881
1882
1883
1884
1885








1886
1887
1888
1889
1890
1891
1892

    /*
     * First allocate the result buffer at the size required.
     */

    for (i = 0;  i < argc;  i++) {
	bytesNeeded += strlen(argv[i]);



    }

    /*
     * All element bytes + (argc - 1) spaces + 1 terminating NULL.
     */









    result = (char *)Tcl_Alloc(bytesNeeded + argc);

    for (p = result, i = 0;  i < argc;  i++) {
	Tcl_Size triml, trimr, elemLength;
	const char *element;








>
>
>





>
>
>
>
>
>
>
>







1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904

    /*
     * First allocate the result buffer at the size required.
     */

    for (i = 0;  i < argc;  i++) {
	bytesNeeded += strlen(argv[i]);
    	if (bytesNeeded < 0) {
	    Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
	}
    }

    /*
     * All element bytes + (argc - 1) spaces + 1 terminating NULL.
     */
    if (bytesNeeded + argc - 1 < 0) {
	/*
	 * Panic test could be tighter, but not going to bother for this
	 * legacy routine.
	 */

	Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
    }

    result = (char *)Tcl_Alloc(bytesNeeded + argc);

    for (p = result, i = 0;  i < argc;  i++) {
	Tcl_Size triml, trimr, elemLength;
	const char *element;

2007
2008
2009
2010
2011
2012
2013



2014
2015
2016
2017
2018
2019
2020
     * the slow way, using the string representations.
     *
     * First try to preallocate the size required.
     */

    for (i = 0;  i < objc;  i++) {
	element = Tcl_GetStringFromObj(objv[i], &elemLength);



	bytesNeeded += elemLength;
    }

    /*
     * Does not matter if this fails, will simply try later to build up the
     * string with each Append reallocating as needed with the usual string
     * append algorithm.  When that fails it will report the error.







>
>
>







2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
     * the slow way, using the string representations.
     *
     * First try to preallocate the size required.
     */

    for (i = 0;  i < objc;  i++) {
	element = Tcl_GetStringFromObj(objv[i], &elemLength);
	if (bytesNeeded > (TCL_SIZE_MAX - elemLength)) {
	    break; /* Overflow. Do not preallocate. See comment below. */
	}
	bytesNeeded += elemLength;
    }

    /*
     * Does not matter if this fails, will simply try later to build up the
     * string with each Append reallocating as needed with the usual string
     * append algorithm.  When that fails it will report the error.
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
				 * TCL_INDEX_NONE then this must be null-terminated. */
    Tcl_Size length)		/* Number of bytes from "bytes" to append. If
				 * TCL_INDEX_NONE, then append all of bytes, up to null
				 * at end. */
{
    Tcl_Size newSize;

    if (length == TCL_INDEX_NONE) {
	length = strlen(bytes);
    }
    newSize = length + dsPtr->length;

    /*
     * Allocate a larger buffer for the string if the current one isn't large
     * enough. Allocate extra space in the new buffer so that there will be







|







2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
				 * TCL_INDEX_NONE then this must be null-terminated. */
    Tcl_Size length)		/* Number of bytes from "bytes" to append. If
				 * TCL_INDEX_NONE, then append all of bytes, up to null
				 * at end. */
{
    Tcl_Size newSize;

    if (length < 0) {
	length = strlen(bytes);
    }
    newSize = length + dsPtr->length;

    /*
     * Allocate a larger buffer for the string if the current one isn't large
     * enough. Allocate extra space in the new buffer so that there will be
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
	    if (bytes >= dsPtr->string
		    && bytes <= dsPtr->string + dsPtr->length) {
		index = bytes - dsPtr->string;
	    }

	    dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);

	    if (index != TCL_INDEX_NONE) {
		bytes = dsPtr->string + index;
	    }
	}
    }

    /*
     * Copy the new string into the buffer at the end of the old one.







|







2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
	    if (bytes >= dsPtr->string
		    && bytes <= dsPtr->string + dsPtr->length) {
		index = bytes - dsPtr->string;
	    }

	    dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);

	    if (index >= 0) {
		bytes = dsPtr->string + index;
	    }
	}
    }

    /*
     * Copy the new string into the buffer at the end of the old one.
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
Tcl_Size
TclFormatInt(
    char *buffer,		/* Points to the storage into which the
				 * formatted characters are written. */
    Tcl_WideInt n)			/* The integer to format. */
{
    Tcl_WideUInt intVal;
    Tcl_Size i = 0, numFormatted, j;
    static const char digits[] = "0123456789";

    /*
     * Generate the characters of the result backwards in the buffer.
     */

    intVal = (n < 0 ? -(Tcl_WideUInt)n : (Tcl_WideUInt)n);







|







3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
Tcl_Size
TclFormatInt(
    char *buffer,		/* Points to the storage into which the
				 * formatted characters are written. */
    Tcl_WideInt n)			/* The integer to format. */
{
    Tcl_WideUInt intVal;
    int i = 0, numFormatted, j;
    static const char digits[] = "0123456789";

    /*
     * Generate the characters of the result backwards in the buffer.
     */

    intVal = (n < 0 ? -(Tcl_WideUInt)n : (Tcl_WideUInt)n);
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348

static int
GetWideForIndex(
    Tcl_Interp *interp,         /* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    Tcl_Obj *objPtr,            /* Points to the value to be parsed */
    Tcl_Size endValue,            /* The value to be stored at *widePtr if
				 * objPtr holds "end".
                                 * NOTE: this value may be TCL_INDEX_NONE. */
    Tcl_WideInt *widePtr)       /* Location filled in with a wide integer
                                 * representing an index. */
{
    int numType;
    void *cd;







|







3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363

static int
GetWideForIndex(
    Tcl_Interp *interp,         /* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    Tcl_Obj *objPtr,            /* Points to the value to be parsed */
    Tcl_WideInt endValue,       /* The value to be stored at *widePtr if
				 * objPtr holds "end".
                                 * NOTE: this value may be TCL_INDEX_NONE. */
    Tcl_WideInt *widePtr)       /* Location filled in with a wide integer
                                 * representing an index. */
{
    int numType;
    void *cd;
3371
3372
3373
3374
3375
3376
3377








3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
 *
 * Tcl_GetIntForIndex --
 *
 *	Provides an integer corresponding to the list index held in a Tcl
 *	object. The string value 'objPtr' is expected have the format
 *	integer([+-]integer)? or end([+-]integer)?.
 *








 * Value
 * 	TCL_OK
 *
 * 	    The index is stored at the address given by by 'indexPtr'. If
 * 	    'objPtr' has the value "end", the value stored is 'endValue'.
 *
 * 	TCL_ERROR
 *
 * 	    The value of 'objPtr' does not have one of the expected formats. If
 * 	    'interp' is non-NULL, an error message is left in the interpreter's
 * 	    result object.
 *
 * Effect
 *
 * 	The object referenced by 'objPtr' is converted, as needed, to an
 * 	integer, wide integer, or end-based-index object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIntForIndex(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If







>
>
>
>
>
>
>
>
|


|
<







|

|
<







3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404

3405
3406
3407
3408
3409
3410
3411
3412
3413
3414

3415
3416
3417
3418
3419
3420
3421
 *
 * Tcl_GetIntForIndex --
 *
 *	Provides an integer corresponding to the list index held in a Tcl
 *	object. The string value 'objPtr' is expected have the format
 *	integer([+-]integer)? or end([+-]integer)?.
 *
 *	If the computed index lies within the valid range of Tcl indices
 *	(0..TCL_SIZE_MAX) it is returned. Higher values are returned as
 *	TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1).
 *
 *	Callers should pass reasonable values for endValue - one in the
 *      valid index range or TCL_INDEX_NONE (-1), for example for an empty
 *	list.
 *
 * Results:
 * 	TCL_OK
 *
 * 	    The index is stored at the address given by by 'indexPtr'.

 *
 * 	TCL_ERROR
 *
 * 	    The value of 'objPtr' does not have one of the expected formats. If
 * 	    'interp' is non-NULL, an error message is left in the interpreter's
 * 	    result object.
 *
 * Side effects:
 *
 * 	The internal representation contained within objPtr may shimmer.

 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIntForIndex(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If
3408
3409
3410
3411
3412
3413
3414

3415
3416
3417
3418
3419
3420
3421
3422
3423
3424

3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441

3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
{
    Tcl_WideInt wide;

    if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (indexPtr != NULL) {

	if ((wide < 0) && (endValue < TCL_INDEX_END)) {
	    *indexPtr = TCL_INDEX_NONE;
	} else if ((Tcl_WideUInt)wide > TCL_INDEX_END && (endValue < TCL_INDEX_END)) {
	    *indexPtr = TCL_INDEX_END;
	} else {
	    *indexPtr = (Tcl_Size) wide;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetEndOffsetFromObj --
 *
 *	Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
 *	convert it to an internal representation.
 *
 *	The internal representation (wideValue) uses the following encoding:
 *
 *	WIDE_MIN:   Index value TCL_INDEX_NONE (or -1)
 *	WIDE_MIN+1: Index value n, for any n < -1  (usually same effect as -1)
 *	-$n:        Index "end-[expr {$n-1}]"
 *	-2:         Index "end-1"
 *	-1:         Index "end"
 *	0:          Index "0"
 *	WIDE_MAX-1: Index "end+n", for any n > 1

 *	WIDE_MAX:   Index "end+1"
 *
 * Results:
 *	Tcl return code.
 *
 * Side effects:
 *	May store a Tcl_ObjType.
 *
 *----------------------------------------------------------------------
 */

static int
GetEndOffsetFromObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,            /* Pointer to the object to parse */
    Tcl_Size endValue,          /* The value to be stored at "widePtr" if
                                 * "objPtr" holds "end". */
    Tcl_WideInt *widePtr)       /* Location filled in with an integer
                                 * representing an index. */
{
    Tcl_ObjInternalRep *irPtr;
    Tcl_WideInt offset = -1;	/* Offset in the "end-offset" expression - 1 */
    void *cd;







>
|
|
|
|

|




>
















|
>















|







3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
{
    Tcl_WideInt wide;

    if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (indexPtr != NULL) {
	/* Note: check against TCL_SIZE_MAX needed for 32-bit builds */
	if (wide >= 0 && wide <= TCL_SIZE_MAX) {
	    *indexPtr = (Tcl_Size)wide;
	} else if (wide > TCL_SIZE_MAX) {
	    *indexPtr = TCL_SIZE_MAX;
	} else {
	    *indexPtr = TCL_INDEX_NONE;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetEndOffsetFromObj --
 *
 *	Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
 *	convert it to an internal representation.
 *
 *	The internal representation (wideValue) uses the following encoding:
 *
 *	WIDE_MIN:   Index value TCL_INDEX_NONE (or -1)
 *	WIDE_MIN+1: Index value n, for any n < -1  (usually same effect as -1)
 *	-$n:        Index "end-[expr {$n-1}]"
 *	-2:         Index "end-1"
 *	-1:         Index "end"
 *	0:          Index "0"
 *	WIDE_MAX-1: Index "end+n", for any n > 1. Distinguish from end+1 for
 *                  commands like lset.
 *	WIDE_MAX:   Index "end+1"
 *
 * Results:
 *	Tcl return code.
 *
 * Side effects:
 *	May store a Tcl_ObjType.
 *
 *----------------------------------------------------------------------
 */

static int
GetEndOffsetFromObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,            /* Pointer to the object to parse */
    Tcl_WideInt endValue,       /* The value to be stored at "widePtr" if
                                 * "objPtr" holds "end". */
    Tcl_WideInt *widePtr)       /* Location filled in with an integer
                                 * representing an index. */
{
    Tcl_ObjInternalRep *irPtr;
    Tcl_WideInt offset = -1;	/* Offset in the "end-offset" expression - 1 */
    void *cd;
3651
3652
3653
3654
3655
3656
3657








3658
3659

3660
3661
3662
3663
3664

3665
3666

3667
3668
3669
3670
3671
3672
3673
	ir.wideValue = offset;
	Tcl_StoreInternalRep(objPtr, &endOffsetType.objType, &ir);
    }

    offset = irPtr->wideValue;

    if (offset == WIDE_MAX) {








	*widePtr = endValue + 1;
    } else if (offset == WIDE_MIN) {

	*widePtr = -1;
    } else if (offset < 0) {
	/* Different signs, sum cannot overflow */
	*widePtr = endValue + offset + 1;
    } else if (offset < WIDE_MAX) {

	*widePtr = offset;
    } else {

	*widePtr = WIDE_MAX;
    }
    return TCL_OK;

    /* Report a parse error. */
  parseError:
    if (interp != NULL) {







>
>
>
>
>
>
>
>


>


|


>


>







3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
	ir.wideValue = offset;
	Tcl_StoreInternalRep(objPtr, &endOffsetType.objType, &ir);
    }

    offset = irPtr->wideValue;

    if (offset == WIDE_MAX) {
	/* 
	 * Encodes end+1. This is distinguished from end+n as noted above 
	 * NOTE: this may wrap around if the caller passes (as lset does)
	 * listLen-1 as endValue and and listLen is 0. The -1 will be
	 * interpreted as FF...FF and adding 1 will result in 0 which
	 * is what we want. 2's complements shenanigans but it is what
	 * it is ...
	 */
	*widePtr = endValue + 1;
    } else if (offset == WIDE_MIN) {
	/* -1 - position before first */
	*widePtr = -1;
    } else if (offset < 0) {
	/* end-(n-1) - Different signs, sum cannot overflow */
	*widePtr = endValue + offset + 1;
    } else if (offset < WIDE_MAX) {
	/* 0:WIDE_MAX-1 - plain old index. */
	*widePtr = offset;
    } else {
	/* Huh, what case remains here? */
	*widePtr = WIDE_MAX;
    }
    return TCL_OK;

    /* Report a parse error. */
  parseError:
    if (interp != NULL) {
3684
3685
3686
3687
3688
3689
3690




3691
3692
3693
3694
3695
3696
3697
3698
3699

3700
3701
3702





3703
3704
3705
3706
3707
3708
3709
3710
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclIndexEncode --




 *
 *      Parse objPtr to determine if it is an index value. Two cases
 *	are possible.  The value objPtr might be parsed as an absolute
 *	index value in the C signed int range.  Note that this includes
 *	index values that are integers as presented and it includes index
 *      arithmetic expressions. The absolute index values that can be
 *	directly meaningful as an index into either a list or a string are
 *	those integer values >= TCL_INDEX_START (0)
 *	and < INT_MAX.

 *      The largest string supported in Tcl 8 has bytelength INT_MAX.
 *      This means the largest supported character length is also INT_MAX,
 *      and the index of the last character in a string of length INT_MAX





 *      is INT_MAX-1.
 *
 *      Any absolute index value parsed outside that range is encoded
 *      using the before and after values passed in by the
 *      caller as the encoding to use for indices that are either
 *      less than or greater than the usable index range. TCL_INDEX_NONE
 *      is available as a good choice for most callers to use for
 *      after. Likewise, the value TCL_INDEX_NONE is good for







>
>
>
>



|

|
<
<
<
>
|
|
|
>
>
>
>
>
|







3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735



3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclIndexEncode --
 *      IMPORTANT: function only encodes indices in the range that fits within
 *      an "int" type. Do NOT change this as the byte code compiler and engine
 *      which call this function cannot handle wider index types. Indices
 *      outside the range will result in the function returning an error.
 *
 *      Parse objPtr to determine if it is an index value. Two cases
 *	are possible.  The value objPtr might be parsed as an absolute
 *	index value in the Tcl_Size range.  Note that this includes
 *	index values that are integers as presented and it includes index
 *      arithmetic expressions.



 *
 *      The largest string supported in Tcl 8 has byte length TCL_SIZE_MAX.
 *      This means the largest supported character length is also TCL_SIZE_MAX,
 *      and the index of the last character in a string of length TCL_SIZE_MAX
 *      is TCL_SIZE_MAX-1. Thus the absolute index values that can be
 *	directly meaningful as an index into either a list or a string are
 *	integer values in the range 0 to TCL_SIZE_MAX - 1.
 *
 *      This function however can only handle integer indices in the range
 *      0 : INT_MAX-1.
 *
 *      Any absolute index value parsed outside that range is encoded
 *      using the before and after values passed in by the
 *      caller as the encoding to use for indices that are either
 *      less than or greater than the usable index range. TCL_INDEX_NONE
 *      is available as a good choice for most callers to use for
 *      after. Likewise, the value TCL_INDEX_NONE is good for
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733

3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751

3752

3753
3754
3755
3756
3757
3758
3759























3760

3761

3762
3763
3764
3765
3766
3767
3768
3769







3770
3771
3772


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
 *      index "end" is encoded as -2, down to the index "end-0x7FFFFFFE"
 *      which is encoded as INT_MIN. Since the largest index into a
 *      string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of
 *      "end-0x7FFFFFFE" for that largest string would be 0.  Thus,
 *      if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed,
 *      they can be encoded with the before value.
 *
 *      These details will require re-examination whenever string and
 *      list length limits are increased, but that will likely also
 *      mean a revised routine capable of returning Tcl_WideInt values.
 *
 * Returns:
 *      TCL_OK if parsing succeeded, and TCL_ERROR if it failed.

 *
 * Side effects:
 *      When TCL_OK is returned, the encoded index value is written
 *      to *indexPtr.
 *
 *----------------------------------------------------------------------
 */

int
TclIndexEncode(
    Tcl_Interp *interp,	/* For error reporting, may be NULL */
    Tcl_Obj *objPtr,	/* Index value to parse */
    Tcl_Size before,		/* Value to return for index before beginning */
    Tcl_Size after,		/* Value to return for index after end */
    int *indexPtr)	/* Where to write the encoded answer, not NULL */
{
    Tcl_WideInt wide;
    int idx;



    if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
	const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType.objType);
	if (irPtr && irPtr->wideValue >= 0) {
	    /* "int[+-]int" syntax, works the same here as "int" */
	    irPtr = NULL;
	}
	/*























	 * We parsed an end+offset index value.

	 * wide holds the offset value in the range WIDE_MIN...WIDE_MAX.

	 */
	if ((irPtr ? ((wide < INT_MIN) && ((Tcl_Size)-wide <= LIST_MAX))
		: ((wide > INT_MAX) && ((Tcl_Size)wide <= LIST_MAX))) && (sizeof(int) != sizeof(Tcl_Size))) {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"index \"%s\" out of range",
			TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"







			"OUTOFRANGE", NULL);
	    }
	    return TCL_ERROR;


	} else if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) {
	    /*
	     * All end+postive or end-negative expressions



	     * always indicate "after the end".












	     */
	    idx = after;
	} else if (wide <= (irPtr ? INT_MAX : -1)) {
	    /* These indices always indicate "before the beginning" */
	    idx = before;
	} else {
	    /* Encoded end-positive (or end+negative) are offset */
	    idx = (int)wide;
	}
    } else {

	return TCL_ERROR;











    }

















    *indexPtr = idx;
    return TCL_OK;














}

/*
 *----------------------------------------------------------------------
 *
 * TclIndexDecode --
 *







<
<
<
<

|
>












|
|




>

>
|
<
<
|
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
|
|
<
<
|
<
|
|
>
>
>
>
>
>
>
|
|
|
>
>
|
|
<
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>


|
|


|



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


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







3763
3764
3765
3766
3767
3768
3769




3770
3771
3772
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
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826


3827

3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843

3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
 *      index "end" is encoded as -2, down to the index "end-0x7FFFFFFE"
 *      which is encoded as INT_MIN. Since the largest index into a
 *      string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of
 *      "end-0x7FFFFFFE" for that largest string would be 0.  Thus,
 *      if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed,
 *      they can be encoded with the before value.
 *




 * Returns:
 *      TCL_OK if parsing succeeded, and TCL_ERROR if it failed or the
 *      index does not fit in an int type.
 *
 * Side effects:
 *      When TCL_OK is returned, the encoded index value is written
 *      to *indexPtr.
 *
 *----------------------------------------------------------------------
 */

int
TclIndexEncode(
    Tcl_Interp *interp,	/* For error reporting, may be NULL */
    Tcl_Obj *objPtr,	/* Index value to parse */
    int before,		/* Value to return for index before beginning */
    int after,		/* Value to return for index after end */
    int *indexPtr)	/* Where to write the encoded answer, not NULL */
{
    Tcl_WideInt wide;
    int idx;
    const Tcl_WideInt ENDVALUE = 2 * (Tcl_WideInt) INT_MAX;

    assert(ENDVALUE < WIDE_MAX);
    if (TCL_OK != GetWideForIndex(interp, objPtr, ENDVALUE, &wide)) {


	return TCL_ERROR;

    }
    /*
     * We passed 2*INT_MAX as the "end value" to GetWideForIndex. The computed
     * index will in one of the following ranges that need to be distinguished
     * for encoding purposes in the following code.
     * (1) 0:INT_MAX when
     *     (a) objPtr was a pure non-negative numeric value in that range
     *     (b) objPtr was a numeric computation M+/-N with a result in that range
     *     (c) objPtr was of the form end-N where N was in range INT_MAX:2*INT_MAX
     * (2) INT_MAX+1:2*INT_MAX when
     *     (a,b) as above
     *     (c) objPtr was of the form end-N where N was in range 0:INT_MAX-1
     * (3) 2*INT_MAX:WIDE_MAX when
     *     (a,b) as above
     *     (c) objPtr was of the form end+N
     * (4) (2*INT_MAX)-TCL_SIZE_MAX : -1 when
     *     (a,b) as above
     *     (c) objPtr was of the form end-N where N was in the range 0:TCL_SIZE_MAX
     * (5) WIDE_MIN:(2*INT_MAX)-TCL_SIZE_MAX
     *     (a,b) as above
     *     (c) objPtr was of the form end-N where N was > TCL_SIZE_MAX
     *
     * For all cases (b) and (c), the internal representation of objPtr
     * will be shimmered to endOffsetType. That allows us to distinguish between
     * (for example) 1a (encodable) and 1c (not encodable) though the computed
     * index value is the same.
     *
     * Further note, the values TCL_SIZE_MAX < N < WIDE_MAX come into play
     * only in the 32-bit builds as TCL_SIZE_MAX == WIDE_MAX for 64-bits.
     */



    const Tcl_ObjInternalRep *irPtr =

	TclFetchInternalRep(objPtr, &endOffsetType.objType);

    if (irPtr && irPtr->wideValue >= 0) {
	/*
	 * "int[+-]int" syntax, works the same here as "int".
	 * Note same does not hold for negative integers.
	 * Distinguishes 1b and 1c where wide will be in 0:INT_MAX for
	 * both but irPtr->wideValue will be negative for 1c.
	 */
	irPtr = NULL;
    }

    if (irPtr == NULL) {
	/* objPtr can be treated as a purely numeric value. */

	/*

	 * On 64-bit systems, indices in the range INT_MAX:TCL_SIZE_MAX are
	 * valid indices but are not in the encodable range. Thus an
	 * error is raised. On 32-bit systems, indices in that range indicate
	 * the position after the end and so do not raise an error.
	 */
	if ((sizeof(int) != sizeof(size_t)) &&
	    (wide > INT_MAX) && (wide < WIDE_MAX-1)) {
	    /* 2(a,b) on 64-bit systems*/
	    goto rangeerror;
	}
	if (wide > INT_MAX) {
	    /*
	     * 3(a,b) on 64-bit systems and 2(a,b), 3(a,b) on 32-bit systems
	     * Because of the check above, this case holds for indices
	     * greater than INT_MAX on 32-bit systems and > TCL_SIZE_MAX
	     * on 64-bit systems. Always maps to the element after the end.
	     */
	    idx = after;
	} else if (wide < 0) {
	    /* 4(a,b) (32-bit systems), 5(a,b) - before the beginning */
	    idx = before;
	} else {
	    /* 1(a,b) Encodable range */
	    idx = (int)wide;
	}
    } else {
	/* objPtr is not purely numeric (end etc.)  */

	/*
	 * On 64-bit systems, indices in the range end-LIST_MAX:end-INT_MAX
	 * are valid indices (with max size strings/lists) but are not in
	 * the encodable range. Thus an error is raised. On 32-bit systems,
	 * indices in that range indicate the position before the beginning
	 * and so do not raise an error.
	 */
	if ((sizeof(int) != sizeof(size_t)) &&
	    (wide > (ENDVALUE - LIST_MAX)) && (wide <= INT_MAX)) {
	    /* 1(c), 4(a,b) on 64-bit systems */
	    goto rangeerror;
	}
	if (wide > ENDVALUE) {
	    /*
	     * 2(c) (32-bit systems), 3(c)
	     * All end+positive or end-negative expressions
	     * always indicate "after the end".
	     * Note we will not reach here for a pure numeric value in this
	     * range because irPtr will be NULL in that case.
	     */
	    idx = after;
	} else if (wide <= INT_MAX) {
	    /* 1(c) (32-bit systems), 4(c) (32-bit systems), 5(c) */
	    idx = before;
	} else {
	    /* 2(c) Encodable end-positive (or end+negative) */
	    idx = (int)wide;
	}
    }
    *indexPtr = idx;
    return TCL_OK;

rangeerror:
    if (interp) {
	Tcl_SetObjResult(
	    interp,
	    Tcl_ObjPrintf("index \"%s\" out of range", TclGetString(objPtr)));
	Tcl_SetErrorCode(interp,
			 "TCL",
			 "VALUE",
			 "INDEX"
			 "OUTOFRANGE",
			 NULL);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclIndexDecode --
 *
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815

3816
3817
3818
3819
3820






























3821
3822
3823
3824
3825
3826
3827
 */

Tcl_Size
TclIndexDecode(
    int encoded,	/* Value to decode */
    Tcl_Size endValue)	/* Meaning of "end" to use, > TCL_INDEX_END */
{
    if (encoded > (int)TCL_INDEX_END) {
	return encoded;
    }

    if (endValue >= TCL_INDEX_END - encoded) {
	return endValue + encoded - TCL_INDEX_END;
    }
    return TCL_INDEX_NONE;
}































/*
 *----------------------------------------------------------------------
 *
 * ClearHash --
 *
 *	Remove all the entries in the hash table *tablePtr.







|


>
|
|



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







3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
 */

Tcl_Size
TclIndexDecode(
    int encoded,	/* Value to decode */
    Tcl_Size endValue)	/* Meaning of "end" to use, > TCL_INDEX_END */
{
    if (encoded > TCL_INDEX_END) {
	return encoded;
    }
    endValue += encoded - TCL_INDEX_END;
    if (endValue >= 0) {
	return endValue;
    }
    return TCL_INDEX_NONE;
}

/*
 *------------------------------------------------------------------------
 *
 * TclIndexInvalidError --
 *
 *    Generates an error message including the invalid index.
 *
 * Results:
 *    Always return TCL_ERROR.
 *
 * Side effects:
 *    If interp is not-NULL, an error message is stored in it.
 *
 *------------------------------------------------------------------------
 */
int
TclIndexInvalidError (
    Tcl_Interp *interp,   /* May be NULL */
    const char *idxType,  /* The descriptive string for idx. Defaults to "index" */
    Tcl_Size idx)         /* Invalid index value */
{
    if (interp) {
	Tcl_SetObjResult(interp,
			 Tcl_ObjPrintf("Invalid %s value %" TCL_SIZE_MODIFIER "d.",
				       idxType ? idxType : "index",
				       idx));
    }
    return TCL_ERROR; /* Always */
}

/*
 *----------------------------------------------------------------------
 *
 * ClearHash --
 *
 *	Remove all the entries in the hash table *tablePtr.
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
	*exactPtr = (anchorLeft && anchorRight);
    }

    return TCL_OK;

  invalidGlob:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
    }
    Tcl_DStringFree(dsPtr);
    return TCL_ERROR;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|













4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
	*exactPtr = (anchorLeft && anchorRight);
    }

    return TCL_OK;

  invalidGlob:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
	Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
    }
    Tcl_DStringFree(dsPtr);
    return TCL_ERROR;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclVar.c.

259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
    } while (0)

#define LocalGetInternalRep(objPtr, index, name)				\
    do {								\
	const Tcl_ObjInternalRep *irPtr;					\
	irPtr = TclFetchInternalRep((objPtr), &localVarNameType);		\
	(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL;		\
	(index) = irPtr ? PTR2UINT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE;	\
    } while (0)

static const Tcl_ObjType parsedVarNameType = {
    "parsedVarName",
    FreeParsedVarName, DupParsedVarName, NULL, NULL, TCL_OBJTYPE_V0
};








|







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
    } while (0)

#define LocalGetInternalRep(objPtr, index, name)				\
    do {								\
	const Tcl_ObjInternalRep *irPtr;					\
	irPtr = TclFetchInternalRep((objPtr), &localVarNameType);		\
	(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL;		\
	(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE;	\
    } while (0)

static const Tcl_ObjType parsedVarNameType = {
    "parsedVarName",
    FreeParsedVarName, DupParsedVarName, NULL, NULL, TCL_OBJTYPE_V0
};

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
    TclVarHashTable *tablePtr,
    const char *key,
    int *newPtr)
{
    Tcl_Obj *keyPtr;
    Var *varPtr;

    keyPtr = Tcl_NewStringObj(key, TCL_INDEX_NONE);
    Tcl_IncrRefCount(keyPtr);
    varPtr = VarHashCreateVar(tablePtr, keyPtr, newPtr);
    Tcl_DecrRefCount(keyPtr);

    return varPtr;
}








|







297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
    TclVarHashTable *tablePtr,
    const char *key,
    int *newPtr)
{
    Tcl_Obj *keyPtr;
    Var *varPtr;

    keyPtr = Tcl_NewStringObj(key, -1);
    Tcl_IncrRefCount(keyPtr);
    varPtr = VarHashCreateVar(tablePtr, keyPtr, newPtr);
    Tcl_DecrRefCount(keyPtr);

    return varPtr;
}

465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
				 * return error if it doesn't exist. */
    Var **arrayPtrPtr)		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{
    Var *varPtr;
    Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, TCL_INDEX_NONE);

    if (createPart1) {
	Tcl_IncrRefCount(part1Ptr);
    }

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
	    createPart1, createPart2, arrayPtrPtr);







|







465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
				 * return error if it doesn't exist. */
    Var **arrayPtrPtr)		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{
    Var *varPtr;
    Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, -1);

    if (createPart1) {
	Tcl_IncrRefCount(part1Ptr);
    }

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
	    createPart1, createPart2, arrayPtrPtr);
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{
    Tcl_Obj *part2Ptr = NULL;
    Var *resPtr;

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, TCL_INDEX_NONE);
	if (createPart2) {
	    Tcl_IncrRefCount(part2Ptr);
	}
    }

    resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
	    flags, msg, createPart1, createPart2, arrayPtrPtr);







|







547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{
    Tcl_Obj *part2Ptr = NULL;
    Var *resPtr;

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);
	if (createPart2) {
	    Tcl_IncrRefCount(part2Ptr);
	}
    }

    resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
	    flags, msg, createPart1, createPart2, arrayPtrPtr);
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    const char *errMsg = NULL;
    int index, parsed = 0;

    size_t localIndex;
    Tcl_Obj *namePtr, *arrayPtr, *elem;

    *arrayPtrPtr = NULL;

  restart:
    LocalGetInternalRep(part1Ptr, localIndex, namePtr);
    if (localIndex != TCL_INDEX_NONE) {
	if (HasLocalVars(varFramePtr)
		&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		&& (localIndex < varFramePtr->numCompiledLocals)) {
	    /*
	     * Use the cached index if the names coincide.
	     */








|






|







600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    const char *errMsg = NULL;
    int index, parsed = 0;

    Tcl_Size localIndex;
    Tcl_Obj *namePtr, *arrayPtr, *elem;

    *arrayPtrPtr = NULL;

  restart:
    LocalGetInternalRep(part1Ptr, localIndex, namePtr);
    if (localIndex >= 0) {
	if (HasLocalVars(varFramePtr)
		&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		&& (localIndex < varFramePtr->numCompiledLocals)) {
	    /*
	     * Use the cached index if the names coincide.
	     */

655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
    }

    if (!parsed) {
	/*
	 * part1Ptr is possibly an unparsed array element.
	 */

	size_t len;
	const char *part1 = Tcl_GetStringFromObj(part1Ptr, &len);

	if ((len > 1) && (part1[len - 1] == ')')) {
	    const char *part2 = strchr(part1, '(');

	    if (part2) {
		if (part2Ptr != NULL) {







|







655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
    }

    if (!parsed) {
	/*
	 * part1Ptr is possibly an unparsed array element.
	 */

	Tcl_Size len;
	const char *part1 = Tcl_GetStringFromObj(part1Ptr, &len);

	if ((len > 1) && (part1[len - 1] == ')')) {
	    const char *part2 = strchr(part1, '(');

	    if (part2) {
		if (part2Ptr != NULL) {
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
		*errMsgPtr = BADNAMESPACE;
		return NULL;
	    } else if (tail == NULL) {
		*errMsgPtr = MISSINGNAME;
		return NULL;
	    }
	    if (tail != varName) {
		tailPtr = Tcl_NewStringObj(tail, TCL_INDEX_NONE);
	    } else {
		tailPtr = varNamePtr;
	    }
	    varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew);
	    if (lookGlobal) {
		/*
		 * The variable was created starting from the global







|







945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
		*errMsgPtr = BADNAMESPACE;
		return NULL;
	    } else if (tail == NULL) {
		*errMsgPtr = MISSINGNAME;
		return NULL;
	    }
	    if (tail != varName) {
		tailPtr = Tcl_NewStringObj(tail, -1);
	    } else {
		tailPtr = varNamePtr;
	    }
	    varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew);
	    if (lookGlobal) {
		/*
		 * The variable was created starting from the global
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
    const char *part2,		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags)			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
				 * bits. */
{
    Tcl_Obj *resultPtr;
    Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, TCL_INDEX_NONE);

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, TCL_INDEX_NONE);
	Tcl_IncrRefCount(part2Ptr);
    }

    resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {







|


|







1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
    const char *part2,		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags)			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
				 * bits. */
{
    Tcl_Obj *resultPtr;
    Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);
	Tcl_IncrRefCount(part2Ptr);
    }

    resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
    const char *part1,		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    const char *part2,		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags)			/* OR-ed combination of TCL_GLOBAL_ONLY, and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, TCL_INDEX_NONE);

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, TCL_INDEX_NONE);
	Tcl_IncrRefCount(part2Ptr);
    }

    resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {







|


|







1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
    const char *part1,		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    const char *part2,		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags)			/* OR-ed combination of TCL_GLOBAL_ONLY, and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);
	Tcl_IncrRefCount(part2Ptr);
    }

    resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
    const char *newValue,	/* New value for variable. */
    int flags)			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
				 * TCL_LEAVE_ERR_MSG. */
{
    Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2,
	    Tcl_NewStringObj(newValue, TCL_INDEX_NONE), flags);

    if (varValuePtr == NULL) {
	return NULL;
    }
    return TclGetString(varValuePtr);
}








|







1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
    const char *newValue,	/* New value for variable. */
    int flags)			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
				 * TCL_LEAVE_ERR_MSG. */
{
    Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2,
	    Tcl_NewStringObj(newValue, -1), flags);

    if (varValuePtr == NULL) {
	return NULL;
    }
    return TclGetString(varValuePtr);
}

1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
				 * in the array part1. */
    Tcl_Obj *newValuePtr,	/* New value for variable. */
    int flags)			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
				 * TCL_LEAVE_ERR_MSG. */
{
    Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, TCL_INDEX_NONE);

    Tcl_IncrRefCount(part1Ptr);
    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, TCL_INDEX_NONE);
	Tcl_IncrRefCount(part2Ptr);
    }

    resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {







|



|







1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
				 * in the array part1. */
    Tcl_Obj *newValuePtr,	/* New value for variable. */
    int flags)			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
				 * TCL_LEAVE_ERR_MSG. */
{
    Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);

    Tcl_IncrRefCount(part1Ptr);
    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);
	Tcl_IncrRefCount(part2Ptr);
    }

    resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
    const char *part1,		/* Name of variable or array. */
    const char *part2,		/* Name of element within array or NULL. */
    int flags)			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    int result;
    Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, TCL_INDEX_NONE);

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, TCL_INDEX_NONE);
    }

    /*
     * Filter to pass through only the flags this interface supports.
     */

    flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);







|


|







2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
    const char *part1,		/* Name of variable or array. */
    const char *part2,		/* Name of element within array or NULL. */
    int flags)			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    int result;
    Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);
    }

    /*
     * Filter to pass through only the flags this interface supports.
     */

    flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
Tcl_LappendObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *varValuePtr, *newValuePtr;
    size_t numElems;
    Var *varPtr, *arrayPtr;
    int result, createdNewObj;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
	return TCL_ERROR;
    }







|







2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
Tcl_LappendObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *varValuePtr, *newValuePtr;
    Tcl_Size numElems;
    Var *varPtr, *arrayPtr;
    int result, createdNewObj;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
	return TCL_ERROR;
    }
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
    ArraySearch *searchPtr = NULL;
    Var *varPtr;
    int isArray;
    size_t numVars;

    /*
     * array for {k v} a body
     */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjLengthM(interp, objv[1], &numVars) != TCL_OK) {
	return TCL_ERROR;
    }

    if (numVars != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have two variable names", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
	return TCL_ERROR;
    }

    arrayNameObj = objv[2];

    if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {







|




















|







3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
    ArraySearch *searchPtr = NULL;
    Var *varPtr;
    int isArray;
    Tcl_Size numVars;

    /*
     * array for {k v} a body
     */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (TclListObjLengthM(interp, objv[1], &numVars) != TCL_OK) {
	return TCL_ERROR;
    }

    if (numVars != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have two variable names", -1));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
	return TCL_ERROR;
    }

    arrayNameObj = objv[2];

    if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
    Tcl_Obj *arrayNameObj = (Tcl_Obj *)data[2];
    Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
    Tcl_Obj **varv;
    Tcl_Obj *keyObj, *valueObj;
    Var *varPtr;
    Var *arrayPtr;
    int done;
    size_t varc;

    /*
     * Process the result from the previous execution of the script body.
     */

    done = TCL_ERROR;








|







3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
    Tcl_Obj *arrayNameObj = (Tcl_Obj *)data[2];
    Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
    Tcl_Obj **varv;
    Tcl_Obj *keyObj, *valueObj;
    Var *varPtr;
    Var *arrayPtr;
    int done;
    Tcl_Size varc;

    /*
     * Process the result from the previous execution of the script body.
     */

    done = TCL_ERROR;

3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
    }

    result = TCL_OK;
    if (done != TCL_CONTINUE) {
	Tcl_ResetResult(interp);
	if (done == TCL_ERROR) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "array changed during iteration", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
	    varPtr->flags |= TCL_LEAVE_ERR_MSG;
	    result = done;
	}
	goto arrayfordone;
    }








|







3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
    }

    result = TCL_OK;
    if (done != TCL_CONTINUE) {
	Tcl_ResetResult(interp);
	if (done == TCL_ERROR) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "array changed during iteration", -1));
	    Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
	    varPtr->flags |= TCL_LEAVE_ERR_MSG;
	    result = done;
	}
	goto arrayfordone;
    }

3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
    Tcl_Obj *const objv[])
{
    Var *varPtr, *varPtr2;
    Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
    Tcl_Obj **nameObjPtr, *patternObj;
    Tcl_HashSearch search;
    const char *pattern;
    size_t i, count;
    int result, isArray;

    switch (objc) {
    case 2:
	varNameObj = objv[1];
	patternObj = NULL;
	break;







|







3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
    Tcl_Obj *const objv[])
{
    Var *varPtr, *varPtr2;
    Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
    Tcl_Obj **nameObjPtr, *patternObj;
    Tcl_HashSearch search;
    const char *pattern;
    Tcl_Size i, count;
    int result, isArray;

    switch (objc) {
    case 2:
	varNameObj = objv[1];
	patternObj = NULL;
	break;
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *arrayNameObj;
    Tcl_Obj *arrayElemObj;
    Var *varPtr, *arrayPtr;
    int result;
    size_t i;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
	return TCL_ERROR;
    }

    if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) {







<







3956
3957
3958
3959
3960
3961
3962

3963
3964
3965
3966
3967
3968
3969
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *arrayNameObj;
    Tcl_Obj *arrayElemObj;
    Var *varPtr, *arrayPtr;
    int result;


    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
	return TCL_ERROR;
    }

    if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) {
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
     */

    arrayElemObj = objv[2];
    if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
	Tcl_Obj *keyPtr, *valuePtr;
	Tcl_DictSearch search;
	int done;
	size_t size;

	if (Tcl_DictObjSize(interp, arrayElemObj, &size) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (size == 0) {
	    /*
	     * Empty, so we'll just force the array to be properly existing







|







3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
     */

    arrayElemObj = objv[2];
    if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
	Tcl_Obj *keyPtr, *valuePtr;
	Tcl_DictSearch search;
	int done;
	Tcl_Size size;

	if (Tcl_DictObjSize(interp, arrayElemObj, &size) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (size == 0) {
	    /*
	     * Empty, so we'll just force the array to be properly existing
4035
4036
4037
4038
4039
4040
4041
4042
4043

4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
	return TCL_OK;
    } else {
	/*
	 * Not a dictionary, so assume (and convert to, for backward-
	 * -compatibility reasons) a list.
	 */

	size_t elemLen;
	Tcl_Obj **elemPtrs, *copyListObj;


	result = TclListObjLengthM(interp, arrayElemObj, &elemLen);
	if (result != TCL_OK) {
	    return result;
	}
	if (elemLen & 1) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "list must have an even number of elements", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
	    return TCL_ERROR;
	}
	if (elemLen == 0) {
	    goto ensureArray;
	}
	result = TclListObjGetElementsM(interp, arrayElemObj,







|

>







|







4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
	return TCL_OK;
    } else {
	/*
	 * Not a dictionary, so assume (and convert to, for backward-
	 * -compatibility reasons) a list.
	 */

	Tcl_Size elemLen;
	Tcl_Obj **elemPtrs, *copyListObj;
	Tcl_Size i;

	result = TclListObjLengthM(interp, arrayElemObj, &elemLen);
	if (result != TCL_OK) {
	    return result;
	}
	if (elemLen & 1) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "list must have an even number of elements", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
	    return TCL_ERROR;
	}
	if (elemLen == 0) {
	    goto ensureArray;
	}
	result = TclListObjGetElementsM(interp, arrayElemObj,
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
    if (!isArray) {
	return NotArrayError(interp, varNameObj);
    }

    stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
    if (stats == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"error reading array statistics", TCL_INDEX_NONE));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, TCL_INDEX_NONE));
    Tcl_Free(stats);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|


|







4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
    if (!isArray) {
	return NotArrayError(interp, varNameObj);
    }

    stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
    if (stats == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"error reading array statistics", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
    Tcl_Free(stats);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
    }
    if (TclIsVarInHash(varPtr)) {
	if (!TclIsVarDeadHash(varPtr)) {
	    namePtr = VarHashGetKey(varPtr);
	    Tcl_AppendObjToObj(objPtr, namePtr);
	}
    } else if (iPtr->varFramePtr->procPtr) {
	size_t index = varPtr - iPtr->varFramePtr->compiledLocals;

	if (index < iPtr->varFramePtr->numCompiledLocals) {
	    namePtr = localName(iPtr->varFramePtr, index);
	    Tcl_AppendObjToObj(objPtr, namePtr);
	}
    }
}







|







4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
    }
    if (TclIsVarInHash(varPtr)) {
	if (!TclIsVarDeadHash(varPtr)) {
	    namePtr = VarHashGetKey(varPtr);
	    Tcl_AppendObjToObj(objPtr, namePtr);
	}
    } else if (iPtr->varFramePtr->procPtr) {
	Tcl_Size index = varPtr - iPtr->varFramePtr->compiledLocals;

	if (index < iPtr->varFramePtr->numCompiledLocals) {
	    namePtr = localName(iPtr->varFramePtr, index);
	    Tcl_AppendObjToObj(objPtr, namePtr);
	}
    }
}
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
 *   twoPtrValue.ptr2: index into locals table
 */

static void
FreeLocalVarName(
    Tcl_Obj *objPtr)
{
    size_t index;
    Tcl_Obj *namePtr;

    LocalGetInternalRep(objPtr, index, namePtr);

    index++;	/* Compiler warning bait. */
    if (namePtr) {
	Tcl_DecrRefCount(namePtr);
    }
}

static void
DupLocalVarName(
    Tcl_Obj *srcPtr,
    Tcl_Obj *dupPtr)
{
    size_t index;
    Tcl_Obj *namePtr;

    LocalGetInternalRep(srcPtr, index, namePtr);
    if (!namePtr) {
	namePtr = srcPtr;
    }
    LocalSetInternalRep(dupPtr, index, namePtr);







|















|







5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
 *   twoPtrValue.ptr2: index into locals table
 */

static void
FreeLocalVarName(
    Tcl_Obj *objPtr)
{
    Tcl_Size index;
    Tcl_Obj *namePtr;

    LocalGetInternalRep(objPtr, index, namePtr);

    index++;	/* Compiler warning bait. */
    if (namePtr) {
	Tcl_DecrRefCount(namePtr);
    }
}

static void
DupLocalVarName(
    Tcl_Obj *srcPtr,
    Tcl_Obj *dupPtr)
{
    Tcl_Size index;
    Tcl_Obj *namePtr;

    LocalGetInternalRep(srcPtr, index, namePtr);
    if (!namePtr) {
	namePtr = srcPtr;
    }
    LocalSetInternalRep(dupPtr, index, namePtr);
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *listPtr,		/* List object to append names to. */
    Tcl_Obj *patternPtr,	/* Pattern to match against. */
    int includeLinks)		/* 1 if upvars should be included, else 0. */
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr;
    size_t i, localVarCt;
    int added;
    Tcl_Obj *objNamePtr;
    const char *varName;
    TclVarHashTable *localVarTablePtr;
    Tcl_HashSearch search;
    Tcl_HashTable addedTable;
    const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;







|







6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *listPtr,		/* List object to append names to. */
    Tcl_Obj *patternPtr,	/* Pattern to match against. */
    int includeLinks)		/* 1 if upvars should be included, else 0. */
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr;
    Tcl_Size i, localVarCt;
    int added;
    Tcl_Obj *objNamePtr;
    const char *varName;
    TclVarHashTable *localVarTablePtr;
    Tcl_HashSearch search;
    Tcl_HashTable addedTable;
    const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;

Changes to generic/tclZipfs.c.

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
/*
 * Macros to report errors only if an interp is present.
 */

#define ZIPFS_ERROR(interp,errstr) \
    do {								\
	if (interp) {							\
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, TCL_INDEX_NONE));	\
	}								\
    } while (0)
#define ZIPFS_MEM_ERROR(interp) \
    do {								\
	if (interp) {							\
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(			\
		    "out of memory", TCL_INDEX_NONE));				\
	    Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);		\
	}								\
    } while (0)
#define ZIPFS_POSIX_ERROR(interp,errstr) \
    do {								\
	if (interp) {							\
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(			\







|






|







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
/*
 * Macros to report errors only if an interp is present.
 */

#define ZIPFS_ERROR(interp,errstr) \
    do {								\
	if (interp) {							\
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1));	\
	}								\
    } while (0)
#define ZIPFS_MEM_ERROR(interp) \
    do {								\
	if (interp) {							\
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(			\
		    "out of memory", -1));				\
	    Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);		\
	}								\
    } while (0)
#define ZIPFS_POSIX_ERROR(interp,errstr) \
    do {								\
	if (interp) {							\
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(			\
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
    } else {
	/*
	 * Not an OS file, but rather something in a Tcl VFS. Must copy into
	 * memory.
	 */

	zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
	if (zf->length == TCL_INDEX_NONE) {
	    ZIPFS_POSIX_ERROR(interp, "seek error");
	    goto error;
	}
	if ((zf->length - ZIP_CENTRAL_END_LEN)
		> (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
	    ZIPFS_ERROR(interp, "illegal file size");
	    ZIPFS_ERROR_CODE(interp, "FILE_SIZE");







|







1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
    } else {
	/*
	 * Not an OS file, but rather something in a Tcl VFS. Must copy into
	 * memory.
	 */

	zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
	if (zf->length == (size_t) TCL_INDEX_NONE) {
	    ZIPFS_POSIX_ERROR(interp, "seek error");
	    goto error;
	}
	if ((zf->length - ZIP_CENTRAL_END_LEN)
		> (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
	    ZIPFS_ERROR(interp, "illegal file size");
	    ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
    int fd = PTR2INT(handle);

    /*
     * Determine the file size.
     */

    zf->length = lseek(fd, 0, SEEK_END);
    if (zf->length == TCL_INDEX_NONE || zf->length < ZIP_CENTRAL_END_LEN) {
	ZIPFS_POSIX_ERROR(interp, "invalid file size");
	return TCL_ERROR;
    }
    lseek(fd, 0, SEEK_SET);

    zf->data = (unsigned char *)
	    mmap(0, zf->length, PROT_READ, MAP_FILE | MAP_PRIVATE, fd, 0);







|







1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
    int fd = PTR2INT(handle);

    /*
     * Determine the file size.
     */

    zf->length = lseek(fd, 0, SEEK_END);
    if (zf->length == (size_t) TCL_INDEX_NONE || zf->length < ZIP_CENTRAL_END_LEN) {
	ZIPFS_POSIX_ERROR(interp, "invalid file size");
	return TCL_ERROR;
    }
    lseek(fd, 0, SEEK_SET);

    zf->data = (unsigned char *)
	    mmap(0, zf->length, PROT_READ, MAP_FILE | MAP_PRIVATE, fd, 0);
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
	     * APK due to the leading dot in the file name component. This
	     * trick should make the files AndroidManifest.xml,
	     * resources.arsc, and classes.dex visible to Tcl.
	     */
	    Tcl_DString ds2;

	    Tcl_DStringInit(&ds2);
	    Tcl_DStringAppend(&ds2, "assets/.root/", TCL_INDEX_NONE);
	    Tcl_DStringAppend(&ds2, path, TCL_INDEX_NONE);
	    if (ZipFSLookup(Tcl_DStringValue(&ds2))) {
		/* should not happen but skip it anyway */
		Tcl_DStringFree(&ds2);
		goto nextent;
	    }
	    Tcl_DStringSetLength(&ds, 0);
	    Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2),







|
|







1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
	     * APK due to the leading dot in the file name component. This
	     * trick should make the files AndroidManifest.xml,
	     * resources.arsc, and classes.dex visible to Tcl.
	     */
	    Tcl_DString ds2;

	    Tcl_DStringInit(&ds2);
	    Tcl_DStringAppend(&ds2, "assets/.root/", -1);
	    Tcl_DStringAppend(&ds2, path, -1);
	    if (ZipFSLookup(Tcl_DStringValue(&ds2))) {
		/* should not happen but skip it anyway */
		Tcl_DStringFree(&ds2);
		goto nextent;
	    }
	    Tcl_DStringSetLength(&ds, 0);
	    Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2),
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795

	if (!z->isDirectory && (z->depth > 1)) {
	    char *dir, *endPtr;
	    ZipEntry *zd;

	    Tcl_DStringSetLength(&ds, strlen(z->name) + 8);
	    Tcl_DStringSetLength(&ds, 0);
	    Tcl_DStringAppend(&ds, z->name, TCL_INDEX_NONE);
	    dir = Tcl_DStringValue(&ds);
	    for (endPtr = strrchr(dir, '/'); endPtr && (endPtr != dir);
		    endPtr = strrchr(dir, '/')) {
		Tcl_DStringSetLength(&ds, endPtr - dir);
		hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
		if (!isNew) {
		    /*







|







1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795

	if (!z->isDirectory && (z->depth > 1)) {
	    char *dir, *endPtr;
	    ZipEntry *zd;

	    Tcl_DStringSetLength(&ds, strlen(z->name) + 8);
	    Tcl_DStringSetLength(&ds, 0);
	    Tcl_DStringAppend(&ds, z->name, -1);
	    dir = Tcl_DStringValue(&ds);
	    for (endPtr = strrchr(dir, '/'); endPtr && (endPtr != dir);
		    endPtr = strrchr(dir, '/')) {
		Tcl_DStringSetLength(&ds, endPtr - dir);
		hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
		if (!isNew) {
		    /*
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
    }

    resultList = Tcl_NewObj();
    for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
	    hPtr = Tcl_NextHashEntry(&search)) {
	zf = (ZipFile *) Tcl_GetHashValue(hPtr);
	Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
		zf->mountPoint, TCL_INDEX_NONE));
	Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
		zf->name, TCL_INDEX_NONE));
    }
    Tcl_SetObjResult(interp, resultList);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------------







|

|







1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
    }

    resultList = Tcl_NewObj();
    for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
	    hPtr = Tcl_NextHashEntry(&search)) {
	zf = (ZipFile *) Tcl_GetHashValue(hPtr);
	Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
		zf->mountPoint, -1));
	Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
		zf->name, -1));
    }
    Tcl_SetObjResult(interp, resultList);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------------
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
    Tcl_Interp *interp,
    const char *mountPoint)
{
    if (interp) {
	ZipFile *zf = ZipFSLookupZip(mountPoint);

	if (zf) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, TCL_INDEX_NONE));
	    return TCL_OK;
	}
    }
    return (interp ? TCL_OK : TCL_BREAK);
}

/*







|







1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
    Tcl_Interp *interp,
    const char *mountPoint)
{
    if (interp) {
	ZipFile *zf = ZipFSLookupZip(mountPoint);

	if (zf) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1));
	    return TCL_OK;
	}
    }
    return (interp ? TCL_OK : TCL_BREAK);
}

/*
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
    if (objc > 1) {
	mountPoint = TclGetString(objv[1]);
    }
    if (objc > 2) {
	zipFileObj = Tcl_FSGetNormalizedPath(interp, objv[2]);
	if (!zipFileObj) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "could not normalize zip filename", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", NULL);
	    return TCL_ERROR;
	}
	Tcl_IncrRefCount(zipFileObj);
	zipFile = TclGetString(zipFileObj);
    }
    if (objc > 3) {







|







2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
    if (objc > 1) {
	mountPoint = TclGetString(objv[1]);
    }
    if (objc > 2) {
	zipFileObj = Tcl_FSGetNormalizedPath(interp, objv[2]);
	if (!zipFileObj) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "could not normalize zip filename", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", NULL);
	    return TCL_ERROR;
	}
	Tcl_IncrRefCount(zipFileObj);
	zipFile = TclGetString(zipFileObj);
    }
    if (objc > 3) {
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
static int
ZipFSRootObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
    Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, TCL_INDEX_NONE));
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSUnmountObjCmd --







|







2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
static int
ZipFSRootObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
    Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSUnmountObjCmd --
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
     * Compute the CRC.
     */

    crc = 0;
    nbyte = nbytecompr = 0;
    while (1) {
	len = Tcl_Read(in, buf, bufsize);
	if (len == TCL_INDEX_NONE) {
	    Tcl_DStringFree(&zpathDs);
	    if (nbyte == 0 && errno == EISDIR) {
		Tcl_Close(interp, in);
		return TCL_OK;
	    }
	readErrorWithChannelOpen:
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",







|







2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
     * Compute the CRC.
     */

    crc = 0;
    nbyte = nbytecompr = 0;
    while (1) {
	len = Tcl_Read(in, buf, bufsize);
	if (len == (size_t) TCL_INDEX_NONE) {
	    Tcl_DStringFree(&zpathDs);
	    if (nbyte == 0 && errno == EISDIR) {
		Tcl_Close(interp, in);
		return TCL_OK;
	    }
	readErrorWithChannelOpen:
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
	Tcl_Close(interp, in);
	Tcl_DStringFree(&zpathDs);
	return TCL_ERROR;
    }

    do {
	len = Tcl_Read(in, buf, bufsize);
	if (len == TCL_INDEX_NONE) {
	    deflateEnd(&stream);
	    goto readErrorWithChannelOpen;
	}
	stream.avail_in = len;
	stream.next_in = (unsigned char *) buf;
	flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH;
	do {







|







2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
	Tcl_Close(interp, in);
	Tcl_DStringFree(&zpathDs);
	return TCL_ERROR;
    }

    do {
	len = Tcl_Read(in, buf, bufsize);
	if (len == (size_t) TCL_INDEX_NONE) {
	    deflateEnd(&stream);
	    goto readErrorWithChannelOpen;
	}
	stream.avail_in = len;
	stream.next_in = (unsigned char *) buf;
	flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH;
	do {
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
	    Tcl_Close(interp, in);
	    Tcl_DStringFree(&zpathDs);
	    return TCL_ERROR;
	}
	nbytecompr = (passwd ? 12 : 0);
	while (1) {
	    len = Tcl_Read(in, buf, bufsize);
	    if (len == TCL_INDEX_NONE) {
		goto readErrorWithChannelOpen;
	    } else if (len == 0) {
		break;
	    }
	    if (passwd) {
		size_t i;
		int tmp;







|







2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
	    Tcl_Close(interp, in);
	    Tcl_DStringFree(&zpathDs);
	    return TCL_ERROR;
	}
	nbytecompr = (passwd ? 12 : 0);
	while (1) {
	    len = Tcl_Read(in, buf, bufsize);
	    if (len == (size_t) TCL_INDEX_NONE) {
		goto readErrorWithChannelOpen;
	    } else if (len == 0) {
		break;
	    }
	    if (passwd) {
		size_t i;
		int tmp;
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
ZipFSFind(
    Tcl_Interp *interp,
    Tcl_Obj *dirRoot)
{
    Tcl_Obj *cmd[2];
    int result;

    cmd[0] = Tcl_NewStringObj("::tcl::zipfs::find", TCL_INDEX_NONE);
    cmd[1] = dirRoot;
    Tcl_IncrRefCount(cmd[0]);
    result = Tcl_EvalObjv(interp, 2, cmd, 0);
    Tcl_DecrRefCount(cmd[0]);
    if (result != TCL_OK) {
	return NULL;
    }







|







2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
ZipFSFind(
    Tcl_Interp *interp,
    Tcl_Obj *dirRoot)
{
    Tcl_Obj *cmd[2];
    int result;

    cmd[0] = Tcl_NewStringObj("::tcl::zipfs::find", -1);
    cmd[1] = dirRoot;
    Tcl_IncrRefCount(cmd[0]);
    result = Tcl_EvalObjv(interp, 2, cmd, 0);
    Tcl_DecrRefCount(cmd[0]);
    if (result != TCL_OK) {
	return NULL;
    }
2987
2988
2989
2990
2991
2992
2993
2994

2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
				 * do not strip anything (except for dirRoot
				 * itself). */
    Tcl_Obj *passwordObj)	/* The password for encoding things. NULL if
				 * there's no password protection. */
{
    Tcl_Channel out;
    int count, ret = TCL_ERROR;
    size_t pwlen = 0, slen = 0, lobjc, len, i = 0;

    long long directoryStartOffset;
				/* The overall file offset of the start of the
				 * central directory. */
    long long suffixStartOffset;/* The overall file offset of the start of the
				 * suffix of the central directory (i.e.,
				 * where this data will be written). */
    Tcl_Obj **lobjv, *list = mappingList;
    ZipEntry *z;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;







|
>

|
|







2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
				 * do not strip anything (except for dirRoot
				 * itself). */
    Tcl_Obj *passwordObj)	/* The password for encoding things. NULL if
				 * there's no password protection. */
{
    Tcl_Channel out;
    int count, ret = TCL_ERROR;
    size_t pwlen = 0, slen = 0, len, i = 0;
    Tcl_Size lobjc;
    long long directoryStartOffset;
    /* The overall file offset of the start of the
     * central directory. */
    long long suffixStartOffset;/* The overall file offset of the start of the
				 * suffix of the central directory (i.e.,
				 * where this data will be written). */
    Tcl_Obj **lobjv, *list = mappingList;
    ZipEntry *z;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
    }

    /*
     * Get the length of the file (and exclude non-files).
     */

    i = Tcl_Seek(in, 0, SEEK_END);
    if (i == TCL_INDEX_NONE) {
	errMsg = "seek error";
	goto copyError;
    }
    Tcl_Seek(in, 0, SEEK_SET);

    /*
     * Copy the whole file, 8 blocks at a time (reasonably efficient). Note







|







3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
    }

    /*
     * Get the length of the file (and exclude non-files).
     */

    i = Tcl_Seek(in, 0, SEEK_END);
    if (i == (size_t) TCL_INDEX_NONE) {
	errMsg = "seek error";
	goto copyError;
    }
    Tcl_Seek(in, 0, SEEK_SET);

    /*
     * Copy the whole file, 8 blocks at a time (reasonably efficient). Note
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
	if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) {
	    return TCL_ERROR;
	}
	mntpoint = TclGetString(objv[1]);
	filename = TclGetString(objv[2]);
	result = CanonicalPath(mntpoint, filename, &dPath, zipfs);
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, TCL_INDEX_NONE));
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSExistsObjCmd --







|







3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
	if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) {
	    return TCL_ERROR;
	}
	mntpoint = TclGetString(objv[1]);
	filename = TclGetString(objv[2]);
	result = CanonicalPath(mntpoint, filename, &dPath, zipfs);
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSExistsObjCmd --
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
    /*
     * Prepend ZIPFS_VOLUME to filename, eliding the final /
     */

    filename = TclGetString(objv[1]);
    Tcl_DStringInit(&ds);
    Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1);
    Tcl_DStringAppend(&ds, filename, TCL_INDEX_NONE);
    filename = Tcl_DStringValue(&ds);

    ReadLock();
    exists = ZipFSLookup(filename) != NULL;
    Unlock();

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));







|







3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
    /*
     * Prepend ZIPFS_VOLUME to filename, eliding the final /
     */

    filename = TclGetString(objv[1]);
    Tcl_DStringInit(&ds);
    Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1);
    Tcl_DStringAppend(&ds, filename, -1);
    filename = Tcl_DStringValue(&ds);

    ReadLock();
    exists = ZipFSLookup(filename) != NULL;
    Unlock();

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
    filename = TclGetString(objv[1]);
    ReadLock();
    z = ZipFSLookup(filename);
    if (z) {
	Tcl_Obj *result = Tcl_GetObjResult(interp);

	Tcl_ListObjAppendElement(interp, result,
		Tcl_NewStringObj(z->zipFilePtr->name, TCL_INDEX_NONE));
	Tcl_ListObjAppendElement(interp, result,
		Tcl_NewWideIntObj(z->numBytes));
	Tcl_ListObjAppendElement(interp, result,
		Tcl_NewWideIntObj(z->numCompressedBytes));
	Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
    }
    Unlock();







|







3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
    filename = TclGetString(objv[1]);
    ReadLock();
    z = ZipFSLookup(filename);
    if (z) {
	Tcl_Obj *result = Tcl_GetObjResult(interp);

	Tcl_ListObjAppendElement(interp, result,
		Tcl_NewStringObj(z->zipFilePtr->name, -1));
	Tcl_ListObjAppendElement(interp, result,
		Tcl_NewWideIntObj(z->numBytes));
	Tcl_ListObjAppendElement(interp, result,
		Tcl_NewWideIntObj(z->numCompressedBytes));
	Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
    }
    Unlock();
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
    if (pattern) {
	for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	    if (Tcl_StringMatch(z->name, pattern)) {
		Tcl_ListObjAppendElement(interp, result,
			Tcl_NewStringObj(z->name, TCL_INDEX_NONE));
	    }
	}
    } else if (regexp) {
	for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
		hPtr; hPtr = Tcl_NextHashEntry(&search)) {
	    ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	    if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
		Tcl_ListObjAppendElement(interp, result,
			Tcl_NewStringObj(z->name, TCL_INDEX_NONE));
	    }
	}
    } else {
	for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
		hPtr; hPtr = Tcl_NextHashEntry(&search)) {
	    ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	    Tcl_ListObjAppendElement(interp, result,
		    Tcl_NewStringObj(z->name, TCL_INDEX_NONE));
	}
    }
    Unlock();
    return TCL_OK;
}

/*







|









|








|







3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
    if (pattern) {
	for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	    if (Tcl_StringMatch(z->name, pattern)) {
		Tcl_ListObjAppendElement(interp, result,
			Tcl_NewStringObj(z->name, -1));
	    }
	}
    } else if (regexp) {
	for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
		hPtr; hPtr = Tcl_NextHashEntry(&search)) {
	    ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	    if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
		Tcl_ListObjAppendElement(interp, result,
			Tcl_NewStringObj(z->name, -1));
	    }
	}
    } else {
	for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
		hPtr; hPtr = Tcl_NextHashEntry(&search)) {
	    ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	    Tcl_ListObjAppendElement(interp, result,
		    Tcl_NewStringObj(z->name, -1));
	}
    }
    Unlock();
    return TCL_OK;
}

/*
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937

    /*
     * Use the cached value if that has been set; we don't want to repeat the
     * searching and mounting.
     */

    if (zipfs_literal_tcl_library) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, TCL_INDEX_NONE);
    }

    /*
     * Look for the library file system within the executable.
     */

    vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",
	    -1);
    Tcl_IncrRefCount(vfsInitScript);
    found = Tcl_FSAccess(vfsInitScript, F_OK);
    Tcl_DecrRefCount(vfsInitScript);
    if (found == TCL_OK) {
	zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
	return Tcl_NewStringObj(zipfs_literal_tcl_library, TCL_INDEX_NONE);
    }

    /*
     * Look for the library file system within the DLL/shared library.  Note
     * that we must mount the zip file and dll before releasing to search.
     */

#if !defined(STATIC_BUILD)
#if defined(_WIN32) || defined(__CYGWIN__)
    hModule = (HMODULE)TclWinGetTclInstance();
    GetModuleFileNameW(hModule, wName, MAX_PATH);
#ifdef __CYGWIN__
    cygwin_conv_path(3, wName, dllName, sizeof(dllName));
#else
    WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL);
#endif

    if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, TCL_INDEX_NONE);
    }
#elif !defined(NO_DLFCN_H)
    Dl_info dlinfo;
    if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
	&& (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, TCL_INDEX_NONE);
    }
#else
    if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, TCL_INDEX_NONE);
    }
#endif /* _WIN32 */
#endif /* !defined(STATIC_BUILD) */

    /*
     * If anything set the cache (but subsequently failed) go with that
     * anyway.
     */

    if (zipfs_literal_tcl_library) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, TCL_INDEX_NONE);
    }
    return NULL;
}

/*
 *-------------------------------------------------------------------------
 *







|













|


















|





|



|










|







3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938

    /*
     * Use the cached value if that has been set; we don't want to repeat the
     * searching and mounting.
     */

    if (zipfs_literal_tcl_library) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    }

    /*
     * Look for the library file system within the executable.
     */

    vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",
	    -1);
    Tcl_IncrRefCount(vfsInitScript);
    found = Tcl_FSAccess(vfsInitScript, F_OK);
    Tcl_DecrRefCount(vfsInitScript);
    if (found == TCL_OK) {
	zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    }

    /*
     * Look for the library file system within the DLL/shared library.  Note
     * that we must mount the zip file and dll before releasing to search.
     */

#if !defined(STATIC_BUILD)
#if defined(_WIN32) || defined(__CYGWIN__)
    hModule = (HMODULE)TclWinGetTclInstance();
    GetModuleFileNameW(hModule, wName, MAX_PATH);
#ifdef __CYGWIN__
    cygwin_conv_path(3, wName, dllName, sizeof(dllName));
#else
    WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL);
#endif

    if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    }
#elif !defined(NO_DLFCN_H)
    Dl_info dlinfo;
    if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
	&& (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    }
#else
    if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    }
#endif /* _WIN32 */
#endif /* !defined(STATIC_BUILD) */

    /*
     * If anything set the cache (but subsequently failed) go with that
     * anyway.
     */

    if (zipfs_literal_tcl_library) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    }
    return NULL;
}

/*
 *-------------------------------------------------------------------------
 *
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
 *-------------------------------------------------------------------------
 */

static Tcl_Obj *
ZipFSFilesystemSeparatorProc(
    TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
    return Tcl_NewStringObj("/", TCL_INDEX_NONE);
}

/*
 *-------------------------------------------------------------------------
 *
 * AppendWithPrefix --
 *







|







4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
 *-------------------------------------------------------------------------
 */

static Tcl_Obj *
ZipFSFilesystemSeparatorProc(
    TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
    return Tcl_NewStringObj("/", -1);
}

/*
 *-------------------------------------------------------------------------
 *
 * AppendWithPrefix --
 *
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
     */

    if (!pattern || (pattern[0] == '\0')) {
	ZipEntry *z = ZipFSLookup(path);

	if (z && ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
		|| (dirOnly && z->isDirectory))) {
	    AppendWithPrefix(result, prefixBuf, z->name, TCL_INDEX_NONE);
	}
	goto end;
    }

    /*
     * We've got to work for our supper and do the actual globbing. And all
     * we've got really is an undifferentiated pile of all the filenames we've







|







5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
     */

    if (!pattern || (pattern[0] == '\0')) {
	ZipEntry *z = ZipFSLookup(path);

	if (z && ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
		|| (dirOnly && z->isDirectory))) {
	    AppendWithPrefix(result, prefixBuf, z->name, -1);
	}
	goto end;
    }

    /*
     * We've got to work for our supper and do the actual globbing. And all
     * we've got really is an undifferentiated pile of all the filenames we've
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
	ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory)
		|| (!dirOnly && z->isDirectory))) {
	    continue;
	}
	if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
	    AppendWithPrefix(result, prefixBuf, z->name + strip, TCL_INDEX_NONE);
	}
    }
    Tcl_Free(pat);

  end:
    Unlock();
    Tcl_DStringFree(&dsPref);







|







5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
	ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);

	if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory)
		|| (!dirOnly && z->isDirectory))) {
	    continue;
	}
	if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
	    AppendWithPrefix(result, prefixBuf, z->name + strip, -1);
	}
    }
    Tcl_Free(pat);

  end:
    Unlock();
    Tcl_DStringFree(&dsPref);
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Obj *
ZipFSListVolumesProc(void)
{
    return Tcl_NewStringObj(ZIPFS_VOLUME, TCL_INDEX_NONE);
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSFileAttrStringsProc --
 *







|







5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Obj *
ZipFSListVolumesProc(void)
{
    return Tcl_NewStringObj(ZIPFS_VOLUME, -1);
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSFileAttrStringsProc --
 *
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
	TclNewIntObj(*objPtrRef, z->offset);
	break;
    case ZIP_ATTR_MOUNT:
	*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
		z->zipFilePtr->mountPointLen);
	break;
    case ZIP_ATTR_ARCHIVE:
	*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, TCL_INDEX_NONE);
	break;
    case ZIP_ATTR_PERMISSIONS:
	*objPtrRef = Tcl_NewStringObj("0o555", TCL_INDEX_NONE);
	break;
    case ZIP_ATTR_CRC:
	TclNewIntObj(*objPtrRef, z->crc32);
	break;
    default:
	ZIPFS_ERROR(interp, "unknown attribute");
	ZIPFS_ERROR_CODE(interp, "FILE_ATTR");







|


|







5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
	TclNewIntObj(*objPtrRef, z->offset);
	break;
    case ZIP_ATTR_MOUNT:
	*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
		z->zipFilePtr->mountPointLen);
	break;
    case ZIP_ATTR_ARCHIVE:
	*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1);
	break;
    case ZIP_ATTR_PERMISSIONS:
	*objPtrRef = Tcl_NewStringObj("0o555", -1);
	break;
    case ZIP_ATTR_CRC:
	TclNewIntObj(*objPtrRef, z->crc32);
	break;
    default:
	ZIPFS_ERROR(interp, "unknown attribute");
	ZIPFS_ERROR_CODE(interp, "FILE_ATTR");
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
 *-------------------------------------------------------------------------
 */

static Tcl_Obj *
ZipFSFilesystemPathTypeProc(
    TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
    return Tcl_NewStringObj("zip", TCL_INDEX_NONE);
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSLoadFile --
 *







|







5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
 *-------------------------------------------------------------------------
 */

static Tcl_Obj *
ZipFSFilesystemPathTypeProc(
    TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
    return Tcl_NewStringObj("zip", -1);
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSLoadFile --
 *
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
		Tcl_IsSafe(interp) ? (initMap + 4) : initMap);

	/*
	 * Add the [zipfs find] subcommand.
	 */

	Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
	Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", TCL_INDEX_NONE),
		Tcl_NewStringObj("::tcl::zipfs::find", TCL_INDEX_NONE));
	Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
		ZipFSTclLibraryObjCmd, NULL, NULL);
	Tcl_PkgProvide(interp, "tcl::zipfs", "2.0");
    }
    return TCL_OK;
#else /* !HAVE_ZLIB */
    ZIPFS_ERROR(interp, "no zlib available");







|
|







5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
		Tcl_IsSafe(interp) ? (initMap + 4) : initMap);

	/*
	 * Add the [zipfs find] subcommand.
	 */

	Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
	Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
		Tcl_NewStringObj("::tcl::zipfs::find", -1));
	Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
		ZipFSTclLibraryObjCmd, NULL, NULL);
	Tcl_PkgProvide(interp, "tcl::zipfs", "2.0");
    }
    return TCL_OK;
#else /* !HAVE_ZLIB */
    ZIPFS_ERROR(interp, "no zlib available");

Changes to generic/tclZlib.c.

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
typedef struct {
    Tcl_Interp *interp;
    z_stream stream;		/* The interface to the zlib library. */
    int streamEnd;		/* If we've got to end-of-stream. */
    Tcl_Obj *inData, *outData;	/* Input / output buffers (lists) */
    Tcl_Obj *currentInput;	/* Pointer to what is currently being
				 * inflated. */
    size_t outPos;
    int mode;			/* Either TCL_ZLIB_STREAM_DEFLATE or
				 * TCL_ZLIB_STREAM_INFLATE. */
    int format;			/* Flags from the TCL_ZLIB_FORMAT_* */
    int level;			/* Default 5, 0-9 */
    int flush;			/* Stores the flush param for deferred the
				 * decompression. */
    int wbits;			/* The encoded compression mode, so we can







|







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
typedef struct {
    Tcl_Interp *interp;
    z_stream stream;		/* The interface to the zlib library. */
    int streamEnd;		/* If we've got to end-of-stream. */
    Tcl_Obj *inData, *outData;	/* Input / output buffers (lists) */
    Tcl_Obj *currentInput;	/* Pointer to what is currently being
				 * inflated. */
    Tcl_Size outPos;
    int mode;			/* Either TCL_ZLIB_STREAM_DEFLATE or
				 * TCL_ZLIB_STREAM_INFLATE. */
    int format;			/* Flags from the TCL_ZLIB_FORMAT_* */
    int level;			/* Default 5, 0-9 */
    int flush;			/* Stores the flush param for deferred the
				 * decompression. */
    int wbits;			/* The encoded compression mode, so we can
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

    default:
	codeStr = "UNKNOWN";
	codeStr2 = codeStrBuf;
	snprintf(codeStrBuf, sizeof(codeStrBuf), "%d", code);
	break;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), TCL_INDEX_NONE));

    /*
     * Tricky point! We might pass NULL twice here (and will when the error
     * type is known).
     */

    Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL);







|







309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

    default:
	codeStr = "UNKNOWN";
	codeStr2 = codeStrBuf;
	snprintf(codeStrBuf, sizeof(codeStrBuf), "%d", code);
	break;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1));

    /*
     * Tricky point! We might pass NULL twice here (and will when the error
     * type is known).
     */

    Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL);
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
	TclNewLiteralStringObj(objv[2], "BUF");
	return Tcl_NewListObj(3, objv);
    case Z_VERSION_ERROR:
	TclNewLiteralStringObj(objv[2], "VERSION");
	return Tcl_NewListObj(3, objv);
    case Z_ERRNO:
	TclNewLiteralStringObj(objv[2], "POSIX");
	objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), TCL_INDEX_NONE);
	return Tcl_NewListObj(4, objv);
    case Z_NEED_DICT:
	TclNewLiteralStringObj(objv[2], "NEED_DICT");
	TclNewIntObj(objv[3], (Tcl_WideInt)adler);
	return Tcl_NewListObj(4, objv);

	/*







|







346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
	TclNewLiteralStringObj(objv[2], "BUF");
	return Tcl_NewListObj(3, objv);
    case Z_VERSION_ERROR:
	TclNewLiteralStringObj(objv[2], "VERSION");
	return Tcl_NewListObj(3, objv);
    case Z_ERRNO:
	TclNewLiteralStringObj(objv[2], "POSIX");
	objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
	return Tcl_NewListObj(4, objv);
    case Z_NEED_DICT:
	TclNewLiteralStringObj(objv[2], "NEED_DICT");
	TclNewIntObj(objv[3], (Tcl_WideInt)adler);
	return Tcl_NewListObj(4, objv);

	/*
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
static inline int
GetValue(
    Tcl_Interp *interp,
    Tcl_Obj *dictObj,
    const char *nameStr,
    Tcl_Obj **valuePtrPtr)
{
    Tcl_Obj *name = Tcl_NewStringObj(nameStr, TCL_INDEX_NONE);
    int result = Tcl_DictObjGet(interp, dictObj, name, valuePtrPtr);

    TclDecrRefCount(name);
    return result;
}

static int







|







401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
static inline int
GetValue(
    Tcl_Interp *interp,
    Tcl_Obj *dictObj,
    const char *nameStr,
    Tcl_Obj **valuePtrPtr)
{
    Tcl_Obj *name = Tcl_NewStringObj(nameStr, -1);
    int result = Tcl_DictObjGet(interp, dictObj, name, valuePtrPtr);

    TclDecrRefCount(name);
    return result;
}

static int
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
 * Side effects:
 *	Updates the dictionary, which must be writable (i.e. refCount < 2).
 *
 *----------------------------------------------------------------------
 */

#define SetValue(dictObj, key, value) \
	Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), TCL_INDEX_NONE), (value))

static void
ExtractHeader(
    gz_header *headerPtr,	/* The gzip header to extract from. */
    Tcl_Obj *dictObj)		/* The dictionary to store in. */
{
    Tcl_Encoding latin1enc = NULL;







|







551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
 * Side effects:
 *	Updates the dictionary, which must be writable (i.e. refCount < 2).
 *
 *----------------------------------------------------------------------
 */

#define SetValue(dictObj, key, value) \
	Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value))

static void
ExtractHeader(
    gz_header *headerPtr,	/* The gzip header to extract from. */
    Tcl_Obj *dictObj)		/* The dictionary to store in. */
{
    Tcl_Encoding latin1enc = NULL;
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
	SetValue(dictObj, "os", Tcl_NewWideIntObj(headerPtr->os));
    }
    if (headerPtr->time != 0 /* magic - no time */) {
	SetValue(dictObj, "time", Tcl_NewWideIntObj(headerPtr->time));
    }
    if (headerPtr->text != Z_UNKNOWN) {
	SetValue(dictObj, "type",
		Tcl_NewStringObj(headerPtr->text ? "text" : "binary", TCL_INDEX_NONE));
    }

    if (latin1enc != NULL) {
	Tcl_FreeEncoding(latin1enc);
    }
}








|







602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
	SetValue(dictObj, "os", Tcl_NewWideIntObj(headerPtr->os));
    }
    if (headerPtr->time != 0 /* magic - no time */) {
	SetValue(dictObj, "time", Tcl_NewWideIntObj(headerPtr->time));
    }
    if (headerPtr->text != Z_UNKNOWN) {
	SetValue(dictObj, "type",
		Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1));
    }

    if (latin1enc != NULL) {
	Tcl_FreeEncoding(latin1enc);
    }
}

845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
	}
	Tcl_DStringInit(&cmdname);
	TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_");
	TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
	if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname),
		NULL, 0) != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "BUG: Stream command name already exists", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
	    Tcl_DStringFree(&cmdname);
	    goto error;
	}
	Tcl_ResetResult(interp);

	/*







|







845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
	}
	Tcl_DStringInit(&cmdname);
	TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_");
	TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
	if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname),
		NULL, 0) != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "BUG: Stream command name already exists", -1));
	    Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
	    Tcl_DStringFree(&cmdname);
	    goto error;
	}
	Tcl_ResetResult(interp);

	/*
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
    int e;
    size_t size = 0, outSize, toStore;
    unsigned char *bytes;

    if (zshPtr->streamEnd) {
	if (zshPtr->interp) {
	    Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
		    "already past compressed stream end", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
	}
	return TCL_ERROR;
    }

    bytes = Tcl_GetBytesFromObj(zshPtr->interp, data, &size);
    if (bytes == NULL) {







|







1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
    int e;
    size_t size = 0, outSize, toStore;
    unsigned char *bytes;

    if (zshPtr->streamEnd) {
	if (zshPtr->interp) {
	    Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
		    "already past compressed stream end", -1));
	    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
	}
	return TCL_ERROR;
    }

    bytes = Tcl_GetBytesFromObj(zshPtr->interp, data, &size);
    if (bytes == NULL) {
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
 *----------------------------------------------------------------------
 */

int
Tcl_ZlibStreamGet(
    Tcl_ZlibStream zshandle,	/* As obtained from Tcl_ZlibStreamInit */
    Tcl_Obj *data,		/* A place to append the data. */
    size_t count)			/* Number of bytes to grab as a maximum, you
				 * may get less! */
{
    ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
    int e;
    size_t listLen, i, itemLen = 0, dataPos = 0;
    Tcl_Obj *itemObj;
    unsigned char *dataPtr, *itemPtr;
    size_t existing = 0;

    /*
     * Getting beyond the of stream, just return empty string.
     */

    if (zshPtr->streamEnd) {
	return TCL_OK;
    }

    if (NULL == Tcl_GetBytesFromObj(zshPtr->interp, data, &existing)) {
	return TCL_ERROR;
    }

    if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
	if (count == TCL_INDEX_NONE) {
	    /*
	     * The only safe thing to do is restict to 65k. We might cause a
	     * panic for out of memory if we just kept growing the buffer.
	     */

	    count = MAX_BUFFER_SIZE;
	}







|




|


|














|







1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
 *----------------------------------------------------------------------
 */

int
Tcl_ZlibStreamGet(
    Tcl_ZlibStream zshandle,	/* As obtained from Tcl_ZlibStreamInit */
    Tcl_Obj *data,		/* A place to append the data. */
    Tcl_Size count)			/* Number of bytes to grab as a maximum, you
				 * may get less! */
{
    ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
    int e;
    Tcl_Size listLen, i, itemLen = 0, dataPos = 0;
    Tcl_Obj *itemObj;
    unsigned char *dataPtr, *itemPtr;
    Tcl_Size existing = 0;

    /*
     * Getting beyond the of stream, just return empty string.
     */

    if (zshPtr->streamEnd) {
	return TCL_OK;
    }

    if (NULL == Tcl_GetBytesFromObj(zshPtr->interp, data, &existing)) {
	return TCL_ERROR;
    }

    if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
	if (count < 0) {
	    /*
	     * The only safe thing to do is restict to 65k. We might cause a
	     * panic for out of memory if we just kept growing the buffer.
	     */

	    count = MAX_BUFFER_SIZE;
	}
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
	     * more to inflate.
	     */

	    if (zshPtr->stream.avail_in > 0) {
		if (zshPtr->interp) {
		    Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
			    "unexpected zlib internal state during"
			    " decompression", TCL_INDEX_NONE));
		    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
			    NULL);
		}
		Tcl_SetByteArrayLength(data, existing);
		return TCL_ERROR;
	    }








|







1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
	     * more to inflate.
	     */

	    if (zshPtr->stream.avail_in > 0) {
		if (zshPtr->interp) {
		    Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
			    "unexpected zlib internal state during"
			    " decompression", -1));
		    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
			    NULL);
		}
		Tcl_SetByteArrayLength(data, existing);
		return TCL_ERROR;
	    }

1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
		Tcl_DecrRefCount(zshPtr->currentInput);
		zshPtr->currentInput = 0;
	    }
	    inflateEnd(&zshPtr->stream);
	}
    } else {
	TclListObjLengthM(NULL, zshPtr->outData, &listLen);
	if (count == TCL_INDEX_NONE) {
	    count = 0;
	    for (i=0; i<listLen; i++) {
		Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
		(void) Tcl_GetByteArrayFromObj(itemObj, &itemLen);
		if (i == 0) {
		    count += itemLen - zshPtr->outPos;
		} else {







|







1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
		Tcl_DecrRefCount(zshPtr->currentInput);
		zshPtr->currentInput = 0;
	    }
	    inflateEnd(&zshPtr->stream);
	}
    } else {
	TclListObjLengthM(NULL, zshPtr->outData, &listLen);
	if (count < 0) {
	    count = 0;
	    for (i=0; i<listLen; i++) {
		Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
		(void) Tcl_GetByteArrayFromObj(itemObj, &itemLen);
		if (i == 0) {
		    count += itemLen - zshPtr->outPos;
		} else {
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
	    /*
	     * Get the next chunk off our list of chunks and grab the data out
	     * of it.
	     */

	    Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
	    itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
	    if (itemLen-zshPtr->outPos + dataPos >= count) {
		size_t len = count - dataPos;

		memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
		zshPtr->outPos += len;
		dataPos += len;
		if (zshPtr->outPos == itemLen) {
		    zshPtr->outPos = 0;
		}
	    } else {
		size_t len = itemLen - zshPtr->outPos;

		memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
		dataPos += len;
		zshPtr->outPos = 0;
	    }
	    if (zshPtr->outPos == 0) {
		Tcl_ListObjReplace(NULL, zshPtr->outData, 0, 1, 0, NULL);







|
|








|







1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
	    /*
	     * Get the next chunk off our list of chunks and grab the data out
	     * of it.
	     */

	    Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
	    itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
	    if ((itemLen-zshPtr->outPos) >= count-dataPos) {
		Tcl_Size len = count - dataPos;

		memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
		zshPtr->outPos += len;
		dataPos += len;
		if (zshPtr->outPos == itemLen) {
		    zshPtr->outPos = 0;
		}
	    } else {
		Tcl_Size len = itemLen - zshPtr->outPos;

		memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
		dataPos += len;
		zshPtr->outPos = 0;
	    }
	    if (zshPtr->outPos == 0) {
		Tcl_ListObjReplace(NULL, zshPtr->outData, 0, 1, 0, NULL);
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
 */

int
Tcl_ZlibInflate(
    Tcl_Interp *interp,
    int format,
    Tcl_Obj *data,
    size_t bufferSize,
    Tcl_Obj *gzipHeaderDictObj)
{
    int wbits = 0, e = 0;
    size_t inLen = 0, newBufferSize;
    Byte *inData = NULL, *outData = NULL, *newOutData = NULL;
    z_stream stream;
    gz_header header, *headerPtr = NULL;
    Tcl_Obj *obj;
    char *nameBuf = NULL, *commentBuf = NULL;

    if (!interp) {







|



|







1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
 */

int
Tcl_ZlibInflate(
    Tcl_Interp *interp,
    int format,
    Tcl_Obj *data,
    Tcl_Size bufferSize,
    Tcl_Obj *gzipHeaderDictObj)
{
    int wbits = 0, e = 0;
    Tcl_Size inLen = 0, newBufferSize;
    Byte *inData = NULL, *outData = NULL, *newOutData = NULL;
    z_stream stream;
    gz_header header, *headerPtr = NULL;
    Tcl_Obj *obj;
    char *nameBuf = NULL, *commentBuf = NULL;

    if (!interp) {
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
 *----------------------------------------------------------------------
 */

unsigned int
Tcl_ZlibCRC32(
    unsigned int crc,
    const unsigned char *buf,
    size_t len)
{
    /* Nothing much to do, just wrap the crc32(). */
    return crc32(crc, (Bytef *) buf, len);
}

unsigned int
Tcl_ZlibAdler32(
    unsigned int adler,
    const unsigned char *buf,
    size_t len)
{
    return adler32(adler, (Bytef *) buf, len);
}

/*
 *----------------------------------------------------------------------
 *







|









|







1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
 *----------------------------------------------------------------------
 */

unsigned int
Tcl_ZlibCRC32(
    unsigned int crc,
    const unsigned char *buf,
    Tcl_Size len)
{
    /* Nothing much to do, just wrap the crc32(). */
    return crc32(crc, (Bytef *) buf, len);
}

unsigned int
Tcl_ZlibAdler32(
    unsigned int adler,
    const unsigned char *buf,
    Tcl_Size len)
{
    return adler32(adler, (Bytef *) buf, len);
}

/*
 *----------------------------------------------------------------------
 *
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
					 *	-> channel */
	return ZlibPushSubcmd(interp, objc, objv);
    };

    return TCL_ERROR;

  badLevel:
    Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", TCL_INDEX_NONE));
    Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
    if (extraInfoStr) {
	Tcl_AddErrorInfo(interp, extraInfoStr);
    }
    return TCL_ERROR;
  badBuffer:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(







|







2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
					 *	-> channel */
	return ZlibPushSubcmd(interp, objc, objv);
    };

    return TCL_ERROR;

  badLevel:
    Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1));
    Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
    if (extraInfoStr) {
	Tcl_AddErrorInfo(interp, extraInfoStr);
    }
    return TCL_ERROR;
  badBuffer:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
    static const char *const pushDecompressOptions[] = {
	"-dictionary", "-header", "-level", "-limit", NULL
    };
    const char *const *pushOptions = pushDecompressOptions;
    enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option;
    Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
    int limit = DEFAULT_BUFFER_SIZE;
    size_t dummy;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,







|







2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
    static const char *const pushDecompressOptions[] = {
	"-dictionary", "-header", "-level", "-limit", NULL
    };
    const char *const *pushOptions = pushDecompressOptions;
    enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option;
    Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
    int limit = DEFAULT_BUFFER_SIZE;
    Tcl_Size dummy;

    if (objc < 4) {
	Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509

    /*
     * Sanity checks.
     */

    if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"compression may only be applied to writable channels", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL);
	return TCL_ERROR;
    }
    if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"decompression may only be applied to readable channels",TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL);







|







2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509

    /*
     * Sanity checks.
     */

    if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"compression may only be applied to writable channels", -1));
	Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL);
	return TCL_ERROR;
    }
    if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"decompression may only be applied to readable channels",TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL);
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
	    break;
	case poLevel:
	    if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) {
		goto genericOptionError;
	    }
	    if (level < 0 || level > 9) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"level must be 0 to 9", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL",
			NULL);
		goto genericOptionError;
	    }
	    break;
	case poLimit:
	    if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) {







|







2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
	    break;
	case poLevel:
	    if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) {
		goto genericOptionError;
	    }
	    if (level < 0 || level > 9) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"level must be 0 to 9", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL",
			NULL);
		goto genericOptionError;
	    }
	    break;
	case poLimit:
	    if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) {
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
		goto genericOptionError;
	    }
	    break;
	case poDictionary:
	    if (format == TCL_ZLIB_FORMAT_GZIP) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"a compression dictionary may not be set in the "
			"gzip format", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
		goto genericOptionError;
	    }
	    compDictObj = objv[i];
	    break;
	}
    }







|







2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
		goto genericOptionError;
	    }
	    break;
	case poDictionary:
	    if (format == TCL_ZLIB_FORMAT_GZIP) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"a compression dictionary may not be set in the "
			"gzip format", -1));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
		goto genericOptionError;
	    }
	    compDictObj = objv[i];
	    break;
	}
    }
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
		flush = Z_FINISH;
	    }
	    break;
	case ao_buffer: /* -buffer */
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-buffer\" option must be followed by integer "
			"decompression buffersize", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"buffer size must be 1 to %d",
			MAX_BUFFER_SIZE));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
		return TCL_ERROR;
	    }
	    break;
	case ao_dictionary:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-dictionary\" option must be followed by"
			" compression dictionary bytes", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    compDictObj = objv[++i];
	    break;
	}

	if (flush == -2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "\"-flush\", \"-fullflush\" and \"-finalize\" options"
		    " are mutually exclusive", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
	    return TCL_ERROR;
	}
    }
    if (flush == -1) {
	flush = 0;
    }







|


















|










|







2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
		flush = Z_FINISH;
	    }
	    break;
	case ao_buffer: /* -buffer */
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-buffer\" option must be followed by integer "
			"decompression buffersize", -1));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"buffer size must be 1 to %d",
			MAX_BUFFER_SIZE));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
		return TCL_ERROR;
	    }
	    break;
	case ao_dictionary:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-dictionary\" option must be followed by"
			" compression dictionary bytes", -1));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    compDictObj = objv[++i];
	    break;
	}

	if (flush == -2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "\"-flush\", \"-fullflush\" and \"-finalize\" options"
		    " are mutually exclusive", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
	    return TCL_ERROR;
	}
    }
    if (flush == -1) {
	flush = 0;
    }
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
		flush = Z_FINISH;
	    }
	    break;
	case po_dictionary:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-dictionary\" option must be followed by"
			" compression dictionary bytes", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    compDictObj = objv[++i];
	    break;
	}
	if (flush == -2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "\"-flush\", \"-fullflush\" and \"-finalize\" options"
		    " are mutually exclusive", TCL_INDEX_NONE));
	    Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
	    return TCL_ERROR;
	}
    }
    if (flush == -1) {
	flush = 0;
    }







|









|







2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
		flush = Z_FINISH;
	    }
	    break;
	case po_dictionary:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-dictionary\" option must be followed by"
			" compression dictionary bytes", -1));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    compDictObj = objv[++i];
	    break;
	}
	if (flush == -2) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "\"-flush\", \"-fullflush\" and \"-finalize\" options"
		    " are mutually exclusive", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
	    return TCL_ERROR;
	}
    }
    if (flush == -1) {
	flush = 0;
    }
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 2, objv, NULL);
	return TCL_ERROR;
    } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE
	    || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"only gunzip streams can produce header information", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj);
    Tcl_SetObjResult(interp, resultObj);







|







2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 2, objv, NULL);
	return TCL_ERROR;
    } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE
	    || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"only gunzip streams can produce header information", -1));
	Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj);
    Tcl_SetObjResult(interp, resultObj);
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
    }

    errObj = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
    Tcl_ListObjAppendElement(NULL, errObj,
	    ConvertErrorToList(e, cd->outStream.adler));
    Tcl_ListObjAppendElement(NULL, errObj,
	    Tcl_NewStringObj(cd->outStream.msg, TCL_INDEX_NONE));
    Tcl_SetChannelError(cd->parent, errObj);
    *errorCodePtr = EINVAL;
    return -1;
}

/*
 *----------------------------------------------------------------------







|







3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
    }

    errObj = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
    Tcl_ListObjAppendElement(NULL, errObj,
	    ConvertErrorToList(e, cd->outStream.adler));
    Tcl_ListObjAppendElement(NULL, errObj,
	    Tcl_NewStringObj(cd->outStream.msg, -1));
    Tcl_SetChannelError(cd->parent, errObj);
    *errorCodePtr = EINVAL;
    return -1;
}

/*
 *----------------------------------------------------------------------
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
	if (optionName && strcmp(optionName, "-limit") == 0) {
	    int newLimit;

	    if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) {
		return TCL_ERROR;
	    } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"-limit must be between 1 and 65536", TCL_INDEX_NONE));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL);
		return TCL_ERROR;
	    }
	}
    }

    if (setOptionProc == NULL) {







|







3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
	if (optionName && strcmp(optionName, "-limit") == 0) {
	    int newLimit;

	    if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) {
		return TCL_ERROR;
	    } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"-limit must be between 1 and 65536", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL);
		return TCL_ERROR;
	    }
	}
    }

    if (setOptionProc == NULL) {
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
	}

	snprintf(buf, sizeof(buf), "%lu", crc);
	if (optionName == NULL) {
	    Tcl_DStringAppendElement(dsPtr, "-checksum");
	    Tcl_DStringAppendElement(dsPtr, buf);
	} else {
	    Tcl_DStringAppend(dsPtr, buf, TCL_INDEX_NONE);
	    return TCL_OK;
	}
    }

    if ((cd->format != TCL_ZLIB_FORMAT_GZIP) &&
	    (optionName == NULL || strcmp(optionName, "-dictionary") == 0)) {
	/*







|







3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
	}

	snprintf(buf, sizeof(buf), "%lu", crc);
	if (optionName == NULL) {
	    Tcl_DStringAppendElement(dsPtr, "-checksum");
	    Tcl_DStringAppendElement(dsPtr, buf);
	} else {
	    Tcl_DStringAppend(dsPtr, buf, -1);
	    return TCL_OK;
	}
    }

    if ((cd->format != TCL_ZLIB_FORMAT_GZIP) &&
	    (optionName == NULL || strcmp(optionName, "-dictionary") == 0)) {
	/*
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
    chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
	    Tcl_GetChannelMode(channel), channel);
    if (chan == NULL) {
	goto error;
    }
    cd->chan = chan;
    cd->parent = Tcl_GetStackedChannel(chan);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), TCL_INDEX_NONE));
    return chan;

  error:
    if (cd->inBuffer) {
	Tcl_Free(cd->inBuffer);
	inflateEnd(&cd->inStream);
    }







|







3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
    chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
	    Tcl_GetChannelMode(channel), channel);
    if (chan == NULL) {
	goto error;
    }
    cd->chan = chan;
    cd->parent = Tcl_GetStackedChannel(chan);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
    return chan;

  error:
    if (cd->inBuffer) {
	Tcl_Free(cd->inBuffer);
	inflateEnd(&cd->inStream);
    }
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962

  handleError:
    errObj = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
    Tcl_ListObjAppendElement(NULL, errObj,
	    ConvertErrorToList(e, cd->inStream.adler));
    Tcl_ListObjAppendElement(NULL, errObj,
	    Tcl_NewStringObj(cd->inStream.msg, TCL_INDEX_NONE));
    Tcl_SetChannelError(cd->parent, errObj);
    *errorCodePtr = EINVAL;
    return -1;
}

/*
 *----------------------------------------------------------------------







|







3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962

  handleError:
    errObj = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
    Tcl_ListObjAppendElement(NULL, errObj,
	    ConvertErrorToList(e, cd->inStream.adler));
    Tcl_ListObjAppendElement(NULL, errObj,
	    Tcl_NewStringObj(cd->inStream.msg, -1));
    Tcl_SetChannelError(cd->parent, errObj);
    *errorCodePtr = EINVAL;
    return -1;
}

/*
 *----------------------------------------------------------------------
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
    int mode,
    int format,
    int level,
    Tcl_Obj *dictObj,
    Tcl_ZlibStream *zshandle)
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
    }
    return TCL_ERROR;
}

int
Tcl_ZlibStreamClose(







|







4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
    int mode,
    int format,
    int level,
    Tcl_Obj *dictObj,
    Tcl_ZlibStream *zshandle)
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
	Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
    }
    return TCL_ERROR;
}

int
Tcl_ZlibStreamClose(
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
    Tcl_Interp *interp,
    int format,
    Tcl_Obj *data,
    int level,
    Tcl_Obj *gzipHeaderDictObj)
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
    }
    return TCL_ERROR;
}

int
Tcl_ZlibInflate(
    Tcl_Interp *interp,
    int format,
    Tcl_Obj *data,
    size_t bufferSize,
    Tcl_Obj *gzipHeaderDictObj)
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", TCL_INDEX_NONE));
	Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
    }
    return TCL_ERROR;
}

unsigned int
Tcl_ZlibCRC32(







|














|







4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
    Tcl_Interp *interp,
    int format,
    Tcl_Obj *data,
    int level,
    Tcl_Obj *gzipHeaderDictObj)
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
	Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
    }
    return TCL_ERROR;
}

int
Tcl_ZlibInflate(
    Tcl_Interp *interp,
    int format,
    Tcl_Obj *data,
    size_t bufferSize,
    Tcl_Obj *gzipHeaderDictObj)
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
	Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
    }
    return TCL_ERROR;
}

unsigned int
Tcl_ZlibCRC32(

Changes to macosx/tclMacOSXBundle.c.

166
167
168
169
170
171
172
173
174
175
176
177
178
179
180

int
Tcl_MacOSXOpenVersionedBundleResources(
    TCL_UNUSED(Tcl_Interp *),
    const char *bundleName,
    const char *bundleVersion,
    int hasResourceFile,
    size_t maxPathLen,
    char *libraryPath)
{
#ifdef HAVE_COREFOUNDATION
    CFBundleRef bundleRef, versionedBundleRef = NULL;
    CFStringRef bundleNameRef;
    CFURLRef libURL;








|







166
167
168
169
170
171
172
173
174
175
176
177
178
179
180

int
Tcl_MacOSXOpenVersionedBundleResources(
    TCL_UNUSED(Tcl_Interp *),
    const char *bundleName,
    const char *bundleVersion,
    int hasResourceFile,
    Tcl_Size maxPathLen,
    char *libraryPath)
{
#ifdef HAVE_COREFOUNDATION
    CFBundleRef bundleRef, versionedBundleRef = NULL;
    CFStringRef bundleNameRef;
    CFURLRef libURL;

Changes to tests/indexObj.test.

15
16
17
18
19
20
21

22
23
24
25
26
27
28

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testgetintforindex [llength [info commands testgetintforindex]]
testConstraint testparseargs [llength [info commands testparseargs]]


test indexObj-1.1 {exact match} testindexobj {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
    testindexobj 1 1 abc abc def xyz alm
} {0}







>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testgetintforindex [llength [info commands testgetintforindex]]
testConstraint testparseargs [llength [info commands testparseargs]]
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]

test indexObj-1.1 {exact match} testindexobj {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
    testindexobj 1 1 abc abc def xyz alm
} {0}
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
    testgetintforindex -2 0
} -1
test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex {
    testgetintforindex 2147483647 0
} 2147483647
test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex {
    testgetintforindex 2147483648 0
} 2147483648
test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 2147483646
} 2147483645
test indexObj-8.7 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 2147483647
} 2147483646
test indexObj-8.8 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end 2147483646
} 2147483646
test indexObj-8.9 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end 2147483647
} 2147483647
test indexObj-8.10 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 -1
} -2
test indexObj-8.11 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 -2
} -3
test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -1
} -1
test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -2
} -2
test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex {
    testgetintforindex end+1 -1
} 0
test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex {
    testgetintforindex end+1 -2
} -1








|














|


|





|







181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
    testgetintforindex -2 0
} -1
test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex {
    testgetintforindex 2147483647 0
} 2147483647
test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex {
    testgetintforindex 2147483648 0
} [expr {[testConstraint has64BitLengths] ? 2147483648 : 2147483647}]
test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 2147483646
} 2147483645
test indexObj-8.7 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 2147483647
} 2147483646
test indexObj-8.8 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end 2147483646
} 2147483646
test indexObj-8.9 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end 2147483647
} 2147483647
test indexObj-8.10 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 -1
} -1
test indexObj-8.11 {Tcl_GetIntForIndex end-1} testgetintforindex {
    testgetintforindex end-1 -2
} -1
test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -1
} -1
test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex {
    testgetintforindex end -2
} -1
test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex {
    testgetintforindex end+1 -1
} 0
test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex {
    testgetintforindex end+1 -2
} -1

Changes to tests/interp.test.

2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
    list $result $msg
} {1 {expected integer but got "bar"}}
test interp-29.1.5 {interp recursionlimit argument checking} -body {
    interp create moo
    set result [catch {interp recursionlimit moo 0} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.6 {interp recursionlimit argument checking} -body {
    interp create moo
    set result [catch {interp recursionlimit moo -1} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.7 {interp recursionlimit argument checking} {
    interp create moo
    set result [catch {interp recursionlimit moo [expr {wide(1)<<64}]} msg]
    interp delete moo
    list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.1.8 {child recursionlimit argument checking} {







|





|







2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
    list $result $msg
} {1 {expected integer but got "bar"}}
test interp-29.1.5 {interp recursionlimit argument checking} -body {
    interp create moo
    set result [catch {interp recursionlimit moo 0} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0}}
test interp-29.1.6 {interp recursionlimit argument checking} -body {
    interp create moo
    set result [catch {interp recursionlimit moo -1} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
    interp create moo
    set result [catch {interp recursionlimit moo [expr {wide(1)<<64}]} msg]
    interp delete moo
    list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.1.8 {child recursionlimit argument checking} {
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
    list $result $msg
} {1 {expected integer but got "foo"}}
test interp-29.1.10 {child recursionlimit argument checking} -body {
    interp create moo
    set result [catch {moo recursionlimit 0} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.11 {child recursionlimit argument checking} -body {
    interp create moo
    set result [catch {moo recursionlimit -1} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.12 {child recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit [expr {wide(1)<<64}]} msg]
    interp delete moo
    list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {







|





|







2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
    list $result $msg
} {1 {expected integer but got "foo"}}
test interp-29.1.10 {child recursionlimit argument checking} -body {
    interp create moo
    set result [catch {moo recursionlimit 0} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0}}
test interp-29.1.11 {child recursionlimit argument checking} -body {
    interp create moo
    set result [catch {moo recursionlimit -1} msg]
    interp delete moo
    list $result $msg
} -match glob -result {1 {recursion limit must be > 0}}
test interp-29.1.12 {child recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit [expr {wide(1)<<64}]} msg]
    interp delete moo
    list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {

Changes to tests/listObj.test.

18
19
20
21
22
23
24



25
26
27
28
29
30
31

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]
testConstraint memory [llength [info commands memory]]




catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
    # Test removed; tested an internal detail
    # that's no longer correct, and duplicated test obj-1.1
} {}

test listobj-2.1 {Tcl_SetListObj, use in lappend} {







>
>
>







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]
testConstraint memory [llength [info commands memory]]

set INT_MAX 0x7fffffff; # Assumes sizeof(int) == 4
set SIZE_MAX [expr {(1 << (8*$::tcl_platform(pointerSize) - 1)) - 1}]

catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
    # Test removed; tested an internal detail
    # that's no longer correct, and duplicated test obj-1.1
} {}

test listobj-2.1 {Tcl_SetListObj, use in lappend} {
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
    testlistobj get 1
} {f c d e}
test listobj-10.3 {Tcl_ListObjReplace with negative count value} testobj {
    testlistobj set 1 a b c d e
    testlistobj replace 1 1 -1 f
    testlistobj get 1
} {a f b c d e}
test listobj-10.4 {Tcl_ListObjReplace with UINT_MAX-1 count value} testobj {
    testlistobj set 1 a b c d e
    testlistobj replace 1 1 0xFFFFFFFE f
    testlistobj get 1
} {a f}
test listobj-10.5 {Tcl_ListObjReplace with SIZE_MAX-1 count value} testobj {
    testlistobj set 1 a b c d e
    testlistobj replace 1 1 -2 f
    testlistobj get 1
} {a f}

test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
    testobj bug3598580
} 123








|

|




|







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
    testlistobj get 1
} {f c d e}
test listobj-10.3 {Tcl_ListObjReplace with negative count value} testobj {
    testlistobj set 1 a b c d e
    testlistobj replace 1 1 -1 f
    testlistobj get 1
} {a f b c d e}
test listobj-10.4 {Tcl_ListObjReplace with $SIZE_MAX count value} testobj {
    testlistobj set 1 a b c d e
    testlistobj replace 1 1 $SIZE_MAX f
    testlistobj get 1
} {a f}
test listobj-10.5 {Tcl_ListObjReplace with SIZE_MAX-1 count value} testobj {
    testlistobj set 1 a b c d e
    testlistobj replace 1 1 [expr {$SIZE_MAX -1}] f
    testlistobj get 1
} {a f}

test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
    testobj bug3598580
} 123

Changes to tests/stringObj.test.

27
28
29
30
31
32
33



34
35
36
37
38
39
40

test stringObj-1.1 {string type registration} testobj {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first >= 0}]
} 1




test stringObj-2.1 {Tcl_NewStringObj} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [teststringobj set 1 abcd]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} abcd string 2}







>
>
>







27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

test stringObj-1.1 {string type registration} testobj {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first >= 0}]
} 1

set INT_MAX 0x7fffffff; # Assumes sizeof(int) == 4
set SIZE_MAX [expr {(1 << (8*$::tcl_platform(pointerSize) - 1)) - 1}]

test stringObj-2.1 {Tcl_NewStringObj} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [teststringobj set 1 abcd]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} abcd string 2}
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524

525
526
527
528
529
530
531
532
533
534
535
536
537
538
    teststringobj range 1 -1 -1
} abcde
test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj {
    # Older implementations could return "cde"
    teststringobj set 1 abcde
    teststringobj range 1 2 0
} {}
test stringObj-16.7 {Tcl_GetRange: first = UINT_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 0xFFFFFFFE 3
} {}
test stringObj-16.8 {Tcl_GetRange: first = SIZE_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 -2 3
} {}
test stringObj-16.9 {Tcl_GetRange: last = UINT_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 1 0xFFFFFFFE
} bcde
test stringObj-16.10 {Tcl_GetRange: last = SIZE_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 1 -2
} bcde
test stringObj-16.11 {Tcl_GetRange: first = last = UINT_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 0xFFFFFFFE 0xFFFFFFFE
} {}
test stringObj-16.12 {Tcl_GetRange: first = last = SIZE_MAX-1} testobj {
    teststringobj set 1 abcde

    teststringobj range 1 -2 -2
} {}

if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







|

|



|

|

|



|

|

|



>
|













499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
    teststringobj range 1 -1 -1
} abcde
test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj {
    # Older implementations could return "cde"
    teststringobj set 1 abcde
    teststringobj range 1 2 0
} {}
test stringObj-16.7 {Tcl_GetRange: first = INT_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 [expr {$INT_MAX-1}] 3
} {}
test stringObj-16.8 {Tcl_GetRange: first = SIZE_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 [expr {$SIZE_MAX - 1}] 3
} {}
test stringObj-16.9 {Tcl_GetRange: last = INT_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 1 [expr {$INT_MAX-1}]
} bcde
test stringObj-16.10 {Tcl_GetRange: last = SIZE_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 1 [expr {$SIZE_MAX - 1}] 
} bcde
test stringObj-16.11 {Tcl_GetRange: first = last = INT_MAX-1} testobj {
    teststringobj set 1 abcde
    teststringobj range 1 [expr {$INT_MAX-1}] [expr {$INT_MAX-1}]
} {}
test stringObj-16.12 {Tcl_GetRange: first = last = SIZE_MAX-1} testobj {
    teststringobj set 1 abcde
    set i [expr {$SIZE_MAX - 1}]
    teststringobj range 1 $i $i
} {}

if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to unix/dltest/pkgt.c.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

#undef STATIC_BUILD
#include "tcl.h"

static int TraceProc2 (
    void *clientData,
    Tcl_Interp *interp,
    size_t level,
    const char *command,
    Tcl_Command commandInfo,
    size_t objc,
    struct Tcl_Obj *const *objv)
{
    (void)clientData;
    (void)interp;
    (void)level;
    (void)command;
    (void)commandInfo;







|


|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

#undef STATIC_BUILD
#include "tcl.h"

static int TraceProc2 (
    void *clientData,
    Tcl_Interp *interp,
    ptrdiff_t level,
    const char *command,
    Tcl_Command commandInfo,
    ptrdiff_t objc,
    struct Tcl_Obj *const *objv)
{
    (void)clientData;
    (void)interp;
    (void)level;
    (void)command;
    (void)commandInfo;
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
 *----------------------------------------------------------------------
 */

static int
Pkgt_EqObjCmd2(
    void *dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    size_t objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_WideInt result;
    const char *str1, *str2;
    size_t len1, len2;
    (void)dummy;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv,  "string1 string2");
	return TCL_ERROR;
    }

    str1 = Tcl_GetStringFromObj(objv[1], &len1);
    str2 = Tcl_GetStringFromObj(objv[2], &len2);
    if (len1 == len2) {
	result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
    } else {
	result = 0;
    }
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
    return TCL_OK;
}








|




|










|







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
 *----------------------------------------------------------------------
 */

static int
Pkgt_EqObjCmd2(
    void *dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    ptrdiff_t objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_WideInt result;
    const char *str1, *str2;
    ptrdiff_t len1, len2;
    (void)dummy;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv,  "string1 string2");
	return TCL_ERROR;
    }

    str1 = Tcl_GetStringFromObj(objv[1], &len1);
    str2 = Tcl_GetStringFromObj(objv[2], &len2);
    if (len1 == len2) {
	result = (Tcl_UtfNcmp(str1, str2, (size_t) len1) == 0);
    } else {
	result = 0;
    }
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
    return TCL_OK;
}


Changes to unix/dltest/pkgua.c.

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
	Tcl_WrongNumArgs(interp, 1, objv,  "string1 string2");
	return TCL_ERROR;
    }

    str1 = Tcl_GetStringFromObj(objv[1], &len1);
    str2 = Tcl_GetStringFromObj(objv[2], &len2);
    if (len1 == len2) {
	result = (Tcl_UtfNcmp(str1, str2, (size_t)len1) == 0);
    } else {
	result = 0;
    }
    Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
    return TCL_OK;
}








|







134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
	Tcl_WrongNumArgs(interp, 1, objv,  "string1 string2");
	return TCL_ERROR;
    }

    str1 = Tcl_GetStringFromObj(objv[1], &len1);
    str2 = Tcl_GetStringFromObj(objv[2], &len2);
    if (len1 == len2) {
	result = (Tcl_UtfNcmp(str1, str2, (size_t) len1) == 0);
    } else {
	result = 0;
    }
    Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
    return TCL_OK;
}


Changes to unix/tclUnixChan.c.

592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Which option to set? */
    const char *value)		/* New value for option. */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len, vlen;
    TtyAttrs tty;
    size_t argc;
    const char **argv;
    struct termios iostate;

    len = strlen(optionName);
    vlen = strlen(value);

    /*







|







592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Which option to set? */
    const char *value)		/* New value for option. */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len, vlen;
    TtyAttrs tty;
    Tcl_Size argc;
    const char **argv;
    struct termios iostate;

    len = strlen(optionName);
    vlen = strlen(value);

    /*
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
    /*
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
#if defined(TIOCMGET) && defined(TIOCMSET)
	int control, flag;
	size_t i;

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(







|







728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
    /*
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
#if defined(TIOCMGET) && defined(TIOCMSET)
	int control, flag;
	Tcl_Size i;

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(

Changes to unix/tclUnixFCmd.c.

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
    const Tcl_StatBuf *statBufPtr,
				/* Used to determine mode and blocksize. */
    int dontCopyAtts)		/* If flag set, don't copy attributes. */
{
    int srcFd, dstFd;
    size_t blockSize;		/* Optimal I/O blocksize for filesystem */
    char *buffer;		/* Data buffer for copy */
    size_t nread;

#ifdef DJGPP
#define BINMODE |O_BINARY
#else
#define BINMODE
#endif /* DJGPP */








|







545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
    const Tcl_StatBuf *statBufPtr,
				/* Used to determine mode and blocksize. */
    int dontCopyAtts)		/* If flag set, don't copy attributes. */
{
    int srcFd, dstFd;
    size_t blockSize;		/* Optimal I/O blocksize for filesystem */
    char *buffer;		/* Data buffer for copy */
    ssize_t nread;

#ifdef DJGPP
#define BINMODE |O_BINARY
#else
#define BINMODE
#endif /* DJGPP */

602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

    if (blockSize <= 0) {
	blockSize = DEFAULT_COPY_BLOCK_SIZE;
    }
    buffer = (char *)Tcl_Alloc(blockSize);
    while (1) {
	nread = read(srcFd, buffer, blockSize);
	if ((nread == TCL_IO_FAILURE) || (nread == 0)) {
	    break;
	}
	if ((size_t) write(dstFd, buffer, nread) != nread) {
	    nread = TCL_IO_FAILURE;
	    break;
	}
    }

    Tcl_Free(buffer);
    close(srcFd);
    if ((close(dstFd) != 0) || (nread == TCL_IO_FAILURE)) {
	unlink(dst);					/* INTL: Native. */
	return TCL_ERROR;
    }
    if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
	/*
	 * The copy succeeded, but setting the permissions failed, so be in a
	 * consistent state, we remove the file that was created by the copy.







|


|
|






|







602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

    if (blockSize <= 0) {
	blockSize = DEFAULT_COPY_BLOCK_SIZE;
    }
    buffer = (char *)Tcl_Alloc(blockSize);
    while (1) {
	nread = read(srcFd, buffer, blockSize);
	if ((nread == -1) || (nread == 0)) {
	    break;
	}
	if (write(dstFd, buffer, nread) != nread) {
	    nread = -1;
	    break;
	}
    }

    Tcl_Free(buffer);
    close(srcFd);
    if ((close(dstFd) != 0) || (nread == -1)) {
	unlink(dst);					/* INTL: Native. */
	return TCL_ERROR;
    }
    if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
	/*
	 * The copy succeeded, but setting the permissions failed, so be in a
	 * consistent state, we remove the file that was created by the copy.
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
	     */

	    return 0;
	}

	nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
	if (Realpath(nativePath, normPath) != NULL) {
	    size_t newNormLen;

	wholeStringOk:
	    newNormLen = strlen(normPath);
	    if ((newNormLen == Tcl_DStringLength(&ds))
		    && (strcmp(normPath, nativePath) == 0)) {
		/*
		 * The original path is unchanged.







|







2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
	     */

	    return 0;
	}

	nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
	if (Realpath(nativePath, normPath) != NULL) {
	    Tcl_Size newNormLen;

	wholeStringOk:
	    newNormLen = strlen(normPath);
	    if ((newNormLen == Tcl_DStringLength(&ds))
		    && (strcmp(normPath, nativePath) == 0)) {
		/*
		 * The original path is unchanged.

Changes to unix/tclUnixInit.c.

451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
 *
 *-------------------------------------------------------------------------
 */

void
TclpInitLibraryPath(
    char **valuePtr,
    size_t *lengthPtr,
    Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE	    32
    Tcl_Obj *pathPtr, *objPtr;
    const char *str;
    Tcl_DString buffer;








|







451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
 *
 *-------------------------------------------------------------------------
 */

void
TclpInitLibraryPath(
    char **valuePtr,
    TCL_HASH_TYPE *lengthPtr,
    Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE	    32
    Tcl_Obj *pathPtr, *objPtr;
    const char *str;
    Tcl_DString buffer;

474
475
476
477
478
479
480
481
482
483
484
485
486
487
488

    str = getenv("TCL_LIBRARY");			/* INTL: Native. */
    Tcl_ExternalToUtfDStringEx(NULL, NULL, str, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &buffer, NULL);
    str = Tcl_DStringValue(&buffer);

    if ((str != NULL) && (str[0] != '\0')) {
	Tcl_DString ds;
	size_t pathc;
	const char **pathv;
	char installLib[LIBRARY_SIZE];

	Tcl_DStringInit(&ds);

	/*
	 * Initialize the substrings used when locating an executable. The







|







474
475
476
477
478
479
480
481
482
483
484
485
486
487
488

    str = getenv("TCL_LIBRARY");			/* INTL: Native. */
    Tcl_ExternalToUtfDStringEx(NULL, NULL, str, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &buffer, NULL);
    str = Tcl_DStringValue(&buffer);

    if ((str != NULL) && (str[0] != '\0')) {
	Tcl_DString ds;
	Tcl_Size pathc;
	const char **pathv;
	char installLib[LIBRARY_SIZE];

	Tcl_DStringInit(&ds);

	/*
	 * Initialize the substrings used when locating an executable. The
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensitive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or TCL_INDEX_NONE if there is no such entry. The integer at *lengthPtr is
 *	filled in with the length of name (if a matching entry is found) or
 *	the length of the environ array (if no matching entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

size_t
TclpFindVariable(
    const char *name,		/* Name of desired environment variable
				 * (native). */
    size_t *lengthPtr)		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    size_t i, result = TCL_INDEX_NONE;
    const char *env, *p1, *p2;
    Tcl_DString envString;

    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	p1 = Tcl_ExternalToUtfDString(NULL, env, TCL_INDEX_NONE, &envString);
	p2 = name;







|









|



|




|







998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensitive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or -1 if there is no such entry. The integer at *lengthPtr is
 *	filled in with the length of name (if a matching entry is found) or
 *	the length of the environ array (if no matching entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
TclpFindVariable(
    const char *name,		/* Name of desired environment variable
				 * (native). */
    Tcl_Size *lengthPtr)	/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    Tcl_Size i, result = -1;
    const char *env, *p1, *p2;
    Tcl_DString envString;

    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	p1 = Tcl_ExternalToUtfDString(NULL, env, TCL_INDEX_NONE, &envString);
	p2 = name;

Changes to win/tclWinFCmd.c.

305
306
307
308
309
310
311
312

313
314
315
316
317
318
319
	return TCL_ERROR;
    }
    if (errno == EACCES) {
    decode:
	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    WCHAR *nativeSrcRest, *nativeDstRest;
	    const char **srcArgv, **dstArgv;
	    size_t size, srcArgc, dstArgc;

	    WCHAR nativeSrcPath[MAX_PATH];
	    WCHAR nativeDstPath[MAX_PATH];
	    Tcl_DString srcString, dstString;
	    const char *src, *dst;

	    size = GetFullPathNameW(nativeSrc, MAX_PATH,
		    nativeSrcPath, &nativeSrcRest);







|
>







305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
	return TCL_ERROR;
    }
    if (errno == EACCES) {
    decode:
	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    WCHAR *nativeSrcRest, *nativeDstRest;
	    const char **srcArgv, **dstArgv;
	    size_t size;
	    Tcl_Size srcArgc, dstArgc;
	    WCHAR nativeSrcPath[MAX_PATH];
	    WCHAR nativeDstPath[MAX_PATH];
	    Tcl_DString srcString, dstString;
	    const char *src, *dst;

	    size = GetFullPathNameW(nativeSrc, MAX_PATH,
		    nativeSrcPath, &nativeSrcRest);
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
ConvertFileNameFormat(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    TCL_UNUSED(int) /*objIndex*/,
    Tcl_Obj *fileName,		/* The name of the file. */
    int longShort,		/* 0 to short name, 1 to long name. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    size_t pathc, i;
    Tcl_Obj *splitPath;
    size_t length;

    splitPath = Tcl_FSSplitPath(fileName, &pathc);

    if (splitPath == NULL || pathc == 0) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "could not read \"%s\": no such file or directory",







|

<







1592
1593
1594
1595
1596
1597
1598
1599
1600

1601
1602
1603
1604
1605
1606
1607
ConvertFileNameFormat(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    TCL_UNUSED(int) /*objIndex*/,
    Tcl_Obj *fileName,		/* The name of the file. */
    int longShort,		/* 0 to short name, 1 to long name. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    Tcl_Size pathc, i, length;
    Tcl_Obj *splitPath;


    splitPath = Tcl_FSSplitPath(fileName, &pathc);

    if (splitPath == NULL || pathc == 0) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "could not read \"%s\": no such file or directory",

Changes to win/tclWinInit.c.

120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
 *
 *-------------------------------------------------------------------------
 */

void
TclpInitLibraryPath(
    char **valuePtr,
    size_t *lengthPtr,
    Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE	    64
    Tcl_Obj *pathPtr;
    char installLib[LIBRARY_SIZE];
    const char *bytes;
    size_t length;







|







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
 *
 *-------------------------------------------------------------------------
 */

void
TclpInitLibraryPath(
    char **valuePtr,
    TCL_HASH_TYPE *lengthPtr,
    Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE	    64
    Tcl_Obj *pathPtr;
    char installLib[LIBRARY_SIZE];
    const char *bytes;
    size_t length;
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
 */

static void
AppendEnvironment(
    Tcl_Obj *pathPtr,
    const char *lib)
{
    size_t pathc;
    WCHAR wBuf[MAX_PATH];
    char buf[MAX_PATH * 3];
    Tcl_Obj *objPtr;
    Tcl_DString ds;
    const char **pathv;
    char *shortlib;








|







194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
 */

static void
AppendEnvironment(
    Tcl_Obj *pathPtr,
    const char *lib)
{
    Tcl_Size pathc;
    WCHAR wBuf[MAX_PATH];
    char buf[MAX_PATH * 3];
    Tcl_Obj *objPtr;
    Tcl_DString ds;
    const char **pathv;
    char *shortlib;

551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensitive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or TCL_INDEX_NONE if there is no such entry. The integer
 *	at *lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no
 *	matching entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#  define tenviron2utfdstr(string, len, dsPtr) \
		(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))

size_t
TclpFindVariable(
    const char *name,		/* Name of desired environment variable
				 * (UTF-8). */
    size_t *lengthPtr)		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    size_t i, length, result = TCL_INDEX_NONE;
    const WCHAR *env;
    const char *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive comparison.







|













|



|




|







551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name. On Unix this routine is
 *	case sensitive, on Windows this matches mixed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the name
 *	"name", or -1 if there is no such entry. The integer
 *	at *lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no
 *	matching entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#  define tenviron2utfdstr(string, len, dsPtr) \
		(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))

Tcl_Size
TclpFindVariable(
    const char *name,		/* Name of desired environment variable
				 * (UTF-8). */
    Tcl_Size *lengthPtr)		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    Tcl_Size i, length, result = -1;
    const WCHAR *env;
    const char *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive comparison.
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
	/*
	 * Chop the env string off after the equal sign, then Convert the name
	 * to all upper case, so we do not have to convert all the characters
	 * after the equal sign.
	 */

	Tcl_DStringInit(&envString);
	envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
	length = p1 - envUpper;
	Tcl_DStringSetLength(&envString, length+1);
	Tcl_UtfToUpper(envUpper);







|







600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
	/*
	 * Chop the env string off after the equal sign, then Convert the name
	 * to all upper case, so we do not have to convert all the characters
	 * after the equal sign.
	 */

	Tcl_DStringInit(&envString);
	envUpper = Tcl_WCharToUtfDString(env, -1, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
	length = p1 - envUpper;
	Tcl_DStringSetLength(&envString, length+1);
	Tcl_UtfToUpper(envUpper);

Changes to win/tclWinSerial.c.

1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
{
    SerialInfo *infoPtr;
    DCB dcb;
    BOOL result, flag;
    size_t len, vlen;
    Tcl_DString ds;
    const WCHAR *native;
    size_t argc;
    const char **argv;

    infoPtr = (SerialInfo *) instanceData;

    /*
     * Parse options. This would be far easier if we had Tcl_Objs to work with
     * as that would let us use Tcl_GetIndexFromObj()...







|







1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
{
    SerialInfo *infoPtr;
    DCB dcb;
    BOOL result, flag;
    size_t len, vlen;
    Tcl_DString ds;
    const WCHAR *native;
    Tcl_Size argc;
    const char **argv;

    infoPtr = (SerialInfo *) instanceData;

    /*
     * Parse options. This would be far easier if we had Tcl_Objs to work with
     * as that would let us use Tcl_GetIndexFromObj()...
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
    }

    /*
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
	size_t i;
	int res = TCL_OK;

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp != NULL) {







|







1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
    }

    /*
     * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
     */

    if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
	Tcl_Size i;
	int res = TCL_OK;

	if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if ((argc % 2) == 1) {
	    if (interp != NULL) {