Tcl Source Code

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

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

Overview
Comment:merge trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dgp-refactor
Files: files | file ages | folders
SHA3-256: 08d36921f05851c20d6639f6c0b165e1fd695173ae04e4b3171f7b4219f7d3cb
User & Date: dgp 2019-06-13 12:13:48
Context
2019-06-17
18:36
merge trunk Leaf check-in: d40e234200 user: dgp tags: dgp-refactor
2019-06-13
12:13
merge trunk check-in: 08d36921f0 user: dgp tags: dgp-refactor
2019-06-12
15:42
Merge 8.7 check-in: c5ff3f41bd user: jan.nijtmans tags: trunk
2019-06-06
08:20
Merge 8.7, and add some more usage of TCL_INDEX_NONE/TCL_AUTO_LENGTH check-in: 68a11af555 user: jan.nijtmans tags: trunk
2019-05-16
18:34
merge trunk check-in: d807d42276 user: dgp tags: dgp-refactor
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Name change from README to README.md.

1

2


3
4
5


6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
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
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
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
README:  Tcl

    This is the Tcl 9.0a0 source distribution.


	http://sourceforge.net/projects/tcl/files/Tcl/
    You can get any source release of Tcl from the URL above.



Contents
--------
    1. Introduction
    2. Documentation
    3. Compiling and installing Tcl
    4. Development tools
    5. Tcl newsgroup
    6. The Tcler's Wiki
    7. Mailing lists
    8. Support and Training
    9. Tracking Development
    10. Thank You

1. Introduction
---------------
Tcl provides a powerful platform for creating integration applications that
tie together diverse applications, protocols, devices, and frameworks.
When paired with the Tk toolkit, Tcl provides the fastest and most powerful
way to create GUI applications that run on PCs, Unix, and Mac OS X.
Tcl can also be used for a variety of web-related tasks and for creating
powerful command languages for applications.

Tcl is maintained, enhanced, and distributed freely by the Tcl community.
Source code development and tracking of bug reports and feature requests
takes place at:

	http://core.tcl-lang.org/

Tcl/Tk release and mailing list services are hosted by SourceForge:

	http://sourceforge.net/projects/tcl/

with the Tcl Developer Xchange hosted at:

	http://www.tcl-lang.org/

Tcl is a freely available open source package.  You can do virtually
anything you like with it, such as modifying it, redistributing it,
and selling it either in whole or in part.  See the file
"license.terms" for complete information.

2. Documentation
----------------

Extensive documentation is available at our website.
The home page for this release, including new features, is
	http://www.tcl-lang.org/software/tcltk/9.0.html

Detailed release notes can be found at the file distributions page

by clicking on the relevant version.
	http://sourceforge.net/projects/tcl/files/Tcl/

Information about Tcl itself can be found at
	http://www.tcl-lang.org/about/

There have been many Tcl books on the market.  Many are mentioned in the Wiki:
	http://wiki.tcl-lang.org/_/ref?N=25206

To view the complete set of reference manual entries for Tcl 9.0 online,
visit the URL:
	http://www.tcl-lang.org/man/tcl9.0/

2a. Unix Documentation
----------------------

The "doc" subdirectory in this release contains a complete set of
reference manual entries for Tcl.  Files with extension ".1" are for
programs (for example, tclsh.1); files with extension ".3" are for C

library procedures; and files with extension ".n" describe Tcl
commands.  The file "doc/Tcl.n" gives a quick summary of the Tcl
language syntax.  To print any of the man pages on Unix, cd to the
"doc" directory and invoke your favorite variant of troff using the
normal -man macros, for example

		ditroff -man Tcl.n

to print Tcl.n.  If Tcl has been installed correctly and your "man" program
supports it, you should be able to access the Tcl manual entries using the
normal "man" mechanisms, such as

		man Tcl

2b. Windows Documentation
-------------------------

The "doc" subdirectory in this release contains a complete set of Windows
help files for Tcl.  Once you install this Tcl release, a shortcut to the
Windows help Tcl documentation will appear in the "Start" menu:

	Start | Programs | Tcl | Tcl Help

3. Compiling and installing Tcl
-------------------------------

There are brief notes in the unix/README, win/README, and macosx/README about
compiling on these different platforms.  There is additional information
about building Tcl from sources at

	http://www.tcl-lang.org/doc/howto/compile.html

4. Development tools
---------------------------

ActiveState produces a high quality set of commercial quality development
tools that is available to accelerate your Tcl application development.
Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger,
static code checker, single-file wrapping utility, bytecode compiler and
more.  More information can be found at

	http://www.ActiveState.com/Tcl

5. Tcl newsgroup
----------------

There is a USENET news group, "comp.lang.tcl", intended for the exchange of
information about Tcl, Tk, and related applications.  The newsgroup is a
great place to ask general information questions.  For bug reports, please
see the "Support and bug fixes" section below.

6. Tcl'ers Wiki
---------------

A Wiki-based open community site covering all aspects of Tcl/Tk is at:

	http://wiki.tcl-lang.org/

It is dedicated to the Tcl programming language and its extensions.  A
wealth of useful information can be found there.  It contains code
snippets, references to papers, books, and FAQs, as well as pointers to
development tools, extensions, and applications.  You can also recommend
additional URLs by editing the wiki yourself.

7. Mailing lists
----------------

Several mailing lists are hosted at SourceForge to discuss development or
use issues (like Macintosh and Windows topics).  For more information and
to subscribe, visit:

	http://sourceforge.net/projects/tcl/

and go to the Mailing Lists page.

8. Support and Training
------------------------

We are very interested in receiving bug reports, patches, and suggestions
for improvements.  We prefer that you send this information to us as
tickets entered into our tracker at:

	http://core.tcl-lang.org/tcl/reportlist

We will log and follow-up on each bug, although we cannot promise a
specific turn-around time.  Enhancements may take longer and may not happen
at all unless there is widespread support for them (we're trying to
slow the rate at which Tcl/Tk turns into a kitchen sink).  It's very
difficult to make incompatible changes to Tcl/Tk at this point, due to
the size of the installed base.

The Tcl community is too large for us to provide much individual support
for users.  If you need help we suggest that you post questions to


comp.lang.tcl.  We read the newsgroup and will attempt to answer esoteric
questions for which no one else is likely to know the answer.  In addition,
see the following Web site for links to other organizations that offer
Tcl/Tk training:

	http://wiki.tcl-lang.org/training

9. Tracking Development
-----------------------

Tcl is developed in public.  To keep an eye on how Tcl is changing, see
	http://core.tcl-lang.org/

10. Thank You
-------------

We'd like to express our thanks to the Tcl community for all the
helpful suggestions, bug reports, and patches we have received.
Tcl/Tk has improved vastly and will continue to do so with your help.
|
>
|
>
>
|
<

>
>
|
<
|
|
|
|
|
|
|
|
|
|

|
<









<
<
|
<
|
<
|
<
|
<
|




|

|
<
<


|
<
|
>

<

|
|
<
|
|

|
<
|

|
<
<
|
|
<
>
|
|




|

|





|
<
<




|

|
<
<
|
|
|
<
|

|
<
<








|
<
<
|




|
|
<
|
<
<







|
<
<
|
|
<
<
|
<
|

|
<
<
|
|
<
<
|








|
|
>
>
|
|
<
<
<
|

|
<
<
|
|

|
<
<



1
2
3
4
5
6

7
8
9
10

11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31


32

33

34

35

36
37
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
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
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
# README:  Tcl

This is the **Tcl 9.0a0** source distribution.
	
You can get any source release of Tcl from [our distribution
site](https://sourceforge.net/projects/tcl/files/Tcl/).


[![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=master)](https://travis-ci.org/tcltk/tcl)

## Contents

 1. [Introduction](#intro)
 2. [Documentation](#doc)
 3. [Compiling and installing Tcl](#build)
 4. [Development tools](#devtools)
 5. [Tcl newsgroup](#complangtcl)
 6. [The Tcler's Wiki](#wiki)
 7. [Mailing lists](#email)
 8. [Support and Training](#support)
 9. [Tracking Development](#watch)
 10. [Thank You](#thanks)

## <a id="intro">1.</a> Introduction

Tcl provides a powerful platform for creating integration applications that
tie together diverse applications, protocols, devices, and frameworks.
When paired with the Tk toolkit, Tcl provides the fastest and most powerful
way to create GUI applications that run on PCs, Unix, and Mac OS X.
Tcl can also be used for a variety of web-related tasks and for creating
powerful command languages for applications.

Tcl is maintained, enhanced, and distributed freely by the Tcl community.
Source code development and tracking of bug reports and feature requests


takes place at [core.tcl-lang.org](https://core.tcl-lang.org/).

Tcl/Tk release and mailing list services are [hosted by

SourceForge](https://sourceforge.net/projects/tcl/)

with the Tcl Developer Xchange hosted at

[www.tcl-lang.org](https://www.tcl-lang.org).

Tcl is a freely available open source package.  You can do virtually
anything you like with it, such as modifying it, redistributing it,
and selling it either in whole or in part.  See the file
`license.terms` for complete information.

## <a id="doc">2.</a> Documentation


Extensive documentation is available at our website.
The home page for this release, including new features, is
[here](https://www.tcl.tk/software/tcltk/9.0.html).

Detailed release notes can be found at the
[file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/)
by clicking on the relevant version.


Information about Tcl itself can be found at the [Developer
Xchange](https://www.tcl-lang.org/about/).

There have been many Tcl books on the market.  Many are mentioned in
[the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206).

The complete set of reference manual entries for Tcl 9.0 is [online,

here](https://www.tcl-lang.org/man/tcl9.0/).

### <a id="doc.unix">2a.</a> Unix Documentation


The `doc` subdirectory in this release contains a complete set of
reference manual entries for Tcl.  Files with extension "`.1`" are for

programs (for example, `tclsh.1`); files with extension "`.3`" are for C
library procedures; and files with extension "`.n`" describe Tcl
commands.  The file "`doc/Tcl.n`" gives a quick summary of the Tcl
language syntax.  To print any of the man pages on Unix, cd to the
"doc" directory and invoke your favorite variant of troff using the
normal -man macros, for example

		groff -man -Tpdf Tcl.n >output.pdf

to print Tcl.n to PDF.  If Tcl has been installed correctly and your "man" program
supports it, you should be able to access the Tcl manual entries using the
normal "man" mechanisms, such as

		man Tcl

### <a id="doc.win">2b.</a> Windows Documentation


The "doc" subdirectory in this release contains a complete set of Windows
help files for Tcl.  Once you install this Tcl release, a shortcut to the
Windows help Tcl documentation will appear in the "Start" menu:

		Start | Programs | Tcl | Tcl Help

## <a id="build">3.</a> Compiling and installing Tcl


There are brief notes in the `unix/README`, `win/README`, and `macosx/README`
about compiling on these different platforms.  There is additional information
about building Tcl from sources

[online](https://www.tcl-lang.org/doc/howto/compile.html).

## <a id="devtools">4.</a> Development tools


ActiveState produces a high quality set of commercial quality development
tools that is available to accelerate your Tcl application development.
Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger,
static code checker, single-file wrapping utility, bytecode compiler and
more.  More information can be found at

	http://www.ActiveState.com/Tcl

## <a id="complangtcl">5.</a> Tcl newsgroup


There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of
information about Tcl, Tk, and related applications.  The newsgroup is a
great place to ask general information questions.  For bug reports, please
see the "Support and bug fixes" section below.

## <a id="wiki">6.</a> Tcl'ers Wiki
There is a [wiki-based open community site](https://wiki.tcl-lang.org/)

covering all aspects of Tcl/Tk.



It is dedicated to the Tcl programming language and its extensions.  A
wealth of useful information can be found there.  It contains code
snippets, references to papers, books, and FAQs, as well as pointers to
development tools, extensions, and applications.  You can also recommend
additional URLs by editing the wiki yourself.

## <a id="email">7.</a> Mailing lists


Several mailing lists are hosted at SourceForge to discuss development or use
issues (like Macintosh and Windows topics).  For more information and to


subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the

Mailing Lists page.

## <a id="support">8.</a> Support and Training


We are very interested in receiving bug reports, patches, and suggestions for
improvements.  We prefer that you send this information to us as tickets


entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist).

We will log and follow-up on each bug, although we cannot promise a
specific turn-around time.  Enhancements may take longer and may not happen
at all unless there is widespread support for them (we're trying to
slow the rate at which Tcl/Tk turns into a kitchen sink).  It's very
difficult to make incompatible changes to Tcl/Tk at this point, due to
the size of the installed base.

The Tcl community is too large for us to provide much individual support for
users.  If you need help we suggest that you post questions to `comp.lang.tcl`
or ask a question on [Stack
Overflow](https://stackoverflow.com/questions/tagged/tcl).  We read the
newsgroup and will attempt to answer esoteric questions for which no one else
is likely to know the answer.  In addition, see the wiki for [links to other



organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training.

## <a id="watch">9.</a> Tracking Development


Tcl is developed in public.  You can keep an eye on how Tcl is changing at
[core.tcl-lang.org](https://core.tcl-lang.org/).

## <a id="thanks">10.</a> Thank You


We'd like to express our thanks to the Tcl community for all the
helpful suggestions, bug reports, and patches we have received.
Tcl/Tk has improved vastly and will continue to do so with your help.

Changes to doc/IntObj.3.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
27
28
29
30
31
32
33



34
35
36
37
38
39
40
..
51
52
53
54
55
56
57


58
59
60
61
62
63
64
...
110
111
112
113
114
115
116










117
118
119
120
121
122
123
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewIntObj\fR(\fIintValue\fR)
.sp
................................................................................
\fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR)
.sp
\fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR)
.sp
int
\fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR)
.sp



int
\fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR)
.sp
int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
.sp
.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 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.
.AP Tcl_Obj *objPtr in/out
................................................................................
and \fBTcl_SetBignumObj\fR routines each set the value of an existing
Tcl value pointed to by \fIobjPtr\fR to the integral value provided
by the other argument.  The \fIobjPtr\fR argument must point to an
unshared Tcl value.  Any attempt to set the value of a shared Tcl value
violates Tcl's copy-on-write policy.  Any existing string representation
or internal representation in the unshared Tcl value will be freed
as a consequence of setting the new value.










.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






|







 







>
>
>







 







>
>







 







>
>
>
>
>
>
>
>
>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewIntObj\fR(\fIintValue\fR)
.sp
................................................................................
\fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR)
.sp
\fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR)
.sp
int
\fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR)
.sp
int
\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, intPtr\fR)
.sp
int
\fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR)
.sp
int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
.sp
.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 int 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.
.AP Tcl_Obj *objPtr in/out
................................................................................
and \fBTcl_SetBignumObj\fR routines each set the value of an existing
Tcl value pointed to by \fIobjPtr\fR to the integral value provided
by the other argument.  The \fIobjPtr\fR argument must point to an
unshared Tcl value.  Any attempt to set the value of a shared Tcl value
violates Tcl's copy-on-write policy.  Any existing string representation
or internal representation in the unshared Tcl value will be freed
as a consequence of setting the new value.
.PP
The \fBTcl_GetIntForIndex\fR routine attempts to retrieve an index
value 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 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

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_BYTES\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 int 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_BYTES\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

Changes to doc/RegExp.3.

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
..
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
...
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
.AP 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 int 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
................................................................................
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 int 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 int 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 \-1, 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
................................................................................
\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 {
    int \fInsubs\fR;
    Tcl_RegExpIndices *\fImatches\fR;
    long \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
................................................................................
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 {
    long \fIstart\fR;
    long \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






|







 







|



|


|







 







|

|







 







|
|







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
..
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
...
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
.AP 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
................................................................................
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
................................................................................
\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
................................................................................
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

Changes to doc/Utf.3.

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
specified character (not byte) \fIindex\fR in the UTF-8 string
\fIsrc\fR.  The source string must contain at least \fIindex\fR
characters.
.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_UtfNext\fR \fIindex\fR times.  If \fIindex\fR is TCL_AUTO_LENGTH,
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 \fBTCL_UTF_MAX\fR bytes are stored in the buffer.
\fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number






|







240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
specified character (not byte) \fIindex\fR in the UTF-8 string
\fIsrc\fR.  The source string must contain at least \fIindex\fR
characters.
.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_UtfNext\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 \fBTCL_UTF_MAX\fR bytes are stored in the buffer.
\fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number

Changes to doc/coroutine.n.

10
11
12
13
14
15
16
17
18
19

20



21
22
23
24
25
26
27
..
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
..
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
...
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
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
coroutine, yield, yieldto \- Create and produce values from coroutines
.SH SYNOPSIS
.nf
\fBcoroutine \fIname command\fR ?\fIarg...\fR?
\fByield\fR ?\fIvalue\fR?
.VS TIP396
\fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
\fIname\fR ?\fIvalue...\fR?

.VE TIP396



.fi
.BE
.SH DESCRIPTION
.PP
The \fBcoroutine\fR command creates a new coroutine context (with associated
command) named \fIname\fR and executes that context by calling \fIcommand\fR,
passing in the other remaining arguments without further interpretation. Once
................................................................................
of the context can then be resumed by calling the context command, optionally
passing in the \fIsingle\fR value to use as the result of the \fByield\fR call
that caused
the context to be suspended. If the coroutine context never yields and instead
returns conventionally, the result of the \fBcoroutine\fR command will be the
result of the evaluation of the context.
.PP
.VS TIP396
The coroutine may also suspend its execution by use of the \fByieldto\fR
command, which instead of returning, cedes execution to some command called
\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
number\fR of arguments may be passed. Since every coroutine has a context
command, \fByieldto\fR can be used to transfer control directly from one
coroutine to another (this is only advisable if the two coroutines are
expecting this to happen) but \fIany\fR command may be the target. If a
................................................................................
decide what to do with those values.
.PP
The recommended way of writing a version of \fByield\fR that allows resumption
with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
command, like this:
.PP
.CS
proc yieldm {value} {
    \fByieldto\fR return -level 0 $value
}
.CE
.VE TIP396
.PP
The coroutine can also be deleted by destroying the command \fIname\fR, and
the name of the current coroutine can be retrieved by using
\fBinfo coroutine\fR.
If there are deletion traces on variables in the coroutine's
implementation, they will fire at the point when the coroutine is explicitly
deleted (or, naturally, if the command returns conventionally).
.PP
At the point when \fIcommand\fR is called, the current namespace will be the
global namespace and there will be no stack frames above it (in the sense of
\fBupvar\fR and \fBuplevel\fR). However, which command to call will be
determined in the namespace that the \fBcoroutine\fR command was called from.













































.SH EXAMPLES
.PP
This example shows a coroutine that will produce an infinite sequence of
even values, and a loop that consumes the first ten of them.
.PP
.CS
proc allNumbers {} {
................................................................................
    }
}} allNumbers
for {set i 1} {$i <= 20} {incr i} {
    puts "prime#$i = [\fIeratosthenes\fR]"
}
.CE
.PP
.VS TIP396
This example shows how a value can be passed around a group of three
coroutines that yield to each other:
.PP
.CS
proc juggler {name target {value ""}} {
    if {$value eq ""} {
        set value [\fByield\fR [info coroutine]]
    }
    while {$value ne ""} {
        puts "$name : $value"
        set value [string range $value 0 end-1]
        lassign [\fByieldto\fR $target $value] value
    }
}
\fBcoroutine\fR j1 juggler Larry [
    \fBcoroutine\fR j2 juggler Curly [
        \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
.CE
.VE TIP396











































.SS "DETAILED SEMANTICS"
.PP
This example demonstrates that coroutines start from the global namespace, and
that \fIcommand\fR resolution happens before the coroutine stack is created.
.PP
.CS
proc report {where level} {






<


>
|
>
>
>







 







<







 







|
|


<












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







 







<











|






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







10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30
..
38
39
40
41
42
43
44

45
46
47
48
49
50
51
..
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
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
...
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
221
222
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
253
254
255
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
coroutine, yield, yieldto \- Create and produce values from coroutines
.SH SYNOPSIS
.nf
\fBcoroutine \fIname command\fR ?\fIarg...\fR?
\fByield\fR ?\fIvalue\fR?

\fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
\fIname\fR ?\fIvalue...\fR?
.sp
.VS "8.7, TIP383"
\fBcoroinject \fIcoroName command\fR ?\fIarg...\fR?
\fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR?
.VE "8.7, TIP383"
.fi
.BE
.SH DESCRIPTION
.PP
The \fBcoroutine\fR command creates a new coroutine context (with associated
command) named \fIname\fR and executes that context by calling \fIcommand\fR,
passing in the other remaining arguments without further interpretation. Once
................................................................................
of the context can then be resumed by calling the context command, optionally
passing in the \fIsingle\fR value to use as the result of the \fByield\fR call
that caused
the context to be suspended. If the coroutine context never yields and instead
returns conventionally, the result of the \fBcoroutine\fR command will be the
result of the evaluation of the context.
.PP

The coroutine may also suspend its execution by use of the \fByieldto\fR
command, which instead of returning, cedes execution to some command called
\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
number\fR of arguments may be passed. Since every coroutine has a context
command, \fByieldto\fR can be used to transfer control directly from one
coroutine to another (this is only advisable if the two coroutines are
expecting this to happen) but \fIany\fR command may be the target. If a
................................................................................
decide what to do with those values.
.PP
The recommended way of writing a version of \fByield\fR that allows resumption
with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
command, like this:
.PP
.CS
proc yieldMultiple {value} {
    tailcall \fByieldto\fR string cat $value
}
.CE

.PP
The coroutine can also be deleted by destroying the command \fIname\fR, and
the name of the current coroutine can be retrieved by using
\fBinfo coroutine\fR.
If there are deletion traces on variables in the coroutine's
implementation, they will fire at the point when the coroutine is explicitly
deleted (or, naturally, if the command returns conventionally).
.PP
At the point when \fIcommand\fR is called, the current namespace will be the
global namespace and there will be no stack frames above it (in the sense of
\fBupvar\fR and \fBuplevel\fR). However, which command to call will be
determined in the namespace that the \fBcoroutine\fR command was called from.
.PP
.VS "8.7, TIP383"
A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d)
may have its state inspected (or modified) at that point by using
\fBcoroprobe\fR to run a command at the point where the coroutine is at. The
command takes the name of the coroutine to run the command in, \fIcoroName\fR,
and the name of a command (any any arguments it requires) to immediately run
at that point. The result of that command is the result of the \fBcoroprobe\fR
command, and the gross state of the coroutine remains the same afterwards
(i.e., the coroutine is still expecting the results of a \fByield\fR or
\fByieldto\fR as before) though variables may have been changed.
.PP
Similarly, the \fBcoroinject\fR command may be used to place a command to be
run inside a suspended coroutine (when it is resumed) to process arguments,
with quite a bit of similarity to \fBcoroprobe\fR. However, with
\fBcoroinject\fR there are several key differences:
.VE "8.7, TIP383"
.IP \(bu
.VS "8.7, TIP383"
The coroutine is not immediately resumed after the injection has been done.  A
consequence of this is that multiple injections may be done before the
coroutine is resumed. There injected commands are performed in \fIreverse
order of definition\fR (that is, they are internally stored on a stack).
.VE "8.7, TIP383"
.IP \(bu
.VS "8.7, TIP383"
An additional two arguments are appended to the list of arguments to be run
(that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements).
The first is the name of the command that suspended the coroutine (\fByield\fR
or \fByieldto\fR), and the second is the argument (or list of arguments, in
the case of \fByieldto\fR) that is the current resumption value.
.VE "8.7, TIP383"
.IP \(bu
.VS "8.7, TIP383"
The result of the injected command is used as the result of the \fByield\fR or
\fByieldto\fR that caused the coroutine to become suspended. Where there are
multiple injected commands, the result of one becomes the resumption value
processed by the next.
.PP
The injection is a one-off. It is not retained once it has been executed. It
may \fByield\fR or \fByieldto\fR as part of its execution.
.PP
Note that running coroutines may be neither probed nor injected; the
operations may only be applied to
.VE "8.7, TIP383"
.SH EXAMPLES
.PP
This example shows a coroutine that will produce an infinite sequence of
even values, and a loop that consumes the first ten of them.
.PP
.CS
proc allNumbers {} {
................................................................................
    }
}} allNumbers
for {set i 1} {$i <= 20} {incr i} {
    puts "prime#$i = [\fIeratosthenes\fR]"
}
.CE
.PP

This example shows how a value can be passed around a group of three
coroutines that yield to each other:
.PP
.CS
proc juggler {name target {value ""}} {
    if {$value eq ""} {
        set value [\fByield\fR [info coroutine]]
    }
    while {$value ne ""} {
        puts "$name : $value"
        set value [string range $value 0 end-1]
        lassign [\fByieldto\fR \fI$target\fR $value] value
    }
}
\fBcoroutine\fR j1 juggler Larry [
    \fBcoroutine\fR j2 juggler Curly [
        \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
.CE
.PP
.VS "8.7, TIP383"
This example shows a simple coroutine that collects non-empty values and
returns a list of them when not given an argument. It also shows how we can
look inside the coroutine to find out what it is doing, and how we can modify
the input on a one-off basis.
.PP
.CS
proc collectorImpl {} {
    set me [info coroutine]
    set accumulator {}
    for {set val [\fByield\fR $me]} {$val ne ""} {set val [\fByield\fR]} {
        lappend accumulator $val
    }
    return $accumulator
}

\fBcoroutine\fR collect collectorImpl
\fIcollect\fR 123
\fIcollect\fR "abc def"
\fIcollect\fR 456

puts [\fBcoroprobe \fIcollect\fR set accumulator]
# ==> 123 {abc def} 456

\fIcollect\fR "pqr"

\fBcoroinject \fIcollect\fR apply {{type value} {
    puts "Received '$value' at a $type in [info coroutine]"
    return [string toupper $value]
}}

\fIcollect\fR rst
# ==> Received 'rst' at a yield in ::collect
\fIcollect\fR xyz

puts [\fIcollect\fR]
# ==> 123 {abc def} 456 pqr RST xyz
.CE
.PP
This example shows a simple coroutine that collects non-empty values and
returns a list of them when not given an argument. It also shows how we can
look inside the coroutine to find out what it is doing.
.VE "8.7, TIP383"
.SS "DETAILED SEMANTICS"
.PP
This example demonstrates that coroutines start from the global namespace, and
that \fIcommand\fR resolution happens before the coroutine stack is created.
.PP
.CS
proc report {where level} {

Changes to doc/expr.n.

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
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
...
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
365
366

367
368
369
370
371
372
373
\fBTcl\fR.
.PP
Below are some examples of simple expressions where the value of \fBa\fR is 3
and the value of \fBb\fR is 6.  The command on the left side of each line
produces the value on the right side.
.PP
.CS
.ta 6c
\fBexpr\fR 3.1 + $a	\fI6.1\fR
\fBexpr\fR 2 + "$a.$b"	\fI5.6\fR
\fBexpr\fR 4*[llength "6 2"]	\fI8\fR
\fBexpr\fR {{word one} < "word $a"}	\fI0\fR
.CE
.SS OPERATORS
.PP
................................................................................
\fB|\fR
.
Bit-wise OR.  Valid for integer operands.
.TP 20
\fB&&\fR
.
Logical AND.  If both operands are true, the result is 1, or 0 otherwise.





.TP 20
\fB||\fR
.
Logical OR.  If both operands are false, the result is 0, or 1 otherwise.


.TP 20
\fIx\fB?\fIy\fB:\fIz\fR

.
If-then-else, as in C.  If \fIx\fR is false , the result is the value of
\fIy\fR.  Otherwise the result is the value of \fIz\fR.

.PP
The exponentiation operator promotes types in the same way that the multiply
and divide operators do, and the result is is the same as the result of
\fBpow\fR.
Exponentiation groups right-to-left within a precedence level. Other binary
operators group left-to-right.  For example, the value of

.PP
.CS
\fBexpr\fR {4*2 < 7}
.CE
.PP
is 0, while the value of
.PP
................................................................................
substitutions on, enclosing an expression in braces or otherwise quoting it
so that it's a static value allows the Tcl compiler to generate bytecode for
the expression, resulting in better speed and smaller storage requirements.
This also avoids issues that can arise if Tcl is allowed to perform
substitution on the value before \fBexpr\fR is called.
.PP
In the following example, the value of the expression is 11 because the Tcl parser first
substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR.  Enclosing the



expression in braces would result in a syntax error.


.CS
set a 3
set b {$a + 2}
\fBexpr\fR $b*4
.CE
.PP

When an expression is generated at runtime, like the one above is, the bytcode
compiler must ensure that new code is generated each time the expression
is evaluated.  This is the most costly kind of expression from a performance
perspective.  In such cases, consider directly using the commands described in
the \fBmathfunc\fR(n) or \fBmathop\fR(n) documentation instead of \fBexpr\fR.

Most expressions are not formed at runtime, but are literal strings or contain
substitutions that don't introduce other substitutions.  To allow the bytecode
compiler to work with an expression as a string literal at compilation time,
ensure that it contains no substitutions or that it is enclosed in braces or
otherwise quoted to prevent Tcl from performing substitutions, allowing
\fBexpr\fR to perform them instead.




















.SH EXAMPLES
.PP
A numeric comparison whose result is 1:

.CS
\fBexpr\fR {"0x03" > "2"}
.CE
.PP
A string comparison whose result is 1:

.CS
\fBexpr\fR {"0y" > "0x12"}
.CE
.PP
Define a procedure that computes an
.QW interesting
mathematical function:






|







 







<
>
>
>
>




>
>

<
>



>






>







 







|
>
>
>
|
>
>






<
|




|






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



>





>







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
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
...
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
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
405
406
\fBTcl\fR.
.PP
Below are some examples of simple expressions where the value of \fBa\fR is 3
and the value of \fBb\fR is 6.  The command on the left side of each line
produces the value on the right side.
.PP
.CS
.ta 9c
\fBexpr\fR 3.1 + $a	\fI6.1\fR
\fBexpr\fR 2 + "$a.$b"	\fI5.6\fR
\fBexpr\fR 4*[llength "6 2"]	\fI8\fR
\fBexpr\fR {{word one} < "word $a"}	\fI0\fR
.CE
.SS OPERATORS
.PP
................................................................................
\fB|\fR
.
Bit-wise OR.  Valid for integer operands.
.TP 20
\fB&&\fR
.
Logical AND.  If both operands are true, the result is 1, or 0 otherwise.

This operator evaluates lazily; it only evaluates its second operand if it
must in order to determine its result.
This operator evaluates lazily; it only evaluates its second operand if it
must in order to determine its result.
.TP 20
\fB||\fR
.
Logical OR.  If both operands are false, the result is 0, or 1 otherwise.
This operator evaluates lazily; it only evaluates its second operand if it
must in order to determine its result.
.TP 20

\fIx \fB?\fI y \fB:\fI z\fR
.
If-then-else, as in C.  If \fIx\fR is false , the result is the value of
\fIy\fR.  Otherwise the result is the value of \fIz\fR.
This operator evaluates lazily; it evaluates only one of \fIy\fR or \fIz\fR.
.PP
The exponentiation operator promotes types in the same way that the multiply
and divide operators do, and the result is is the same as the result of
\fBpow\fR.
Exponentiation groups right-to-left within a precedence level. Other binary
operators group left-to-right.  For example, the value of
.PP
.PP
.CS
\fBexpr\fR {4*2 < 7}
.CE
.PP
is 0, while the value of
.PP
................................................................................
substitutions on, enclosing an expression in braces or otherwise quoting it
so that it's a static value allows the Tcl compiler to generate bytecode for
the expression, resulting in better speed and smaller storage requirements.
This also avoids issues that can arise if Tcl is allowed to perform
substitution on the value before \fBexpr\fR is called.
.PP
In the following example, the value of the expression is 11 because the Tcl parser first
substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR as part
of evaluating the expression
.QW "$a + 2*4" .
Enclosing the
expression in braces would result in a syntax error as \fB$b\fR does
not evaluate to a numeric value.
.PP
.CS
set a 3
set b {$a + 2}
\fBexpr\fR $b*4
.CE
.PP

When an expression is generated at runtime, like the one above is, the bytecode
compiler must ensure that new code is generated each time the expression
is evaluated.  This is the most costly kind of expression from a performance
perspective.  In such cases, consider directly using the commands described in
the \fBmathfunc\fR(n) or \fBmathop\fR(n) documentation instead of \fBexpr\fR.
.PP
Most expressions are not formed at runtime, but are literal strings or contain
substitutions that don't introduce other substitutions.  To allow the bytecode
compiler to work with an expression as a string literal at compilation time,
ensure that it contains no substitutions or that it is enclosed in braces or
otherwise quoted to prevent Tcl from performing substitutions, allowing
\fBexpr\fR to perform them instead.
.PP
If it is necessary to include a non-constant expression string within the
wider context of an otherwise-constant expression, the most efficient
technique is to put the varying part inside a recursive \fBexpr\fR, as this at
least allows for the compilation of the outer part, though it does mean that
the varying part must itself be evaluated as a separate expression. Thus, in
this example the result is 20 and the outer expression benefits from fully
cached bytecode compilation.
.PP
.CS
set a 3
set b {$a + 2}
\fBexpr\fR {[\fBexpr\fR $b] * 4}
.CE
.PP
In general, you should enclose your expression in braces wherever possible,
and where not possible, the argument to \fBexpr\fR should be an expression
defined elsewhere as simply as possible. It is usually more efficient and
safer to use other techniques (e.g., the commands in the \fBtcl::mathop\fR
namespace) than it is to do complex expression generation.
.SH EXAMPLES
.PP
A numeric comparison whose result is 1:
.PP
.CS
\fBexpr\fR {"0x03" > "2"}
.CE
.PP
A string comparison whose result is 1:
.PP
.CS
\fBexpr\fR {"0y" > "0x12"}
.CE
.PP
Define a procedure that computes an
.QW interesting
mathematical function:

Changes to doc/file.n.

428
429
430
431
432
433
434






























435
436
437
438
439
440
441
\fBfile tail \fIname\fR
.
Returns all of the characters in the last filesystem component of
\fIname\fR.  Any trailing directory separator in \fIname\fR is ignored.
If \fIname\fR contains no separators then returns \fIname\fR.  So,
\fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all
return \fBb\fR.






























.TP
\fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR?
'\" TIP #210
.VS 8.6
Creates a temporary file and returns a read-write channel opened on that file.
If the \fInameVar\fR is given, it specifies a variable that the name of the
temporary file will be written into; if absent, Tcl will attempt to arrange






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







428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
\fBfile tail \fIname\fR
.
Returns all of the characters in the last filesystem component of
\fIname\fR.  Any trailing directory separator in \fIname\fR is ignored.
If \fIname\fR contains no separators then returns \fIname\fR.  So,
\fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all
return \fBb\fR.
.TP
\fBfile tempdir\fR ?\fItemplate\fR?
.VS "8.7, TIP 431"
Creates a temporary directory (guaranteed to be newly created and writable by
the current script) and returns its name. If \fItemplate\fR is given, it
specifies one of or both of the existing directory (on a filesystem controlled
by the operating system) to contain the temporary directory, and the base part
of the directory name; it is considered to have the location of the directory
if there is a directory separator in the name, and the base part is everything
after the last directory separator (if non-empty).  The default containing
directory is determined by system-specific operations, and the default base
name prefix is
.QW \fBtcl\fR .
.RS
.PP
The following output is typical and illustrative; the actual output will vary
between platforms:
.PP
.CS
% \fBfile tempdir\fR
/var/tmp/tcl_u0kuy5
 % \fBfile tempdir\fR /tmp/myapp
/tmp/myapp_8o7r9L
% \fBfile tempdir\fR /tmp/
/tmp/tcl_1mOJHD
% \fBfile tempdir\fR myapp
/var/tmp/myapp_0ihS0n
.CE
.RE
.VE "8.7, TIP 431"
.TP
\fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR?
'\" TIP #210
.VS 8.6
Creates a temporary file and returns a read-write channel opened on that file.
If the \fInameVar\fR is given, it specifies a variable that the name of the
temporary file will be written into; if absent, Tcl will attempt to arrange

Changes to doc/timerate.n.

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
by the maximal number of iterations to evaluate the script.
If \fImax-count\fR is specified, the evalution will stop either this count of
iterations is reached or the time is exceeded.
.sp
It will then return a canonical tcl-list of the form:
.PP
.CS
\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR
.CE
.PP
which indicates:
.IP \(bu 3
the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0])
.IP \(bu 3
the count how many times it was executed ([\fBlindex\fR $result 2])






|







37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
by the maximal number of iterations to evaluate the script.
If \fImax-count\fR is specified, the evalution will stop either this count of
iterations is reached or the time is exceeded.
.sp
It will then return a canonical tcl-list of the form:
.PP
.CS
\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 net-ms\fR
.CE
.PP
which indicates:
.IP \(bu 3
the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0])
.IP \(bu 3
the count how many times it was executed ([\fBlindex\fR $result 2])

Changes to generic/regcomp.c.

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
....
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
    v->cv = NULL;
    v->cv2 = NULL;
    v->lacons = NULL;
    v->nlacons = 0;
    v->spaceused = 0;
    re->re_magic = REMAGIC;
    re->re_info = 0;		/* bits get set during parse */
    re->re_csize = sizeof(chr);
    re->re_guts = NULL;
    re->re_fns = (void*)(&functions);

    /*
     * More complex setup, malloced things.
     */

................................................................................
    g = (struct guts *) re->re_guts;
    if (g->magic != GUTSMAGIC) {
	fprintf(f, "bad guts magic number (0x%x not 0x%x)\n",
		g->magic, GUTSMAGIC);
    }

    fprintf(f, "\n\n\n========= DUMP ==========\n");
    fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n",
	    (int) re->re_nsub, re->re_info, re->re_csize, g->ntree);

    dumpcolors(&g->cmap, f);
    if (!NULLCNFA(g->search)) {
	fprintf(f, "\nsearch:\n");
	dumpcnfa(&g->search, f);
    }
    for (i = 1; i < g->nlacons; i++) {






<







 







|
|







334
335
336
337
338
339
340

341
342
343
344
345
346
347
....
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
    v->cv = NULL;
    v->cv2 = NULL;
    v->lacons = NULL;
    v->nlacons = 0;
    v->spaceused = 0;
    re->re_magic = REMAGIC;
    re->re_info = 0;		/* bits get set during parse */

    re->re_guts = NULL;
    re->re_fns = (void*)(&functions);

    /*
     * More complex setup, malloced things.
     */

................................................................................
    g = (struct guts *) re->re_guts;
    if (g->magic != GUTSMAGIC) {
	fprintf(f, "bad guts magic number (0x%x not 0x%x)\n",
		g->magic, GUTSMAGIC);
    }

    fprintf(f, "\n\n\n========= DUMP ==========\n");
    fprintf(f, "nsub %" TCL_Z_MODIFIER "d, info 0%lo, ntree %d\n",
	    re->re_nsub, re->re_info, g->ntree);

    dumpcolors(&g->cmap, f);
    if (!NULLCNFA(g->search)) {
	fprintf(f, "\nsearch:\n");
	dumpcnfa(&g->search, f);
    }
    for (i = 1; i < g->nlacons; i++) {

Changes to generic/regex.h.

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
/*
 * other interface types
 */

/* the biggie, a compiled RE (or rather, a front end to same) */
typedef struct {
    int re_magic;		/* magic number */
    size_t re_nsub;		/* number of subexpressions */
    long re_info;		/* information about RE */

#define	REG_UBACKREF		000001
#define	REG_ULOOKAHEAD		000002
#define	REG_UBOUNDS		000004
#define	REG_UBRACES		000010
#define	REG_UBSALNUM		000020
#define	REG_UPBOTCH		000040
#define	REG_UBBS		000100
................................................................................
#define	REG_UNONPOSIX		000200
#define	REG_UUNSPEC		000400
#define	REG_UUNPORT		001000
#define	REG_ULOCALE		002000
#define	REG_UEMPTYMATCH		004000
#define	REG_UIMPOSSIBLE		010000
#define	REG_USHORTEST		020000
    int re_csize;		/* sizeof(character) */
    char *re_endp;		/* backward compatibility kludge */
    /* the rest is opaque pointers to hidden innards */
    char *re_guts;		/* `char *' is more portable than `void *' */
    char *re_fns;
} regex_t;

/* result reporting (may acquire more fields later) */
typedef struct {
    long rm_so;		/* start of substring */
    long rm_eo;		/* end of substring */
} regmatch_t;

/* supplementary control and reporting */
typedef struct {
    regmatch_t rm_extend;	/* see REG_EXPECT */
} rm_detail_t;







<

>







 







<








|
|







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
/*
 * other interface types
 */

/* the biggie, a compiled RE (or rather, a front end to same) */
typedef struct {
    int re_magic;		/* magic number */

    long re_info;		/* information about RE */
    size_t re_nsub;		/* number of subexpressions */
#define	REG_UBACKREF		000001
#define	REG_ULOOKAHEAD		000002
#define	REG_UBOUNDS		000004
#define	REG_UBRACES		000010
#define	REG_UBSALNUM		000020
#define	REG_UPBOTCH		000040
#define	REG_UBBS		000100
................................................................................
#define	REG_UNONPOSIX		000200
#define	REG_UUNSPEC		000400
#define	REG_UUNPORT		001000
#define	REG_ULOCALE		002000
#define	REG_UEMPTYMATCH		004000
#define	REG_UIMPOSSIBLE		010000
#define	REG_USHORTEST		020000

    char *re_endp;		/* backward compatibility kludge */
    /* the rest is opaque pointers to hidden innards */
    char *re_guts;		/* `char *' is more portable than `void *' */
    char *re_fns;
} regex_t;

/* result reporting (may acquire more fields later) */
typedef struct {
    size_t rm_so;		/* start of substring */
    size_t rm_eo;		/* end of substring */
} regmatch_t;

/* supplementary control and reporting */
typedef struct {
    regmatch_t rm_extend;	/* see REG_EXPECT */
} rm_detail_t;

Changes to generic/regexec.c.

183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
...
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
     * Sanity checks.
     */

    if (re == NULL || string == NULL || re->re_magic != REMAGIC) {
	FreeVars(v);
	return REG_INVARG;
    }
    if (re->re_csize != sizeof(chr)) {
	FreeVars(v);
	return REG_MIXED;
    }

    /*
     * Setup.
     */

    v->re = re;
    v->g = (struct guts *)re->re_guts;
................................................................................
    assert(t->op == 'b');
    assert(n >= 0);
    assert((size_t)n < v->nmatch);

    MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max));

    /* get the backreferenced string */
    if (v->pmatch[n].rm_so == -1) {
	return REG_NOMATCH;
    }
    brstring = v->start + v->pmatch[n].rm_so;
    brlen = v->pmatch[n].rm_eo - v->pmatch[n].rm_so;

    /* special cases for zero-length strings */
    if (brlen == 0) {






<
<
<
<







 







|







183
184
185
186
187
188
189




190
191
192
193
194
195
196
...
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
     * Sanity checks.
     */

    if (re == NULL || string == NULL || re->re_magic != REMAGIC) {
	FreeVars(v);
	return REG_INVARG;
    }





    /*
     * Setup.
     */

    v->re = re;
    v->g = (struct guts *)re->re_guts;
................................................................................
    assert(t->op == 'b');
    assert(n >= 0);
    assert((size_t)n < v->nmatch);

    MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max));

    /* get the backreferenced string */
    if (v->pmatch[n].rm_so == TCL_INDEX_NONE) {
	return REG_NOMATCH;
    }
    brstring = v->start + v->pmatch[n].rm_so;
    brlen = v->pmatch[n].rm_eo - v->pmatch[n].rm_so;

    /* special cases for zero-length strings */
    if (brlen == 0) {

Changes to generic/tcl.decls.

2432
2433
2434
2435
2436
2437
2438
2439





2440
2441
2442
2443
2444
2445
2446
declare 643 {
    int Tcl_IsShared(Tcl_Obj *objPtr)
}

# TIP#312 New Tcl_LinkArray() function
declare 644 {
    int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
	    int type, int size)





}

# ----- BASELINE -- FOR -- 8.7.0 ----- #

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

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






|
>
>
>
>
>







2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
declare 643 {
    int Tcl_IsShared(Tcl_Obj *objPtr)
}

# TIP#312 New Tcl_LinkArray() function
declare 644 {
    int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
	    int type, size_t size)
}

declare 645 {
    int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    size_t endValue, size_t *indexPtr)
}

# ----- BASELINE -- FOR -- 8.7.0 ----- #

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

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

Changes to generic/tcl.h.

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
....
2167
2168
2169
2170
2171
2172
2173

2174
2175
2176
2177
2178
2179
2180
/*
 * Structures filled in by Tcl_RegExpInfo. Note that all offset values are
 * relative to the start of the match string, not the beginning of the entire
 * string.
 */

typedef struct Tcl_RegExpIndices {
    long start;			/* Character offset of first character in
				 * match. */
    long end;			/* Character offset of first character after
				 * the match. */
} Tcl_RegExpIndices;

typedef struct Tcl_RegExpInfo {
    int nsubs;			/* Number of subexpressions in the compiled
				 * expression. */
    Tcl_RegExpIndices *matches;	/* Array of nsubs match offset pairs. */
    long extendStart;		/* The offset at which a subsequent match
				 * might begin. */
    long reserved;		/* Reserved for later use. */
} Tcl_RegExpInfo;

/*
 * Picky compilers complain if this typdef doesn't appear before the struct's
 * reference in tclDecls.h.
 */

................................................................................

/*
 * Constants for special size_t-typed values, see TIP #494
 */

#define TCL_IO_FAILURE	((size_t)-1)
#define TCL_AUTO_LENGTH	((size_t)-1)


/*
 *----------------------------------------------------------------------------
 * Single public declaration for NRE.
 */

typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp,






|

|




|


|

<







 







>







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
....
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
/*
 * Structures filled in by Tcl_RegExpInfo. Note that all offset values are
 * relative to the start of the match string, not the beginning of the entire
 * string.
 */

typedef struct Tcl_RegExpIndices {
    size_t start;			/* Character offset of first character in
				 * match. */
    size_t end;			/* Character offset of first character after
				 * the match. */
} Tcl_RegExpIndices;

typedef struct Tcl_RegExpInfo {
    size_t nsubs;			/* Number of subexpressions in the compiled
				 * expression. */
    Tcl_RegExpIndices *matches;	/* Array of nsubs match offset pairs. */
    size_t extendStart;		/* The offset at which a subsequent match
				 * might begin. */

} Tcl_RegExpInfo;

/*
 * Picky compilers complain if this typdef doesn't appear before the struct's
 * reference in tclDecls.h.
 */

................................................................................

/*
 * Constants for special size_t-typed values, see TIP #494
 */

#define TCL_IO_FAILURE	((size_t)-1)
#define TCL_AUTO_LENGTH	((size_t)-1)
#define TCL_INDEX_NONE  ((size_t)-1)

/*
 *----------------------------------------------------------------------------
 * Single public declaration for NRE.
 */

typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp,

Changes to generic/tclAssembly.c.

511
512
513
514
515
516
517

518
519
520
521
522
523
524
 * The instructions must be in ascending order by numeric operation code.
 */

static const unsigned char NonThrowingByteCodes[] = {
    INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP,			/* 1-4 */
    INST_JUMP1, INST_JUMP4,					/* 34-35 */
    INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE,	/* 70-72 */

    INST_LIST,							/* 79 */
    INST_OVER,							/* 95 */
    INST_PUSH_RETURN_OPTIONS,					/* 108 */
    INST_REVERSE,						/* 126 */
    INST_NOP,							/* 132 */
    INST_STR_MAP,						/* 143 */
    INST_STR_FIND,						/* 144 */






>







511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
 * The instructions must be in ascending order by numeric operation code.
 */

static const unsigned char NonThrowingByteCodes[] = {
    INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP,			/* 1-4 */
    INST_JUMP1, INST_JUMP4,					/* 34-35 */
    INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE,	/* 70-72 */
    INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN,	/* 73-76 */
    INST_LIST,							/* 79 */
    INST_OVER,							/* 95 */
    INST_PUSH_RETURN_OPTIONS,					/* 108 */
    INST_REVERSE,						/* 126 */
    INST_NOP,							/* 132 */
    INST_STR_MAP,						/* 143 */
    INST_STR_FIND,						/* 144 */

Changes to generic/tclBasic.c.

151
152
153
154
155
156
157
158
159
160




161
162
163
164
165
166
167
...
220
221
222
223
224
225
226


227
228
229
230
231
232
233
...
343
344
345
346
347
348
349

350
351
352
353
354
355
356
...
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
...
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
....
8505
8506
8507
8508
8509
8510
8511





























8512







8513































































































































































































































8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545

8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
static Tcl_NRPostProc	TEOV_Exception;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;





MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
................................................................................

    {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	NULL,	CMD_IS_SAFE},
    {"apply",		Tcl_ApplyObjCmd,	NULL,			TclNRApplyObjCmd,	CMD_IS_SAFE},
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	NULL,	CMD_IS_SAFE},
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
    {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},


    {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
    {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	CMD_IS_SAFE},
    {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	CMD_IS_SAFE},
    {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	CMD_IS_SAFE},
................................................................................
    {"file", "readable"},
    {"file", "readlink"},
    {"file", "rename"},
    {"file", "rootname"},
    {"file", "size"},
    {"file", "stat"},
    {"file", "tail"},

    {"file", "tempfile"},
    {"file", "type"},
    {"file", "volumes"},
    {"file", "writable"},
    /* [info] has two unsafe commands */
    {"info", "cmdtype"},
    {"info", "nameofexecutable"},
................................................................................
    }

#if defined(_WIN32) && !defined(_WIN64)
    if (sizeof(time_t) != 4) {
	/*NOTREACHED*/
	Tcl_Panic("<time.h> is not compatible with MSVC");
    }
    if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
	    || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
	/*NOTREACHED*/
	Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
    }
#endif

    if (cancelTableInitialized == 0) {
	Tcl_MutexLock(&cancelLock);
................................................................................
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    /* Coroutine monkeybusiness */
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
            CoroTypeObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
................................................................................
        return TCL_ERROR;
    }
}
 
/*
 *----------------------------------------------------------------------
 *





























 * NRCoroInjectObjCmd --







 *































































































































































































































 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

static int
NRCoroInjectObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr;
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;

    /*
     * Usage more or less like tailcall:
     *   inject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objv[1]), NULL);

        return TCL_ERROR;
    }

    corPtr = cmdPtr->objClientData;
    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;
    }







|


>
>
>
>







 







>
>







 







>







 







|
|







 







|







 







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






|





<













|
<
<
|
<
<
>


<
<







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
...
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
...
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
...
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
...
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
....
8512
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
8572
8573
8574
8575
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
8591
8592
8593
8594
8595
8596
8597
8598
8599
8600
8601
8602
8603
8604
8605
8606
8607
8608
8609
8610
8611
8612
8613
8614
8615
8616
8617
8618
8619
8620
8621
8622
8623
8624
8625
8626
8627
8628
8629
8630
8631
8632
8633
8634
8635
8636
8637
8638
8639
8640
8641
8642
8643
8644
8645
8646
8647
8648
8649
8650
8651
8652
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
8683
8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
8696
8697
8698
8699
8700
8701
8702
8703
8704
8705
8706
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
8720
8721
8722
8723
8724
8725
8726
8727
8728
8729
8730
8731
8732
8733
8734
8735
8736
8737
8738
8739
8740
8741
8742
8743
8744
8745
8746
8747
8748
8749
8750
8751
8752
8753
8754
8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777
8778
8779
8780
8781
8782
8783
8784
8785
8786
8787
8788
8789
8790
8791

8792
8793
8794
8795
8796
8797
8798
8799
8800
8801
8802
8803
8804
8805


8806


8807
8808
8809


8810
8811
8812
8813
8814
8815
8816
static Tcl_NRPostProc	TEOV_Exception;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;
static Tcl_ObjCmdProc TclNRCoroInjectObjCmd;
static Tcl_ObjCmdProc TclNRCoroProbeObjCmd;
static Tcl_NRPostProc InjectHandler;
static Tcl_NRPostProc InjectHandlerPostCall;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
................................................................................

    {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	NULL,	CMD_IS_SAFE},
    {"apply",		Tcl_ApplyObjCmd,	NULL,			TclNRApplyObjCmd,	CMD_IS_SAFE},
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	NULL,	CMD_IS_SAFE},
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
    {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},
    {"coroinject",	NULL,			NULL,                   TclNRCoroInjectObjCmd,	CMD_IS_SAFE},
    {"coroprobe",	NULL,			NULL,                   TclNRCoroProbeObjCmd,	CMD_IS_SAFE},
    {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
    {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	CMD_IS_SAFE},
    {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	CMD_IS_SAFE},
    {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	CMD_IS_SAFE},
................................................................................
    {"file", "readable"},
    {"file", "readlink"},
    {"file", "rename"},
    {"file", "rootname"},
    {"file", "size"},
    {"file", "stat"},
    {"file", "tail"},
    {"file", "tempdir"},
    {"file", "tempfile"},
    {"file", "type"},
    {"file", "volumes"},
    {"file", "writable"},
    /* [info] has two unsafe commands */
    {"info", "cmdtype"},
    {"info", "nameofexecutable"},
................................................................................
    }

#if defined(_WIN32) && !defined(_WIN64)
    if (sizeof(time_t) != 4) {
	/*NOTREACHED*/
	Tcl_Panic("<time.h> is not compatible with MSVC");
    }
    if ((offsetof(Tcl_StatBuf,st_atime) != 32)
	    || (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
	/*NOTREACHED*/
	Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
    }
#endif

    if (cancelTableInitialized == 0) {
	Tcl_MutexLock(&cancelLock);
................................................................................
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    /* Coroutine monkeybusiness */
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRInjectObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
            CoroTypeObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
................................................................................
        return TCL_ERROR;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd --
 *
 *      Implementation of [coroinject] and [coroprobe] commands.
 *
 *----------------------------------------------------------------------
 */

static inline CoroutineData *
GetCoroutineFromObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    const char *errMsg)
{
    /*
     * 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 cmdPtr->objClientData;
}

static int
TclNRCoroInjectObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;

    /*
     * Usage more or less like tailcall:
     *   coroinject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

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

    iPtr->execEnvPtr = corPtr->eePtr;
    TclNRAddCallback(interp, InjectHandler, corPtr,
            Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
    iPtr->execEnvPtr = savedEEPtr;

    return TCL_OK;
}

static int
TclNRCoroProbeObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;
    int numLevels, unused;
    int *stackLevel = &unused;

    /*
     * Usage more or less like tailcall:
     *   coroprobe coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    corPtr = GetCoroutineFromObj(interp, objv[1],
            "can only inject a probe command into a coroutine");
    if (!corPtr) {
        return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a probe 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.
     */

    iPtr->execEnvPtr = corPtr->eePtr;
    TclNRAddCallback(interp, InjectHandler, corPtr,
            Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
    iPtr->execEnvPtr = savedEEPtr;

    /*
     * Now we immediately transfer control to the coroutine to run our probe.
     * TRICKY STUFF copied from the [yield] implementation.
     *
     * Push the callback to restore the caller's context on yield back.
     */

    TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
            NULL, NULL, NULL);

    /*
     * 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 = stackLevel;
    numLevels = corPtr->auxNumLevels;
    corPtr->auxNumLevels = iPtr->numLevels;

    /*
     * Do the actual stack swap.
     */

    SAVE_CONTEXT(corPtr->caller);
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;
    iPtr->numLevels += numLevels;
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * InjectHandler, InjectHandlerPostProc --
 *
 *      Part of the implementation of [coroinject] and [coroprobe]. These are
 *      run inside the context of the coroutine being injected/probed into.
 *
 *      InjectHandler runs a script (possibly adding arguments) in the context
 *      of the coroutine. The script is specified as a one-shot list (with
 *      reference count equal to 1) in data[1]. This function also arranges
 *      for InjectHandlerPostProc to be the part that runs after the script
 *      completes.
 *
 *      InjectHandlerPostProc cleans up after InjectHandler (deleting the
 *      list) and, for the [coroprobe] command *only*, yields back to the
 *      caller context (i.e., where [coroprobe] was run).
 *s
 *----------------------------------------------------------------------
 */

static int
InjectHandler(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CoroutineData *corPtr = data[0];
    Tcl_Obj *listPtr = data[1];
    int nargs = PTR2INT(data[2]);
    ClientData isProbe = data[3];
    int objc;
    Tcl_Obj **objv;

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

        if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) {
            Tcl_ListObjAppendElement(NULL, listPtr,
                    Tcl_NewStringObj("yield", -1));
        } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) {
            Tcl_ListObjAppendElement(NULL, listPtr,
                    Tcl_NewStringObj("yieldto", -1));
        } else {
            /*
             * I don't think this is reachable...
             */

            Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs));
        }
        Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp));
    }

    /*
     * Call the user's script; we're in the right place.
     */

    Tcl_IncrRefCount(listPtr);
    TclMarkTailcall(interp);
    TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
            INT2PTR(nargs), isProbe);
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}

static int
InjectHandlerPostCall(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CoroutineData *corPtr = data[0];
    Tcl_Obj *listPtr = data[1];
    int nargs = PTR2INT(data[2]);
    ClientData isProbe = data[3];
    int numLevels;

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

    Tcl_DecrRefCount(listPtr);

    /*
     * If we were doing a probe, splice ourselves back out of the stack
     * cleanly here. General injection should instead just look after itself.
     *
     * Code from guts of [yield] implementation.
     */

    if (isProbe) {
        if (result == TCL_ERROR) {
            Tcl_AddErrorInfo(interp,
                    "\n    (injected coroutine probe command)");
        }
        corPtr->nargs = nargs;
        corPtr->stackLevel = NULL;
        numLevels = iPtr->numLevels;
        iPtr->numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
        iPtr->execEnvPtr = corPtr->callerEEPtr;
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NRInjectObjCmd --
 *
 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

static int
NRInjectObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;

    /*
     * Usage more or less like tailcall:
     *   inject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    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;
    }

Changes to generic/tclBinary.c.

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
219
220
221
222
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
253
254
255
...
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
...
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
...
706
707
708
709
710
711
712

713
714
715

716
717
718
719
720
721
722
723
724
725
726
727
...
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
...
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
....
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
....
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
....
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
....
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
....
2038
2039
2040
2041
2042
2043
2044

2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
....
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
....
2247
2248
2249
2250
2251
2252
2253

2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
....
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
....
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
2525
2526
2527
2528
2529
2530
2531
2532
....
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
....
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
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
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
....
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
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
....
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
2814
2815
....
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
....
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
....
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
....
3049
3050
3051
3052
3053
3054
3055

3056
3057


3058
3059
3060
3061
3062
3063
3064
....
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
....
3134
3135
3136
3137
3138
3139
3140
3141
    { "hex",      BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    { "uuencode", BinaryDecodeUu,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    { "base64",   BinaryDecode64,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    { NULL, NULL, NULL, NULL, NULL, 0 }
};

/*
 * The following object types represent an array of bytes. The intent is
 * to allow arbitrary binary data to pass through Tcl as a Tcl value
 * without loss or damage. Such values are useful for things like
 * encoded strings or Tk images to name just two.
 *
 * It's strange to have two Tcl_ObjTypes in place for this task when
 * one would do, so a bit of detail and history how we got to this point
 * and where we might go from here.
 *
 * A bytearray is an ordered sequence of bytes. Each byte is an integer
 * value in the range [0-255].  To be a Tcl value type, we need a way to
 * encode each value in the value set as a Tcl string.  The simplest
 * encoding is to represent each byte value as the same codepoint value.
 * A bytearray of N bytes is encoded into a Tcl string of N characters
 * where the codepoint of each character is the value of corresponding byte.
 * This approach creates a one-to-one map between all bytearray values
 * and a subset of Tcl string values.
 *
 * When converting a Tcl string value to the bytearray internal rep, the
 * question arises what to do with strings outside that subset?  That is,
 * those Tcl strings containing at least one codepoint greater than 255?
 * The obviously correct answer is to raise an error!  That string value
 * does not represent any valid bytearray value. Full Stop.  The
 * setFromAnyProc signature has a completion code return value for just
 * this reason, to reject invalid inputs.
 *
 * Unfortunately this was not the path taken by the authors of the
 * original tclByteArrayType.  They chose to accept all Tcl string values
 * as acceptable string encodings of the bytearray values that result
 * from masking away the high bits of any codepoint value at all. This
 * meant that every bytearray value had multiple accepted string
 * representations.
 *
 * The implications of this choice are truly ugly.  When a Tcl value has
 * a string representation, we are required to accept that as the true
 * value.  Bytearray values that possess a string representation cannot
 * be processed as bytearrays because we cannot know which true value
 * that bytearray represents.  The consequence is that we drag around
 * an internal rep that we cannot make any use of.  This painful price
 * is extracted at any point after a string rep happens to be generated
 * for the value.  This happens even when the troublesome codepoints
 * outside the byte range never show up.  This happens rather routinely
 * in normal Tcl operations unless we burden the script writer with the
 * cognitive burden of avoiding it.  The price is also paid by callers
 * of the C interface.  The routine
 *
 *	unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr)
 *
 * has a guarantee to always return a non-NULL value, but that value
 * points to a byte sequence that cannot be used by the caller to
 * process the Tcl value absent some sideband testing that objPtr
 * is "pure".  Tcl offers no public interface to perform this test,
 * so callers either break encapsulation or are unavoidably buggy.  Tcl
 * has defined a public interface that cannot be used correctly. The
 * Tcl source code itself suffers the same problem, and has been buggy,
 * but progressively less so as more and more portions of the code have
 * been retrofitted with the required "purity testing".  The set of values
 * able to pass the purity test can be increased via the introduction of
 * a "canonical" flag marker, but the only way the broken interface itself
 * can be discarded is to start over and define the Tcl_ObjType properly.
 * Bytearrays should simply be usable as bytearrays without a kabuki
 * dance of testing.
 *
 * The "Pure" ByteArray type is (nearly) a correct

 * implementation of bytearrays.  Any Tcl value with the type
 * properByteArrayType can have its bytearray value fetched and
 * used with confidence that acting on that value is equivalent to
 * acting on the true Tcl string value.  This still implies a side
 * testing burden -- past mistakes will not let us avoid that
 * immediately, but it is at least a conventional test of type, and
 * can be implemented entirely by examining the objPtr fields, with
 * no need to query the intrep, as a canonical flag would require.
 *
 * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can
 * be revised to admit the possibility of returning NULL when the true
 * value is not a valid bytearray, we need a mechanism to retain
 * compatibility with the deployed callers of the broken interface.
 * That's what the retained "tclByteArrayType" provides.  In those
 * unusual circumstances where we convert an invalid bytearray value
 * to a bytearray type, it is to this legacy type.  Essentially any
 * time this legacy type gets used, it's a signal of a bug being ignored.
 * A TIP should be drafted to remove this connection to the broken past
 * so that Tcl 9 will no longer have any trace of it.  Prescribing a
 * migration path will be the key element of that work.  The internal
 * changes now in place are the limit of what can be done short of
 * interface repair.  They provide a great expansion of the histories
 * over which bytearray values can be useful in the meanwhile.
 */

static const Tcl_ObjType properByteArrayType = {
    "bytearray",
    FreeProperByteArrayInternalRep,
    DupProperByteArrayInternalRep,
    UpdateStringOfByteArray,
................................................................................
				 * minus 1 byte. */
    unsigned char bytes[1];	/* The array of bytes. The actual size of this
				 * field depends on the 'allocated' field
				 * above. */
} ByteArray;

#define BYTEARRAY_SIZE(len) \
		((TclOffset(ByteArray, bytes) + (len)))
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
		(irPtr)->twoPtrValue.ptr1 = (baPtr)
 
int
TclIsPureByteArray(
    Tcl_Obj * objPtr)
................................................................................
 *
 *----------------------------------------------------------------------
 */

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 length > 0. */
    size_t length)			/* Length of the array of bytes, which must
				   be >= 0. */
{
    ByteArray *byteArrayPtr;
    Tcl_ObjIntRep ir;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
    }
................................................................................
	if ((src[i] == 0) || (src[i] > 127)) {
	    size++;
	}
    }

    if (size == length) {
	char *dst = Tcl_InitStringRep(objPtr, (char *)src, size);

	TclOOM(dst, size);
    } else {
	char *dst = Tcl_InitStringRep(objPtr, NULL, size);

	TclOOM(dst, size);
	for (i = 0; i < length; i++) {
	    dst += Tcl_UniCharToUtf(src[i], dst);
	}
	(void)Tcl_InitStringRep(objPtr, NULL, size);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclAppendBytesToByteArray --
................................................................................
     */

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

	if (needed <= INT_MAX/2) {

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


	    attempt = 2 * needed;
	    ptr = Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
	}
	if (ptr == NULL) {

	    /* Try to allocate double the increment that is needed (plus). */


	    size_t limit = UINT_MAX - needed;
	    size_t extra = len + TCL_MIN_GROWTH;
	    size_t growth = (extra > limit) ? limit : extra;

	    attempt = needed + growth;
	    ptr = Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
	}
	if (ptr == NULL) {

	    /* Last chance: Try to allocate exactly what is needed. */


	    attempt = needed;
	    ptr = Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
	}
	byteArrayPtr = ptr;
	byteArrayPtr->allocated = attempt;
	SET_BYTEARRAY(irPtr, byteArrayPtr);
    }
................................................................................
    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;
................................................................................
     */

    resultPtr = Tcl_NewObj();
    buffer = Tcl_SetByteArrayLength(resultPtr, length);
    memset(buffer, 0, length);

    /*
     * Pack the data into the result object. Note that we can skip the
     * error checking during this pass, since we have already parsed the
     * string once.
     */

    arg = 2;
    format = TclGetString(objv[1]);
    cursor = buffer;
    maxPos = cursor;
    while (*format != 0) {
................................................................................
		TclListObjGetElements(interp, objv[arg], &listc, &listv);
		if (count == BINARY_ALL) {
		    count = listc;
		}
	    }
	    arg++;
	    for (i = 0; (size_t)i < count; i++) {
		if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
		    Tcl_DecrRefCount(resultPtr);
		    return TCL_ERROR;
		}
	    }
	    break;
	}
	case 'x':
................................................................................
    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;
    int offset, size;
    size_t length = 0;
................................................................................

	    /*
	     * Trim trailing nulls and spaces, if necessary.
	     */

	    if (cmd == 'A') {
		while (size > 0) {
		    if (src[size-1] != '\0' && src[size-1] != ' ') {
			break;
		    }
		    size--;
		}
	    }

	    /*
................................................................................
	 * Single-precision floating point values. Tcl_GetDoubleFromObj
	 * returns TCL_ERROR for NaN, but we can check by comparing the
	 * object's type pointer.
	 */

	if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
	    const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType);

	    if (irPtr == NULL) {
		return TCL_ERROR;
	    }
	    dvalue = irPtr->doubleValue;
	}

	/*
	 * Because some compilers will generate floating point exceptions on
	 * an overflow cast (e.g. Borland), we restrict the values to the
	 * valid range for float.
	 */

	if (fabs(dvalue) > (double)FLT_MAX) {
	    fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
	} else {
	    fvalue = (float) dvalue;
	}
	CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
	*cursorPtr += sizeof(float);
	return TCL_OK;
................................................................................

static Tcl_Obj *
ScanNumber(
    unsigned char *buffer,	/* Buffer to scan number from. */
    int type,			/* Format character from "binary scan" */
    int flags,			/* Format field flags */
    Tcl_HashTable **numberCachePtrPtr)
				/* Place to look for cache of scanned
				 * value objects, or NULL if too many
				 * different numbers have been scanned. */
{
    long value;
    float fvalue;
    double dvalue;
    Tcl_WideUInt uwvalue;

    /*
................................................................................
		    + (buffer[1] << 16)
		    + (((long) buffer[0]) << 24));
	}

	/*
	 * Check to see if the value was sign extended properly on systems
	 * where an int is more than 32-bits.

	 * We avoid caching unsigned integers as we cannot distinguish between
	 * 32bit signed and unsigned in the hash (short and char are ok).
	 */

	if (flags & BINARY_UNSIGNED) {
	    return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value);
	}
	if ((value & (((unsigned) 1)<<31)) && (value > 0)) {
	    value -= (((unsigned) 1)<<31);
	    value -= (((unsigned) 1)<<31);
	}

    returnNumericObject:
	if (*numberCachePtrPtr == NULL) {
	    return Tcl_NewWideIntObj(value);
	} else {
	    register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
................................................................................
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    data = TclGetByteArrayFromObj(objv[1], &count);
    cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
    for (offset = 0; offset < count; ++offset) {
	*cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)];
	*cursor++ = HexDigits[(data[offset] & 0x0f)];
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
    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;
    }
    for (i = 1; i < objc-1; ++i) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_STRICT:
	    strict = 1;
	    break;
	}
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
	    TclGetStringFromObj(objv[objc-1], &count);
    dataend = data + count;
    size = (count + 1) / 2;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {
	value = 0;
	for (i=0 ; i<2 ; i++) {
	    if (data >= dataend) {
		value <<= 4;
		break;
	    }

	    c = *data++;
	    if (!isxdigit(UCHAR(c))) {
................................................................................
	    c -= '0';
	    if (c > 9) {
		c += ('0' - 'A') + 10;
	    }
	    if (c > 16) {
		c += ('A' - 'a');
	    }
	    value |= (c & 0xf);
	}
	if (i < 2) {
	    cut++;
	}
	*cursor++ = UCHAR(value);
	value = 0;
    }
................................................................................
    Tcl_Obj *resultObj;
    unsigned char *data, *cursor, *limit;
    int maxlen = 0;
    const char *wrapchar = "\n";
    size_t wrapcharlen = 1;
    int i, index, size, outindex = 0;
    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", -1));
		Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
			"LINE_LENGTH", NULL);
		return TCL_ERROR;
	    }
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = TclGetStringFromObj(objv[i+1], &wrapcharlen);
	    if (wrapcharlen == 0) {
		maxlen = 0;
	    }
	    break;
	}
    }

    resultObj = Tcl_NewObj();
    data = TclGetByteArrayFromObj(objv[objc-1], &count);
    if (count > 0) {
	size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */
	if (maxlen > 0 && size > maxlen) {
	    int adjusted = size + (wrapcharlen * (size / maxlen));

	    if (size % maxlen == 0) {
		adjusted -= wrapcharlen;
	    }
	    size = adjusted;
	}
	cursor = Tcl_SetByteArrayLength(resultObj, size);
	limit = cursor + size;
	for (offset = 0; offset < count; offset+=3) {
	    unsigned char d[3] = {0, 0, 0};

	    for (i = 0; i < 3 && offset+i < count; ++i) {
		d[i] = data[offset + i];
	    }
	    OUTPUT(B64Digits[d[0] >> 2]);
	    OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
	    if (offset+1 < count) {
		OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
	    } else {
		OUTPUT(B64Digits[64]);
	    }
	    if (offset+2 < count) {
		OUTPUT(B64Digits[d[2] & 0x3f]);
	    } else {
................................................................................
    int lineLength = 61;
    const unsigned char SingleNewline[] = { (unsigned char) '\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;
    }
    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], &lineLength) != TCL_OK) {

		return TCL_ERROR;
	    }
	    if (lineLength < 3 || 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;
	    }
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = TclGetByteArrayFromObj(objv[i+1], &wrapcharlen);
	    break;
	}
    }

    /*
     * Allocate the buffer. This is a little bit too long, but is "good
     * enough".
     */

    resultObj = Tcl_NewObj();
    offset = 0;
    data = TclGetByteArrayFromObj(objv[objc-1], &count);
    rawLength = (lineLength - 1) * 3 / 4;
    start = cursor = Tcl_SetByteArrayLength(resultObj,
	    (lineLength + wrapcharlen) *
	    ((count + (rawLength - 1)) / rawLength));
    n = bits = 0;

    /*
................................................................................
    while (offset < count) {
	int lineLen = count - offset;

	if (lineLen > rawLength) {
	    lineLen = rawLength;
	}
	*cursor++ = UueDigits[lineLen];
	for (i=0 ; i<lineLen ; i++) {
	    n <<= 8;
	    n |= data[offset++];
	    for (bits += 8; bits > 6 ; bits -= 6) {
		*cursor++ = UueDigits[(n >> (bits-6)) & 0x3f];
	    }
	}
	if (bits > 0) {
	    n <<= 8;
	    *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f];
	    bits = 0;
	}
	for (j=0 ; j<wrapcharlen ; ++j) {
	    *cursor++ = wrapchar[j];
	}
    }

    /*
     * Fix the length of the output bytearray.
     */

    Tcl_SetByteArrayLength(resultObj, cursor-start);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor;
    int i, index, size, strict = 0, lineLen;
    size_t count = 0;
    unsigned char c;
    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;
    }
    for (i = 1; i < objc-1; ++i) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_STRICT:
	    strict = 1;
	    break;
	}
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
	    TclGetStringFromObj(objv[objc-1], &count);
    dataend = data + count;
    size = ((count + 3) & ~3) * 3 / 4;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    lineLen = -1;

    /*
     * The decoding loop. First, we get the length of line (strictly, the
................................................................................
	    lineLen = (c - 32) & 0x3f;
	}

	/*
	 * Now we read a four-character grouping.
	 */

	for (i=0 ; i<4 ; i++) {
	    if (data < dataend) {
		d[i] = c = *data++;
		if (c < 32 || c > 96) {
		    if (strict) {
			if (!TclIsSpaceProc(c)) {
			    goto badUu;
			} else if (c == '\n') {
................................................................................
    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;
    }
    for (i = 1; i < objc-1; ++i) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_STRICT:
	    strict = 1;
	    break;
	}
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
	    TclGetStringFromObj(objv[objc-1], &count);
    dataend = data + count;
    size = ((count + 3) & ~3) * 3 / 4;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {
	unsigned long value = 0;

	/*
................................................................................

	    if (data < dataend) {
		c = *data++;
	    } else if (i > 1) {
		c = '=';
	    } else {
		if (strict && i <= 1) {

		    /* single resp. unfulfilled char (each 4th next single char)
		     * is rather bad64 error case in strict mode */


		    goto bad64;
		}
		cut += 3;
		break;
	    }

	    /*
................................................................................
	     * because they're only valid as the last character or two of the
	     * final block of input. Unless strict mode is enabled, skip any
	     * input whitespace characters.
	     */

	    if (cut) {
		if (c == '=' && i > 1) {
		     value <<= 6;
		     cut++;
		} else if (!strict && TclIsSpaceProc(c)) {
		     i--;
		} else {
		    goto bad64;
		}
	    } else if (c >= 'A' && c <= 'Z') {
		value = (value << 6) | ((c - 'A') & 0x3f);
	    } else if (c >= 'a' && c <= 'z') {
		value = (value << 6) | ((c - 'a' + 26) & 0x3f);
	    } else if (c >= '0' && c <= '9') {
		value = (value << 6) | ((c - '0' + 52) & 0x3f);
	    } else if (c == '+') {
		value = (value << 6) | 0x3e;
	    } else if (c == '/') {
		value = (value << 6) | 0x3f;
	    } else if (c == '=' && (

		!strict || i > 1) /* "=" and "a=" is rather bad64 error case in strict mode */
	    ) {


		value <<= 6;
		if (i) cut++;


	    } else if (strict || !TclIsSpaceProc(c)) {
		goto bad64;
	    } else {
		i--;
	    }
	}
	*cursor++ = UCHAR((value >> 16) & 0xff);
................................................................................
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|
|
|
|

|
|
|

|
|
|
|
|
|
|
|



|
|
|
|
|

|
|
|
|
|
<

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



|
|
|
<
|
|
|
|
|
|
|

|
|

<
>
|
<
|
|
|
|
|
|

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







 







|







 







|
|

|







 







>



>




|







 







>
|
>
>




>
|
>
>








>
|
>
>







 







|







 







|
|
|







 







|







 







|







 







|







 







>












|







 







|
|
|







 







>







|
|
|







 







|
|







 







|













|





|







 







|







 







|


|




|






|











|








|

|










|


|




|







 







|




|






|
>











|











|







 







|



|







|








|







 







|






|













|







 







|







 







|













|







 







>
|
|
>
>







 







|
|

|













|
>
|
<
>
>

|
>
>







 







<
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
219
220
221

222
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
...
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
...
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
...
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
...
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
...
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
....
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
....
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
....
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
....
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
....
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
....
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
....
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
....
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
....
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
2533
2534
2535
2536
2537
2538
2539
2540
....
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
....
2621
2622
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
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
2687
2688
2689
2690
2691
2692
....
2731
2732
2733
2734
2735
2736
2737
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
2782
....
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
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
....
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
2875
2876
2877
2878
2879
....
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
....
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
....
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
....
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
....
3150
3151
3152
3153
3154
3155
3156

    { "hex",      BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    { "uuencode", BinaryDecodeUu,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    { "base64",   BinaryDecode64,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
    { NULL, NULL, NULL, NULL, NULL, 0 }
};

/*
 * The following object types represent an array of bytes. The intent is to
 * allow arbitrary binary data to pass through Tcl as a Tcl value without loss
 * or damage. Such values are useful for things like encoded strings or Tk
 * images to name just two.
 *
 * It's strange to have two Tcl_ObjTypes in place for this task when one would
 * do, so a bit of detail and history how we got to this point and where we
 * might go from here.
 *
 * A bytearray is an ordered sequence of bytes. Each byte is an integer value
 * in the range [0-255].  To be a Tcl value type, we need a way to encode each
 * value in the value set as a Tcl string.  The simplest encoding is to
 * represent each byte value as the same codepoint value.  A bytearray of N
 * bytes is encoded into a Tcl string of N characters where the codepoint of
 * each character is the value of corresponding byte.  This approach creates a
 * one-to-one map between all bytearray values and a subset of Tcl string
 * values.
 *
 * When converting a Tcl string value to the bytearray internal rep, the
 * question arises what to do with strings outside that subset?  That is,
 * those Tcl strings containing at least one codepoint greater than 255?  The
 * obviously correct answer is to raise an error!  That string value does not
 * represent any valid bytearray value. Full Stop.  The setFromAnyProc
 * signature has a completion code return value for just this reason, to
 * reject invalid inputs.
 *
 * Unfortunately this was not the path taken by the authors of the original
 * tclByteArrayType.  They chose to accept all Tcl string values as acceptable
 * string encodings of the bytearray values that result from masking away the
 * high bits of any codepoint value at all. This meant that every bytearray
 * value had multiple accepted string representations.

 *
 * The implications of this choice are truly ugly.  When a Tcl value has a
 * string representation, we are required to accept that as the true value.
 * Bytearray values that possess a string representation cannot be processed
 * as bytearrays because we cannot know which true value that bytearray
 * represents.  The consequence is that we drag around an internal rep that we
 * cannot make any use of.  This painful price is extracted at any point after

 * a string rep happens to be generated for the value.  This happens even when
 * the troublesome codepoints outside the byte range never show up.  This
 * happens rather routinely in normal Tcl operations unless we burden the
 * script writer with the cognitive burden of avoiding it.  The price is also
 * paid by callers of the C interface.  The routine
 *
 *	unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr)
 *
 * has a guarantee to always return a non-NULL value, but that value points to
 * a byte sequence that cannot be used by the caller to process the Tcl value
 * absent some sideband testing that objPtr is "pure".  Tcl offers no public

 * interface to perform this test, so callers either break encapsulation or
 * are unavoidably buggy.  Tcl has defined a public interface that cannot be
 * used correctly. The Tcl source code itself suffers the same problem, and
 * has been buggy, but progressively less so as more and more portions of the
 * code have been retrofitted with the required "purity testing".  The set of
 * values able to pass the purity test can be increased via the introduction
 * of a "canonical" flag marker, but the only way the broken interface itself
 * can be discarded is to start over and define the Tcl_ObjType properly.
 * Bytearrays should simply be usable as bytearrays without a kabuki dance of
 * testing.
 *

 * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation
 * of bytearrays.  Any Tcl value with the type properByteArrayType can have

 * its bytearray value fetched and used with confidence that acting on that
 * value is equivalent to acting on the true Tcl string value.  This still
 * implies a side testing burden -- past mistakes will not let us avoid that
 * immediately, but it is at least a conventional test of type, and can be
 * implemented entirely by examining the objPtr fields, with no need to query
 * the intrep, as a canonical flag would require.
 *
 * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised
 * to admit the possibility of returning NULL when the true value is not a
 * valid bytearray, we need a mechanism to retain compatibility with the
 * deployed callers of the broken interface.  That's what the retained
 * "tclByteArrayType" provides.  In those unusual circumstances where we
 * convert an invalid bytearray value to a bytearray type, it is to this

 * legacy type.  Essentially any time this legacy type gets used, it's a
 * signal of a bug being ignored.  A TIP should be drafted to remove this
 * connection to the broken past so that Tcl 9 will no longer have any trace
 * of it.  Prescribing a migration path will be the key element of that work.
 * The internal changes now in place are the limit of what can be done short
 * of interface repair.  They provide a great expansion of the histories over
 * which bytearray values can be useful in the meanwhile.
 */

static const Tcl_ObjType properByteArrayType = {
    "bytearray",
    FreeProperByteArrayInternalRep,
    DupProperByteArrayInternalRep,
    UpdateStringOfByteArray,
................................................................................
				 * minus 1 byte. */
    unsigned char bytes[1];	/* 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))
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
		(irPtr)->twoPtrValue.ptr1 = (baPtr)
 
int
TclIsPureByteArray(
    Tcl_Obj * objPtr)
................................................................................
 *
 *----------------------------------------------------------------------
 */

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 length > 0. */
    size_t length)			/* Length of the array of bytes, which must
				 * be >= 0. */
{
    ByteArray *byteArrayPtr;
    Tcl_ObjIntRep ir;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
    }
................................................................................
	if ((src[i] == 0) || (src[i] > 127)) {
	    size++;
	}
    }

    if (size == length) {
	char *dst = Tcl_InitStringRep(objPtr, (char *)src, size);

	TclOOM(dst, size);
    } else {
	char *dst = Tcl_InitStringRep(objPtr, NULL, size);

	TclOOM(dst, size);
	for (i = 0; i < length; i++) {
	    dst += Tcl_UniCharToUtf(src[i], dst);
	}
	(void) Tcl_InitStringRep(objPtr, NULL, size);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclAppendBytesToByteArray --
................................................................................
     */

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

	if (needed <= INT_MAX/2) {
	    /*
	     * Try to allocate double the total space that is needed.
	     */

	    attempt = 2 * needed;
	    ptr = Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
	}
	if (ptr == NULL) {
	    /*
	     * Try to allocate double the increment that is needed (plus).
	     */

	    size_t limit = UINT_MAX - needed;
	    size_t extra = len + TCL_MIN_GROWTH;
	    size_t growth = (extra > limit) ? limit : extra;

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

	    attempt = needed;
	    ptr = Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
	}
	byteArrayPtr = ptr;
	byteArrayPtr->allocated = attempt;
	SET_BYTEARRAY(irPtr, byteArrayPtr);
    }
................................................................................
    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;
................................................................................
     */

    resultPtr = Tcl_NewObj();
    buffer = Tcl_SetByteArrayLength(resultPtr, length);
    memset(buffer, 0, length);

    /*
     * Pack the data into the result object. Note that we can skip the error
     * checking during this pass, since we have already parsed the string
     * once.
     */

    arg = 2;
    format = TclGetString(objv[1]);
    cursor = buffer;
    maxPos = cursor;
    while (*format != 0) {
................................................................................
		TclListObjGetElements(interp, objv[arg], &listc, &listv);
		if (count == BINARY_ALL) {
		    count = listc;
		}
	    }
	    arg++;
	    for (i = 0; (size_t)i < count; i++) {
		if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) {
		    Tcl_DecrRefCount(resultPtr);
		    return TCL_ERROR;
		}
	    }
	    break;
	}
	case 'x':
................................................................................
    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;
    int offset, size;
    size_t length = 0;
................................................................................

	    /*
	     * Trim trailing nulls and spaces, if necessary.
	     */

	    if (cmd == 'A') {
		while (size > 0) {
		    if (src[size - 1] != '\0' && src[size - 1] != ' ') {
			break;
		    }
		    size--;
		}
	    }

	    /*
................................................................................
	 * Single-precision floating point values. Tcl_GetDoubleFromObj
	 * returns TCL_ERROR for NaN, but we can check by comparing the
	 * object's type pointer.
	 */

	if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
	    const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType);

	    if (irPtr == NULL) {
		return TCL_ERROR;
	    }
	    dvalue = irPtr->doubleValue;
	}

	/*
	 * Because some compilers will generate floating point exceptions on
	 * an overflow cast (e.g. Borland), we restrict the values to the
	 * valid range for float.
	 */

	if (fabs(dvalue) > (double) FLT_MAX) {
	    fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
	} else {
	    fvalue = (float) dvalue;
	}
	CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
	*cursorPtr += sizeof(float);
	return TCL_OK;
................................................................................

static Tcl_Obj *
ScanNumber(
    unsigned char *buffer,	/* Buffer to scan number from. */
    int type,			/* Format character from "binary scan" */
    int flags,			/* Format field flags */
    Tcl_HashTable **numberCachePtrPtr)
				/* Place to look for cache of scanned value
				 * objects, or NULL if too many different
				 * numbers have been scanned. */
{
    long value;
    float fvalue;
    double dvalue;
    Tcl_WideUInt uwvalue;

    /*
................................................................................
		    + (buffer[1] << 16)
		    + (((long) buffer[0]) << 24));
	}

	/*
	 * Check to see if the value was sign extended properly on systems
	 * where an int is more than 32-bits.
	 *
	 * We avoid caching unsigned integers as we cannot distinguish between
	 * 32bit signed and unsigned in the hash (short and char are ok).
	 */

	if (flags & BINARY_UNSIGNED) {
	    return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value);
	}
	if ((value & (((unsigned) 1) << 31)) && (value > 0)) {
	    value -= (((unsigned) 1) << 31);
	    value -= (((unsigned) 1) << 31);
	}

    returnNumericObject:
	if (*numberCachePtrPtr == NULL) {
	    return Tcl_NewWideIntObj(value);
	} else {
	    register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
................................................................................
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    data = TclGetByteArrayFromObj(objv[1], &count);
    cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
    for (offset = 0; offset < count; ++offset) {
	*cursor++ = HexDigits[(data[offset] >> 4) & 0x0f];
	*cursor++ = HexDigits[data[offset] & 0x0f];
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
    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;
    }
    for (i = 1; i < objc - 1; ++i) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_STRICT:
	    strict = 1;
	    break;
	}
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
	    TclGetStringFromObj(objv[objc - 1], &count);
    dataend = data + count;
    size = (count + 1) / 2;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {
	value = 0;
	for (i = 0 ; i < 2 ; i++) {
	    if (data >= dataend) {
		value <<= 4;
		break;
	    }

	    c = *data++;
	    if (!isxdigit(UCHAR(c))) {
................................................................................
	    c -= '0';
	    if (c > 9) {
		c += ('0' - 'A') + 10;
	    }
	    if (c > 16) {
		c += ('A' - 'a');
	    }
	    value |= c & 0xf;
	}
	if (i < 2) {
	    cut++;
	}
	*cursor++ = UCHAR(value);
	value = 0;
    }
................................................................................
    Tcl_Obj *resultObj;
    unsigned char *data, *cursor, *limit;
    int maxlen = 0;
    const char *wrapchar = "\n";
    size_t wrapcharlen = 1;
    int i, index, size, outindex = 0;
    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", -1));
		Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
			"LINE_LENGTH", NULL);
		return TCL_ERROR;
	    }
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
	    if (wrapcharlen == 0) {
		maxlen = 0;
	    }
	    break;
	}
    }

    resultObj = Tcl_NewObj();
    data = TclGetByteArrayFromObj(objv[objc - 1], &count);
    if (count > 0) {
	size = (((count * 4) / 3) + 3) & ~3;	/* ensure 4 byte chunks */
	if (maxlen > 0 && size > maxlen) {
	    int adjusted = size + (wrapcharlen * (size / maxlen));

	    if (size % maxlen == 0) {
		adjusted -= wrapcharlen;
	    }
	    size = adjusted;
	}
	cursor = Tcl_SetByteArrayLength(resultObj, size);
	limit = cursor + size;
	for (offset = 0; offset < count; offset += 3) {
	    unsigned char d[3] = {0, 0, 0};

	    for (i = 0; i < 3 && offset + i < count; ++i) {
		d[i] = data[offset + i];
	    }
	    OUTPUT(B64Digits[d[0] >> 2]);
	    OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
	    if (offset + 1 < count) {
		OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
	    } else {
		OUTPUT(B64Digits[64]);
	    }
	    if (offset+2 < count) {
		OUTPUT(B64Digits[d[2] & 0x3f]);
	    } else {
................................................................................
    int lineLength = 61;
    const unsigned char SingleNewline[] = { (unsigned char) '\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;
    }
    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],
		    &lineLength) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (lineLength < 3 || 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;
	    }
	    break;
	case OPT_WRAPCHAR:
	    wrapchar = TclGetByteArrayFromObj(objv[i + 1], &wrapcharlen);
	    break;
	}
    }

    /*
     * Allocate the buffer. This is a little bit too long, but is "good
     * enough".
     */

    resultObj = Tcl_NewObj();
    offset = 0;
    data = TclGetByteArrayFromObj(objv[objc - 1], &count);
    rawLength = (lineLength - 1) * 3 / 4;
    start = cursor = Tcl_SetByteArrayLength(resultObj,
	    (lineLength + wrapcharlen) *
	    ((count + (rawLength - 1)) / rawLength));
    n = bits = 0;

    /*
................................................................................
    while (offset < count) {
	int lineLen = count - offset;

	if (lineLen > rawLength) {
	    lineLen = rawLength;
	}
	*cursor++ = UueDigits[lineLen];
	for (i = 0 ; i < lineLen ; i++) {
	    n <<= 8;
	    n |= data[offset++];
	    for (bits += 8; bits > 6 ; bits -= 6) {
		*cursor++ = UueDigits[(n >> (bits - 6)) & 0x3f];
	    }
	}
	if (bits > 0) {
	    n <<= 8;
	    *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f];
	    bits = 0;
	}
	for (j = 0 ; j < wrapcharlen ; ++j) {
	    *cursor++ = wrapchar[j];
	}
    }

    /*
     * Fix the length of the output bytearray.
     */

    Tcl_SetByteArrayLength(resultObj, cursor - start);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor;
    int i, index, size, strict = 0, lineLen;
    size_t count = 0;
    unsigned char c;
    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;
    }
    for (i = 1; i < objc - 1; ++i) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_STRICT:
	    strict = 1;
	    break;
	}
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
	    TclGetStringFromObj(objv[objc - 1], &count);
    dataend = data + count;
    size = ((count + 3) & ~3) * 3 / 4;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    lineLen = -1;

    /*
     * The decoding loop. First, we get the length of line (strictly, the
................................................................................
	    lineLen = (c - 32) & 0x3f;
	}

	/*
	 * Now we read a four-character grouping.
	 */

	for (i = 0 ; i < 4 ; i++) {
	    if (data < dataend) {
		d[i] = c = *data++;
		if (c < 32 || c > 96) {
		    if (strict) {
			if (!TclIsSpaceProc(c)) {
			    goto badUu;
			} else if (c == '\n') {
................................................................................
    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;
    }
    for (i = 1; i < objc - 1; ++i) {
	if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case OPT_STRICT:
	    strict = 1;
	    break;
	}
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
	    TclGetStringFromObj(objv[objc - 1], &count);
    dataend = data + count;
    size = ((count + 3) & ~3) * 3 / 4;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {
	unsigned long value = 0;

	/*
................................................................................

	    if (data < dataend) {
		c = *data++;
	    } else if (i > 1) {
		c = '=';
	    } else {
		if (strict && i <= 1) {
		    /*
		     * Single resp. unfulfilled char (each 4th next single
		     * char) is rather bad64 error case in strict mode.
		     */

		    goto bad64;
		}
		cut += 3;
		break;
	    }

	    /*
................................................................................
	     * because they're only valid as the last character or two of the
	     * final block of input. Unless strict mode is enabled, skip any
	     * input whitespace characters.
	     */

	    if (cut) {
		if (c == '=' && i > 1) {
		    value <<= 6;
		    cut++;
		} else if (!strict && TclIsSpaceProc(c)) {
		    i--;
		} else {
		    goto bad64;
		}
	    } else if (c >= 'A' && c <= 'Z') {
		value = (value << 6) | ((c - 'A') & 0x3f);
	    } else if (c >= 'a' && c <= 'z') {
		value = (value << 6) | ((c - 'a' + 26) & 0x3f);
	    } else if (c >= '0' && c <= '9') {
		value = (value << 6) | ((c - '0' + 52) & 0x3f);
	    } else if (c == '+') {
		value = (value << 6) | 0x3e;
	    } else if (c == '/') {
		value = (value << 6) | 0x3f;
	    } else if (c == '=' && (!strict || i > 1)) {
		/*
		 * "=" and "a=" is rather bad64 error case in strict mode.

		 */

		value <<= 6;
		if (i) {
		    cut++;
		}
	    } else if (strict || !TclIsSpaceProc(c)) {
		goto bad64;
	    } else {
		i--;
	    }
	}
	*cursor++ = UCHAR((value >> 16) & 0xff);
................................................................................
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclCkalloc.c.

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
    size_t refCount;		/* Number of mem_headers referencing this
				 * tag. */
    char string[1];		/* Actual size of string will be as large as
				 * needed for actual tag. This must be the
				 * last field in the structure. */
} MemTag;

#define TAG_SIZE(bytesInString) ((TclOffset(MemTag, string) + 1) + bytesInString)

static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
				 * by "memory tag" command). */

/*
 * One of the following structures is allocated just before each dynamically
 * allocated chunk of memory, both to record information about the chunk and






|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
    size_t refCount;		/* Number of mem_headers referencing this
				 * tag. */
    char string[1];		/* Actual size of string will be as large as
				 * needed for actual tag. This must be the
				 * last field in the structure. */
} MemTag;

#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1) + bytesInString)

static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
				 * by "memory tag" command). */

/*
 * One of the following structures is allocated just before each dynamically
 * allocated chunk of memory, both to record information about the chunk and

Changes to generic/tclCmdAH.c.

952
953
954
955
956
957
958

959
960
961
962
963
964
965
	{"rootname",	PathRootNameCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{"separator",	FilesystemSeparatorCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
	{"size",	FileAttrSizeCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{"split",	PathSplitCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"stat",	FileAttrStatCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 1},
	{"system",	PathFilesystemCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
	{"tail",	PathTailCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 1},

	{"tempfile",	TclFileTemporaryCmd,	TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
	{"type",	FileAttrTypeCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{"volumes",	FilesystemVolumesCmd,	TclCompileBasic0ArgCmd, NULL, NULL, 1},
	{"writable",	FileAttrIsWritableCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{NULL, NULL, NULL, NULL, NULL, 0}
    };
    return TclMakeEnsemble(interp, "file", initMap);






>







952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
	{"rootname",	PathRootNameCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{"separator",	FilesystemSeparatorCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
	{"size",	FileAttrSizeCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{"split",	PathSplitCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"stat",	FileAttrStatCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 1},
	{"system",	PathFilesystemCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
	{"tail",	PathTailCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{"tempdir",	TclFileTempDirCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
	{"tempfile",	TclFileTemporaryCmd,	TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
	{"type",	FileAttrTypeCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{"volumes",	FilesystemVolumesCmd,	TclCompileBasic0ArgCmd, NULL, NULL, 1},
	{"writable",	FileAttrIsWritableCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 1},
	{NULL, NULL, NULL, NULL, NULL, 0}
    };
    return TclMakeEnsemble(interp, "file", initMap);

Changes to generic/tclCmdMZ.c.

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
...
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
...
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
405
...
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
...
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
...
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
...
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
...
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
....
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
....
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
....
2020
2021
2022
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

2057
2058
2059
2060
2061
2062
2063
....
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
....
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
....
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
....
4195
4196
4197
4198
4199
4200
4201

4202
4203
4204
4205
4206
4207
4208
....
4379
4380
4381
4382
4383
4384
4385









4386
4387
4388
4389
4390
4391
4392
....
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
....
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
....
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
....
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
....
4667
4668
4669
4670
4671
4672
4673





4674
4675
4676
4677
4678
4679
4680
int
Tcl_RegexpObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t offset;
    int i, indices, match, about, all, doinline, numMatchesSaved;
    int cflags, eflags, stringLength, matchLength;
    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",
	"-nocase",	"-start",	"--",		NULL
................................................................................
	 * 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 > (size_t)stringLength + 1) {
	    eflags = TCL_REG_NOTBOL;
	} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
	    eflags = 0;
	} else {
	    eflags = TCL_REG_NOTBOL;
	}

................................................................................
		resultPtr = Tcl_NewObj();
	    }
	}
	for (i = 0; i < objc; i++) {
	    Tcl_Obj *newPtr;

	    if (indices) {
		int 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 <= 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 ((size_t)end + 1 >= offset + 1) {
			end--;
		    }
		} else {
		    start = -1;
		    end = -1;
		}

		objs[0] = Tcl_NewWideIntObj(start);
		objs[1] = Tcl_NewWideIntObj(end);

		newPtr = Tcl_NewListObj(2, objs);
	    } else {
		if (i <= info.nsubs) {
		    newPtr = Tcl_GetRange(objPtr,
			    offset + info.matches[i].start,
			    offset + info.matches[i].end - 1);
		} else {
		    newPtr = Tcl_NewObj();
		}
	    }
................................................................................
	 * these cases we always want to bump the index up one.
	 */

	if (matchLength == 0) {
	    offset++;
	}
	all++;
	if (offset + 1 >= (size_t)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
................................................................................
int
Tcl_RegsubObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int idx, result, cflags, all, numMatches;
    size_t wlen, wsublen = 0, offset;
    int start, end, subStart, subEnd, match, command, numParts;
    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",
................................................................................

    cflags = TCL_REG_ADVANCED;
    all = 0;
    offset = TCL_INDEX_START;
    command = 0;
    resultPtr = NULL;

    for (idx = 1; idx < objc; idx++) {
	const char *name;
	int index;

	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
................................................................................
	    cflags |= TCL_REG_NLSTOP;
	    break;
	case REGSUB_LINEANCHOR:
	    cflags |= TCL_REG_NLANCH;
	    break;
	case REGSUB_START: {
	    size_t temp;
	    if (++idx >= objc) {
		goto endOfForLoop;
	    }
	    if (TclGetIntForIndexM(interp, objv[idx], TCL_INDEX_START, &temp) != TCL_OK) {
		goto optionError;
	    }
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
................................................................................
	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;
................................................................................
	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
	    stringPtr = p + 1;
	}
	TclNewStringObj(objPtr, stringPtr, end - stringPtr);
	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    } else {
	const char *element, *p, *splitEnd;
	int splitLen;
	Tcl_UniChar splitChar = 0;

	/*
	 * Normal case: split on any of a given set of characters. Discard
	 * instances of the split characters.
	 */

................................................................................
static int
StringMapCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    size_t length1, length2;
    int 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");
................................................................................
	Tcl_DictSearch search;

	/*
	 * We know the type exactly, so all dict operations will succeed for
	 * sure. This shortens this code quite a bit.
	 */

	Tcl_DictObjSize(interp, objv[objc-2], &mapElemc);
	if (mapElemc == 0) {
	    /*
	     * Empty charMap, just return whatever string was given.
	     */

	    Tcl_SetObjResult(interp, objv[objc-1]);
	    return TCL_OK;
	}

	mapElemc *= 2;
	mapWithDict = 1;

	/*
	 * Copy the dictionary out into an array; that's the easiest way to
	 * adapt this code...
	 */

	mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
	Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
		mapElemv+1, &done);
	for (i=2 ; i<mapElemc ; i+=2) {
	    Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
	}
	Tcl_DictObjDone(&search);
    } else {

	if (TclListObjGetElements(interp, objv[objc-2], &mapElemc,
		&mapElemv) != TCL_OK) {
	    return TCL_ERROR;
	}

	if (mapElemc == 0) {
	    /*
	     * empty charMap, just return whatever string was given.
	     */

	    Tcl_SetObjResult(interp, objv[objc-1]);
	    return TCL_OK;
................................................................................
int
TclNRSwitchObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i,j, index, mode, foundmode, splitObjs, numMatchesSaved;
    int noCase;
    size_t patternLength;
    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. */
................................................................................
	    TclNewObj(indicesObj);
	}

	for (j=0 ; j<=info.nsubs ; j++) {
	    if (indexVarObj != NULL) {
		Tcl_Obj *rangeObjAry[2];

		if (info.matches[j].end > 0) {
		    rangeObjAry[0] = Tcl_NewWideIntObj(info.matches[j].start);
		    rangeObjAry[1] = Tcl_NewWideIntObj(info.matches[j].end-1);
		} else {
		    rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1);
		}

		/*
		 * Never fails; the object is always clean at this point.
		 */
................................................................................
	    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");
	}
................................................................................
	"-direct",	"-overhead",	"-calibrate",	"--",	NULL
    };
    enum options {
	TMRT_EV_DIRECT,	TMRT_OVERHEAD,	TMRT_CALIBRATE,	TMRT_LAST
    };
    NRE_callback *rootPtr;
    ByteCode *codePtr = NULL;


    for (i = 1; i < objc - 1; i++) {
	int index;

	if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
		&index) != TCL_OK) {
	    break;
................................................................................

    if (!direct) {
	if (TclInterpReady(interp) != TCL_OK) {
	    return TCL_ERROR;
	}
	codePtr = TclCompileObj(interp, objPtr, NULL, 0);
	TclPreserveByteCode(codePtr);









    }

    /*
     * Get start and stop time.
     */

#ifdef TCL_WIDE_CLICKS
................................................................................
	    if (!direct) {		/* precompiled */
		rootPtr = TOP_CB(interp);
		result = TclNRExecuteByteCode(interp, codePtr);
		result = TclNRRunCallbacks(interp, result, rootPtr);
	    } else {			/* eval */
		result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
	    }
	    if (result != TCL_OK) {
		/*
		 * Allow break from measurement cycle (used for conditional
		 * stop).

		 */

		if (result != TCL_BREAK) {

		    goto done;
		}


		/*
		 * Force stop immediately.
		 */

		threshold = 1;
		maxcnt = 0;

		result = TCL_OK;



	    }

	    /*
	     * Don't check time up to threshold.
	     */

	    if (--threshold > 0) {
................................................................................
		threshold = maxcnt - count;
	    }
	}
    }

    {
	Tcl_Obj *objarr[8], **objs = objarr;
	Tcl_WideInt val;
	int digits;


	middle -= start;		/* execution time in microsecs */



#ifdef TCL_WIDE_CLICKS
	/*
	 * convert execution time in wide clicks to microsecs.
	 */

	middle *= TclpWideClickInMicrosec();
#endif /* TCL_WIDE_CLICKS */

	if (!count) {		/* no iterations - avoid divide by zero */
	    objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
	    goto retRes;
	}

................................................................................
	    if (overhead > 0) {
		/*
		 * Estimate the time of overhead (microsecs).
		 */

		Tcl_WideUInt curOverhead = overhead * count;

		if (middle > (Tcl_WideInt) curOverhead) {
		    middle -= curOverhead;
		} else {
		    middle = 0;
		}
	    }
	} else {
	    /*
	     * Calibration: obtaining new measurement overhead.
	     */

	    if (measureOverhead > ((double) middle) / count) {
		measureOverhead = ((double) middle) / count;
	    }
	    objs[0] = Tcl_NewDoubleObj(measureOverhead);
	    TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
	    objs += 2;
	}

	val = middle / count;		/* microsecs per iteration */
	if (val >= 1000000) {
	    objs[0] = Tcl_NewWideIntObj(val);
	} else {
	    if (val < 10) {
		digits = 6;
	    } else if (val < 100) {
		digits = 4;
................................................................................
	    } else if (val < 1000) {
		digits = 3;
	    } else if (val < 10000) {
		digits = 2;
	    } else {
		digits = 1;
	    }
	    objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) middle)/count);
	}

	objs[2] = Tcl_NewWideIntObj(count); /* iterations */

	/*
	 * Calculate speed as rate (count) per sec
	 */

	if (!middle) {
	    middle++;			/* Avoid divide by zero. */
	}
	if (count < (WIDE_MAX / 1000000)) {
	    val = (count * 1000000) / middle;
	    if (val < 100000) {
		if (val < 100) {
		    digits = 3;
		} else if (val < 1000) {
		    digits = 2;
		} else {
		    digits = 1;
		}
		objs[4] = Tcl_ObjPrintf("%.*f",
			digits, ((double) (count * 1000000)) / middle);
	    } else {
		objs[4] = Tcl_NewWideIntObj(val);
	    }
	} else {
	    objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000);
	}

    retRes:
	/*
	 * Estimated net execution time (in millisecs).
	 */

	if (!calibrate) {
	    if (middle >= 1) {
		objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000);
	    } else {
		objs[6] = Tcl_NewWideIntObj(0);
	    }
	    TclNewLiteralStringObj(objs[7], "nett-ms");
	}

	/*
	 * Construct the result as a list because many programs have always
	 * parsed as such (extracting the first element, typically).
	 */

................................................................................
	TclNewLiteralStringObj(objs[3], "#");
	TclNewLiteralStringObj(objs[5], "#/sec");
	Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
    }

  done:
    if (codePtr != NULL) {





	TclReleaseByteCode(codePtr);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------






|

<







 







|







 







|







|








|



|
|


|
|



|







 







|







 







|
|
|







 







|







 







|







 







|







 







|







 







|
<







 







|
|








|










|
|



>
|



>







 







|

|







 







|
|
|







 







|







 







>







 







>
>
>
>
>
>
>
>
>







 







<
|
|
<
>
|

|
>
|
<
<
>
|
|
|
<
|
|
>
|
>
>
>







 







|


>
|
>
>



|


|







 







|
|

|







|
|






|







 







|








|
|


|









|




|








|
|



|







 







>
>
>
>
>







123
124
125
126
127
128
129
130
131

132
133
134
135
136
137
138
...
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
...
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
...
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
...
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
...
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
...
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
...
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
....
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
....
1977
1978
1979
1980
1981
1982
1983
1984

1985
1986
1987
1988
1989
1990
1991
....
2018
2019
2020
2021
2022
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
2057
2058
2059
2060
2061
2062
2063
....
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
....
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
....
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
....
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
....
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
....
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
....
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
....
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
....
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
....
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
int
Tcl_RegexpObjCmd(
    ClientData dummy,		/* Not used. */
    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",
	"-nocase",	"-start",	"--",		NULL
................................................................................
	 * 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;
	}

................................................................................
		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;
		}

		objs[0] = TclNewWideIntObjFromSize(start);
		objs[1] = TclNewWideIntObjFromSize(end);

		newPtr = Tcl_NewListObj(2, objs);
	    } else {
		if (i <= (int)info.nsubs) {
		    newPtr = Tcl_GetRange(objPtr,
			    offset + info.matches[i].start,
			    offset + info.matches[i].end - 1);
		} else {
		    newPtr = Tcl_NewObj();
		}
	    }
................................................................................
	 * 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
................................................................................
int
Tcl_RegsubObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int result, cflags, all, match, command, numParts;
    size_t idx, wlen, wsublen = 0, offset, numMatches;
    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",
................................................................................

    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;
	int index;

	name = TclGetString(objv[idx]);
	if (name[0] != '-') {
	    break;
	}
................................................................................
	    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], TCL_INDEX_START, &temp) != TCL_OK) {
		goto optionError;
	    }
	    if (startIndex) {
		Tcl_DecrRefCount(startIndex);
................................................................................
	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;
................................................................................
	    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;
	Tcl_UniChar splitChar = 0;

	/*
	 * Normal case: split on any of a given set of characters. Discard
	 * instances of the split characters.
	 */

................................................................................
static int
StringMapCmd(
    ClientData dummy,		/* Not used. */
    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");
................................................................................
	Tcl_DictSearch search;

	/*
	 * We know the type exactly, so all dict operations will succeed for
	 * sure. This shortens this code quite a bit.
	 */

	Tcl_DictObjSize(interp, objv[objc-2], &i);
	if (i == 0) {
	    /*
	     * Empty charMap, just return whatever string was given.
	     */

	    Tcl_SetObjResult(interp, objv[objc-1]);
	    return TCL_OK;
	}

	mapElemc = 2 * i;
	mapWithDict = 1;

	/*
	 * Copy the dictionary out into an array; that's the easiest way to
	 * adapt this code...
	 */

	mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
	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 {
	int i;
	if (TclListObjGetElements(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;
................................................................................
int
TclNRSwitchObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, index, 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. */
................................................................................
	    TclNewObj(indicesObj);
	}

	for (j=0 ; j<=info.nsubs ; j++) {
	    if (indexVarObj != NULL) {
		Tcl_Obj *rangeObjAry[2];

		if (info.matches[j].end + 1 > 1) {
		    rangeObjAry[0] = TclNewWideIntObjFromSize(info.matches[j].start);
		    rangeObjAry[1] = TclNewWideIntObjFromSize(info.matches[j].end-1);
		} else {
		    rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1);
		}

		/*
		 * Never fails; the object is always clean at this point.
		 */
................................................................................
	    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");
	}
................................................................................
	"-direct",	"-overhead",	"-calibrate",	"--",	NULL
    };
    enum options {
	TMRT_EV_DIRECT,	TMRT_OVERHEAD,	TMRT_CALIBRATE,	TMRT_LAST
    };
    NRE_callback *rootPtr;
    ByteCode *codePtr = NULL;
    int codeOptimized = 0;

    for (i = 1; i < objc - 1; i++) {
	int index;

	if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
		&index) != TCL_OK) {
	    break;
................................................................................

    if (!direct) {
	if (TclInterpReady(interp) != TCL_OK) {
	    return TCL_ERROR;
	}
	codePtr = TclCompileObj(interp, objPtr, NULL, 0);
	TclPreserveByteCode(codePtr);
	/*
	 * Replace last compiled done instruction with continue: it's a part of
	 * iteration, this way evaluation will be more similar to a cycle (also
	 * avoids extra overhead to set result to interp, etc.)
	 */
	if (codePtr->codeStart[codePtr->numCodeBytes-1] == INST_DONE) {
	    codePtr->codeStart[codePtr->numCodeBytes-1] = INST_CONTINUE;
	    codeOptimized = 1;
	}
    }

    /*
     * Get start and stop time.
     */

#ifdef TCL_WIDE_CLICKS
................................................................................
	    if (!direct) {		/* precompiled */
		rootPtr = TOP_CB(interp);
		result = TclNRExecuteByteCode(interp, codePtr);
		result = TclNRRunCallbacks(interp, result, rootPtr);
	    } else {			/* eval */
		result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
	    }

	    /*
	     * Allow break and continue from measurement cycle (used for

	     * conditional stop and flow control of iterations).
	     */

	    switch (result) {
		case TCL_OK:
		    break;


		case TCL_BREAK:
		    /*
		     * Force stop immediately.
		     */

		    threshold = 1;
		    maxcnt = 0;
		case TCL_CONTINUE:
		    result = TCL_OK;
		    break;
		default:
		    goto done;
	    }

	    /*
	     * Don't check time up to threshold.
	     */

	    if (--threshold > 0) {
................................................................................
		threshold = maxcnt - count;
	    }
	}
    }

    {
	Tcl_Obj *objarr[8], **objs = objarr;
	Tcl_WideUInt usec, val;
	int digits;

	/*
	 * Absolute execution time in microseconds or in wide clicks.
	 */
	usec = (Tcl_WideUInt)(middle - start);

#ifdef TCL_WIDE_CLICKS
	/*
	 * convert execution time (in wide clicks) to microsecs.
	 */

	usec *= TclpWideClickInMicrosec();
#endif /* TCL_WIDE_CLICKS */

	if (!count) {		/* no iterations - avoid divide by zero */
	    objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
	    goto retRes;
	}

................................................................................
	    if (overhead > 0) {
		/*
		 * Estimate the time of overhead (microsecs).
		 */

		Tcl_WideUInt curOverhead = overhead * count;

		if (usec > curOverhead) {
		    usec -= curOverhead;
		} else {
		    usec = 0;
		}
	    }
	} else {
	    /*
	     * Calibration: obtaining new measurement overhead.
	     */

	    if (measureOverhead > ((double) usec) / count) {
		measureOverhead = ((double) usec) / count;
	    }
	    objs[0] = Tcl_NewDoubleObj(measureOverhead);
	    TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
	    objs += 2;
	}

	val = usec / count;		/* microsecs per iteration */
	if (val >= 1000000) {
	    objs[0] = Tcl_NewWideIntObj(val);
	} else {
	    if (val < 10) {
		digits = 6;
	    } else if (val < 100) {
		digits = 4;
................................................................................
	    } else if (val < 1000) {
		digits = 3;
	    } else if (val < 10000) {
		digits = 2;
	    } else {
		digits = 1;
	    }
	    objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count);
	}

	objs[2] = Tcl_NewWideIntObj(count); /* iterations */

	/*
	 * Calculate speed as rate (count) per sec
	 */

	if (!usec) {
	    usec++;			/* Avoid divide by zero. */
	}
	if (count < (WIDE_MAX / 1000000)) {
	    val = (count * 1000000) / usec;
	    if (val < 100000) {
		if (val < 100) {
		    digits = 3;
		} else if (val < 1000) {
		    digits = 2;
		} else {
		    digits = 1;
		}
		objs[4] = Tcl_ObjPrintf("%.*f",
			digits, ((double) (count * 1000000)) / usec);
	    } else {
		objs[4] = Tcl_NewWideIntObj(val);
	    }
	} else {
	    objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000);
	}

    retRes:
	/*
	 * Estimated net execution time (in millisecs).
	 */

	if (!calibrate) {
	    if (usec >= 1) {
		objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000);
	    } else {
		objs[6] = Tcl_NewWideIntObj(0);
	    }
	    TclNewLiteralStringObj(objs[7], "net-ms");
	}

	/*
	 * Construct the result as a list because many programs have always
	 * parsed as such (extracting the first element, typically).
	 */

................................................................................
	TclNewLiteralStringObj(objs[3], "#");
	TclNewLiteralStringObj(objs[5], "#/sec");
	Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
    }

  done:
    if (codePtr != NULL) {
	if ( codeOptimized
	  && codePtr->codeStart[codePtr->numCodeBytes-1] == INST_CONTINUE
	) {
	    codePtr->codeStart[codePtr->numCodeBytes-1] = INST_DONE;
	}
	TclReleaseByteCode(codePtr);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------

Changes to generic/tclCompile.c.

3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
    /*
     * Create a new variable if appropriate.
     */

    if (create || (name == NULL)) {
	localVar = procPtr->numCompiledLocals;
	localPtr = Tcl_Alloc(TclOffset(CompiledLocal, name) + nameBytes + 1);
	if (procPtr->firstLocalPtr == NULL) {
	    procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	} else {
	    procPtr->lastLocalPtr->nextPtr = localPtr;
	    procPtr->lastLocalPtr = localPtr;
	}
	localPtr->nextPtr = NULL;






|







3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
    /*
     * Create a new variable if appropriate.
     */

    if (create || (name == NULL)) {
	localVar = procPtr->numCompiledLocals;
	localPtr = Tcl_Alloc(offsetof(CompiledLocal, name) + nameBytes + 1);
	if (procPtr->firstLocalPtr == NULL) {
	    procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	} else {
	    procPtr->lastLocalPtr->nextPtr = localPtr;
	    procPtr->lastLocalPtr = localPtr;
	}
	localPtr->nextPtr = NULL;

Changes to generic/tclDecls.h.

1748
1749
1750
1751
1752
1753
1754
1755




1756
1757
1758
1759
1760
1761
1762
....
2428
2429
2430
2431
2432
2433
2434
2435

2436
2437
2438
2439
2440
2441
2442
....
3695
3696
3697
3698
3699
3700
3701


3702
3703
3704
3705
3706
3707
3708
/* 642 */
EXTERN void		Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
EXTERN int		Tcl_IsShared(Tcl_Obj *objPtr);
/* 644 */
EXTERN int		Tcl_LinkArray(Tcl_Interp *interp,
				const char *varName, void *addr, int type,
				int size);





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

................................................................................
    char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, size_t numBytes); /* 637 */
    Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
    void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
    int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
    void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
    void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
    int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
    int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */

} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
}
#endif
................................................................................
	(tclStubsPtr->tcl_IncrRefCount) /* 641 */
#define Tcl_DecrRefCount \
	(tclStubsPtr->tcl_DecrRefCount) /* 642 */
#define Tcl_IsShared \
	(tclStubsPtr->tcl_IsShared) /* 643 */
#define Tcl_LinkArray \
	(tclStubsPtr->tcl_LinkArray) /* 644 */



#endif /* defined(USE_TCL_STUBS) */

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

#if defined(USE_TCL_STUBS)
#   undef Tcl_CreateInterp






|
>
>
>
>







 







|
>







 







>
>







1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
....
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
....
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
/* 642 */
EXTERN void		Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
EXTERN int		Tcl_IsShared(Tcl_Obj *objPtr);
/* 644 */
EXTERN int		Tcl_LinkArray(Tcl_Interp *interp,
				const char *varName, void *addr, int type,
				size_t size);
/* 645 */
EXTERN int		Tcl_GetIntForIndex(Tcl_Interp *interp,
				Tcl_Obj *objPtr, size_t endValue,
				size_t *indexPtr);

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

................................................................................
    char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, size_t numBytes); /* 637 */
    Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
    void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
    int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
    void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
    void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
    int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
    int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, size_t size); /* 644 */
    int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, size_t *indexPtr); /* 645 */
} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
}
#endif
................................................................................
	(tclStubsPtr->tcl_IncrRefCount) /* 641 */
#define Tcl_DecrRefCount \
	(tclStubsPtr->tcl_DecrRefCount) /* 642 */
#define Tcl_IsShared \
	(tclStubsPtr->tcl_IsShared) /* 643 */
#define Tcl_LinkArray \
	(tclStubsPtr->tcl_LinkArray) /* 644 */
#define Tcl_GetIntForIndex \
	(tclStubsPtr->tcl_GetIntForIndex) /* 645 */

#endif /* defined(USE_TCL_STUBS) */

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

#if defined(USE_TCL_STUBS)
#   undef Tcl_CreateInterp

Changes to generic/tclEnv.c.

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
     * exist, enlarge the array if necessary to make room. If the name exists,
     * free its old entry.
     */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    if (index == TCL_AUTO_LENGTH) {
#ifndef USE_PUTENV
	/*
	 * We need to handle the case where the environment may be changed
	 * outside our control. ourEnvironSize is only valid if the current
	 * environment is the one we allocated. [Bug 979640]
	 */

................................................................................

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++). In
     * this case we need to free the string immediately. Otherwise update the
     * string in the cache.
     */

    if ((index != TCL_AUTO_LENGTH) && (environ[index] == p)) {
	ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
    } else {
	/*
	 * This putenv() copies instead of taking ownership.
	 */







|







 







|







228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
     * exist, enlarge the array if necessary to make room. If the name exists,
     * free its old entry.
     */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    if (index == TCL_INDEX_NONE) {
#ifndef USE_PUTENV
	/*
	 * We need to handle the case where the environment may be changed
	 * outside our control. ourEnvironSize is only valid if the current
	 * environment is the one we allocated. [Bug 979640]
	 */

................................................................................

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++). In
     * this case we need to free the string immediately. Otherwise update the
     * string in the cache.
     */

    if ((index != TCL_INDEX_NONE) && (environ[index] == p)) {
	ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
    } else {
	/*
	 * This putenv() copies instead of taking ownership.
	 */

Changes to generic/tclExecute.c.

93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
....
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
....
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
....
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
....
7834
7835
7836
7837
7838
7839
7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
....
8808
8809
8810
8811
8812
8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
....
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
....
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
9136
9137
9138
9139
9140
9141
9142
....
9173
9174
9175
9176
9177
9178
9179
9180
9181
9182
9183
9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
....
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
....
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
....
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
....
9324
9325
9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
....
9374
9375
9376
9377
9378
9379
9380
9381

9382
9383
9384
9385
9386
9387
9388
9389
9390
9391
9392
9393
9394
9395
9396
9397
9398
....
9416
9417
9418
9419
9420
9421
9422
9423
9424
9425
9426
9427
9428
9429
9430
....
9439
9440
9441
9442
9443
9444
9445
9446
9447
9448
9449
9450
9451
9452
9453
....
9472
9473
9474
9475
9476
9477
9478
9479
9480
9481
9482
9483
9484
9485
9486
#endif

/*
 * These are used by evalstats to monitor object usage in Tcl.
 */

#ifdef TCL_COMPILE_STATS
long		tclObjsAlloced = 0;
long		tclObjsFreed = 0;
long		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
 
/*
 * NR_TEBC
 * Helpers for NR - non-recursive calls to TEBC
 * Minimal data required to fully reconstruct the execution state.
 */
................................................................................
    } while (0)
 
/*
 * These variable-access macros have to coincide with those in tclVar.c
 */

#define VarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))

static inline Var *
VarHashCreateVar(
    TclVarHashTable *tablePtr,
    Tcl_Obj *key,
    int *newPtr)
{
................................................................................
	TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
		(match < 0 ? -1 : match > 0 ? 1 : 0)));
	JUMP_PEEPHOLE_F(match, 1, 2);

    case INST_STR_LEN:
	valuePtr = OBJ_AT_TOS;
	slength = Tcl_GetCharLength(valuePtr);
	TclNewIntObj(objResultPtr, slength);
	TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "d\n", O2S(valuePtr), slength));
	NEXT_INST_F(1, 1, 1);

    case INST_STR_UPPER:
	valuePtr = OBJ_AT_TOS;
	TRACE(("\"%.20s\" => ", O2S(valuePtr)));
	if (Tcl_IsShared(valuePtr)) {
	    s1 = TclGetStringFromObj(valuePtr, &slength);
................................................................................
	}
	Tcl_IncrRefCount(dictPtr);
	if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
		&keyPtrPtr) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	if ((unsigned int)length != duiPtr->length) {
	    Tcl_Panic("dictUpdateStart argument length mismatch");
	}
	for (i=0 ; i<length ; i++) {
	    if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
		    &valuePtr) != TCL_OK) {
		TRACE_ERROR(interp);
		Tcl_DecrRefCount(dictPtr);
................................................................................

	Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);

	mp_init(&bigResult);
	if (opcode == INST_LSHIFT) {
	    mp_mul_2d(&big1, shift, &bigResult);
	} else {
	    mp_tc_div_2d(&big1, shift, &bigResult);
	}
	mp_clear(&big1);
	BIG_RESULT(&bigResult);
    }

    case INST_BITOR:
    case INST_BITXOR:
................................................................................
	    Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
	    Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);

	    mp_init(&bigResult);

	    switch (opcode) {
	    case INST_BITAND:
		mp_tc_and(&big1, &big2, &bigResult);
		break;

	    case INST_BITOR:
		mp_tc_or(&big1, &big2, &bigResult);
		break;

	    case INST_BITXOR:
		mp_tc_xor(&big1, &big2, &bigResult);
		break;
	    }

	    mp_clear(&big1);
	    mp_clear(&big2);
	    BIG_RESULT(&bigResult);
	}
................................................................................
    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 ((int)pcOffset < codePtr->numCodeBytes);

    /*
     * Decode the code and source offset and length for each command. The
     * closest enclosing command is the last one whose code started before
     * pcOffset.
     */

................................................................................
				 * point or a catch range. */
    ByteCode *codePtr)		/* Points to the ByteCode in which to search
				 * for the enclosing ExceptionRange. */
{
    ExceptionRange *rangeArrayPtr;
    int numRanges = codePtr->numExceptRanges;
    ExceptionRange *rangePtr;
    unsigned int pcOffset = pc - codePtr->codeStart;
    unsigned int start;

    if (numRanges == 0) {
	return NULL;
    }

    /*
     * This exploits peculiarities of our compiler: nested ranges are always
................................................................................
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    ByteCodeStats *statsPtr = &iPtr->stats;
    double totalCodeBytes, currentCodeBytes;
    double totalLiteralBytes, currentLiteralBytes;
    double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
    double strBytesSharedMultX, strBytesSharedOnce;
    double numInstructions, currentHeaderBytes;
    long numCurrentByteCodes, numByteCodeLits;
    long refCountSum, literalMgmtBytes, sum;
    int numSharedMultX, numSharedOnce;
    size_t decadeHigh, minSizeDecade, maxSizeDecade, length, i;
    char *litTableStats;
    LiteralEntry *entryPtr;
    Tcl_Obj *objPtr;

#define Percent(a,b) ((a) * 100.0 / (b))

    objPtr = Tcl_NewObj();
................................................................................
     */

    Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
    Tcl_AppendPrintfToObj(objPtr,
	    "Compilation and execution statistics for interpreter %p\n",
	    iPtr);

    Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "d\n",
	    statsPtr->numExecutions);
    Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "d\n",
	    statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Mean executions/compile\t%.1f\n",
	    statsPtr->numExecutions / (float)statsPtr->numCompilations);

    Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n",
	    numInstructions);
    Tcl_AppendPrintfToObj(objPtr, "  Mean inst/compile\t\t%.0f\n",
	    numInstructions / statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Mean inst/execution\t\t%.0f\n",
	    numInstructions / statsPtr->numExecutions);

    Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "d\n",
	    statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Source bytes\t\t\t%.6g\n",
	    statsPtr->totalSrcBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Code bytes\t\t\t%.6g\n",
	    totalCodeBytes);
    Tcl_AppendPrintfToObj(objPtr, "    ByteCode bytes\t\t%.6g\n",
	    statsPtr->totalByteCodeBytes);
................................................................................
	    statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
	    statsPtr->totalLitStringBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Mean code/compile\t\t%.1f\n",
	    totalCodeBytes / statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Mean code/source\t\t%.1f\n",
	    totalCodeBytes / statsPtr->totalSrcBytes);

    Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n",
	    numCurrentByteCodes);
    Tcl_AppendPrintfToObj(objPtr, "  Source bytes\t\t\t%.6g\n",
	    statsPtr->currentSrcBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Code bytes\t\t\t%.6g\n",
	    currentCodeBytes);
    Tcl_AppendPrintfToObj(objPtr, "    ByteCode bytes\t\t%.6g\n",
	    statsPtr->currentByteCodeBytes);
................................................................................
     *
     * This gives the refcount of each obj as Tcl_IsShared was called for it.
     * Shared objects must be duplicated before they can be modified.
     */

    numSharedMultX = 0;
    Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
    Tcl_AppendPrintfToObj(objPtr, "  Object had refcount <=1 (not shared)\t%ld\n",
	    tclObjsShared[1]);
    for (i = 2;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {
	Tcl_AppendPrintfToObj(objPtr, "  refcount ==%" TCL_Z_MODIFIER "d\t\t%ld\n",
		i, tclObjsShared[i]);
	numSharedMultX += tclObjsShared[i];
    }
    Tcl_AppendPrintfToObj(objPtr, "  refcount >=%" TCL_Z_MODIFIER "d\t\t%ld\n",
	    i, tclObjsShared[0]);
    numSharedMultX += tclObjsShared[0];
    Tcl_AppendPrintfToObj(objPtr, "  Total shared objects\t\t\t%d\n",
	    numSharedMultX);

    /*
     * Literal table statistics.
     */

    numByteCodeLits = 0;
................................................................................
		strBytesSharedOnce += (length+1);
	    }
	}
    }
    sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
	    - currentLiteralBytes;

    Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n",
	    tclObjsAlloced);
    Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n",
	    (tclObjsAlloced - tclObjsFreed));
    Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "d\n",
	    statsPtr->numLiteralsCreated);

    Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_Z_MODIFIER "d (%0.1f%% of current objects)\n",
	    globalTablePtr->numEntries,
	    Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
    Tcl_AppendPrintfToObj(objPtr, "  ByteCode literals\t\t%ld (%0.1f%% of current literals)\n",
	    numByteCodeLits,
	    Percent(numByteCodeLits, globalTablePtr->numEntries));
    Tcl_AppendPrintfToObj(objPtr, "  Literals reused > 1x\t\t%d\n",
	    numSharedMultX);
    Tcl_AppendPrintfToObj(objPtr, "  Mean reference count\t\t%.2f\n",
	    ((double) refCountSum) / globalTablePtr->numEntries);
    Tcl_AppendPrintfToObj(objPtr, "  Mean len, str reused >1x \t%.2f\n",
	    (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
    Tcl_AppendPrintfToObj(objPtr, "  Mean len, str used 1x\t\t%.2f\n",
	    (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
................................................................................
	    statsPtr->currentLitStringBytes);
    Tcl_AppendPrintfToObj(objPtr, "    Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n",
	    (objBytesIfUnshared + strBytesIfUnshared),
	    objBytesIfUnshared, strBytesIfUnshared);
    Tcl_AppendPrintfToObj(objPtr, "  String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
	    (strBytesIfUnshared - statsPtr->currentLitStringBytes),
	    strBytesIfUnshared, statsPtr->currentLitStringBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n",
	    literalMgmtBytes,
	    Percent(literalMgmtBytes, currentLiteralBytes));
    Tcl_AppendPrintfToObj(objPtr, "    table %lu + buckets %lu + entries %lu\n",
	    (unsigned long) sizeof(LiteralTable),
	    (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
	    (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)));

................................................................................
    /*
     * Detailed literal statistics.
     */

    Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
    Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
    maxSizeDecade = 0;
    for (i = 31;  i >= 0;  i--) {

	if (statsPtr->literalCount[i] > 0) {
	    maxSizeDecade = i;
	    break;
	}
    }
    sum = 0;
    for (i = 0;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->literalCount[i];
	Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "d\t\t%8.0f%%\n",
		decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
    }

    litTableStats = TclLiteralStats(globalTablePtr);
    Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
	    litTableStats);
    Tcl_Free(litTableStats);
................................................................................
	    break;
	}
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->srcCount[i];
	Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "d\t\t%8.0f%%\n",
		decadeHigh, Percent(sum, statsPtr->numCompilations));
    }

    Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
    Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
................................................................................
	    break;
	}
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->byteCodeCount[i];
	Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "d\t\t%8.0f%%\n",
		decadeHigh, Percent(sum, statsPtr->numCompilations));
    }

    Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
    Tcl_AppendPrintfToObj(objPtr, "\t       Up to ms\t\tPercentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
................................................................................

    /*
     * Instruction counts.
     */

    Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
    for (i = 0;  i < LAST_INST_OPCODE;  i++) {
	Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "d ",
		tclInstructionTable[i].name, statsPtr->instructionCount[i]);
	if (statsPtr->instructionCount[i]) {
	    Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
		    Percent(statsPtr->instructionCount[i], numInstructions));
	} else {
	    Tcl_AppendPrintfToObj(objPtr, "0\n");
	}






|
|
|







 







|







 







|
|







 







|







 







|







 







|



|



|







 







|







 







|
|







 







|
|
|
<







 







|

|











|







 







|







 







|


|



|


|







 







|

|

|


|


|


|







 







|







 







|
>









|







 







|







 







|







 







|







93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
....
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
....
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
....
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
....
7834
7835
7836
7837
7838
7839
7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
....
8808
8809
8810
8811
8812
8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
....
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
....
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134

9135
9136
9137
9138
9139
9140
9141
....
9172
9173
9174
9175
9176
9177
9178
9179
9180
9181
9182
9183
9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
....
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
....
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
....
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
....
9323
9324
9325
9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
....
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
9387
9388
9389
9390
9391
9392
9393
9394
9395
9396
9397
9398
....
9416
9417
9418
9419
9420
9421
9422
9423
9424
9425
9426
9427
9428
9429
9430
....
9439
9440
9441
9442
9443
9444
9445
9446
9447
9448
9449
9450
9451
9452
9453
....
9472
9473
9474
9475
9476
9477
9478
9479
9480
9481
9482
9483
9484
9485
9486
#endif

/*
 * These are used by evalstats to monitor object usage in Tcl.
 */

#ifdef TCL_COMPILE_STATS
size_t		tclObjsAlloced = 0;
size_t		tclObjsFreed = 0;
size_t		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
 
/*
 * NR_TEBC
 * Helpers for NR - non-recursive calls to TEBC
 * Minimal data required to fully reconstruct the execution state.
 */
................................................................................
    } while (0)
 
/*
 * These variable-access macros have to coincide with those in tclVar.c
 */

#define VarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))

static inline Var *
VarHashCreateVar(
    TclVarHashTable *tablePtr,
    Tcl_Obj *key,
    int *newPtr)
{
................................................................................
	TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
		(match < 0 ? -1 : match > 0 ? 1 : 0)));
	JUMP_PEEPHOLE_F(match, 1, 2);

    case INST_STR_LEN:
	valuePtr = OBJ_AT_TOS;
	slength = Tcl_GetCharLength(valuePtr);
	objResultPtr = TclNewWideIntObjFromSize(slength);
	TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength));
	NEXT_INST_F(1, 1, 1);

    case INST_STR_UPPER:
	valuePtr = OBJ_AT_TOS;
	TRACE(("\"%.20s\" => ", O2S(valuePtr)));
	if (Tcl_IsShared(valuePtr)) {
	    s1 = TclGetStringFromObj(valuePtr, &slength);
................................................................................
	}
	Tcl_IncrRefCount(dictPtr);
	if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
		&keyPtrPtr) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	if ((size_t)length != duiPtr->length) {
	    Tcl_Panic("dictUpdateStart argument length mismatch");
	}
	for (i=0 ; i<length ; i++) {
	    if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
		    &valuePtr) != TCL_OK) {
		TRACE_ERROR(interp);
		Tcl_DecrRefCount(dictPtr);
................................................................................

	Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);

	mp_init(&bigResult);
	if (opcode == INST_LSHIFT) {
	    mp_mul_2d(&big1, shift, &bigResult);
	} else {
	    mp_signed_rsh(&big1, shift, &bigResult);
	}
	mp_clear(&big1);
	BIG_RESULT(&bigResult);
    }

    case INST_BITOR:
    case INST_BITXOR:
................................................................................
	    Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
	    Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);

	    mp_init(&bigResult);

	    switch (opcode) {
	    case INST_BITAND:
		mp_and(&big1, &big2, &bigResult);
		break;

	    case INST_BITOR:
		mp_or(&big1, &big2, &bigResult);
		break;

	    case INST_BITXOR:
		mp_xor(&big1, &big2, &bigResult);
		break;
	    }

	    mp_clear(&big1);
	    mp_clear(&big2);
	    BIG_RESULT(&bigResult);
	}
................................................................................
    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 < (size_t)codePtr->numCodeBytes);

    /*
     * Decode the code and source offset and length for each command. The
     * closest enclosing command is the last one whose code started before
     * pcOffset.
     */

................................................................................
				 * point or a catch range. */
    ByteCode *codePtr)		/* Points to the ByteCode in which to search
				 * for the enclosing ExceptionRange. */
{
    ExceptionRange *rangeArrayPtr;
    int numRanges = codePtr->numExceptRanges;
    ExceptionRange *rangePtr;
    size_t pcOffset = pc - codePtr->codeStart;
    size_t start;

    if (numRanges == 0) {
	return NULL;
    }

    /*
     * This exploits peculiarities of our compiler: nested ranges are always
................................................................................
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    ByteCodeStats *statsPtr = &iPtr->stats;
    double totalCodeBytes, currentCodeBytes;
    double totalLiteralBytes, currentLiteralBytes;
    double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
    double strBytesSharedMultX, strBytesSharedOnce;
    double numInstructions, currentHeaderBytes;
    size_t numCurrentByteCodes, numByteCodeLits;
    size_t refCountSum, literalMgmtBytes, sum, decadeHigh, length;
    size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i;

    char *litTableStats;
    LiteralEntry *entryPtr;
    Tcl_Obj *objPtr;

#define Percent(a,b) ((a) * 100.0 / (b))

    objPtr = Tcl_NewObj();
................................................................................
     */

    Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
    Tcl_AppendPrintfToObj(objPtr,
	    "Compilation and execution statistics for interpreter %p\n",
	    iPtr);

    Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n",
	    statsPtr->numExecutions);
    Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n",
	    statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Mean executions/compile\t%.1f\n",
	    statsPtr->numExecutions / (float)statsPtr->numCompilations);

    Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n",
	    numInstructions);
    Tcl_AppendPrintfToObj(objPtr, "  Mean inst/compile\t\t%.0f\n",
	    numInstructions / statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Mean inst/execution\t\t%.0f\n",
	    numInstructions / statsPtr->numExecutions);

    Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n",
	    statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Source bytes\t\t\t%.6g\n",
	    statsPtr->totalSrcBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Code bytes\t\t\t%.6g\n",
	    totalCodeBytes);
    Tcl_AppendPrintfToObj(objPtr, "    ByteCode bytes\t\t%.6g\n",
	    statsPtr->totalByteCodeBytes);
................................................................................
	    statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
	    statsPtr->totalLitStringBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Mean code/compile\t\t%.1f\n",
	    totalCodeBytes / statsPtr->numCompilations);
    Tcl_AppendPrintfToObj(objPtr, "  Mean code/source\t\t%.1f\n",
	    totalCodeBytes / statsPtr->totalSrcBytes);

    Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n",
	    numCurrentByteCodes);
    Tcl_AppendPrintfToObj(objPtr, "  Source bytes\t\t\t%.6g\n",
	    statsPtr->currentSrcBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Code bytes\t\t\t%.6g\n",
	    currentCodeBytes);
    Tcl_AppendPrintfToObj(objPtr, "    ByteCode bytes\t\t%.6g\n",
	    statsPtr->currentByteCodeBytes);
................................................................................
     *
     * This gives the refcount of each obj as Tcl_IsShared was called for it.
     * Shared objects must be duplicated before they can be modified.
     */

    numSharedMultX = 0;
    Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
    Tcl_AppendPrintfToObj(objPtr, "  Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n",
	    tclObjsShared[1]);
    for (i = 2;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {
	Tcl_AppendPrintfToObj(objPtr, "  refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n",
		i, tclObjsShared[i]);
	numSharedMultX += tclObjsShared[i];
    }
    Tcl_AppendPrintfToObj(objPtr, "  refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n",
	    i, tclObjsShared[0]);
    numSharedMultX += tclObjsShared[0];
    Tcl_AppendPrintfToObj(objPtr, "  Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n",
	    numSharedMultX);

    /*
     * Literal table statistics.
     */

    numByteCodeLits = 0;
................................................................................
		strBytesSharedOnce += (length+1);
	    }
	}
    }
    sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
	    - currentLiteralBytes;

    Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n",
	    tclObjsAlloced);
    Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n",
	    (tclObjsAlloced - tclObjsFreed));
    Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n",
	    statsPtr->numLiteralsCreated);

    Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current objects)\n",
	    globalTablePtr->numEntries,
	    Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
    Tcl_AppendPrintfToObj(objPtr, "  ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n",
	    numByteCodeLits,
	    Percent(numByteCodeLits, globalTablePtr->numEntries));
    Tcl_AppendPrintfToObj(objPtr, "  Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n",
	    numSharedMultX);
    Tcl_AppendPrintfToObj(objPtr, "  Mean reference count\t\t%.2f\n",
	    ((double) refCountSum) / globalTablePtr->numEntries);
    Tcl_AppendPrintfToObj(objPtr, "  Mean len, str reused >1x \t%.2f\n",
	    (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
    Tcl_AppendPrintfToObj(objPtr, "  Mean len, str used 1x\t\t%.2f\n",
	    (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
................................................................................
	    statsPtr->currentLitStringBytes);
    Tcl_AppendPrintfToObj(objPtr, "    Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n",
	    (objBytesIfUnshared + strBytesIfUnshared),
	    objBytesIfUnshared, strBytesIfUnshared);
    Tcl_AppendPrintfToObj(objPtr, "  String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
	    (strBytesIfUnshared - statsPtr->currentLitStringBytes),
	    strBytesIfUnshared, statsPtr->currentLitStringBytes);
    Tcl_AppendPrintfToObj(objPtr, "  Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n",
	    literalMgmtBytes,
	    Percent(literalMgmtBytes, currentLiteralBytes));
    Tcl_AppendPrintfToObj(objPtr, "    table %lu + buckets %lu + entries %lu\n",
	    (unsigned long) sizeof(LiteralTable),
	    (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
	    (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)));

................................................................................
    /*
     * Detailed literal statistics.
     */

    Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
    Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
    maxSizeDecade = 0;
    i = 32;
    while (i-- > 0) {
	if (statsPtr->literalCount[i] > 0) {
	    maxSizeDecade = i;
	    break;
	}
    }
    sum = 0;
    for (i = 0;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->literalCount[i];
	Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n",
		decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
    }

    litTableStats = TclLiteralStats(globalTablePtr);
    Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
	    litTableStats);
    Tcl_Free(litTableStats);
................................................................................
	    break;
	}
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->srcCount[i];
	Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n",
		decadeHigh, Percent(sum, statsPtr->numCompilations));
    }

    Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
    Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
................................................................................
	    break;
	}
    }
    sum = 0;
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
	decadeHigh = (1 << (i+1)) - 1;
	sum += statsPtr->byteCodeCount[i];
	Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n",
		decadeHigh, Percent(sum, statsPtr->numCompilations));
    }

    Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
    Tcl_AppendPrintfToObj(objPtr, "\t       Up to ms\t\tPercentage\n");
    minSizeDecade = maxSizeDecade = 0;
    for (i = 0;  i < 31;  i++) {
................................................................................

    /*
     * Instruction counts.
     */

    Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
    for (i = 0;  i < LAST_INST_OPCODE;  i++) {
	Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ",
		tclInstructionTable[i].name, statsPtr->instructionCount[i]);
	if (statsPtr->instructionCount[i]) {
	    Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
		    Percent(statsPtr->instructionCount[i], numInstructions));
	} else {
	    Tcl_AppendPrintfToObj(objPtr, "0\n");
	}

Changes to generic/tclFCmd.c.

1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
....
1499
1500
1501
1502
1503
1504
1505
1506
1507

















































































































































1508
1509
1510
1511
1512
1513
    Tcl_DecrRefCount(contents);
    return TCL_OK;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * TclFileTemporaryCmd
 *
 *	This function implements the "tempfile" subcommand of the "file"
 *	command.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
................................................................................
	    Tcl_UnregisterChannel(interp, chan);
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
    return TCL_OK;
}
 
/*

















































































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






|







 









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






1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
....
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
    Tcl_DecrRefCount(contents);
    return TCL_OK;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * TclFileTemporaryCmd --
 *
 *	This function implements the "tempfile" subcommand of the "file"
 *	command.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
................................................................................
	    Tcl_UnregisterChannel(interp, chan);
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
    return TCL_OK;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * TclFileTempDirCmd --
 *
 *	This function implements the "tempdir" subcommand of the "file"
 *	command.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Creates a temporary directory.
 *
 *---------------------------------------------------------------------------
 */

int
TclFileTempDirCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *dirNameObj;	/* Object that will contain the directory
				 * name. */
    Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL;
				/* Pieces of template. Each piece is NULL if
				 * it is omitted. The platform temporary file
				 * engine might ignore some pieces. */

    if (objc < 1 || objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?template?");
	return TCL_ERROR;
    }

    if (objc > 1) {
	int length;
	Tcl_Obj *templateObj = objv[1];
	const char *string = TclGetStringFromObj(templateObj, &length);
	const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);

	/*
	 * Treat an empty string as if it wasn't there.
	 */

	if (length == 0) {
	    goto makeTemporary;
	}

	/*
	 * The template only gives a directory if there is a directory
	 * separator in it, and only gives a base name if there's at least one
	 * character after the last directory separator.
	 */

	if (strchr(string, '/') == NULL
		&& (!onWindows || strchr(string, '\\') == NULL)) {
	    /*
	     * No directory separator, so just assume we have a file name.
	     * This is a bit wrong on Windows where we could have problems
	     * with disk name prefixes... but those are much less common in
	     * naked form so we just pass through and let the OS figure it out
	     * instead.
	     */

	    nameBaseObj = templateObj;
	    Tcl_IncrRefCount(nameBaseObj);
	} else if (string[length-1] != '/'
		&& (!onWindows || string[length-1] != '\\')) {
	    /*
	     * If the template has a non-terminal directory separator, split
	     * into dirname and tail.
	     */

	    baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
	    nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL);
	} else {
	    /*
	     * Otherwise, there must be a terminal directory separator, so
	     * just the directory is given.
	     */

	    baseDirObj = templateObj;
	    Tcl_IncrRefCount(baseDirObj);
	}

	/*
	 * Only allow creation of temporary directories in the native
	 * filesystem since they are frequently used for integration with
	 * external tools or system libraries.
	 */

	if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj)
		!= &tclNativeFilesystem) {
	    TclDecrRefCount(baseDirObj);
	    baseDirObj = NULL;
	}
    }

    /*
     * Convert empty parts of the template into unspecified parts.
     */

    if (baseDirObj && !TclGetString(baseDirObj)[0]) {
	TclDecrRefCount(baseDirObj);
	baseDirObj = NULL;
    }
    if (nameBaseObj && !TclGetString(nameBaseObj)[0]) {
	TclDecrRefCount(nameBaseObj);
	nameBaseObj = NULL;
    }

    /*
     * Create and open the temporary file.
     */

  makeTemporary:
    dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj);

    /*
     * If we created pieces of template, get rid of them now.
     */

    if (baseDirObj) {
	TclDecrRefCount(baseDirObj);
    }
    if (nameBaseObj) {
	TclDecrRefCount(nameBaseObj);
    }

    /*
     * Deal with results.
     */

    if (dirNameObj == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"can't create temporary directory: %s",
		Tcl_PosixError(interp)));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, dirNameObj);
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclHash.c.

280
281
282
283
284
285
286


287

288
289
290
291
292
293
294
...
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
	Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;

	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
	    if (hash != hPtr->hash) {
		continue;
	    }


	    if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) {

		if (newPtr) {
		    *newPtr = 0;
		}
		return hPtr;
	    }
	}
    } else {
................................................................................
    Tcl_HashEntry *hPtr;
    size_t size, allocsize;

    allocsize = size = strlen(string) + 1;
    if (size < sizeof(hPtr->key)) {
	allocsize = sizeof(hPtr->key);
    }
    hPtr = Tcl_Alloc(TclOffset(Tcl_HashEntry, key) + allocsize);
    memcpy(hPtr->key.string, string, size);
    Tcl_SetHashValue(hPtr, NULL);
    return hPtr;
}
 
/*
 *----------------------------------------------------------------------






>
>
|
>







 







|







280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
...
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
	Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;

	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
	    if (hash != hPtr->hash) {
		continue;
	    }
	    /* if keys pointers or values are equal */
	    if ((key == hPtr->key.oneWordValue)
		|| compareKeysProc((void *) key, hPtr)
	    ) {
		if (newPtr) {
		    *newPtr = 0;
		}
		return hPtr;
	    }
	}
    } else {
................................................................................
    Tcl_HashEntry *hPtr;
    size_t size, allocsize;

    allocsize = size = strlen(string) + 1;
    if (size < sizeof(hPtr->key)) {
	allocsize = sizeof(hPtr->key);
    }
    hPtr = Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize);
    memcpy(hPtr->key.string, string, size);
    Tcl_SetHashValue(hPtr, NULL);
    return hPtr;
}
 
/*
 *----------------------------------------------------------------------

Changes to generic/tclIO.h.

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
    				/* Next buffer in chain. */
    char buf[1];		/* Placeholder for real buffer. The real
				 * buffer occuppies this space + bufSize-1
				 * bytes. This must be the last field in the
				 * structure. */
} ChannelBuffer;

#define CHANNELBUFFER_HEADER_SIZE	TclOffset(ChannelBuffer, buf)

/*
 * How much extra space to allocate in buffer to hold bytes from previous
 * buffer (when converting to UTF-8) or to hold bytes that will go to next
 * buffer (when converting from UTF-8).
 */







|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
    				/* Next buffer in chain. */
    char buf[1];		/* Placeholder for real buffer. The real
				 * buffer occuppies this space + bufSize-1
				 * bytes. This must be the last field in the
				 * structure. */
} ChannelBuffer;

#define CHANNELBUFFER_HEADER_SIZE	offsetof(ChannelBuffer, buf)

/*
 * How much extra space to allocate in buffer to hold bytes from previous
 * buffer (when converting to UTF-8) or to hold bytes that will go to next
 * buffer (when converting from UTF-8).
 */

Changes to generic/tclInt.decls.

148
149
150
151
152
153
154
155
156
157
158

159
160
161
162
163
164
165
...
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
....
1053
1054
1055
1056
1057
1058
1059


1060




1061
1062
1063
1064
1065
1066
1067
    int TclGetFrame(Tcl_Interp *interp, const char *str,
	    CallFrame **framePtrPtr)
}
# Removed in 8.5:
#declare 33 {
#    TclCmdProcType TclGetInterpProc(void)
#}
declare 34 {
    int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    size_t endValue, size_t *indexPtr)
}

# Removed in 8.4b2:
#declare 35 {
#    Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    int flags)
#}
# Removed in 8.6a2:
#declare 36 {
................................................................................

# Added for Tcl 8.2

declare 150 {
    int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 {
    void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, int *startPtr,
	    int *endPtr)
}
declare 152 {
    void TclSetLibraryPath(Tcl_Obj *pathPtr)
}
declare 153 {
    Tcl_Obj *TclGetLibraryPath(void)
}
................................................................................
    int	TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
	    Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags)
}
declare 257 {
    void TclStaticPackage(Tcl_Interp *interp, const char *pkgName,
	    Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}


declare 258 {




    int	TclMSB(size_t n)
}
 
##############################################################################

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






|
|
|
|
>







 







|
|







 







>
>

>
>
>
>







148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
...
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
....
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
    int TclGetFrame(Tcl_Interp *interp, const char *str,
	    CallFrame **framePtrPtr)
}
# Removed in 8.5:
#declare 33 {
#    TclCmdProcType TclGetInterpProc(void)
#}
# Removed in 9.0:
#declare 34 {deprecated {Use Tcl_GetIntForIndex}} {
#    int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
#	    int endValue, int *indexPtr)
#}
# Removed in 8.4b2:
#declare 35 {
#    Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    int flags)
#}
# Removed in 8.6a2:
#declare 36 {
................................................................................

# Added for Tcl 8.2

declare 150 {
    int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 {
    void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, size_t *startPtr,
	    size_t *endPtr)
}
declare 152 {
    void TclSetLibraryPath(Tcl_Obj *pathPtr)
}
declare 153 {
    Tcl_Obj *TclGetLibraryPath(void)
}
................................................................................
    int	TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
	    Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags)
}
declare 257 {
    void TclStaticPackage(Tcl_Interp *interp, const char *pkgName,
	    Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}

# TIP 431: temporary directory creation function
declare 258 {
    Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
	    Tcl_Obj *basenameObj)
}
declare 259 {
    int	TclMSB(size_t n)
}
 
##############################################################################

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

Changes to generic/tclInt.h.

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
...
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
....
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
....
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
....
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
....
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
....
2977
2978
2979
2980
2981
2982
2983

2984
2985
2986
2987
2988
2989
2990
....
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
....
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
....
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
....
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
#endif
#ifdef NO_STRING_H
#include "../compat/string.h"
#else
#include <string.h>
#endif
#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \
     || defined(__cplusplus) || defined(_MSC_VER)
#include <stddef.h>
#else
typedef int ptrdiff_t;
#endif

/*
 * Ensure WORDS_BIGENDIAN is defined correctly:
................................................................................
    void *clientData;	/* Argument to pass to proc. */
    int flags;			/* What events the trace procedure is
				 * interested in: OR-ed combination of
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    struct CommandTrace *nextPtr;
				/* Next in list of traces associated with a
				 * particular command. */
    size_t refCount;		/* Used to ensure this structure is not
				 * deleted too early. Keeps track of how many
				 * pieces of code have a pointer to this
				 * structure. */
} CommandTrace;

/*
 * When a command trace is active (i.e. its associated procedure is executing)
................................................................................
				 * NULL if end of chain. */
    Tcl_Obj *objPtr;		/* Points to Tcl object that holds the
				 * literal's bytes and length. */
    size_t refCount;		/* If in an interpreter's global literal
				 * table, the number of ByteCode structures
				 * that share the literal object; the literal
				 * entry can be freed when refCount drops to
				 * 0. If in a local literal table, -1. */
    Namespace *nsPtr;		/* Namespace in which this literal is used. We
				 * try to avoid sharing literal non-FQ command
				 * names among different namespaces to reduce
				 * shimmering. */
} LiteralEntry;

typedef struct LiteralTable {
................................................................................

#define TCL_EACH_KEEP_NONE  0	/* Discard iteration result like [foreach] */
#define TCL_EACH_COLLECT    1	/* Collect iteration result like [lmap] */

/*
 * Macros providing a faster path to booleans and integers:
 * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
 * and TclGetIntForIndex.
 *
 * WARNING: these macros eval their args more than once.
 */

#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    || (objPtr)->typePtr == &tclBooleanType) \
................................................................................
	    ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
	    ? ((*(idxPtr) = ((objPtr)->internalRep.wideValue >= 0) \
	    ? (size_t)(objPtr)->internalRep.wideValue : TCL_INDEX_NONE), TCL_OK) \
	    : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))

/*
 * Macro used to save a function call for common uses of
 * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
 *
 * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			Tcl_WideInt *wideIntPtr);
................................................................................
 * The head of the list of free Tcl objects, and the total number of Tcl
 * objects ever allocated and freed.
 */

MODULE_SCOPE Tcl_Obj *	tclFreeObjList;

#ifdef TCL_COMPILE_STATS
MODULE_SCOPE long	tclObjsAlloced;
MODULE_SCOPE long	tclObjsFreed;
#define TCL_MAX_SHARED_OBJ_STATS 5
MODULE_SCOPE long	tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */

/*
 * Pointer to a heap-allocated string of length zero that the Tcl core uses as
 * the value of an empty string representation for an object. This value is
 * shared by all new objects allocated by Tcl_NewObj.
 */
................................................................................
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd;

MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd;
MODULE_SCOPE void	TclCreateLateExitHandler(Tcl_ExitProc *proc,
			    void *clientData);
MODULE_SCOPE void	TclDeleteLateExitHandler(Tcl_ExitProc *proc,
			    void *clientData);
MODULE_SCOPE char *	TclDStringAppendObj(Tcl_DString *dsPtr,
			    Tcl_Obj *objPtr);
................................................................................
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclDivOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileDivOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclLessOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileLessOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclLeqOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileLeqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclGreaterOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileGreaterOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclGeqOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileGeqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclEqOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileEqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclStreqOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileStreqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);

MODULE_SCOPE int	TclCompileAssembleCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
................................................................................

MODULE_SCOPE int	TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    size_t before, size_t after, int *indexPtr);
MODULE_SCOPE size_t	TclIndexDecode(int encoded, size_t endValue);

/* Constants used in index value encoding routines. */
#define TCL_INDEX_END           ((size_t)-2)
#define TCL_INDEX_NONE          ((size_t)-1) /* Index out of range or END+1 */
#define TCL_INDEX_START         ((size_t)0)

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and release Tcl objects.
 * TclNewObj(objPtr) creates a new object denoting an empty string.
 * TclDecrRefCount(objPtr) decrements the object's reference count, and frees
................................................................................
#    ifdef NO_ISNAN
#	 define TclIsNaN(d)	((d) != (d))
#    else
#	 define TclIsNaN(d)	(isnan(d))
#    endif
#endif

/*
 * ----------------------------------------------------------------------
 * Macro to use to find the offset of a field in a structure. Computes number
 * of bytes from beginning of structure to a given field.
 */

#ifdef offsetof
#define TclOffset(type, field) (offsetof(type, field))
#else
#define TclOffset(type, field) (((char *) &((type *) 0)->field))
#endif

/*
 *----------------------------------------------------------------
 * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace.
 */

................................................................................
 */

#if (!defined(TCL_WIDE_INT_IS_LONG) || (LONG_MAX > UINT_MAX)) && (SIZE_MAX <= UINT_MAX)
#   define TclWideIntFromSize(value)	(((Tcl_WideInt)(((size_t)(value))+1))-1)
#   define TclNewWideIntObjFromSize(value) \
	Tcl_NewWideIntObj(TclWideIntFromSize(value))
#else
#   define TclWideIntFromSize(value)	(value)
#   define TclNewWideIntObjFromSize Tcl_NewWideIntObj
#endif

/*
 * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
 */







|







 







|







 







|







 







|







 







|







 







|
|

|







 







>







 







<
<
<



<
<
<



<
<
<



<
<
<



<
<
<



<
<
<







 







<







 







|
<
<
<
<
<
|
<
<
|







 







|







61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
...
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
....
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
....
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
....
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
....
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
....
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
....
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
....
4211
4212
4213
4214
4215
4216
4217

4218
4219
4220
4221
4222
4223
4224
....
4920
4921
4922
4923
4924
4925
4926
4927





4928


4929
4930
4931
4932
4933
4934
4935
4936
....
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
#endif
#ifdef NO_STRING_H
#include "../compat/string.h"
#else
#include <string.h>
#endif
#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \
     || defined(__cplusplus) || defined(_MSC_VER) || defined(__ICC)
#include <stddef.h>
#else
typedef int ptrdiff_t;
#endif

/*
 * Ensure WORDS_BIGENDIAN is defined correctly:
................................................................................
    void *clientData;	/* Argument to pass to proc. */
    int flags;			/* What events the trace procedure is
				 * interested in: OR-ed combination of
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    struct CommandTrace *nextPtr;
				/* Next in list of traces associated with a
				 * particular command. */
    size_t refCount;	/* Used to ensure this structure is not
				 * deleted too early. Keeps track of how many
				 * pieces of code have a pointer to this
				 * structure. */
} CommandTrace;

/*
 * When a command trace is active (i.e. its associated procedure is executing)
................................................................................
				 * NULL if end of chain. */
    Tcl_Obj *objPtr;		/* Points to Tcl object that holds the
				 * literal's bytes and length. */
    size_t refCount;		/* If in an interpreter's global literal
				 * table, the number of ByteCode structures
				 * that share the literal object; the literal
				 * entry can be freed when refCount drops to
				 * 0. If in a local literal table, TCL_AUTO_LENGTH. */
    Namespace *nsPtr;		/* Namespace in which this literal is used. We
				 * try to avoid sharing literal non-FQ command
				 * names among different namespaces to reduce
				 * shimmering. */
} LiteralEntry;

typedef struct LiteralTable {
................................................................................

#define TCL_EACH_KEEP_NONE  0	/* Discard iteration result like [foreach] */
#define TCL_EACH_COLLECT    1	/* Collect iteration result like [lmap] */

/*
 * Macros providing a faster path to booleans and integers:
 * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
 * and Tcl_GetIntForIndex.
 *
 * WARNING: these macros eval their args more than once.
 */

#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    || (objPtr)->typePtr == &tclBooleanType) \
................................................................................
	    ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
	    ? ((*(idxPtr) = ((objPtr)->internalRep.wideValue >= 0) \
	    ? (size_t)(objPtr)->internalRep.wideValue : TCL_INDEX_NONE), 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:
 *
 * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 *			Tcl_WideInt *wideIntPtr);
................................................................................
 * The head of the list of free Tcl objects, and the total number of Tcl
 * objects ever allocated and freed.
 */

MODULE_SCOPE Tcl_Obj *	tclFreeObjList;

#ifdef TCL_COMPILE_STATS
MODULE_SCOPE size_t	tclObjsAlloced;
MODULE_SCOPE size_t	tclObjsFreed;
#define TCL_MAX_SHARED_OBJ_STATS 5
MODULE_SCOPE size_t	tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */

/*
 * Pointer to a heap-allocated string of length zero that the Tcl core uses as
 * the value of an empty string representation for an object. This value is
 * shared by all new objects allocated by Tcl_NewObj.
 */
................................................................................
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd;
MODULE_SCOPE void	TclCreateLateExitHandler(Tcl_ExitProc *proc,
			    void *clientData);
MODULE_SCOPE void	TclDeleteLateExitHandler(Tcl_ExitProc *proc,
			    void *clientData);
MODULE_SCOPE char *	TclDStringAppendObj(Tcl_DString *dsPtr,
			    Tcl_Obj *objPtr);
................................................................................
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclDivOpCmd(void *clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileDivOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);



MODULE_SCOPE int	TclCompileLessOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);



MODULE_SCOPE int	TclCompileLeqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);



MODULE_SCOPE int	TclCompileGreaterOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);



MODULE_SCOPE int	TclCompileGeqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);



MODULE_SCOPE int	TclCompileEqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);



MODULE_SCOPE int	TclCompileStreqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);

MODULE_SCOPE int	TclCompileAssembleCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
................................................................................

MODULE_SCOPE int	TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    size_t before, size_t after, int *indexPtr);
MODULE_SCOPE size_t	TclIndexDecode(int encoded, size_t endValue);

/* Constants used in index value encoding routines. */
#define TCL_INDEX_END           ((size_t)-2)

#define TCL_INDEX_START         ((size_t)0)

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and release Tcl objects.
 * TclNewObj(objPtr) creates a new object denoting an empty string.
 * TclDecrRefCount(objPtr) decrements the object's reference count, and frees
................................................................................
#    ifdef NO_ISNAN
#	 define TclIsNaN(d)	((d) != (d))
#    else
#	 define TclIsNaN(d)	(isnan(d))
#    endif
#endif

/* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */





#ifndef offsetof


#   define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field))
#endif

/*
 *----------------------------------------------------------------
 * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace.
 */

................................................................................
 */

#if (!defined(TCL_WIDE_INT_IS_LONG) || (LONG_MAX > UINT_MAX)) && (SIZE_MAX <= UINT_MAX)
#   define TclWideIntFromSize(value)	(((Tcl_WideInt)(((size_t)(value))+1))-1)
#   define TclNewWideIntObjFromSize(value) \
	Tcl_NewWideIntObj(TclWideIntFromSize(value))
#else
#   define TclWideIntFromSize(value)	((Tcl_WideInt)(value))
#   define TclNewWideIntObjFromSize Tcl_NewWideIntObj
#endif

/*
 * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
 */

Changes to generic/tclIntDecls.h.

104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
...
580
581
582
583
584
585
586



587
588
589
590
591
592
593
...
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
...
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
...
844
845
846
847
848
849
850

851
852
853
854
855
856
857
858
...
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
....
1262
1263
1264
1265
1266
1267
1268


1269
1270
1271
1272
1273
1274
1275
1276
1277
/* Slot 30 is reserved */
/* 31 */
EXTERN const char *	TclGetExtension(const char *name);
/* 32 */
EXTERN int		TclGetFrame(Tcl_Interp *interp, const char *str,
				CallFrame **framePtrPtr);
/* Slot 33 is reserved */
/* 34 */
EXTERN int		TclGetIntForIndex(Tcl_Interp *interp,
				Tcl_Obj *objPtr, size_t endValue,
				size_t *indexPtr);
/* Slot 35 is reserved */
/* Slot 36 is reserved */
/* 37 */
EXTERN int		TclGetLoadedPackages(Tcl_Interp *interp,
				const char *targetName);
/* 38 */
EXTERN int		TclGetNamespaceForQualName(Tcl_Interp *interp,
................................................................................
EXTERN TclHandle	TclHandlePreserve(TclHandle handle);
/* 149 */
EXTERN void		TclHandleRelease(TclHandle handle);
/* 150 */
EXTERN int		TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re);
/* 151 */
EXTERN void		TclRegExpRangeUniChar(Tcl_RegExp re, size_t index,
				int *startPtr, int *endPtr);
/* 152 */
EXTERN void		TclSetLibraryPath(Tcl_Obj *pathPtr);
/* 153 */
EXTERN Tcl_Obj *	TclGetLibraryPath(void);
/* Slot 154 is reserved */
/* Slot 155 is reserved */
/* 156 */
................................................................................
				Tcl_Obj *part2Ptr, const int flags);
/* 257 */
EXTERN void		TclStaticPackage(Tcl_Interp *interp,
				const char *pkgName,
				Tcl_PackageInitProc *initProc,
				Tcl_PackageInitProc *safeInitProc);
/* 258 */



EXTERN int		TclMSB(size_t n);

typedef struct TclIntStubs {
    int magic;
    void *hooks;

    void (*reserved0)(void);
................................................................................
    void (*reserved27)(void);
    Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */
    void (*reserved29)(void);
    void (*reserved30)(void);
    const char * (*tclGetExtension) (const char *name); /* 31 */
    int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */
    void (*reserved33)(void);
    int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, size_t *indexPtr); /* 34 */
    void (*reserved35)(void);
    void (*reserved36)(void);
    int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
    int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
    TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
    int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
    Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
................................................................................
    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 */
    void (*tclRegExpRangeUniChar) (Tcl_RegExp re, size_t index, int *startPtr, int *endPtr); /* 151 */
    void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */
    Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */
    void (*reserved154)(void);
    void (*reserved155)(void);
    void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
    Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
    void (*reserved158)(void);
................................................................................
    int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */
    Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */
    Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */
    Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const 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, const int flags); /* 256 */
    void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */

    int (*tclMSB) (size_t n); /* 258 */
} TclIntStubs;

extern const TclIntStubs *tclIntStubsPtr;

#ifdef __cplusplus
}
#endif
................................................................................
/* Slot 29 is reserved */
/* Slot 30 is reserved */
#define TclGetExtension \
	(tclIntStubsPtr->tclGetExtension) /* 31 */
#define TclGetFrame \
	(tclIntStubsPtr->tclGetFrame) /* 32 */
/* Slot 33 is reserved */
#define TclGetIntForIndex \
	(tclIntStubsPtr->tclGetIntForIndex) /* 34 */
/* Slot 35 is reserved */
/* Slot 36 is reserved */
#define TclGetLoadedPackages \
	(tclIntStubsPtr->tclGetLoadedPackages) /* 37 */
#define TclGetNamespaceForQualName \
	(tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */
#define TclGetObjInterpProc \
................................................................................
	(tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */
#define TclPtrObjMakeUpvar \
	(tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */
#define TclPtrUnsetVar \
	(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
#define TclStaticPackage \
	(tclIntStubsPtr->tclStaticPackage) /* 257 */


#define TclMSB \
	(tclIntStubsPtr->tclMSB) /* 258 */

#endif /* defined(USE_TCL_STUBS) */

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

#if defined(USE_TCL_STUBS)
#undef Tcl_StaticPackage






|
<
<
<







 







|







 







>
>
>







 







|







 







|







 







>
|







 







|
<







 







>
>

|







104
105
106
107
108
109
110
111



112
113
114
115
116
117
118
...
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
...
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
...
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
...
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
...
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
...
911
912
913
914
915
916
917
918

919
920
921
922
923
924
925
....
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
/* Slot 30 is reserved */
/* 31 */
EXTERN const char *	TclGetExtension(const char *name);
/* 32 */
EXTERN int		TclGetFrame(Tcl_Interp *interp, const char *str,
				CallFrame **framePtrPtr);
/* Slot 33 is reserved */
/* Slot 34 is reserved */



/* Slot 35 is reserved */
/* Slot 36 is reserved */
/* 37 */
EXTERN int		TclGetLoadedPackages(Tcl_Interp *interp,
				const char *targetName);
/* 38 */
EXTERN int		TclGetNamespaceForQualName(Tcl_Interp *interp,
................................................................................
EXTERN TclHandle	TclHandlePreserve(TclHandle handle);
/* 149 */
EXTERN void		TclHandleRelease(TclHandle handle);
/* 150 */
EXTERN int		TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re);
/* 151 */
EXTERN void		TclRegExpRangeUniChar(Tcl_RegExp re, size_t index,
				size_t *startPtr, size_t *endPtr);
/* 152 */
EXTERN void		TclSetLibraryPath(Tcl_Obj *pathPtr);
/* 153 */
EXTERN Tcl_Obj *	TclGetLibraryPath(void);
/* Slot 154 is reserved */
/* Slot 155 is reserved */
/* 156 */
................................................................................
				Tcl_Obj *part2Ptr, const int flags);
/* 257 */
EXTERN void		TclStaticPackage(Tcl_Interp *interp,
				const char *pkgName,
				Tcl_PackageInitProc *initProc,
				Tcl_PackageInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj *	TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
				Tcl_Obj *basenameObj);
/* 259 */
EXTERN int		TclMSB(size_t n);

typedef struct TclIntStubs {
    int magic;
    void *hooks;

    void (*reserved0)(void);
................................................................................
    void (*reserved27)(void);
    Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */
    void (*reserved29)(void);
    void (*reserved30)(void);
    const char * (*tclGetExtension) (const char *name); /* 31 */
    int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */
    void (*reserved33)(void);
    void (*reserved34)(void);
    void (*reserved35)(void);
    void (*reserved36)(void);
    int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
    int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
    TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
    int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
    Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
................................................................................
    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 */
    void (*tclRegExpRangeUniChar) (Tcl_RegExp re, size_t index, size_t *startPtr, size_t *endPtr); /* 151 */
    void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */
    Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */
    void (*reserved154)(void);
    void (*reserved155)(void);
    void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
    Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
    void (*reserved158)(void);
................................................................................
    int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */
    Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */
    Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */
    Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const 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, const int flags); /* 256 */
    void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
    Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
    int (*tclMSB) (size_t n); /* 259 */
} TclIntStubs;

extern const TclIntStubs *tclIntStubsPtr;

#ifdef __cplusplus
}
#endif
................................................................................
/* Slot 29 is reserved */
/* Slot 30 is reserved */
#define TclGetExtension \
	(tclIntStubsPtr->tclGetExtension) /* 31 */
#define TclGetFrame \
	(tclIntStubsPtr->tclGetFrame) /* 32 */
/* Slot 33 is reserved */
/* Slot 34 is reserved */

/* Slot 35 is reserved */
/* Slot 36 is reserved */
#define TclGetLoadedPackages \
	(tclIntStubsPtr->tclGetLoadedPackages) /* 37 */
#define TclGetNamespaceForQualName \
	(tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */
#define TclGetObjInterpProc \
................................................................................
	(tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */
#define TclPtrObjMakeUpvar \
	(tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */
#define TclPtrUnsetVar \
	(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
#define TclStaticPackage \
	(tclIntStubsPtr->tclStaticPackage) /* 257 */
#define TclpCreateTemporaryDirectory \
	(tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */
#define TclMSB \
	(tclIntStubsPtr->tclMSB) /* 259 */

#endif /* defined(USE_TCL_STUBS) */

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

#if defined(USE_TCL_STUBS)
#undef Tcl_StaticPackage

Changes to generic/tclLink.c.

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
...
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
...
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
...
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
....
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
    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. */
    int bytes;			/* Size of C variable array. This is 0 when
				 * single variables, and >0 used for array
				 * variables. */
    int 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;
................................................................................
    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. */
    int size)			/* Size of C variable array, >1 if array */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    Namespace *dummy;
    const char *name;
    int code;

................................................................................
    Tcl_Interp *interp,		/* Interpreter containing Tcl variable. */
    const char *name1,		/* First part of variable name. */
    const char *name2,		/* Second part of variable name. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = clientData;
    int changed;
    int valueLength;
    const char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    Tcl_WideUInt valueUWide;
    double valueDouble;
................................................................................
	pp = (char **) linkPtr->addr;

	*pp = Tcl_Realloc(*pp, ++valueLength);
	memcpy(*pp, value, valueLength);
	return NULL;

    case TCL_LINK_CHARS:
	value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength);
	valueLength++;		/* include end of string char */
	if (valueLength > linkPtr->bytes) {
	    return (char *) "wrong size of char* value";
	}
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
	    memcpy(linkPtr->addr, value, (size_t) valueLength);
................................................................................
	} else {
	    linkPtr->lastValue.c = '\0';
	    LinkedVar(char) = linkPtr->lastValue.c;
	}
	return NULL;

    case TCL_LINK_BINARY:
	value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength);
	if (valueLength != linkPtr->bytes) {
	    return (char *) "wrong size of binary value";
	}
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
	    memcpy(linkPtr->addr, value, (size_t) valueLength);
	} else {
................................................................................

    /*
     * If we're working with an array of numbers, extract the Tcl list.
     */

    if (linkPtr->flags & LINK_ALLOC_LAST) {
	if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR
		|| objc != linkPtr->numElems) {
	    return (char *) "wrong dimension";
	}
    }

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
................................................................................

static Tcl_Obj *
ObjValue(
    Link *linkPtr)		/* Structure describing linked variable. */
{
    char *p;
    Tcl_Obj *resultObj, **objv;
    int i;

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
	    for (i=0; i < linkPtr->numElems; i++) {






|


|







 







|







 







|







 







|







 







|







 







|







 







|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
...
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
...
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
...
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
....
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
    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;
................................................................................
    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;

................................................................................
    Tcl_Interp *interp,		/* Interpreter containing Tcl variable. */
    const char *name1,		/* First part of variable name. */
    const char *name2,		/* Second part of variable name. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = 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;
................................................................................
	pp = (char **) linkPtr->addr;

	*pp = Tcl_Realloc(*pp, ++valueLength);
	memcpy(*pp, value, valueLength);
	return NULL;

    case TCL_LINK_CHARS:
	value = (char *) TclGetStringFromObj(valueObj, &valueLength);
	valueLength++;		/* include end of string char */
	if (valueLength > linkPtr->bytes) {
	    return (char *) "wrong size of char* value";
	}
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
	    memcpy(linkPtr->addr, value, (size_t) valueLength);
................................................................................
	} else {
	    linkPtr->lastValue.c = '\0';
	    LinkedVar(char) = linkPtr->lastValue.c;
	}
	return NULL;

    case TCL_LINK_BINARY:
	value = (char *) TclGetByteArrayFromObj(valueObj, &valueLength);
	if (valueLength != linkPtr->bytes) {
	    return (char *) "wrong size of binary value";
	}
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
	    memcpy(linkPtr->addr, value, (size_t) valueLength);
	} else {
................................................................................

    /*
     * If we're working with an array of numbers, extract the Tcl list.
     */

    if (linkPtr->flags & LINK_ALLOC_LAST) {
	if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR
		|| (size_t)objc != linkPtr->numElems) {
	    return (char *) "wrong dimension";
	}
    }

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
................................................................................

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_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
	    for (i=0; i < linkPtr->numElems; i++) {

Changes to generic/tclLiteral.c.

232
233
234
235
236
237
238

239

240
241
242
243
244
245
246
247
248
249
250
251
...
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
...
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
....
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
		}
		if ((flags & LITERAL_ON_HEAP)) {
		    Tcl_Free((void *)bytes);
		}
		if (globalPtrPtr) {
		    *globalPtrPtr = globalPtr;
		} else {

		    globalPtr->refCount++;

#ifdef TCL_COMPILE_DEBUG
    if (globalPtr->refCount + 1 < 2) {
	Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
		"TclRegisterLiteral", (length>60? 60 : length), bytes,
		globalPtr->refCount);
    }
#endif
		}
		return objPtr;
	    }
	}
    }
................................................................................
	if (entryPtr->objPtr == objPtr) {
	    /*
	     * If the literal is no longer being used by any ByteCode, delete
	     * the entry then remove the reference corresponding to the global
	     * literal table entry (decrement the ref count of the object).
	     */

	    if (entryPtr->refCount-- <= 1) {
		if (prevPtr == NULL) {
		    globalTablePtr->buckets[index] = entryPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = entryPtr->nextPtr;
		}
		Tcl_Free(entryPtr);
		globalTablePtr->numEntries--;
................................................................................
     */

    result = Tcl_Alloc(NUM_COUNTERS*60 + 300);
    sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n",
	    tablePtr->numEntries, tablePtr->numBuckets);
    p = result + strlen(result);
    for (i=0 ; i<NUM_COUNTERS ; i++) {
	sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "d entries: %" TCL_Z_MODIFIER "d\n",
		i, count[i]);
	p += strlen(p);
    }
    sprintf(p, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "d\n",
	    NUM_COUNTERS, overflow);
    p += strlen(p);
    sprintf(p, "average search distance for entry: %.1f", average);
    return result;
}
#endif /*TCL_COMPILE_STATS*/
 
................................................................................

    for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
	for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
		globalPtr=globalPtr->nextPtr) {
	    count++;
	    if (globalPtr->refCount + 1 < 2) {
		bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
		Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "d",
			"TclVerifyGlobalLiteralTable",
			(length>60? 60 : (int)length), bytes, globalPtr->refCount);
	    }
	    if (globalPtr->objPtr->bytes == NULL) {
		Tcl_Panic("%s: literal has NULL string rep",
			"TclVerifyGlobalLiteralTable");
	    }
	}
    }
    if (count != globalTablePtr->numEntries) {
	Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "d entries, should be %" TCL_Z_MODIFIER "d",
		"TclVerifyGlobalLiteralTable", count,
		globalTablePtr->numEntries);
    }
}
#endif /*TCL_COMPILE_DEBUG*/
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






>
|
>


|
|
|







 







|







 







|



|







 







|










|













232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
...
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
...
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
....
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
		}
		if ((flags & LITERAL_ON_HEAP)) {
		    Tcl_Free((void *)bytes);
		}
		if (globalPtrPtr) {
		    *globalPtrPtr = globalPtr;
		} else {
		    if (globalPtr->refCount != TCL_AUTO_LENGTH) {
			globalPtr->refCount++;
		    }
#ifdef TCL_COMPILE_DEBUG
    if (globalPtr->refCount + 1 < 2) {
	Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %"
		TCL_Z_MODIFIER "u", "TclRegisterLiteral",
		(length>60? 60 : length), bytes, globalPtr->refCount);
    }
#endif
		}
		return objPtr;
	    }
	}
    }
................................................................................
	if (entryPtr->objPtr == objPtr) {
	    /*
	     * If the literal is no longer being used by any ByteCode, delete
	     * the entry then remove the reference corresponding to the global
	     * literal table entry (decrement the ref count of the object).
	     */

	    if ((entryPtr->refCount != TCL_AUTO_LENGTH) && (entryPtr->refCount-- <= 1)) {
		if (prevPtr == NULL) {
		    globalTablePtr->buckets[index] = entryPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = entryPtr->nextPtr;
		}
		Tcl_Free(entryPtr);
		globalTablePtr->numEntries--;
................................................................................
     */

    result = Tcl_Alloc(NUM_COUNTERS*60 + 300);
    sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n",
	    tablePtr->numEntries, tablePtr->numBuckets);
    p = result + strlen(result);
    for (i=0 ; i<NUM_COUNTERS ; i++) {
	sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n",
		i, count[i]);
	p += strlen(p);
    }
    sprintf(p, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n",
	    NUM_COUNTERS, overflow);
    p += strlen(p);
    sprintf(p, "average search distance for entry: %.1f", average);
    return result;
}
#endif /*TCL_COMPILE_STATS*/
 
................................................................................

    for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
	for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
		globalPtr=globalPtr->nextPtr) {
	    count++;
	    if (globalPtr->refCount + 1 < 2) {
		bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
		Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
			"TclVerifyGlobalLiteralTable",
			(length>60? 60 : (int)length), bytes, globalPtr->refCount);
	    }
	    if (globalPtr->objPtr->bytes == NULL) {
		Tcl_Panic("%s: literal has NULL string rep",
			"TclVerifyGlobalLiteralTable");
	    }
	}
    }
    if (count != globalTablePtr->numEntries) {
	Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u",
		"TclVerifyGlobalLiteralTable", count,
		globalTablePtr->numEntries);
    }
}
#endif /*TCL_COMPILE_DEBUG*/
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclOOMethod.c.

117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
/*
 * Helper macros (derived from things private to tclVar.c)
 */

#define TclVarTable(contextNs) \
    ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
    ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))
 
/*
 * ----------------------------------------------------------------------
 *
 * Tcl_NewInstanceMethod --
 *
 *	Attach a method to an object instance.






|







117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
/*
 * Helper macros (derived from things private to tclVar.c)
 */

#define TclVarTable(contextNs) \
    ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
    ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
 
/*
 * ----------------------------------------------------------------------
 *
 * Tcl_NewInstanceMethod --
 *
 *	Attach a method to an object instance.

Changes to generic/tclProc.c.

630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
	    localPtr = localPtr->nextPtr;
	} else {
	    /*
	     * Allocate an entry in the runtime procedure frame's array of
	     * local variables for the argument.
	     */

	    localPtr = Tcl_Alloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1);
	    if (procPtr->firstLocalPtr == NULL) {
		procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	    } else {
		procPtr->lastLocalPtr->nextPtr = localPtr;
		procPtr->lastLocalPtr = localPtr;
	    }
	    localPtr->nextPtr = NULL;






|







630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
	    localPtr = localPtr->nextPtr;
	} else {
	    /*
	     * Allocate an entry in the runtime procedure frame's array of
	     * local variables for the argument.
	     */

	    localPtr = Tcl_Alloc(offsetof(CompiledLocal, name) + fieldValues[0]->length +1);
	    if (procPtr->firstLocalPtr == NULL) {
		procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
	    } else {
		procPtr->lastLocalPtr->nextPtr = localPtr;
		procPtr->lastLocalPtr = localPtr;
	    }
	    localPtr->nextPtr = NULL;

Changes to generic/tclRegexp.c.

260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
...
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
...
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
				 * 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 == -1) {
	*startPtr = *endPtr = NULL;
    } else {
	if (regexpPtr->objPtr) {
	    string = TclGetString(regexpPtr->objPtr);
	} else {
	    string = regexpPtr->string;
	}
................................................................................

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, -1 means the range of the
				 * rm_extend field. */
    int *startPtr,		/* Store address of first character in
				 * (sub-)range here. */
    int *endPtr)		/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;

    if ((regexpPtr->flags&REG_EXPECT) && index == TCL_AUTO_LENGTH) {
	*startPtr = regexpPtr->details.rm_extend.rm_so;
	*endPtr = regexpPtr->details.rm_extend.rm_eo;
    } else if (index > regexpPtr->re.re_nsub) {
	*startPtr = -1;
	*endPtr = -1;
    } else {
	*startPtr = regexpPtr->matches[index].rm_so;
	*endPtr = regexpPtr->matches[index].rm_eo;
    }
}
 
/*
................................................................................
     * Assume that there will never be more than INT_MAX subexpressions. This
     * is a pretty reasonable assumption; the RE engine doesn't scale _that_
     * well and Tcl has other limits that constrain things as well...
     */

    resultObj = Tcl_NewObj();
    Tcl_ListObjAppendElement(NULL, resultObj,
	    Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub));

    /*
     * Now append a list of all the bit-flags set for the RE.
     */

    TclNewObj(infoObj);
    for (inf=infonames ; inf->bit != 0 ; inf++) {






|







 







|

|

|




|


|
|
|







 







|







260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
...
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
...
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
				 * 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;
	}
................................................................................

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;
    }
}
 
/*
................................................................................
     * Assume that there will never be more than INT_MAX subexpressions. This
     * is a pretty reasonable assumption; the RE engine doesn't scale _that_
     * well and Tcl has other limits that constrain things as well...
     */

    resultObj = Tcl_NewObj();
    Tcl_ListObjAppendElement(NULL, resultObj,
	    TclNewWideIntObjFromSize(regexpPtr->re.re_nsub));

    /*
     * Now append a list of all the bit-flags set for the RE.
     */

    TclNewObj(infoObj);
    for (inf=infonames ; inf->bit != 0 ; inf++) {

Changes to generic/tclStrToD.c.

4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
	if (lsb == -1-shift) {

	    /*
	     * Round to even
	     */

	    mp_div_2d(a, -shift, &b, NULL);
	    if (mp_get_bit(&b, 0)) {
		if (b.sign == MP_ZPOS) {
		    mp_add_d(&b, 1, &b);
		} else {
		    mp_sub_d(&b, 1, &b);
		}
	    }
	} else {






|







4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
	if (lsb == -1-shift) {

	    /*
	     * Round to even
	     */

	    mp_div_2d(a, -shift, &b, NULL);
	    if (mp_isodd(&b)) {
		if (b.sign == MP_ZPOS) {
		    mp_add_d(&b, 1, &b);
		} else {
		    mp_sub_d(&b, 1, &b);
		}
	    }
	} else {

Changes to generic/tclStringObj.c.

1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
     * "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 offset = TCL_AUTO_LENGTH;

	/*
	 * 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 != TCL_AUTO_LENGTH) {
	    unicode = stringPtr->unicode + offset;
	}
    }

    /*
     * Copy the new string onto the end of the old string, then add the
     * trailing null.
     */






|









|









|
|







1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
     * "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.
     */

Changes to generic/tclStubInit.c.

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
...
454
455
456
457
458
459
460

461
462
463
464
465
466
467
468
...
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
....
1335
1336
1337
1338
1339
1340
1341

1342
1343
1344
    0, /* 27 */
    TclpGetDefaultStdChannel, /* 28 */
    0, /* 29 */
    0, /* 30 */
    TclGetExtension, /* 31 */
    TclGetFrame, /* 32 */
    0, /* 33 */
    TclGetIntForIndex, /* 34 */
    0, /* 35 */
    0, /* 36 */
    TclGetLoadedPackages, /* 37 */
    TclGetNamespaceForQualName, /* 38 */
    TclGetObjInterpProc, /* 39 */
    TclGetOpenMode, /* 40 */
    TclGetOriginalCommand, /* 41 */
................................................................................
    TclRegisterLiteral, /* 251 */
    TclPtrGetVar, /* 252 */
    TclPtrSetVar, /* 253 */
    TclPtrIncrObjVar, /* 254 */
    TclPtrObjMakeUpvar, /* 255 */
    TclPtrUnsetVar, /* 256 */
    TclStaticPackage, /* 257 */

    TclMSB, /* 258 */
};

static const TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
    TclGetAndDetachPids, /* 0 */
................................................................................
    0, /* 66 */
    TclBN_mp_expt_d_ex, /* 67 */
    TclBN_mp_set_long_long, /* 68 */
    TclBN_mp_get_long_long, /* 69 */
    TclBN_mp_set_long, /* 70 */
    TclBN_mp_get_long, /* 71 */
    TclBN_mp_get_int, /* 72 */
    TclBN_mp_tc_and, /* 73 */
    TclBN_mp_tc_or, /* 74 */
    TclBN_mp_tc_xor, /* 75 */
    TclBN_mp_tc_div_2d, /* 76 */
    TclBN_mp_get_bit, /* 77 */
};

static const TclStubHooks tclStubHooks = {
    &tclPlatStubs,
    &tclIntStubs,
    &tclIntPlatStubs
................................................................................
    Tcl_FetchIntRep, /* 638 */
    Tcl_StoreIntRep, /* 639 */
    Tcl_HasStringRep, /* 640 */
    Tcl_IncrRefCount, /* 641 */
    Tcl_DecrRefCount, /* 642 */
    Tcl_IsShared, /* 643 */
    Tcl_LinkArray, /* 644 */

};

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






|







 







>
|







 







|
|
|
|







 







>



230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
...
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
...
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
....
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
    0, /* 27 */
    TclpGetDefaultStdChannel, /* 28 */
    0, /* 29 */
    0, /* 30 */
    TclGetExtension, /* 31 */
    TclGetFrame, /* 32 */
    0, /* 33 */
    0, /* 34 */
    0, /* 35 */
    0, /* 36 */
    TclGetLoadedPackages, /* 37 */
    TclGetNamespaceForQualName, /* 38 */
    TclGetObjInterpProc, /* 39 */
    TclGetOpenMode, /* 40 */
    TclGetOriginalCommand, /* 41 */
................................................................................
    TclRegisterLiteral, /* 251 */
    TclPtrGetVar, /* 252 */
    TclPtrSetVar, /* 253 */
    TclPtrIncrObjVar, /* 254 */
    TclPtrObjMakeUpvar, /* 255 */
    TclPtrUnsetVar, /* 256 */
    TclStaticPackage, /* 257 */
    TclpCreateTemporaryDirectory, /* 258 */
    TclMSB, /* 259 */
};

static const TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
    TclGetAndDetachPids, /* 0 */
................................................................................
    0, /* 66 */
    TclBN_mp_expt_d_ex, /* 67 */
    TclBN_mp_set_long_long, /* 68 */
    TclBN_mp_get_long_long, /* 69 */
    TclBN_mp_set_long, /* 70 */
    TclBN_mp_get_long, /* 71 */
    TclBN_mp_get_int, /* 72 */
    0, /* 73 */
    0, /* 74 */
    0, /* 75 */
    TclBN_mp_signed_rsh, /* 76 */
    TclBN_mp_get_bit, /* 77 */
};

static const TclStubHooks tclStubHooks = {
    &tclPlatStubs,
    &tclIntStubs,
    &tclIntPlatStubs
................................................................................
    Tcl_FetchIntRep, /* 638 */
    Tcl_StoreIntRep, /* 639 */
    Tcl_HasStringRep, /* 640 */
    Tcl_IncrRefCount, /* 641 */
    Tcl_DecrRefCount, /* 642 */
    Tcl_IsShared, /* 643 */
    Tcl_LinkArray, /* 644 */
    Tcl_GetIntForIndex, /* 645 */
};

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

Changes to generic/tclTest.c.

344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
....
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
....
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
....
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178

4179
4180
4181
4182
4183
4184
4185
4186
....
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
....
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
static int		TestregexpObjCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestreturnObjCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static void		TestregexpXflags(const char *string,
			    int length, int *cflagsPtr, int *eflagsPtr);
static int		TestsaveresultCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static void		TestsaveresultFree(void *blockPtr);
static int		TestsetassocdataCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestsetCmd(void *dummy,
................................................................................
	 * value 0.
	 */

	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
	if (objc > 2 && (cflags&REG_EXPECT) && indices) {
	    const char *varName;
	    const char *value;
	    int start, end;
	    char resinfo[TCL_INTEGER_SPACE * 2];

	    varName = Tcl_GetString(objv[2]);
	    TclRegExpRangeUniChar(regExpr, -1, &start, &end);
	    sprintf(resinfo, "%d %d", start, end-1);
	    value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
	    if (value == NULL) {
		Tcl_AppendResult(interp, "couldn't set variable \"",
			varName, "\"", NULL);
		return TCL_ERROR;
	    }
	} else if (cflags & TCL_REG_CANMATCH) {
	    const char *varName;
	    const char *value;
	    char resinfo[TCL_INTEGER_SPACE * 2];

	    Tcl_RegExpGetInfo(regExpr, &info);
	    varName = Tcl_GetString(objv[2]);
	    sprintf(resinfo, "%ld", info.extendStart);
	    value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
	    if (value == NULL) {
		Tcl_AppendResult(interp, "couldn't set variable \"",
			varName, "\"", NULL);
		return TCL_ERROR;
	    }
	}
................................................................................
     */

    objc -= 2;
    objv += 2;

    Tcl_RegExpGetInfo(regExpr, &info);
    for (i = 0; i < objc; i++) {
	int start, end;
	Tcl_Obj *newPtr, *varPtr, *valuePtr;

	varPtr = objv[i];
	ii = ((cflags&REG_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : (size_t)i;
	if (indices) {
	    Tcl_Obj *objs[2];

	    if (ii == TCL_INDEX_NONE) {
		TclRegExpRangeUniChar(regExpr, ii, &start, &end);
	    } else if (ii > (size_t)info.nsubs) {
		start = -1;
		end = -1;
	    } else {
		start = info.matches[ii].start;
		end = info.matches[ii].end;
	    }

	    /*
	     * Adjust index so it refers to the last character in the match
	     * instead of the first character after the match.
	     */

	    if (end >= 0) {
		end--;
	    }

	    objs[0] = Tcl_NewWideIntObj(start);
	    objs[1] = Tcl_NewWideIntObj(end);

	    newPtr = Tcl_NewListObj(2, objs);
	} else {
	    if (ii == TCL_INDEX_NONE) {
		TclRegExpRangeUniChar(regExpr, ii, &start, &end);
		newPtr = Tcl_GetRange(objPtr, start, end);
	    } else if (ii > (size_t)info.nsubs) {
		newPtr = Tcl_NewObj();
	    } else {
		newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
			info.matches[ii].end - 1);
	    }
	}
	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG);
................................................................................
 *
 *----------------------------------------------------------------------
 */

static void
TestregexpXflags(
    const char *string,	/* The string of flags. */
    int length,			/* The length of the string in bytes. */
    int *cflagsPtr,		/* compile flags word */
    int *eflagsPtr)		/* exec flags word */
{

    int i, cflags, eflags;

    cflags = *cflagsPtr;
    eflags = *eflagsPtr;
    for (i = 0; i < length; i++) {
	switch (string[i]) {
	case 'a':
	    cflags |= REG_ADVF;
................................................................................
}
 
/*
 *----------------------------------------------------------------------
 *
 * TestupvarCmd --
 *
 *	This procedure implements the "testupvar2" command.  It is used
 *	to test Tcl_UpVar and Tcl_UpVar2.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates or modifies an "upvar" reference.
................................................................................
    if (resVarInfo->var) {
        HashVarFree(resVarInfo->var);
    }
    Tcl_Free(vInfoPtr);
}

#define TclVarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))

static Tcl_Var
MyCompiledVarFetch(
    Tcl_Interp *interp,
    Tcl_ResolvedVarInfo *vinfoPtr)
{
    MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;






|







 







|




|













|







 







|









|
|
|










|



|
|






|







 







|



>
|







 







|







 







|







344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
....
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
....
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
....
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
....
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
....
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
static int		TestregexpObjCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestreturnObjCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static void		TestregexpXflags(const char *string,
			    size_t length, int *cflagsPtr, int *eflagsPtr);
static int		TestsaveresultCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static void		TestsaveresultFree(void *blockPtr);
static int		TestsetassocdataCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestsetCmd(void *dummy,
................................................................................
	 * value 0.
	 */

	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
	if (objc > 2 && (cflags&REG_EXPECT) && indices) {
	    const char *varName;
	    const char *value;
	    size_t start, end;
	    char resinfo[TCL_INTEGER_SPACE * 2];

	    varName = Tcl_GetString(objv[2]);
	    TclRegExpRangeUniChar(regExpr, -1, &start, &end);
	    sprintf(resinfo, "%" TCL_LL_MODIFIER "d %" TCL_LL_MODIFIER "d", TclWideIntFromSize(start), TclWideIntFromSize(end-1));
	    value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
	    if (value == NULL) {
		Tcl_AppendResult(interp, "couldn't set variable \"",
			varName, "\"", NULL);
		return TCL_ERROR;
	    }
	} else if (cflags & TCL_REG_CANMATCH) {
	    const char *varName;
	    const char *value;
	    char resinfo[TCL_INTEGER_SPACE * 2];

	    Tcl_RegExpGetInfo(regExpr, &info);
	    varName = Tcl_GetString(objv[2]);
	    sprintf(resinfo, "%" TCL_LL_MODIFIER "d", TclWideIntFromSize(info.extendStart));
	    value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
	    if (value == NULL) {
		Tcl_AppendResult(interp, "couldn't set variable \"",
			varName, "\"", NULL);
		return TCL_ERROR;
	    }
	}
................................................................................
     */

    objc -= 2;
    objv += 2;

    Tcl_RegExpGetInfo(regExpr, &info);
    for (i = 0; i < objc; i++) {
	size_t start, end;
	Tcl_Obj *newPtr, *varPtr, *valuePtr;

	varPtr = objv[i];
	ii = ((cflags&REG_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : (size_t)i;
	if (indices) {
	    Tcl_Obj *objs[2];

	    if (ii == TCL_INDEX_NONE) {
		TclRegExpRangeUniChar(regExpr, ii, &start, &end);
	    } else if (ii > info.nsubs) {
		start = TCL_INDEX_NONE;
		end = TCL_INDEX_NONE;
	    } else {
		start = info.matches[ii].start;
		end = info.matches[ii].end;
	    }

	    /*
	     * Adjust index so it refers to the last character in the match
	     * instead of the first character after the match.
	     */

	    if (end != TCL_INDEX_NONE) {
		end--;
	    }

	    objs[0] = TclNewWideIntObjFromSize(start);
	    objs[1] = TclNewWideIntObjFromSize(end);

	    newPtr = Tcl_NewListObj(2, objs);
	} else {
	    if (ii == TCL_INDEX_NONE) {
		TclRegExpRangeUniChar(regExpr, ii, &start, &end);
		newPtr = Tcl_GetRange(objPtr, start, end);
	    } else if (ii > info.nsubs) {
		newPtr = Tcl_NewObj();
	    } else {
		newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
			info.matches[ii].end - 1);
	    }
	}
	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG);
................................................................................
 *
 *----------------------------------------------------------------------
 */

static void
TestregexpXflags(
    const char *string,	/* The string of flags. */
    size_t length,			/* The length of the string in bytes. */
    int *cflagsPtr,		/* compile flags word */
    int *eflagsPtr)		/* exec flags word */
{
    size_t i;
    int cflags, eflags;

    cflags = *cflagsPtr;
    eflags = *eflagsPtr;
    for (i = 0; i < length; i++) {
	switch (string[i]) {
	case 'a':
	    cflags |= REG_ADVF;
................................................................................
}
 
/*
 *----------------------------------------------------------------------
 *
 * TestupvarCmd --
 *
 *	This procedure implements the "testupvar" command.  It is used
 *	to test Tcl_UpVar and Tcl_UpVar2.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates or modifies an "upvar" reference.
................................................................................
    if (resVarInfo->var) {
        HashVarFree(resVarInfo->var);
    }
    Tcl_Free(vInfoPtr);
}

#define TclVarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))

static Tcl_Var
MyCompiledVarFetch(
    Tcl_Interp *interp,
    Tcl_ResolvedVarInfo *vinfoPtr)
{
    MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;

Changes to generic/tclTestObj.c.

286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
	    return TCL_ERROR;
	}
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetIntObj(varPtr[varIndex], !mp_get_bit(&bignumValue, 0));
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_get_bit(&bignumValue, 0)));
	}
	mp_clear(&bignumValue);
	break;

    case BIGNUM_RADIXSIZE:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");






|

|







286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
	    return TCL_ERROR;
	}
	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
		&bignumValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue));
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue)));
	}
	mp_clear(&bignumValue);
	break;

    case BIGNUM_RADIXSIZE:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");

Changes to generic/tclThreadAlloc.c.

641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
	if (cachePtr == sharedPtr) {
	    Tcl_DStringAppendElement(dsPtr, "shared");
	} else {
	    sprintf(buf, "thread%p", cachePtr->owner);
	    Tcl_DStringAppendElement(dsPtr, buf);
	}
	for (n = 0; n < NBUCKETS; ++n) {
	    sprintf(buf, "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d",
		    bucketInfo[n].blockSize,
		    cachePtr->buckets[n].numFree,
		    cachePtr->buckets[n].numRemoves,
		    cachePtr->buckets[n].numInserts,
		    cachePtr->buckets[n].totalAssigned,
		    cachePtr->buckets[n].numLocks,
		    cachePtr->buckets[n].numWaits);






|







641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
	if (cachePtr == sharedPtr) {
	    Tcl_DStringAppendElement(dsPtr, "shared");
	} else {
	    sprintf(buf, "thread%p", cachePtr->owner);
	    Tcl_DStringAppendElement(dsPtr, buf);
	}
	for (n = 0; n < NBUCKETS; ++n) {
	    sprintf(buf, "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u",
		    bucketInfo[n].blockSize,
		    cachePtr->buckets[n].numFree,
		    cachePtr->buckets[n].numRemoves,
		    cachePtr->buckets[n].numInserts,
		    cachePtr->buckets[n].totalAssigned,
		    cachePtr->buckets[n].numLocks,
		    cachePtr->buckets[n].numWaits);

Changes to generic/tclTomMath.decls.

217
218
219
220
221
222
223

224
225
226


227
228
229


230
231
232

233
234
235
236
237
238
239
240
241
242
243
    unsigned long TclBN_mp_get_long(const mp_int *a)
}
declare 72 {
    unsigned long TclBN_mp_get_int(const mp_int *a)
}

# Added in libtommath 1.1.0

declare 73 {
    int TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)
}


declare 74 {
    int TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)
}


declare 75 {
    int TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)
}

declare 76 {
    int TclBN_mp_tc_div_2d(const mp_int *a, int b, mp_int *c)
}
declare 77 {
    int TclBN_mp_get_bit(const mp_int *a, int b)
}


# Local Variables:
# mode: tcl
# End:






>
|
|
<
>
>
|
|
<
>
>
|
|
<
>

|









217
218
219
220
221
222
223
224
225
226

227
228
229
230

231
232
233
234

235
236
237
238
239
240
241
242
243
244
245
246
    unsigned long TclBN_mp_get_long(const mp_int *a)
}
declare 72 {
    unsigned long TclBN_mp_get_int(const mp_int *a)
}

# Added in libtommath 1.1.0
# No longer in use: replaced by mp_and()
#declare 73 {
#    int TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)

#}
# No longer in use: replaced by mp_or()
#declare 74 {
#    int TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)

#}
# No longer in use: replaced by mp_xor()
#declare 75 {
#    int TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)

#}
declare 76 {
    int TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
declare 77 {
    int TclBN_mp_get_bit(const mp_int *a, int b)
}


# Local Variables:
# mode: tcl
# End:

Changes to generic/tclTomMath.h.

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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
...
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
437
};

/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);


/* error code to char* string */

const char *mp_error_to_string(int code);


/* ---> init and deinit bignum functions <--- */
/* init a bignum */
/*
int mp_init(mp_int *a);
*/

/* free a bignum */
/*
void mp_clear(mp_int *a);
*/

/* init a null terminated series of arguments */
/*
int mp_init_multi(mp_int *mp, ...);
*/

/* clear a null terminated series of arguments */
/*
void mp_clear_multi(mp_int *mp, ...);
*/

................................................................................
/* exchange two ints */
/*
void mp_exch(mp_int *a, mp_int *b);
*/

/* shrink ram required for a bignum */
/*
int mp_shrink(mp_int *a);
*/

/* grow an int to a given size */
/*
int mp_grow(mp_int *a, int size);
*/

/* init to a given number of digits */
/*
int mp_init_size(mp_int *a, int size);
*/

/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
#define mp_iseven(a) (!mp_get_bit((a),0))
#define mp_isodd(a)  mp_get_bit((a),0)
#define mp_isneg(a)  (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)

/* set to zero */
/*
void mp_zero(mp_int *a);
*/

................................................................................
*/

/* c = a AND b */
/*
int mp_and(const mp_int *a, const mp_int *b, mp_int *c);
*/

/* c = a XOR b (two complement) */
/*
int mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c);
*/

/* c = a OR b (two complement) */
/*
int mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c);
*/

/* c = a AND b (two complement) */
/*
int mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c);
*/

/* right shift (two complement) */
/*
int mp_tc_div_2d(const mp_int *a, int b, mp_int *c);
*/

/* ---> Basic arithmetic <--- */

/* b = ~a */
/*
int mp_complement(const mp_int *a, mp_int *b);






>
|
>




|









|







 







|




|




|




|
|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


|







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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
...
408
409
410
411
412
413
414















415
416
417
418
419
420
421
422
423
424
};

/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);


/* error code to char* string */
/*
const char *mp_error_to_string(mp_err code);
*/

/* ---> init and deinit bignum functions <--- */
/* init a bignum */
/*
mp_err mp_init(mp_int *a);
*/

/* free a bignum */
/*
void mp_clear(mp_int *a);
*/

/* init a null terminated series of arguments */
/*
mp_err mp_init_multi(mp_int *mp, ...);
*/

/* clear a null terminated series of arguments */
/*
void mp_clear_multi(mp_int *mp, ...);
*/

................................................................................
/* exchange two ints */
/*
void mp_exch(mp_int *a, mp_int *b);
*/

/* shrink ram required for a bignum */
/*
mp_err mp_shrink(mp_int *a);
*/

/* grow an int to a given size */
/*
mp_err mp_grow(mp_int *a, int size);
*/

/* init to a given number of digits */
/*
mp_err mp_init_size(mp_int *a, int size);
*/

/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
#define mp_isodd(a)  (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)
#define mp_isneg(a)  (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)

/* set to zero */
/*
void mp_zero(mp_int *a);
*/

................................................................................
*/

/* c = a AND b */
/*
int mp_and(const mp_int *a, const mp_int *b, mp_int *c);
*/
















/* right shift (two complement) */
/*
int mp_signed_rsh(const mp_int *a, int b, mp_int *c);
*/

/* ---> Basic arithmetic <--- */

/* b = ~a */
/*
int mp_complement(const mp_int *a, mp_int *b);

Changes to generic/tclTomMathDecls.h.

67
68
69
70
71
72
73
74
75
76
77


78
79
80
81
82
83
84
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
...
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
...
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
...
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
#define mp_div_2 TclBN_mp_div_2
#define mp_div_2d TclBN_mp_div_2d
#define mp_div_3 TclBN_mp_div_3
#define mp_div_d TclBN_mp_div_d
#define mp_exch TclBN_mp_exch
#define mp_expt_d TclBN_mp_expt_d
#define mp_expt_d_ex TclBN_mp_expt_d_ex
#define mp_get_bit TclBN_mp_get_bit
#define mp_get_int TclBN_mp_get_int
#define mp_get_long TclBN_mp_get_long
#define mp_get_long_long TclBN_mp_get_long_long


#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
#define mp_init_multi TclBN_mp_init_multi
#define mp_init_set TclBN_mp_init_set
#define mp_init_set_int TclBN_mp_init_set_int
#define mp_init_size TclBN_mp_init_size
................................................................................
#define mp_set_long TclBN_mp_set_long
#define mp_set_long_long TclBN_mp_set_long_long
#define mp_shrink TclBN_mp_shrink
#define mp_sqr TclBN_mp_sqr
#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
#define mp_sub_d TclBN_mp_sub_d
#define mp_tc_and TclBN_mp_tc_and
#define mp_tc_div_2d TclBN_mp_tc_div_2d
#define mp_tc_or TclBN_mp_tc_or
#define mp_tc_xor TclBN_mp_tc_xor
#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toom_mul TclBN_mp_toom_mul
#define s_mp_toom_mul TclBN_mp_toom_mul
#define mp_toom_sqr TclBN_mp_toom_sqr
#define s_mp_toom_sqr TclBN_mp_toom_sqr
#define mp_toradix_n TclBN_mp_toradix_n
................................................................................
EXTERN Tcl_WideUInt	TclBN_mp_get_long_long(const mp_int *a);
/* 70 */
EXTERN int		TclBN_mp_set_long(mp_int *a, unsigned long i);
/* 71 */
EXTERN unsigned long	TclBN_mp_get_long(const mp_int *a);
/* 72 */
EXTERN unsigned long	TclBN_mp_get_int(const mp_int *a);
/* 73 */
EXTERN int		TclBN_mp_tc_and(const mp_int *a, const mp_int *b,
				mp_int *c);
/* 74 */
EXTERN int		TclBN_mp_tc_or(const mp_int *a, const mp_int *b,
				mp_int *c);
/* 75 */
EXTERN int		TclBN_mp_tc_xor(const mp_int *a, const mp_int *b,
				mp_int *c);
/* 76 */
EXTERN int		TclBN_mp_tc_div_2d(const mp_int *a, int b, mp_int *c);
/* 77 */
EXTERN int		TclBN_mp_get_bit(const mp_int *a, int b);

typedef struct TclTomMathStubs {
    int magic;
    void *hooks;

................................................................................
    void (*reserved66)(void);
    int (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */
    int (*tclBN_mp_set_long_long) (mp_int *a, Tcl_WideUInt i); /* 68 */
    Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */
    int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */
    unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */
    unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */
    int (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */
    int (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */
    int (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */
    int (*tclBN_mp_tc_div_2d) (const mp_int *a, int b, mp_int *c); /* 76 */
    int (*tclBN_mp_get_bit) (const mp_int *a, int b); /* 77 */
} TclTomMathStubs;

extern const TclTomMathStubs *tclTomMathStubsPtr;

#ifdef __cplusplus
}
................................................................................
	(tclTomMathStubsPtr->tclBN_mp_get_long_long) /* 69 */
#define TclBN_mp_set_long \
	(tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */
#define TclBN_mp_get_long \
	(tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */
#define TclBN_mp_get_int \
	(tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */
#define TclBN_mp_tc_and \
	(tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */
#define TclBN_mp_tc_or \
	(tclTomMathStubsPtr->tclBN_mp_tc_or) /* 74 */
#define TclBN_mp_tc_xor \
	(tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */
#define TclBN_mp_tc_div_2d \
	(tclTomMathStubsPtr->tclBN_mp_tc_div_2d) /* 76 */
#define TclBN_mp_get_bit \
	(tclTomMathStubsPtr->tclBN_mp_get_bit) /* 77 */

#endif /* defined(USE_TCL_STUBS) */

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

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLINTDECLS */






<



>
>







 







|
<
<
<







 







|
|
|
|
|

<
<
<
<
<







 







|
|
|
|







 







|
|
|
<
|
|
<
<











67
68
69
70
71
72
73

74
75
76
77
78
79
80
81
82
83
84
85
...
104
105
106
107
108
109
110
111



112
113
114
115
116
117
118
...
318
319
320
321
322
323
324
325
326
327
328
329
330





331
332
333
334
335
336
337
...
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
...
555
556
557
558
559
560
561
562
563
564

565
566


567
568
569
570
571
572
573
574
575
576
577
#define mp_div_2 TclBN_mp_div_2
#define mp_div_2d TclBN_mp_div_2d
#define mp_div_3 TclBN_mp_div_3
#define mp_div_d TclBN_mp_div_d
#define mp_exch TclBN_mp_exch
#define mp_expt_d TclBN_mp_expt_d
#define mp_expt_d_ex TclBN_mp_expt_d_ex

#define mp_get_int TclBN_mp_get_int
#define mp_get_long TclBN_mp_get_long
#define mp_get_long_long TclBN_mp_get_long_long
#define mp_grow TclBN_mp_grow
#define s_mp_get_bit TclBN_mp_get_bit
#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
#define mp_init_multi TclBN_mp_init_multi
#define mp_init_set TclBN_mp_init_set
#define mp_init_set_int TclBN_mp_init_set_int
#define mp_init_size TclBN_mp_init_size
................................................................................
#define mp_set_long TclBN_mp_set_long
#define mp_set_long_long TclBN_mp_set_long_long
#define mp_shrink TclBN_mp_shrink
#define mp_sqr TclBN_mp_sqr
#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
#define mp_sub_d TclBN_mp_sub_d
#define mp_signed_rsh TclBN_mp_signed_rsh



#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toom_mul TclBN_mp_toom_mul
#define s_mp_toom_mul TclBN_mp_toom_mul
#define mp_toom_sqr TclBN_mp_toom_sqr
#define s_mp_toom_sqr TclBN_mp_toom_sqr
#define mp_toradix_n TclBN_mp_toradix_n
................................................................................
EXTERN Tcl_WideUInt	TclBN_mp_get_long_long(const mp_int *a);
/* 70 */
EXTERN int		TclBN_mp_set_long(mp_int *a, unsigned long i);
/* 71 */
EXTERN unsigned long	TclBN_mp_get_long(const mp_int *a);
/* 72 */
EXTERN unsigned long	TclBN_mp_get_int(const mp_int *a);
/* Slot 73 is reserved */
/* Slot 74 is reserved */
/* Slot 75 is reserved */
/* 76 */
EXTERN int		TclBN_mp_signed_rsh(const mp_int *a, int b,
				mp_int *c);





/* 77 */
EXTERN int		TclBN_mp_get_bit(const mp_int *a, int b);

typedef struct TclTomMathStubs {
    int magic;
    void *hooks;

................................................................................
    void (*reserved66)(void);
    int (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */
    int (*tclBN_mp_set_long_long) (mp_int *a, Tcl_WideUInt i); /* 68 */
    Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */
    int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */
    unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */
    unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */
    void (*reserved73)(void);
    void (*reserved74)(void);
    void (*reserved75)(void);
    int (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */
    int (*tclBN_mp_get_bit) (const mp_int *a, int b); /* 77 */
} TclTomMathStubs;

extern const TclTomMathStubs *tclTomMathStubsPtr;

#ifdef __cplusplus
}
................................................................................
	(tclTomMathStubsPtr->tclBN_mp_get_long_long) /* 69 */
#define TclBN_mp_set_long \
	(tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */
#define TclBN_mp_get_long \
	(tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */
#define TclBN_mp_get_int \
	(tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */
/* Slot 73 is reserved */
/* Slot 74 is reserved */
/* Slot 75 is reserved */

#define TclBN_mp_signed_rsh \
	(tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */


#define TclBN_mp_get_bit \
	(tclTomMathStubsPtr->tclBN_mp_get_bit) /* 77 */

#endif /* defined(USE_TCL_STUBS) */

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

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLINTDECLS */

Changes to generic/tclTrace.c.

467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
...
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
		break;
	    }
	}
	command = TclGetStringFromObj(objv[5], &commandLength);
	length = commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    TraceCommandInfo *tcmdPtr = Tcl_Alloc(
		    TclOffset(TraceCommandInfo, command) + 1 + length);

	    tcmdPtr->flags = flags;
	    tcmdPtr->stepTrace = NULL;
	    tcmdPtr->startLevel = 0;
	    tcmdPtr->startCmd = NULL;
	    tcmdPtr->length = length;
	    tcmdPtr->refCount = 1;
................................................................................
	    }
	}

	command = TclGetStringFromObj(objv[5], &commandLength);
	length = commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    TraceCommandInfo *tcmdPtr = Tcl_Alloc(
		    TclOffset(TraceCommandInfo, command) + 1 + length);

	    tcmdPtr->flags = flags;
	    tcmdPtr->stepTrace = NULL;
	    tcmdPtr->startLevel = 0;
	    tcmdPtr->startCmd = NULL;
	    tcmdPtr->length = length;
	    tcmdPtr->refCount = 1;
................................................................................
		break;
	    }
	}
	command = TclGetStringFromObj(objv[5], &commandLength);
	length = commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    CombinedTraceVarInfo *ctvarPtr = Tcl_Alloc(
		    TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
		    + 1 + length);

	    ctvarPtr->traceCmdInfo.flags = flags;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	    if (objv[0] == NULL) {
		ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
	    }






|







 







|







 







|







467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
...
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
		break;
	    }
	}
	command = TclGetStringFromObj(objv[5], &commandLength);
	length = commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    TraceCommandInfo *tcmdPtr = Tcl_Alloc(
		    offsetof(TraceCommandInfo, command) + 1 + length);

	    tcmdPtr->flags = flags;
	    tcmdPtr->stepTrace = NULL;
	    tcmdPtr->startLevel = 0;
	    tcmdPtr->startCmd = NULL;
	    tcmdPtr->length = length;
	    tcmdPtr->refCount = 1;
................................................................................
	    }
	}

	command = TclGetStringFromObj(objv[5], &commandLength);
	length = commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    TraceCommandInfo *tcmdPtr = Tcl_Alloc(
		    offsetof(TraceCommandInfo, command) + 1 + length);

	    tcmdPtr->flags = flags;
	    tcmdPtr->stepTrace = NULL;
	    tcmdPtr->startLevel = 0;
	    tcmdPtr->startCmd = NULL;
	    tcmdPtr->length = length;
	    tcmdPtr->refCount = 1;
................................................................................
		break;
	    }
	}
	command = TclGetStringFromObj(objv[5], &commandLength);
	length = commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    CombinedTraceVarInfo *ctvarPtr = Tcl_Alloc(
		    offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
		    + 1 + length);

	    ctvarPtr->traceCmdInfo.flags = flags;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	    if (objv[0] == NULL) {
		ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
	    }

Changes to generic/tclUtf.c.

1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
    register size_t index)		/* The position of the desired character. */
{
    Tcl_UniChar ch = 0;
#if TCL_UTF_MAX <= 4
    size_t len = 0;
#endif

    if (index != TCL_AUTO_LENGTH) {
	while (index--) {
#if TCL_UTF_MAX <= 4
	    src += (len = TclUtfToUniChar(src, &ch));
#else
	    src += TclUtfToUniChar(src, &ch);
#endif
	}






|







1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
    register size_t index)		/* The position of the desired character. */
{
    Tcl_UniChar ch = 0;
#if TCL_UTF_MAX <= 4
    size_t len = 0;
#endif

    if (index != TCL_INDEX_NONE) {
	while (index--) {
#if TCL_UTF_MAX <= 4
	    src += (len = TclUtfToUniChar(src, &ch));
#else
	    src += TclUtfToUniChar(src, &ch);
#endif
	}

Changes to generic/tclUtil.c.

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
....
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
....
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
....
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
....
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
			    int stringLength, const char *typeStr,
			    const char *typeCode, const char **elementPtr,
			    const char **nextPtr, size_t *sizePtr,
			    int *literalPtr);
/*
 * The following is the Tcl object type definition for an object that
 * represents a list index in the form, "end-offset". It is used as a
 * performance optimization in TclGetIntForIndex. The internal rep is
 * stored directly in the wideValue, so no memory management is required
 * for it. This is a caching intrep, keeping the result of a parse
 * around. This type is only created from a pre-existing string, so an
 * updateStringProc will never be called and need not exist. The type
 * is unregistered, so has no need of a setFromAnyProc either.
 */

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

char *
Tcl_DStringAppend(
    Tcl_DString *dsPtr,		/* Structure describing dynamic string. */
    const char *bytes,		/* String to append. If length is -1 then this
				 * must be null-terminated. */
    size_t length)			/* Number of bytes from "bytes" to append. If
				 * -1, then append all of bytes, up to null
				 * at end. */
{
    size_t newSize;

    if (length == TCL_AUTO_LENGTH) {
	length = strlen(bytes);
    }
................................................................................
	dsPtr->spaceAvl = newSize * 2;
	if (dsPtr->string == dsPtr->staticSpace) {
	    char *newString = Tcl_Alloc(dsPtr->spaceAvl);

	    memcpy(newString, dsPtr->string, dsPtr->length);
	    dsPtr->string = newString;
	} else {
	    size_t offset = TCL_AUTO_LENGTH;

	    /* See [16896d49fd] */
	    if (bytes >= dsPtr->string
		    && bytes <= dsPtr->string + dsPtr->length) {
		offset = bytes - dsPtr->string;
	    }

	    dsPtr->string = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);

	    if (offset != TCL_AUTO_LENGTH) {
		bytes = dsPtr->string + offset;
	    }
	}
    }

    /*
     * Copy the new string into the buffer at the end of the old one.
     */
................................................................................
    }
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetIntForIndex --
 *
 *	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 object referenced by 'objPtr' is converted, as needed, to an
 * 	integer, wide integer, or end-based-index object.
 *
 *----------------------------------------------------------------------
 */

int
TclGetIntForIndex(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. If
				 * NULL, then no error message is left after
				 * errors. */
    Tcl_Obj *objPtr,		/* Points to an object containing either "end"
				 * or an integer. */
    size_t endValue,		/* The value to be stored at "indexPtr" if
				 * "objPtr" holds "end". */






|







 







|
|

|







 







|




|




|
|







 







|







 







|







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
....
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
....
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
....
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
....
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
			    int stringLength, const char *typeStr,
			    const char *typeCode, const char **elementPtr,
			    const char **nextPtr, size_t *sizePtr,
			    int *literalPtr);
/*
 * The following is the Tcl object type definition for an object that
 * represents a list index in the form, "end-offset". It is used as a
 * performance optimization in Tcl_GetIntForIndex. The internal rep is
 * stored directly in the wideValue, so no memory management is required
 * for it. This is a caching intrep, keeping the result of a parse
 * around. This type is only created from a pre-existing string, so an
 * updateStringProc will never be called and need not exist. The type
 * is unregistered, so has no need of a setFromAnyProc either.
 */

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

char *
Tcl_DStringAppend(
    Tcl_DString *dsPtr,		/* Structure describing dynamic string. */
    const char *bytes,		/* String to append. If length is
				 * TCL_AUTO_LENGTH then this must be null-terminated. */
    size_t length)			/* Number of bytes from "bytes" to append. If
				 * TCL_AUTO_LENGTH, then append all of bytes, up to null
				 * at end. */
{
    size_t newSize;

    if (length == TCL_AUTO_LENGTH) {
	length = strlen(bytes);
    }
................................................................................
	dsPtr->spaceAvl = newSize * 2;
	if (dsPtr->string == dsPtr->staticSpace) {
	    char *newString = Tcl_Alloc(dsPtr->spaceAvl);

	    memcpy(newString, dsPtr->string, dsPtr->length);
	    dsPtr->string = newString;
	} else {
	    size_t index = TCL_INDEX_NONE;

	    /* See [16896d49fd] */
	    if (bytes >= dsPtr->string
		    && bytes <= dsPtr->string + dsPtr->length) {
		index = bytes - dsPtr->string;
	    }

	    dsPtr->string = 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.
     */
................................................................................
    }
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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 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
				 * NULL, then no error message is left after
				 * errors. */
    Tcl_Obj *objPtr,		/* Points to an object containing either "end"
				 * or an integer. */
    size_t endValue,		/* The value to be stored at "indexPtr" if
				 * "objPtr" holds "end". */

Changes to generic/tclVar.c.

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
			    Tcl_Obj *key, int *newPtr);
static inline Var *	VarHashFirstVar(TclVarHashTable *tablePtr,
			    Tcl_HashSearch *searchPtr);
static inline Var *	VarHashNextVar(Tcl_HashSearch *searchPtr);
static inline void	CleanupVar(Var *varPtr, Var *arrayPtr);

#define VarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))

/*
 * NOTE: VarHashCreateVar increments the recount of its key argument.
 * All callers that will call Tcl_DecrRefCount on that argument must
 * call Tcl_IncrRefCount on it before passing it in.  This requirement
 * can bubble up to callers of callers .... etc.
 */






|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
			    Tcl_Obj *key, int *newPtr);
static inline Var *	VarHashFirstVar(TclVarHashTable *tablePtr,
			    Tcl_HashSearch *searchPtr);
static inline Var *	VarHashNextVar(Tcl_HashSearch *searchPtr);
static inline void	CleanupVar(Var *varPtr, Var *arrayPtr);

#define VarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))

/*
 * NOTE: VarHashCreateVar increments the recount of its key argument.
 * All callers that will call Tcl_DecrRefCount on that argument must
 * call Tcl_IncrRefCount on it before passing it in.  This requirement
 * can bubble up to callers of callers .... etc.
 */

Changes to libtommath/bn_mp_and.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20




21
22

23
24
25








26
27
28
29
30
31

32
33





34
35
36
37

38





39
40
41
42
43
44


45
46
47
48
49
50
51
52
53
54
#include "tommath_private.h"
#ifdef BN_MP_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* AND two ints together */

int mp_and(const mp_int *a, const mp_int *b, mp_int *c)
{
   int     res, ix, px;
   mp_int  t;
   const mp_int *x;





   if (a->used > b->used) {

      if ((res = mp_init_copy(&t, a)) != MP_OKAY) {
         return res;
      }








      px = b->used;
      x = b;
   } else {
      if ((res = mp_init_copy(&t, b)) != MP_OKAY) {
         return res;
      }

      px = a->used;
      x = a;





   }

   for (ix = 0; ix < px; ix++) {
      t.dp[ix] &= x->dp[ix];

   }






   /* zero digits above the last from the smallest mp_int */
   for (; ix < t.used; ix++) {
      t.dp[ix] = 0;
   }



   mp_clamp(&t);
   mp_exch(c, &t);
   mp_clear(&t);
   return MP_OKAY;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */

|
<
<
<
<
<
<
<
<
|
<

<
>
|

<
<
<
>
>
>
>

<
>
|
|

>
>
>
>
>
>
>
>
|
|
|
|
<

>
|
|
>
>
>
>
>
|

<
<
>
|
>
>
>
>
>
|
<
<
<


>
>
|
<
<



<
<
<
<
1
2
3








4

5

6
7
8



9
10
11
12
13

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40


41
42
43
44
45
46
47
48



49
50
51
52
53


54
55
56




#include "tommath_private.h"
#ifdef BN_MP_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */



/* two complement and */
mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c)
{



   int used = MAX(a->used, b->used) + 1, i;
   mp_err err;
   mp_digit ac = 1, bc = 1, cc = 1;
   mp_sign csign = ((a->sign == MP_NEG) && (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS;


   if (c->alloc < used) {
      if ((err = mp_grow(c, used)) != MP_OKAY) {
         return err;
      }
   }

   for (i = 0; i < used; i++) {
      mp_digit x, y;

      /* convert to two complement if negative */
      if (a->sign == MP_NEG) {
         ac += (i >= a->used) ? MP_MASK : (~a->dp[i] & MP_MASK);
         x = ac & MP_MASK;
         ac >>= MP_DIGIT_BIT;
      } else {
         x = (i >= a->used) ? 0uL : a->dp[i];

      }

      /* convert to two complement if negative */
      if (b->sign == MP_NEG) {
         bc += (i >= b->used) ? MP_MASK : (~b->dp[i] & MP_MASK);
         y = bc & MP_MASK;
         bc >>= MP_DIGIT_BIT;
      } else {
         y = (i >= b->used) ? 0uL : b->dp[i];
      }



      c->dp[i] = x & y;

      /* convert to to sign-magnitude if negative */
      if (csign == MP_NEG) {
         cc += ~c->dp[i] & MP_MASK;
         c->dp[i] = cc & MP_MASK;
         cc >>= MP_DIGIT_BIT;
      }



   }

   c->used = used;
   c->sign = csign;
   mp_clamp(c);


   return MP_OKAY;
}
#endif




Changes to libtommath/bn_mp_cmp.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
29
30
31
32
33
34
35
36
37
38
39
#include "tommath_private.h"
#ifdef BN_MP_CMP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* compare two ints (signed)*/
int mp_cmp(const mp_int *a, const mp_int *b)
{
   /* compare based on sign */
   if (a->sign != b->sign) {
      if (a->sign == MP_NEG) {
         return MP_LT;
      } else {
         return MP_GT;
................................................................................
      /* if negative compare opposite direction */
      return mp_cmp_mag(b, a);
   } else {
      return mp_cmp_mag(a, b);
   }
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */

|
<
<
<
<
<
<
<
<
|
<


|







 







<
<
<
<
1
2
3








4

5
6
7
8
9
10
11
12
13
14
..
20
21
22
23
24
25
26




#include "tommath_private.h"
#ifdef BN_MP_CMP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */


/* compare two ints (signed)*/
mp_ord mp_cmp(const mp_int *a, const mp_int *b)
{
   /* compare based on sign */
   if (a->sign != b->sign) {
      if (a->sign == MP_NEG) {
         return MP_LT;
      } else {
         return MP_GT;
................................................................................
      /* if negative compare opposite direction */
      return mp_cmp_mag(b, a);
   } else {
      return mp_cmp_mag(a, b);
   }
}
#endif




Changes to libtommath/bn_mp_cmp_d.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
31
32
33
34
35
36
37
38
39
40
41
#include "tommath_private.h"
#ifdef BN_MP_CMP_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* compare a digit */
int mp_cmp_d(const mp_int *a, mp_digit b)
{
   /* compare based on sign */
   if (a->sign == MP_NEG) {
      return MP_LT;
   }

   /* compare based on magnitude */
................................................................................
   } else if (a->dp[0] < b) {
      return MP_LT;
   } else {
      return MP_EQ;
   }
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */

|
<
<
<
<
<
<
<
<
|
<


|







 







<
<
<
<
1
2
3








4

5
6
7
8
9
10
11
12
13
14
..
22
23
24
25
26
27
28




#include "tommath_private.h"
#ifdef BN_MP_CMP_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */


/* compare a digit */
mp_ord mp_cmp_d(const mp_int *a, mp_digit b)
{
   /* compare based on sign */
   if (a->sign == MP_NEG) {
      return MP_LT;
   }

   /* compare based on magnitude */
................................................................................
   } else if (a->dp[0] < b) {
      return MP_LT;
   } else {
      return MP_EQ;
   }
}
#endif




Changes to libtommath/bn_mp_cmp_mag.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
42
43
44
45
46
47
48
49
50
51
52
#include "tommath_private.h"
#ifdef BN_MP_CMP_MAG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* compare maginitude of two ints (unsigned) */
int mp_cmp_mag(const mp_int *a, const mp_int *b)
{
   int     n;
   mp_digit *tmpa, *tmpb;

   /* compare based on # of non-zero digits */
   if (a->used > b->used) {
      return MP_GT;
   }

   if (a->used < b->used) {
................................................................................
      if (*tmpa < *tmpb) {
         return MP_LT;
      }
   }
   return MP_EQ;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */

|
<
<
<
<
<
<
<
<
|
<


|


|







 







<
<
<
<
1
2
3








4

5
6
7
8
9
10
11
12
13
14
15
16
17
..
33
34
35
36
37
38
39




#include "tommath_private.h"
#ifdef BN_MP_CMP_MAG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */


/* compare maginitude of two ints (unsigned) */
mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b)
{
   int     n;
   const mp_digit *tmpa, *tmpb;

   /* compare based on # of non-zero digits */
   if (a->used > b->used) {
      return MP_GT;
   }

   if (a->used < b->used) {
................................................................................
      if (*tmpa < *tmpb) {
         return MP_LT;
      }
   }
   return MP_EQ;
}
#endif




Changes to libtommath/bn_mp_or.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20




21
22

23
24
25








26
27
28
29
30
31

32
33





34
35
36
37

38










39
40
41
42
43
44
45
46
47
48
#include "tommath_private.h"
#ifdef BN_MP_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* OR two ints together */

int mp_or(const mp_int *a, const mp_int *b, mp_int *c)
{
   int     res, ix, px;
   mp_int  t;
   const mp_int *x;





   if (a->used > b->used) {

      if ((res = mp_init_copy(&t, a)) != MP_OKAY) {
         return res;
      }








      px = b->used;
      x = b;
   } else {
      if ((res = mp_init_copy(&t, b)) != MP_OKAY) {
         return res;
      }

      px = a->used;
      x = a;





   }

   for (ix = 0; ix < px; ix++) {
      t.dp[ix] |= x->dp[ix];

   }










   mp_clamp(&t);
   mp_exch(c, &t);
   mp_clear(&t);
   return MP_OKAY;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */

|
<
<
<
<
<
<
<
<
|
<

<
>
|

<
<
<
>
>
>
>

<
>
|
|

>
>
>
>
>
>
>
>
|
|
|
|
<

>
|
|
>
>
>
>
>
|

<
<
>
|
>
>
>
>
>
>
>
>
>
>
|
<
<



<
<
<
<
1
2
3








4

5

6
7
8



9
10
11
12
13

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40


41
42
43
44
45
46
47
48
49
50
51
52
53


54
55
56




#include "tommath_private.h"
#ifdef BN_MP_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */



/* two complement or */
mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c)
{



   int used = MAX(a->used, b->used) + 1, i;
   mp_err err;
   mp_digit ac = 1, bc = 1, cc = 1;
   mp_sign csign = ((a->sign == MP_NEG) || (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS;


   if (c->alloc < used) {
      if ((err = mp_grow(c, used)) != MP_OKAY) {
         return err;
      }
   }

   for (i = 0; i < used; i++) {
      mp_digit x, y;

      /* convert to two complement if negative */
      if (a->sign == MP_NEG) {
         ac += (i >= a->used) ? MP_MASK : (~a->dp[i] & MP_MASK);
         x = ac & MP_MASK;
         ac >>= MP_DIGIT_BIT;
      } else {
         x = (i >= a->used) ? 0uL : a->dp[i];

      }

      /* convert to two complement if negative */
      if (b->sign == MP_NEG) {
         bc += (i >= b->used) ? MP_MASK : (~b->dp[i] & MP_MASK);
         y = bc & MP_MASK;
         bc >>= MP_DIGIT_BIT;
      } else {
         y = (i >= b->used) ? 0uL : b->dp[i];
      }



      c->dp[i] = x | y;

      /* convert to to sign-magnitude if negative */
      if (csign == MP_NEG) {
         cc += ~c->dp[i] & MP_MASK;
         c->dp[i] = cc & MP_MASK;
         cc >>= MP_DIGIT_BIT;
      }
   }

   c->used = used;
   c->sign = csign;
   mp_clamp(c);


   return MP_OKAY;
}
#endif




Name change from libtommath/bn_mp_tc_div_2d.c to libtommath/bn_mp_signed_rsh.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
#include "tommath_private.h"
#ifdef BN_MP_TC_DIV_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* two complement right shift */

int mp_tc_div_2d(const mp_int *a, int b, mp_int *c)
{
   int res;
   if (mp_isneg(a) == MP_NO) {

      return mp_div_2d(a, b, c, NULL);
   }

   res = mp_add_d(a, 1uL, c);
   if (res != MP_OKAY) {
      return res;
   }

   res = mp_div_2d(c, b, c, NULL);
   return (res == MP_OKAY) ? mp_sub_d(c, 1uL, c) : res;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
|
|
<
<
<
<
<
<
<
<
|
<

<
>
|

|
<
>












<
<
<
<
1
2
3








4

5

6
7
8
9

10
11
12
13
14
15
16
17
18
19
20
21
22




#include "tommath_private.h"
#ifdef BN_MP_SIGNED_RSH_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */



/* shift right by a certain bit count with sign extension */
mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c)
{
   mp_err res;

   if (a->sign == MP_ZPOS) {
      return mp_div_2d(a, b, c, NULL);
   }

   res = mp_add_d(a, 1uL, c);
   if (res != MP_OKAY) {
      return res;
   }

   res = mp_div_2d(c, b, c, NULL);
   return (res == MP_OKAY) ? mp_sub_d(c, 1uL, c) : res;
}
#endif




Deleted libtommath/bn_mp_tc_and.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
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
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
#include "tommath_private.h"
#ifdef BN_MP_TC_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* two complement and */
int mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)
{
   int res = MP_OKAY, bits, abits, bbits;
   int as = mp_isneg(a), bs = mp_isneg(b);
   mp_int *mx = NULL, _mx, acpy, bcpy;

   if ((as != MP_NO) || (bs != MP_NO)) {
      abits = mp_count_bits(a);
      bbits = mp_count_bits(b);
      bits = MAX(abits, bbits);
      res = mp_init_set_int(&_mx, 1uL);
      if (res != MP_OKAY) {
         goto end;
      }

      mx = &_mx;
      res = mp_mul_2d(mx, bits + 1, mx);
      if (res != MP_OKAY) {
         goto end;
      }

      if (as != MP_NO) {
         res = mp_init(&acpy);
         if (res != MP_OKAY) {
            goto end;
         }

         res = mp_add(mx, a, &acpy);
         if (res != MP_OKAY) {
            mp_clear(&acpy);
            goto end;
         }
         a = &acpy;
      }
      if (bs != MP_NO) {
         res = mp_init(&bcpy);
         if (res != MP_OKAY) {
            goto end;
         }

         res = mp_add(mx, b, &bcpy);
         if (res != MP_OKAY) {
            mp_clear(&bcpy);
            goto end;
         }
         b = &bcpy;
      }
   }

   res = mp_and(a, b, c);

   if ((as != MP_NO) && (bs != MP_NO) && (res == MP_OKAY)) {
      res = mp_sub(c, mx, c);
   }

end:
   if (a == &acpy) {
      mp_clear(&acpy);
   }

   if (b == &bcpy) {
      mp_clear(&bcpy);
   }

   if (mx == &_mx) {
      mp_clear(mx);
   }

   return res;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































Deleted libtommath/bn_mp_tc_or.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
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
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
#include "tommath_private.h"
#ifdef BN_MP_TC_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* two complement or */
int mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)
{
   int res = MP_OKAY, bits, abits, bbits;
   int as = mp_isneg(a), bs = mp_isneg(b);
   mp_int *mx = NULL, _mx, acpy, bcpy;

   if ((as != MP_NO) || (bs != MP_NO)) {
      abits = mp_count_bits(a);
      bbits = mp_count_bits(b);
      bits = MAX(abits, bbits);
      res = mp_init_set_int(&_mx, 1uL);
      if (res != MP_OKAY) {
         goto end;
      }

      mx = &_mx;
      res = mp_mul_2d(mx, bits + 1, mx);
      if (res != MP_OKAY) {
         goto end;
      }

      if (as != MP_NO) {
         res = mp_init(&acpy);
         if (res != MP_OKAY) {
            goto end;
         }

         res = mp_add(mx, a, &acpy);
         if (res != MP_OKAY) {
            mp_clear(&acpy);
            goto end;
         }
         a = &acpy;
      }
      if (bs != MP_NO) {
         res = mp_init(&bcpy);
         if (res != MP_OKAY) {
            goto end;
         }

         res = mp_add(mx, b, &bcpy);
         if (res != MP_OKAY) {
            mp_clear(&bcpy);
            goto end;
         }
         b = &bcpy;
      }
   }

   res = mp_or(a, b, c);

   if (((as != MP_NO) || (bs != MP_NO)) && (res == MP_OKAY)) {
      res = mp_sub(c, mx, c);
   }

end:
   if (a == &acpy) {
      mp_clear(&acpy);
   }

   if (b == &bcpy) {
      mp_clear(&bcpy);
   }

   if (mx == &_mx) {
      mp_clear(mx);
   }

   return res;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































Deleted libtommath/bn_mp_tc_xor.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
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
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
#include "tommath_private.h"
#ifdef BN_MP_TC_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* two complement xor */
int mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)
{
   int res = MP_OKAY, bits, abits, bbits;
   int as = mp_isneg(a), bs = mp_isneg(b);
   mp_int *mx = NULL, _mx, acpy, bcpy;

   if ((as != MP_NO) || (bs != MP_NO)) {
      abits = mp_count_bits(a);
      bbits = mp_count_bits(b);
      bits = MAX(abits, bbits);
      res = mp_init_set_int(&_mx, 1uL);
      if (res != MP_OKAY) {
         goto end;
      }

      mx = &_mx;
      res = mp_mul_2d(mx, bits + 1, mx);
      if (res != MP_OKAY) {
         goto end;
      }

      if (as != MP_NO) {
         res = mp_init(&acpy);
         if (res != MP_OKAY) {
            goto end;
         }

         res = mp_add(mx, a, &acpy);
         if (res != MP_OKAY) {
            mp_clear(&acpy);
            goto end;
         }
         a = &acpy;
      }
      if (bs != MP_NO) {
         res = mp_init(&bcpy);
         if (res != MP_OKAY) {
            goto end;
         }

         res = mp_add(mx, b, &bcpy);
         if (res != MP_OKAY) {
            mp_clear(&bcpy);
            goto end;
         }
         b = &bcpy;
      }
   }

   res = mp_xor(a, b, c);

   if ((as != bs) && (res == MP_OKAY)) {
      res = mp_sub(c, mx, c);
   }

end:
   if (a == &acpy) {
      mp_clear(&acpy);
   }

   if (b == &bcpy) {
      mp_clear(&bcpy);
   }

   if (mx == &_mx) {
      mp_clear(mx);
   }

   return res;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































Changes to libtommath/bn_mp_xor.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20




21
22

23
24
25








26
27
28
29
30
31

32
33





34
35
36
37

38










39
40
41
42
43
44
45
46
47
48
#include "tommath_private.h"
#ifdef BN_MP_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* XOR two ints together */

int mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
{
   int     res, ix, px;
   mp_int  t;
   const mp_int *x;





   if (a->used > b->used) {

      if ((res = mp_init_copy(&t, a)) != MP_OKAY) {
         return res;
      }








      px = b->used;
      x = b;
   } else {
      if ((res = mp_init_copy(&t, b)) != MP_OKAY) {
         return res;
      }

      px = a->used;
      x = a;





   }

   for (ix = 0; ix < px; ix++) {
      t.dp[ix] ^= x->dp[ix];

   }










   mp_clamp(&t);
   mp_exch(c, &t);
   mp_clear(&t);
   return MP_OKAY;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */

|
<
<
<
<
<
<
<
<
|
<

<
>
|

<
<
<
>
>
>
>

<
>
|
|

>
>
>
>
>
>
>
>
|
|
|
|
<

>
|
|
>
>
>
>
>
|

<
<
>
|
>
>
>
>
>
>
>
>
>
>
|
<
<



<
<
<
<
1
2
3








4

5

6
7
8



9
10
11
12
13

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40


41
42
43
44
45
46
47
48
49
50
51
52
53


54
55
56




#include "tommath_private.h"
#ifdef BN_MP_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */



/* two complement xor */
mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
{



   int used = MAX(a->used, b->used) + 1, i;
   mp_err err;
   mp_digit ac = 1, bc = 1, cc = 1;
   mp_sign csign = (a->sign != b->sign) ? MP_NEG : MP_ZPOS;


   if (c->alloc < used) {
      if ((err = mp_grow(c, used)) != MP_OKAY) {
         return err;
      }
   }

   for (i = 0; i < used; i++) {
      mp_digit x, y;

      /* convert to two complement if negative */
      if (a->sign == MP_NEG) {
         ac += (i >= a->used) ? MP_MASK : (~a->dp[i] & MP_MASK);
         x = ac & MP_MASK;
         ac >>= MP_DIGIT_BIT;
      } else {
         x = (i >= a->used) ? 0uL : a->dp[i];

      }

      /* convert to two complement if negative */
      if (b->sign == MP_NEG) {
         bc += (i >= b->used) ? MP_MASK : (~b->dp[i] & MP_MASK);
         y = bc & MP_MASK;
         bc >>= MP_DIGIT_BIT;
      } else {
         y = (i >= b->used) ? 0uL : b->dp[i];
      }



      c->dp[i] = x ^ y;

      /* convert to to sign-magnitude if negative */
      if (csign == MP_NEG) {
         cc += ~c->dp[i] & MP_MASK;
         c->dp[i] = cc & MP_MASK;
         cc >>= MP_DIGIT_BIT;
      }
   }

   c->used = used;
   c->sign = csign;
   mp_clamp(c);


   return MP_OKAY;
}
#endif




Name change from libtommath/bn_mp_get_bit.c to libtommath/bn_s_mp_get_bit.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#include "tommath_private.h"
#ifdef BN_MP_GET_BIT_C

/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

/* Checks the bit at position b and returns MP_YES
   if the bit is 1, MP_NO if it is 0 and MP_VAL
   in case of error */
int mp_get_bit(const mp_int *a, int b)
{
   int limb;
   mp_digit bit, isset;

   if (b < 0) {
      return MP_VAL;
   }

   limb = b / DIGIT_BIT;


   if (limb >= a->used) {
      return MP_NO;
   }

   bit = (mp_digit)(1) << (b % DIGIT_BIT);

   isset = a->dp[limb] & bit;
   return (isset != 0u) ? MP_YES : MP_NO;
}

#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
|

|
<
<
<
<
<
<
<
<
|
<

<
|
<
|

<
|
<
<
<
<
<
<
>





|
<
<
|



<
<
<
<
1
2
3
4








5

6

7

8
9

10






11
12
13
14
15
16
17


18
19
20
21




#include "tommath_private.h"
#ifdef BN_S_MP_GET_BIT_C

/* LibTomMath, multiple-precision integer library -- Tom St Denis */








/* SPDX-License-Identifier: Unlicense */



/* Get bit at position b and return MP_YES if the bit is 1, MP_NO if it is 0 */

mp_bool s_mp_get_bit(const mp_int *a, int b)
{

   mp_digit bit;






   int limb = (int)((unsigned)b / MP_DIGIT_BIT);

   if (limb >= a->used) {
      return MP_NO;
   }

   bit = (mp_digit)1 << ((unsigned)b % MP_DIGIT_BIT);


   return ((a->dp[limb] & bit) != 0u) ? MP_YES : MP_NO;
}

#endif




Deleted libtommath/callgraph.txt.

more than 10,000 changes

Changes to libtommath/tommath.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
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
...
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */
#ifndef BN_H_
#define BN_H_

#include <stdio.h>
#include <stdlib.h>
#include <limits.h>

................................................................................
/* clear a null terminated series of arguments */
void mp_clear_multi(mp_int *mp, ...);

/* exchange two ints */
void mp_exch(mp_int *a, mp_int *b);

/* shrink ram required for a bignum */
int mp_shrink(mp_int *a);

/* grow an int to a given size */
int mp_grow(mp_int *a, int size);

/* init to a given number of digits */
int mp_init_size(mp_int *a, int size);

/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
#define mp_iseven(a) (!mp_get_bit((a),0))
#define mp_isodd(a)  mp_get_bit((a),0)
#define mp_isneg(a)  (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)

/* set to zero */
void mp_zero(mp_int *a);

/* set to a digit */
void mp_set(mp_int *a, mp_digit b);
................................................................................
/* c = a OR b (two complement) */
int mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c);

/* c = a AND b (two complement) */
int mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c);

/* right shift (two complement) */
int mp_tc_div_2d(const mp_int *a, int b, mp_int *c);

/* ---> Basic arithmetic <--- */

/* b = ~a */
int mp_complement(const mp_int *a, mp_int *b);

/* b = -a */
|
|
<
<
|
<
<
<
<
<
<







 







|


|


|



|
|







 







|







1
2


3






4
5
6
7
8
9
10
...
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
...
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */









#ifndef BN_H_
#define BN_H_

#include <stdio.h>
#include <stdlib.h>
#include <limits.h>

................................................................................
/* clear a null terminated series of arguments */
void mp_clear_multi(mp_int *mp, ...);

/* exchange two ints */
void mp_exch(mp_int *a, mp_int *b);

/* shrink ram required for a bignum */
mp_err mp_shrink(mp_int *a);

/* grow an int to a given size */
mp_err mp_grow(mp_int *a, int size);

/* init to a given number of digits */
mp_err mp_init_size(mp_int *a, int size);

/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
#define mp_isodd(a)  (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)
#define mp_isneg(a)  (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)

/* set to zero */
void mp_zero(mp_int *a);

/* set to a digit */
void mp_set(mp_int *a, mp_digit b);
................................................................................
/* c = a OR b (two complement) */
int mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c);

/* c = a AND b (two complement) */
int mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c);

/* right shift (two complement) */
int mp_signed_rsh(const mp_int *a, int b, mp_int *c);

/* ---> Basic arithmetic <--- */

/* b = ~a */
int mp_complement(const mp_int *a, mp_int *b);

/* b = -a */

Changes to libtommath/tommath_class.h.

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
...
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
...
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
....
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
#   define BN_MP_EXPT_D_EX_C
#   define BN_MP_EXPTMOD_C
#   define BN_MP_EXPTMOD_FAST_C
#   define BN_MP_EXTEUCLID_C
#   define BN_MP_FREAD_C
#   define BN_MP_FWRITE_C
#   define BN_MP_GCD_C
#   define BN_MP_GET_BIT_C
#   define BN_MP_GET_DOUBLE_C
#   define BN_MP_GET_INT_C
#   define BN_MP_GET_LONG_C
#   define BN_MP_GET_LONG_LONG_C
#   define BN_MP_GROW_C
#   define BN_MP_IMPORT_C
#   define BN_MP_INIT_C
................................................................................
#   define BN_MP_SQRMOD_C
#   define BN_MP_SQRT_C
#   define BN_MP_SQRTMOD_PRIME_C
#   define BN_MP_SUB_C
#   define BN_MP_SUB_D_C
#   define BN_MP_SUBMOD_C
#   define BN_MP_TC_AND_C
#   define BN_MP_TC_DIV_2D_C
#   define BN_MP_TC_OR_C
#   define BN_MP_TC_XOR_C
#   define BN_MP_TO_SIGNED_BIN_C
#   define BN_MP_TO_SIGNED_BIN_N_C
#   define BN_MP_TO_UNSIGNED_BIN_C
#   define BN_MP_TO_UNSIGNED_BIN_N_C
#   define BN_MP_TOOM_MUL_C
................................................................................
#   define BN_MP_CMP_MAG_C
#   define BN_MP_EXCH_C
#   define BN_S_MP_SUB_C
#   define BN_MP_MUL_2D_C
#   define BN_MP_CLEAR_C
#endif

#if defined(BN_MP_GET_BIT_C)
#   define BN_MP_ISZERO_C
#endif

#if defined(BN_MP_GET_DOUBLE_C)
#   define BN_MP_ISNEG_C
#endif

................................................................................
#   define BN_MP_COUNT_BITS_C
#   define BN_MP_MUL_2_C
#   define BN_MP_MUL_D_C
#   define BN_MP_ADD_C
#   define BN_MP_MUL_C
#   define BN_MP_SUB_C
#   define BN_MP_MOD_C
#   define BN_MP_GET_BIT_C
#   define BN_MP_EXCH_C
#   define BN_MP_ISZERO_C
#   define BN_MP_CMP_C
#   define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_MP_PRIME_IS_DIVISIBLE_C)
................................................................................
#   define BN_MP_DIV_2D_C
#   define BN_MP_SET_C
#   define BN_MP_MUL_2_C
#   define BN_MP_COUNT_BITS_C
#   define BN_MP_MOD_C
#   define BN_MP_SQR_C
#   define BN_MP_SUB_C
#   define BN_MP_GET_BIT_C
#   define BN_MP_ADD_C
#   define BN_MP_ISODD_C
#   define BN_MP_DIV_2_C
#   define BN_MP_SUB_D_C
#   define BN_MP_ISZERO_C
#   define BN_MP_CLEAR_MULTI_C
#endif
................................................................................
#   define BN_MP_INIT_C
#   define BN_MP_ADD_C
#   define BN_MP_CLEAR_C
#   define BN_MP_AND_C
#   define BN_MP_SUB_C
#endif

#if defined(BN_MP_TC_DIV_2D_C)
#   define BN_MP_ISNEG_C
#   define BN_MP_DIV_2D_C
#   define BN_MP_ADD_D_C
#   define BN_MP_SUB_D_C
#endif

#if defined(BN_MP_TC_OR_C)






|







 







|







 







|







 







|







 







|







 







|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
...
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
...
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
....
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
#   define BN_MP_EXPT_D_EX_C
#   define BN_MP_EXPTMOD_C
#   define BN_MP_EXPTMOD_FAST_C
#   define BN_MP_EXTEUCLID_C
#   define BN_MP_FREAD_C
#   define BN_MP_FWRITE_C
#   define BN_MP_GCD_C
#   define BN_S_MP_GET_BIT_C
#   define BN_MP_GET_DOUBLE_C
#   define BN_MP_GET_INT_C
#   define BN_MP_GET_LONG_C
#   define BN_MP_GET_LONG_LONG_C
#   define BN_MP_GROW_C
#   define BN_MP_IMPORT_C
#   define BN_MP_INIT_C
................................................................................
#   define BN_MP_SQRMOD_C
#   define BN_MP_SQRT_C
#   define BN_MP_SQRTMOD_PRIME_C
#   define BN_MP_SUB_C
#   define BN_MP_SUB_D_C
#   define BN_MP_SUBMOD_C
#   define BN_MP_TC_AND_C
#   define BN_MP_SIGNED_RSH_C
#   define BN_MP_TC_OR_C
#   define BN_MP_TC_XOR_C
#   define BN_MP_TO_SIGNED_BIN_C
#   define BN_MP_TO_SIGNED_BIN_N_C
#   define BN_MP_TO_UNSIGNED_BIN_C
#   define BN_MP_TO_UNSIGNED_BIN_N_C
#   define BN_MP_TOOM_MUL_C
................................................................................
#   define BN_MP_CMP_MAG_C
#   define BN_MP_EXCH_C
#   define BN_S_MP_SUB_C
#   define BN_MP_MUL_2D_C
#   define BN_MP_CLEAR_C
#endif

#if defined(BN_S_MP_GET_BIT_C)
#   define BN_MP_ISZERO_C
#endif

#if defined(BN_MP_GET_DOUBLE_C)
#   define BN_MP_ISNEG_C
#endif

................................................................................
#   define BN_MP_COUNT_BITS_C
#   define BN_MP_MUL_2_C
#   define BN_MP_MUL_D_C
#   define BN_MP_ADD_C
#   define BN_MP_MUL_C
#   define BN_MP_SUB_C
#   define BN_MP_MOD_C
#   define BN_S_MP_GET_BIT_C
#   define BN_MP_EXCH_C
#   define BN_MP_ISZERO_C
#   define BN_MP_CMP_C
#   define BN_MP_CLEAR_MULTI_C
#endif

#if defined(BN_MP_PRIME_IS_DIVISIBLE_C)
................................................................................
#   define BN_MP_DIV_2D_C
#   define BN_MP_SET_C
#   define BN_MP_MUL_2_C
#   define BN_MP_COUNT_BITS_C
#   define BN_MP_MOD_C
#   define BN_MP_SQR_C
#   define BN_MP_SUB_C
#   define BN_S_MP_GET_BIT_C
#   define BN_MP_ADD_C
#   define BN_MP_ISODD_C
#   define BN_MP_DIV_2_C
#   define BN_MP_SUB_D_C
#   define BN_MP_ISZERO_C
#   define BN_MP_CLEAR_MULTI_C
#endif
................................................................................
#   define BN_MP_INIT_C
#   define BN_MP_ADD_C
#   define BN_MP_CLEAR_C
#   define BN_MP_AND_C
#   define BN_MP_SUB_C
#endif

#if defined(BN_MP_SIGNED_RSH_C)
#   define BN_MP_ISNEG_C
#   define BN_MP_DIV_2D_C
#   define BN_MP_ADD_D_C
#   define BN_MP_SUB_D_C
#endif

#if defined(BN_MP_TC_OR_C)

Changes to tests-perf/test-performance.tcl.

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
77
78
79
80
81
82
83
84
85
86
87
  if {!$tcnt} {
    puts ""
    return
  }

  set mintm 0x7fffffff
  set maxtm 0
  set nett 0
  set wtm 0
  set wcnt 0
  set i 0
  foreach tm $_(itm) {
    if {[llength $tm] > 6} {
      set nett [expr {$nett + [lindex $tm 6]}]
    }
    set wtm [expr {$wtm + [lindex $tm 0]}]
    set wcnt [expr {$wcnt + [lindex $tm 2]}]
    set tm [lindex $tm 0]
    if {$tm > $maxtm} {set maxtm $tm; set maxi $i}
    if {$tm < $mintm} {set mintm $tm; set mini $i}
    incr i
  }

  puts [string repeat ** 40]
  set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]]
  if {$nett > 0} {
    append s [format " (%.2f nett-sec.)" [expr {$nett / 1000.0}]]
  }
  puts "Total $s:"
  lset _(m) 0 [format %.6f $wtm]
  lset _(m) 2 $wcnt
  lset _(m) 4 [format %.3f [expr {$wcnt / (($nett ? $nett : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]]
  if {[llength $_(m)] > 6} {
    lset _(m) 6 [format %.3f $nett]
  }
  puts $_(m)
  puts "Average:"
  lset _(m) 0 [format %.6f [expr {[lindex $_(m) 0] / $tcnt}]]
  lset _(m) 2 [expr {[lindex $_(m) 2] / $tcnt}]
  if {[llength $_(m)] > 6} {
    lset _(m) 6 [format %.3f [expr {[lindex $_(m) 6] / $tcnt}]]






|





|











|
|




|

|







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
77
78
79
80
81
82
83
84
85
86
87
  if {!$tcnt} {
    puts ""
    return
  }

  set mintm 0x7fffffff
  set maxtm 0
  set nettm 0
  set wtm 0
  set wcnt 0
  set i 0
  foreach tm $_(itm) {
    if {[llength $tm] > 6} {
      set nettm [expr {$nettm + [lindex $tm 6]}]
    }
    set wtm [expr {$wtm + [lindex $tm 0]}]
    set wcnt [expr {$wcnt + [lindex $tm 2]}]
    set tm [lindex $tm 0]
    if {$tm > $maxtm} {set maxtm $tm; set maxi $i}
    if {$tm < $mintm} {set mintm $tm; set mini $i}
    incr i
  }

  puts [string repeat ** 40]
  set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]]
  if {$nettm > 0} {
    append s [format " (%.2f net-sec.)" [expr {$nettm / 1000.0}]]
  }
  puts "Total $s:"
  lset _(m) 0 [format %.6f $wtm]
  lset _(m) 2 $wcnt
  lset _(m) 4 [format %.3f [expr {$wcnt / (($nettm ? $nettm : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]]
  if {[llength $_(m)] > 6} {
    lset _(m) 6 [format %.3f $nettm]
  }
  puts $_(m)
  puts "Average:"
  lset _(m) 0 [format %.6f [expr {[lindex $_(m) 0] / $tcnt}]]
  lset _(m) 2 [expr {[lindex $_(m) 2] / $tcnt}]
  if {[llength $_(m)] > 6} {
    lset _(m) 6 [format %.3f [expr {[lindex $_(m) 6] / $tcnt}]]

Changes to tests/cmdAH.test.

229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
....
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
....
1652
1653
1654
1655
1656
1657
1658
























































1659
1660
1661
1662
1663
1664
1665
} -result iso8859-1

test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
    file
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
    file x
} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
    file exists
} -result {wrong # args: should be "file exists name"}
test cmdAH-5.4 {Tcl_FileObjCmd} {
    file exists ""
} 0

................................................................................
    }
    set res
} -result "characterSpecial"

# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file gorp x
} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file ex x
} -match glob -result {unknown or ambiguous subcommand "ex": must be *}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file is x
} -match glob -result {unknown or ambiguous subcommand "is": must be *}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
................................................................................
    set template [file join $dirfile foo]
    close [file tempfile name $template.bar]
    expr {[string match $template*.bar $name] ? "ok" :
	  "$template.bar produced $name"}
} -constraints {unix nonPortable} -cleanup {
    catch {file delete $name}
} -result ok
























































 
# This shouldn't work, but just in case a test above failed...
catch {close $newFileId}

interp delete safeInterp
interp delete simpleInterp







|







 







|







 







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







229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
....
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
....
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
} -result iso8859-1

test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
    file
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
    file x
} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
    file exists
} -result {wrong # args: should be "file exists name"}
test cmdAH-5.4 {Tcl_FileObjCmd} {
    file exists ""
} 0

................................................................................
    }
    set res
} -result "characterSpecial"

# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file gorp x
} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file ex x
} -match glob -result {unknown or ambiguous subcommand "ex": must be *}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file is x
} -match glob -result {unknown or ambiguous subcommand "is": must be *}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
................................................................................
    set template [file join $dirfile foo]
    close [file tempfile name $template.bar]
    expr {[string match $template*.bar $name] ? "ok" :
	  "$template.bar produced $name"}
} -constraints {unix nonPortable} -cleanup {
    catch {file delete $name}
} -result ok

test cmdAH-33.1 {file tempdir} -body {
    file tempdir a b
} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"}
test cmdAH-33.2 {file tempdir} -body {
    set d [file tempdir]
    list [file tail $d] [file exists $d] [file type $d] \
	[glob -nocomplain -directory $d *]
} -match glob -result {tcl_* 1 directory {}} -cleanup {
    catch {file delete $d}
}
test cmdAH-33.3 {file tempdir} -body {
    set d [file tempdir gorp]
    list [file tail $d] [file exists $d] [file type $d] \
	[glob -nocomplain -directory $d *]
} -match glob -result {gorp_* 1 directory {}} -cleanup {
    catch {file delete $d}
}
test cmdAH-33.4 {file tempdir} -setup {
    set base [file join [temporaryDirectory] gorp]
    file mkdir $base
} -body {
    set pre [glob -nocomplain -directory $base *]
    set d [file normalize [file tempdir $base/]]
    list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
	$pre [glob -nocomplain -directory $d *]
} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup {
    catch {file delete -force $base}
}
test cmdAH-33.5 {file tempdir} -setup {
    set base [file join [temporaryDirectory] gorp]
    file mkdir $base
} -body {
    set pre [glob -nocomplain -directory $base *]
    set d [file normalize [file tempdir $base/gorp]]
    list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
	$pre [glob -nocomplain -directory $d *]
} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup {
    catch {file delete -force $base}
}
test cmdAH-33.6 {file tempdir: missing parent dir} -setup {
    set base [file join [temporaryDirectory] gorp]
    file mkdir $base
} -returnCodes error -body {
    file tempdir $base/quux/
} -cleanup {
    catch {file delete -force $base}
} -result {can't create temporary directory: no such file or directory}
test cmdAH-33.7 {file tempdir: missing parent dir} -setup {
    set base [file join [temporaryDirectory] gorp]
    file mkdir $base
} -returnCodes error -body {
    file tempdir $base/quux/foobar
} -cleanup {
    catch {file delete -force $base}
} -result {can't create temporary directory: no such file or directory}
 
# This shouldn't work, but just in case a test above failed...
catch {close $newFileId}

interp delete safeInterp
interp delete simpleInterp

Changes to tests/cmdMZ.test.

365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
...
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
423
424
425
test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} {
    list [catch {timerate -overhead b {} a b} msg] $msg
} {1 {expected floating-point number but got "b"}}
test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} {
    list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? nett-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
    regexp {^0 \ws/# 0 # 0 #/sec 0 nett-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
    set m1 [timerate {_nrt_sleep 0} 20]
    set m2 [timerate {_nrt_sleep 0.2} 20]
    list \
	[expr {[lindex $m1 0] < [lindex $m2 0]}] \
	[expr {[lindex $m1 0] < 100}] \
................................................................................
test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} {
    set m1 [timerate {break}]
    list \
	[expr {[lindex $m1 0] < 1000}] \
	[expr {[lindex $m1 2] == 1}] \
	[expr {[lindex $m1 4] > 1000}] \
	[expr {[lindex $m1 6] < 10}]








} {1 1 1 1}
test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
    set m1 [timerate {} 1000 5];	# max-count wins
    set m2 [timerate {_nrt_sleep 20} 1 5];	# max-time wins
    list [lindex $m1 2] [lindex $m2 2]
} {5 1}
test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} {
................................................................................
    set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1]
    list \
	[expr {[lindex $m1 0] == 0.0}] \
	[expr {[lindex $m1 2] == 1}] \
	[expr {[lindex $m1 4] == 1000000}] \
	[expr {[lindex $m1 6] <= 0.001}]
} {1 1 1 1}







test cmdMZ-try-1.0 {

    fix for issue 45b9faf103f2

    [try] interaction with local variable names produces segmentation violation







|


|







 







>
>
>
>
>
>
>
>







 







>
>
>
>
>
>







365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
...
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
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} {
    list [catch {timerate -overhead b {} a b} msg] $msg
} {1 {expected floating-point number but got "b"}}
test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} {
    list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
    regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
    set m1 [timerate {_nrt_sleep 0} 20]
    set m2 [timerate {_nrt_sleep 0.2} 20]
    list \
	[expr {[lindex $m1 0] < [lindex $m2 0]}] \
	[expr {[lindex $m1 0] < 100}] \
................................................................................
test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} {
    set m1 [timerate {break}]
    list \
	[expr {[lindex $m1 0] < 1000}] \
	[expr {[lindex $m1 2] == 1}] \
	[expr {[lindex $m1 4] > 1000}] \
	[expr {[lindex $m1 6] < 10}]
} {1 1 1 1}
test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} {
    set m1 [timerate {continue; return -code error "unexpected"} 1000 10]
    list \
    [expr {[lindex $m1 0] < 1000}] \
    [expr {[lindex $m1 2] == 10}] \
    [expr {[lindex $m1 4] > 1000}] \
    [expr {[lindex $m1 6] < 100}]
} {1 1 1 1}
test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
    set m1 [timerate {} 1000 5];	# max-count wins
    set m2 [timerate {_nrt_sleep 20} 1 5];	# max-time wins
    list [lindex $m1 2] [lindex $m2 2]
} {5 1}
test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} {
................................................................................
    set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1]
    list \
	[expr {[lindex $m1 0] == 0.0}] \
	[expr {[lindex $m1 2] == 1}] \
	[expr {[lindex $m1 4] == 1000000}] \
	[expr {[lindex $m1 6] <= 0.001}]
} {1 1 1 1}
test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} {
    set m1 {set m2 ok}
    if 1 $m1
    timerate $m1 1000 10
    if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop
} ok

test cmdMZ-try-1.0 {

    fix for issue 45b9faf103f2

    [try] interaction with local variable names produces segmentation violation

Changes to tests/coroutine.test.

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
824
825
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}

test coroutine-9.1 {coro type} {

















































































































































    coroutine demo eval {
	yield
	yield "PHASE 1"
	yieldto string cat "PHASE 2"
	::tcl::unsupported::corotype [info coroutine]
    }
    list [demo] [::tcl::unsupported::corotype demo] \
	[demo] [::tcl::unsupported::corotype demo] [demo]
} {{PHASE 1} yield {PHASE 2} yieldto active}
test coroutine-9.2 {coro type} -setup {
    catch {rename nosuchcommand ""}
} -returnCodes error -body {
    ::tcl::unsupported::corotype nosuchcommand
} -result {can only get coroutine type of a coroutine}
test coroutine-9.3 {coro type} -returnCodes error -body {
    proc notacoroutine {} {}
    ::tcl::unsupported::corotype notacoroutine
} -returnCodes error -cleanup {
    rename notacoroutine {}
} -result {can only get coroutine type of a coroutine}

test coroutine-10.1 {coroutine general introspection} -setup {
    set i [interp create]
} -body {
    $i eval {
	# Make the introspection code
	namespace path tcl::unsupported
	proc probe {type var} {
	    upvar 1 $var v






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









|




|






|







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
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
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
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
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}

test coroutine-9.1 {coroprobe with yield} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2 {}}
test coroutine-9.2 {coroprobe with yieldto} -body {
    coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
    list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2 {{a b} {c d}}}
test coroutine-9.3 {coroprobe errors} -setup {
    catch {rename demo {}}
} -body {
    coroprobe demo set i
} -returnCodes error -result {can only inject a probe command into a coroutine}
test coroutine-9.4 {coroprobe errors} -body {
    proc demo {} { foreach i {1 2} yield }
    coroprobe demo set i
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {can only inject a probe command into a coroutine}
test coroutine-9.5 {coroprobe errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroprobe
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
test coroutine-9.6 {coroprobe errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroprobe demo
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
test coroutine-9.7 {coroprobe errors in probe command} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroprobe demo set
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "set varName ?newValue?"}
test coroutine-9.8 {coroprobe errors in probe command} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    list [catch {coroprobe demo set}] [demo] [coroprobe demo set i]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2}
test coroutine-9.9 {coroprobe: advanced features} -setup {
    set i [interp create]
} -body {
    $i eval {
	coroutine demo apply {{} {
	    set f [info level],[info frame]
	    foreach i {1 2} yield
	}}
	coroprobe demo apply {{} {
	    upvar 1 f f
	    list [info coroutine] [info level] [info frame] $f
	}}
    }
} -cleanup {
    interp delete $i
} -result {::demo 2 3 1,2}

test coroutine-10.1 {coroinject with yield} -setup {
    set result {}
} -body {
    coroutine demo apply {{} { lmap i {1 2} yield }}
    coroinject demo apply {{op val} {lappend ::result $op $val}}
    list $result [demo x] [demo y] $result
} -cleanup {
    catch {rename demo {}}
} -result {{} {} {{yield x} y} {yield x}}
test coroutine-10.2 {coroinject stacking} -setup {
    set result {}
} -body {
    coroutine demo apply {{} { lmap i {1 2} yield }}
    coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}}
    coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}}
    list $result [demo x] [demo y] $result
} -cleanup {
    catch {rename demo {}}
} -result {{} {} {x y} {yield x B yield x A}}
test coroutine-10.3 {coroinject with yieldto} -setup {
    set result {}
} -body {
    coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
    coroinject demo apply {{op val} {lappend ::result $op $val;return $val}}
    list $result [demo x mp] [demo y le] $result
} -cleanup {
    catch {rename demo {}}
} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}}
test coroutine-10.4 {coroinject errors} -setup {
    catch {rename demo {}}
} -body {
    coroinject demo set i
} -returnCodes error -result {can only inject a command into a coroutine}
test coroutine-10.5 {coroinject errors} -body {
    proc demo {} { foreach i {1 2} yield }
    coroinject demo set i
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {can only inject a command into a coroutine}
test coroutine-10.6 {coroinject errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroinject
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
test coroutine-10.7 {coroinject errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroinject demo
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
test coroutine-10.8 {coroinject errors in injected command} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroinject demo apply {args {error "ERR: $args"}}
    list [catch demo msg] $msg [catch demo msg] $msg
} -cleanup {
    catch {rename demo {}}
} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}}
test coroutine-10.9 {coroinject: advanced features} -setup {
    set i [interp create]
} -body {
    $i eval {
	coroutine demo apply {{} {
	    set l [info level]
	    set f [info frame]
	    lmap i {1 2} yield
	}}
	coroinject demo apply {{arg op val} {
	    global result
	    upvar 1 f f l l
	    lappend result [info coroutine] $arg $op $val
	    lappend result [info level] $l [info frame] $f
	    lappend result [yield $arg]
	    return [string toupper $val]
	}} grill
	list [demo ABC] [demo pqr] [demo def] $result
    }
} -cleanup {
    interp delete $i
} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}}

test coroutine-11.1 {coro type} {
    coroutine demo eval {
	yield
	yield "PHASE 1"
	yieldto string cat "PHASE 2"
	::tcl::unsupported::corotype [info coroutine]
    }
    list [demo] [::tcl::unsupported::corotype demo] \
	[demo] [::tcl::unsupported::corotype demo] [demo]
} {{PHASE 1} yield {PHASE 2} yieldto active}
test coroutine-11.2 {coro type} -setup {
    catch {rename nosuchcommand ""}
} -returnCodes error -body {
    ::tcl::unsupported::corotype nosuchcommand
} -result {can only get coroutine type of a coroutine}
test coroutine-11.3 {coro type} -returnCodes error -body {
    proc notacoroutine {} {}
    ::tcl::unsupported::corotype notacoroutine
} -returnCodes error -cleanup {
    rename notacoroutine {}
} -result {can only get coroutine type of a coroutine}

test coroutine-12.1 {coroutine general introspection} -setup {
    set i [interp create]
} -body {
    $i eval {
	# Make the introspection code
	namespace path tcl::unsupported
	proc probe {type var} {
	    upvar 1 $var v

Changes to tests/interp.test.

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testinterpdelete [llength [info commands testinterpdelete]]

set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}

foreach i [interp slaves] {
  interp delete $i
}
 
# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} -returnCodes error -body {






|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testinterpdelete [llength [info commands testinterpdelete]]

set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}

foreach i [interp slaves] {
  interp delete $i
}
 
# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} -returnCodes error -body {

Changes to tools/genStubs.tcl.

519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
...
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
		    set pad 28
		}
		append line $next
		set sep ", "
	    }
	    append line ", ...)"
	    if {[lindex $args end] eq "{const char *} format"} {
		append line " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")"
	    }
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
................................................................................
		    append text " "
		}
		append text [lindex $arg 1] [lindex $arg 2]
		set sep ", "
	    }
	    append text ", ...)"
	    if {[lindex $args end] eq "{const char *} format"} {
		append text " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")"
	    }
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0]
		if {[string index $text end] ne "*"} {






|







 







|







519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
...
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
		    set pad 28
		}
		append line $next
		set sep ", "
	    }
	    append line ", ...)"
	    if {[lindex $args end] eq "{const char *} format"} {
		append line " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")"
	    }
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
................................................................................
		    append text " "
		}
		append text [lindex $arg 1] [lindex $arg 2]
		set sep ", "
	    }
	    append text ", ...)"
	    if {[lindex $args end] eq "{const char *} format"} {
		append text " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")"
	    }
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0]
		if {[string index $text end] ne "*"} {

Changes to tools/man2help2.tcl.

823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    } elseif {$length == 1} {
	set indent 5
    }
    if {$text == {\(bu}} {
	set text "\u00b7"
    }

    set tab [expr $indent * 0.1]i
    newPara $tab -$tab
    set state(sb) 80
    setTabs $tab
    formattedText $text
    tab
}







|







823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    } elseif {$length == 1} {
	set indent 5
    }
    if {$text == {\(bu}} {
	set text "\u00b7"
    }

    set tab [expr {$indent * 0.1}]i
    newPara $tab -$tab
    set state(sb) 80
    setTabs $tab
    formattedText $text
    tab
}

Changes to tools/man2html2.tcl.

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
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
...
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
# string -		Text to output in the paragraph.

proc text string {
    global file textState inDT charCnt inTable

    set pos [string first "\t" $string]
    if {$pos >= 0} {
    	text [string range $string 0 [expr $pos-1]]
    	tab
    	text [string range $string [expr $pos+1] end]
	return
    }
    if {$inTable} {
	if {$inTable == 1} {
	    puts -nonewline $file <TR>
	    set inTable 2
	}
................................................................................
#	puts "formattedText: $text"
    while {$text ne ""} {
	set index [string first \\ $text]
	if {$index < 0} {
	    text $text
	    return
	}
	text [string range $text 0 [expr $index-1]]
	set c [string index $text [expr $index+1]]
	switch -- $c {
	    f {
		font [string index $text [expr $index+2]]
		set text [string range $text [expr $index+3] end]
	    }
	    e {
		text \\
		set text [string range $text [expr $index+2] end]
	    }
	    - {
		dash
		set text [string range $text [expr $index+2] end]
	    }
	    | {
		set text [string range $text [expr $index+2] end]
	    }
	    default {
		puts stderr "Unknown sequence: \\$c"
		set text [string range $text [expr $index+2] end]
	    }
	}
    }
}
 
##############################################################################
# dash --
................................................................................
# Arguments:
# None.

proc tab {} {
    global inPRE charCnt tabString file
#	? charCnt
    if {$inPRE == 1} {
	set pos [expr $charCnt % [string length $tabString] ]
	set spaces [string first "1" [string range $tabString $pos end] ]
	text [format "%*s" [incr spaces] " "]
    } else {
#	puts "tab: found tab outside of <PRE> block"
    }
}







|

|







 







|
|


|
|



|



|


|



|







 







|







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
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
...
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
# string -		Text to output in the paragraph.

proc text string {
    global file textState inDT charCnt inTable

    set pos [string first "\t" $string]
    if {$pos >= 0} {
    	text [string range $string 0 [expr {$pos-1}]]
    	tab
    	text [string range $string [expr {$pos+1}] end]
	return
    }
    if {$inTable} {
	if {$inTable == 1} {
	    puts -nonewline $file <TR>
	    set inTable 2
	}
................................................................................
#	puts "formattedText: $text"
    while {$text ne ""} {
	set index [string first \\ $text]
	if {$index < 0} {
	    text $text
	    return
	}
	text [string range $text 0 [expr {$index-1}]]
	set c [string index $text [expr {$index+1}]]
	switch -- $c {
	    f {
		font [string index $text [expr {$index+2}]]
		set text [string range $text [expr {$index+3}] end]
	    }
	    e {
		text \\
		set text [string range $text [expr {$index+2}] end]
	    }
	    - {
		dash
		set text [string range $text [expr {$index+2}] end]
	    }
	    | {
		set text [string range $text [expr {$index+2}] end]
	    }
	    default {
		puts stderr "Unknown sequence: \\$c"
		set text [string range $text [expr {$index+2}] end]
	    }
	}
    }
}
 
##############################################################################
# dash --
................................................................................
# Arguments:
# None.

proc tab {} {
    global inPRE charCnt tabString file
#	? charCnt
    if {$inPRE == 1} {
	set pos [expr {$charCnt % [string length $tabString]}]
	set spaces [string first "1" [string range $tabString $pos end] ]
	text [format "%*s" [incr spaces] " "]
    } else {
#	puts "tab: found tab outside of <PRE> block"
    }
}

Changes to tools/regexpTestLib.tcl.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
...
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
    set fileId [open $inFileName r]

    set i 0
    while {[gets $fileId line] >= 0} {

	set len [string length $line]

	if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} {
	    if {[info exists lineArray(c$i)] == 0} {
		set lineArray(c$i) 1
	    } else {
		incr lineArray(c$i)
	    }
	    set line [string range $line 0 [expr $len - 2]]
	    append lineArray($i) $line
	    continue
	}
	if {[info exists lineArray(c$i)] == 0} {
	    set lineArray(c$i) 1
	} else {
	    incr lineArray(c$i)
................................................................................
	}
	set str [lindex $currentLine 2]
    }
    set flags [removeFlags $flags]

    # find the test result

    set numVars [expr $len - 3]
    set vars {}
    set vals {}
    set result 0
    set v 0

    if {[regsub {\*} "$flags" "" newFlags] == 1} {
	# an error is expected






|





|







 







|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
...
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
    set fileId [open $inFileName r]

    set i 0
    while {[gets $fileId line] >= 0} {

	set len [string length $line]

	if {($len > 0) && ([string index $line [expr {$len - 1}]] == "\\")} {
	    if {[info exists lineArray(c$i)] == 0} {
		set lineArray(c$i) 1
	    } else {
		incr lineArray(c$i)
	    }
	    set line [string range $line 0 [expr {$len - 2}]]
	    append lineArray($i) $line
	    continue
	}
	if {[info exists lineArray(c$i)] == 0} {
	    set lineArray(c$i) 1
	} else {
	    incr lineArray(c$i)
................................................................................
	}
	set str [lindex $currentLine 2]
    }
    set flags [removeFlags $flags]

    # find the test result

    set numVars [expr {$len - 3}]
    set vars {}
    set vals {}
    set result 0
    set v 0

    if {[regsub {\*} "$flags" "" newFlags] == 1} {
	# an error is expected

Changes to tools/str2c.

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
} else {
    puts "/*
 * Multi parts read only string generated by str2c
 */
static const char * const data\[\]= {"
    set n 1
    for {set i 0} {$i<$lg} {incr i $MAX} {
	set part [string range $r $i [expr $i+$MAX-1]]
	set len  [string length $part];
	puts "\t/* Start of part $n ($len characters) */"
	puts "\t\"[translate $part]\","
	puts "\t/* End of part $n */\n"
	incr n
    }
    puts "\tNULL\t/* End of data marker */\n};"






|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
} else {
    puts "/*
 * Multi parts read only string generated by str2c
 */
static const char * const data\[\]= {"
    set n 1
    for {set i 0} {$i<$lg} {incr i $MAX} {
	set part [string range $r $i [expr {$i+$MAX-1}]]
	set len  [string length $part];
	puts "\t/* Start of part $n ($len characters) */"
	puts "\t\"[translate $part]\","
	puts "\t/* End of part $n */\n"
	incr n
    }
    puts "\tNULL\t/* End of data marker */\n};"

Changes to tools/tcltk-man2html-utils.tcl.

1561
1562
1563
1564
1565
1566
1567




1568
1569
1570
1571
1572
1573
1574
	#
	set manual(toc-$manual(wing-file)-$manual(name)) \
	    [concat <DL> $manual(section-toc) </DL>]
    }
    if {!$verbose} {
	puts stderr ""
    }





    #
    # make the wing table of contents for the section
    #
    set width 0
    foreach name $manual(wing-toc) {
	if {[string length $name] > $width} {






>
>
>
>







1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
	#
	set manual(toc-$manual(wing-file)-$manual(name)) \
	    [concat <DL> $manual(section-toc) </DL>]
    }
    if {!$verbose} {
	puts stderr ""
    }

    if {![llength $manual(wing-toc)]} {
	fatal "not table of contents."
    }

    #
    # make the wing table of contents for the section
    #
    set width 0
    foreach name $manual(wing-toc) {
	if {[string length $name] > $width} {

Changes to tools/tcltk-man2html.tcl.

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
66
67
68
69
70
...
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
##
## Source the utility functions that provide most of the
## implementation of the transformation from nroff to html.
##
source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
 


















proc findversion {top name useversion} {





    set upper [string toupper $name]
    foreach top1 [list $top $top/..] sub {{} generic} {
	foreach dirname [
	    glob -nocomplain -tails -type d -directory $top1 *] {

	    set tclh [join [list $top1 $dirname {*}$sub $name.h] /]
	    if {[file exists $tclh]} {
		set chan [open $tclh]
		set data [read $chan]
		close $chan
		# backslash isn't required in front of quote, but it keeps syntax
		# highlighting straight in some editors
		if {[regexp -lineanchor \
		    [string map [list @[email protected] $upper] \
			{^#define\[email protected]@_VERSION\s+\"([^.])+\.([^.\"]+)}] \
		    $data -> major minor]} {
			# to do
			#     use glob matching instead of string matching or add
			#     brace handling to [string matcch]
			if {$useversion eq {} || [string match $useversion $major.$minor]} {
			    set top [file dirname [file dirname $tclh]]
			    set prefix [file dirname $top]
			    return [list $prefix [file tail $top] $major $minor]
			}
		}
	    }
	}
    }
    return
}

proc parse_command_line {} {
    global argv Version

    # These variables determine where the man pages come from and where
    # the converted pages go to.
................................................................................
	}
    }

    if {!$build_tcl && !$build_tk} {
	set build_tcl 1;
	set build_tk 1
    }




    if {$build_tcl} {
	# Find Tcl.







	lassign [findversion $tcltkdir tcl $useversion] tcltkdir tcldir major minor

	if {$tcldir eq {} && $opt_build_tcl} {
	    puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
	    exit 1
	}
	puts "using Tcl source directory $tcltkdir $tcldir"
    }


    if {$build_tk} {
	# Find Tk.








	lassign [findversion $tcltkdir tk $useversion] tcltkdir tkdir major minor

	if {$tkdir eq {} && $opt_build_tk} {
	    puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
	    exit 1
	}
	puts "using Tk source directory $tkdir"
    }

    puts "verbose messages are [expr {$verbose ? {on} : {off}}]"

    # the title for the man pages overall
    global overall_title
    set overall_title ""
    if {$build_tcl} {

	append overall_title "Tcl $major.$minor"



    }
    if {$build_tcl && $build_tk} {
	append overall_title "/"
    }
    if {$build_tk} {
	append overall_title "[capitalize $tkdir]"
    }






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

>
>
>
>
>





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




<







 








>
>
>

<
>
>
>
>
>
>
>
|
>









|
>
>
>
>
>
>
>
>
|
>













>
|
>
>
>







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







66
67
68
69
70
71
72
73

74
75
76
77

78
79
80
81
82
83
84
...
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
219
220
221
222
223
224
225
##
## Source the utility functions that provide most of the
## implementation of the transformation from nroff to html.
##
source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
 
proc getversion {tclh {name {}}} {
    if {[file exists $tclh]} {
	set chan [open $tclh]
	set data [read $chan]
	close $chan
	if {$name eq ""} {
	    set name [string toupper [file root [file tail $tclh]]]
	}
	# backslash isn't required in front of quote, but it keeps syntax
	# highlighting straight in some editors
	if {[regexp -lineanchor \
	    [string map [list @[email protected] $name] \
		{^#define\[email protected]@_VERSION\s+\"([^.])+\.([^.\"]+)}] \
	    $data -> major minor]} {
		return [list $major $minor]
	}
    }
}
proc findversion {top name useversion} {
    # Default search version is a glob pattern, switch it for string match:
    if {$useversion eq {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}} {
	set useversion {[8-9].[0-9]}
    }
    # Search:
    set upper [string toupper $name]
    foreach top1 [list $top $top/..] sub {{} generic} {
	foreach dirname [
	    glob -nocomplain -tails -type d -directory $top1 *] {

	    set tclh [join [list $top1 $dirname {*}$sub ${name}.h] /]
	    set v [getversion $tclh $upper]
	    if {[llength $v]} {







		lassign $v major minor
		# to do
		#     use glob matching instead of string matching or add
		#     brace handling to [string matcch]
		if {$useversion eq {} || [string match $useversion $major.$minor]} {
		    set top [file dirname [file dirname $tclh]]
		    set prefix [file dirname $top]
		    return [list $prefix [file tail $top] $major $minor]

		}
	    }
	}
    }

}

proc parse_command_line {} {
    global argv Version

    # These variables determine where the man pages come from and where
    # the converted pages go to.
................................................................................
	}
    }

    if {!$build_tcl && !$build_tk} {
	set build_tcl 1;
	set build_tk 1
    }

    set major ""
    set minor ""

    if {$build_tcl} {

	# Find Tcl (firstly using glob pattern / backwards compatible way)
	set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
		-directory $tcltkdir tcl$useversion]] end]
	if {$tcldir ne {}} {
	    # obtain version from generic header if we can:
	    lassign [getversion [file join $tcltkdir $tcldir generic tcl.h]] major minor
	} else {
	    lassign [findversion $tcltkdir tcl $useversion] tcltkdir tcldir major minor
	}
	if {$tcldir eq {} && $opt_build_tcl} {
	    puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
	    exit 1
	}
	puts "using Tcl source directory $tcltkdir $tcldir"
    }


    if {$build_tk} {
	# Find Tk (firstly using glob pattern / backwards compatible way)
	set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
		-directory $tcltkdir tk$useversion]] end]
	if {$tkdir ne {}} {
	    if {$major eq ""} {
		# obtain version from generic header if we can:
		lassign [getversion [file join $tcltkdir $tcldir generic tk.h]] major minor
	    }
	} else {
	    lassign [findversion $tcltkdir tk $useversion] tcltkdir tkdir major minor
	}
	if {$tkdir eq {} && $opt_build_tk} {
	    puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
	    exit 1
	}
	puts "using Tk source directory $tkdir"
    }

    puts "verbose messages are [expr {$verbose ? {on} : {off}}]"

    # the title for the man pages overall
    global overall_title
    set overall_title ""
    if {$build_tcl} {
	if {$major ne ""} {
	    append overall_title "Tcl $major.$minor"
	} else {
	    append overall_title "Tcl [capitalize $tcldir]"
	}
    }
    if {$build_tcl && $build_tk} {
	append overall_title "/"
    }
    if {$build_tk} {
	append overall_title "[capitalize $tkdir]"
    }

Changes to unix/Makefile.in.

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
...
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
....
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
....
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
....
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
TOMMATH_OBJS = bn_reverse.o bn_fast_s_mp_mul_digs.o \
	bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \
	bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \
	bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
	bn_mp_cnt_lsb.o bn_mp_copy.o \
	bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \
	bn_mp_div_2d.o bn_mp_div_3.o bn_mp_exch.o \
	bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_get_bit.o bn_mp_get_int.o \
	bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_init.o \
	bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \
	bn_mp_init_set_int.o bn_mp_init_size.o bn_mp_karatsuba_mul.o \
	bn_mp_karatsuba_sqr.o \
	bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \
	bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \
	bn_mp_radix_size.o bn_mp_radix_smap.o \
	bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_set_int.o \
	bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \
	bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \
	bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \
	bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \
	bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \
	bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
	bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o

STUB_LIB_OBJS = tclStubLib.o \
	tclTomMathStubLib.o \
................................................................................
	$(TOMMATH_DIR)/bn_mp_set_long.c \
	$(TOMMATH_DIR)/bn_mp_set_long_long.c \
	$(TOMMATH_DIR)/bn_mp_shrink.c \
	$(TOMMATH_DIR)/bn_mp_sqr.c \
	$(TOMMATH_DIR)/bn_mp_sqrt.c \
	$(TOMMATH_DIR)/bn_mp_sub.c \
	$(TOMMATH_DIR)/bn_mp_sub_d.c \
	$(TOMMATH_DIR)/bn_mp_tc_and.c \
	$(TOMMATH_DIR)/bn_mp_tc_div_2d.c \
	$(TOMMATH_DIR)/bn_mp_tc_or.c \
	$(TOMMATH_DIR)/bn_mp_tc_xor.c \
	$(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \
	$(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \
	$(TOMMATH_DIR)/bn_mp_toom_mul.c \
	$(TOMMATH_DIR)/bn_mp_toom_sqr.c \
	$(TOMMATH_DIR)/bn_mp_toradix_n.c \
	$(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \
	$(TOMMATH_DIR)/bn_mp_xor.c \
................................................................................

bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c

bn_mp_expt_d_ex.o: $(TOMMATH_DIR)/bn_mp_expt_d_ex.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d_ex.c

bn_mp_get_bit.o: $(TOMMATH_DIR)/bn_mp_get_bit.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_bit.c

bn_mp_get_int.o: $(TOMMATH_DIR)/bn_mp_get_int.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_int.c

bn_mp_get_long.o: $(TOMMATH_DIR)/bn_mp_get_long.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_long.c

................................................................................

bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c

bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c

bn_mp_tc_and.o: $(TOMMATH_DIR)/bn_mp_tc_and.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_tc_and.c

bn_mp_tc_div_2d.o: $(TOMMATH_DIR)/bn_mp_tc_div_2d.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_tc_div_2d.c

bn_mp_tc_or.o: $(TOMMATH_DIR)/bn_mp_tc_or.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_tc_or.c

bn_mp_tc_xor.o: $(TOMMATH_DIR)/bn_mp_tc_xor.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_tc_xor.c

bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c

bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c

................................................................................
		$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
	$(DIST_INSTALL_SCRIPT) $(UNIX_DIR)/configure $(UNIX_DIR)/ldAix $(DISTDIR)/unix
	$(INSTALL_DATA_DIR) $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/README $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README \
		$(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \
		$(DISTDIR)
	$(INSTALL_DATA_DIR) $(DISTDIR)/library
	$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
		$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
	@for i in $(BUILTIN_PACKAGE_LIST) ; do \
	    $(INSTALL_DATA_DIR) $(DISTDIR)/library/$$i;\






|










|







 







<
<
|
<







 







|
|







 







<
<
<
<
<
<
|
|
<
<
<







 







|







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
...
546
547
548
549
550
551
552


553

554
555
556
557
558
559
560
....
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
....
1638
1639
1640
1641
1642
1643
1644






1645
1646



1647
1648
1649
1650
1651
1652
1653
....
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
TOMMATH_OBJS = bn_reverse.o bn_fast_s_mp_mul_digs.o \
	bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \
	bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \
	bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
	bn_mp_cnt_lsb.o bn_mp_copy.o \
	bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \
	bn_mp_div_2d.o bn_mp_div_3.o bn_mp_exch.o \
	bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_s_mp_get_bit.o bn_mp_get_int.o \
	bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_init.o \
	bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \
	bn_mp_init_set_int.o bn_mp_init_size.o bn_mp_karatsuba_mul.o \
	bn_mp_karatsuba_sqr.o \
	bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \
	bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \
	bn_mp_radix_size.o bn_mp_radix_smap.o \
	bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_set_int.o \
	bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \
	bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \
	bn_mp_signed_rsh.o \
	bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \
	bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \
	bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
	bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o

STUB_LIB_OBJS = tclStubLib.o \
	tclTomMathStubLib.o \
................................................................................
	$(TOMMATH_DIR)/bn_mp_set_long.c \
	$(TOMMATH_DIR)/bn_mp_set_long_long.c \
	$(TOMMATH_DIR)/bn_mp_shrink.c \
	$(TOMMATH_DIR)/bn_mp_sqr.c \
	$(TOMMATH_DIR)/bn_mp_sqrt.c \
	$(TOMMATH_DIR)/bn_mp_sub.c \
	$(TOMMATH_DIR)/bn_mp_sub_d.c \


	$(TOMMATH_DIR)/bn_mp_signed_rsh.c \

	$(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \
	$(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \
	$(TOMMATH_DIR)/bn_mp_toom_mul.c \
	$(TOMMATH_DIR)/bn_mp_toom_sqr.c \
	$(TOMMATH_DIR)/bn_mp_toradix_n.c \
	$(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \
	$(TOMMATH_DIR)/bn_mp_xor.c \
................................................................................

bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c

bn_mp_expt_d_ex.o: $(TOMMATH_DIR)/bn_mp_expt_d_ex.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d_ex.c

bn_s_mp_get_bit.o: $(TOMMATH_DIR)/bn_s_mp_get_bit.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_get_bit.c

bn_mp_get_int.o: $(TOMMATH_DIR)/bn_mp_get_int.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_int.c

bn_mp_get_long.o: $(TOMMATH_DIR)/bn_mp_get_long.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_long.c

................................................................................

bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c

bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c







bn_mp_signed_rsh.o: $(TOMMATH_DIR)/bn_mp_signed_rsh.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_signed_rsh.c




bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c

bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c

................................................................................
		$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
	$(DIST_INSTALL_SCRIPT) $(UNIX_DIR)/configure $(UNIX_DIR)/ldAix $(DISTDIR)/unix
	$(INSTALL_DATA_DIR) $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/README $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
	$(DIST_INSTALL_DATA) $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README.md \
		$(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \
		$(DISTDIR)
	$(INSTALL_DATA_DIR) $(DISTDIR)/library
	$(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
		$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
	@for i in $(BUILTIN_PACKAGE_LIST) ; do \
	    $(INSTALL_DATA_DIR) $(DISTDIR)/library/$$i;\

Changes to unix/tclUnixFCmd.c.

2269
2270
2271
2272
2273
2274
2275















































































2276
2277
2278
2279
2280
2281
2282
     * Assume that the default location ("/tmp" if not overridden) is always
     * an existing writable directory; we've no recovery mechanism if it
     * isn't.
     */

    return TCL_TEMPORARY_FILE_DIRECTORY;
}















































































 
#if defined(__CYGWIN__)

static void
StatError(
    Tcl_Interp *interp,		/* The interp that has the error */
    Tcl_Obj *fileName)		/* The name of the file which caused the






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







2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
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
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
     * Assume that the default location ("/tmp" if not overridden) is always
     * an existing writable directory; we've no recovery mechanism if it
     * isn't.
     */

    return TCL_TEMPORARY_FILE_DIRECTORY;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpCreateTemporaryDirectory --
 *
 *	Creates a temporary directory, possibly based on the supplied bits and
 *	pieces of template supplied in the arguments.
 *
 * Results:
 *	An object (refcount 0) containing the name of the newly-created
 *	directory, or NULL on failure.
 *
 * Side effects:
 *	Accesses the native filesystem. Makes a directory.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclpCreateTemporaryDirectory(
    Tcl_Obj *dirObj,
    Tcl_Obj *basenameObj)
{
    Tcl_DString template, tmp;
    const char *string;

#define DEFAULT_TEMP_DIR_PREFIX	"tcl"

    /*
     * Build the template in writable memory from the user-supplied pieces and
     * some defaults.
     */

    if (dirObj) {
	string = TclGetString(dirObj);
	Tcl_UtfToExternalDString(NULL, string, dirObj->length, &template);
    } else {
	Tcl_DStringInit(&template);
	Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */
    }

    if (Tcl_DStringValue(&template)[Tcl_DStringLength(&template) - 1] != '/') {
	TclDStringAppendLiteral(&template, "/");
    }

    if (basenameObj) {
	string = TclGetString(basenameObj);
	if (basenameObj->length) {
	    Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
	    TclDStringAppendDString(&template, &tmp);
	    Tcl_DStringFree(&tmp);
	} else {
	    TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX);
	}
    } else {
	TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX);
    }

    TclDStringAppendLiteral(&template, "_XXXXXX");

    /*
     * Make the temporary directory.
     */

    if (mkdtemp(Tcl_DStringValue(&template)) == NULL) {
	Tcl_DStringFree(&template);
	return NULL;
    }

    /*
     * The template has been updated. Tell the caller what it was.
     */

    Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template),
	    Tcl_DStringLength(&template), &tmp);
    Tcl_DStringFree(&template);
    return TclDStringToObj(&tmp);
}
 
#if defined(__CYGWIN__)

static void
StatError(
    Tcl_Interp *interp,		/* The interp that has the error */
    Tcl_Obj *fileName)		/* The name of the file which caused the

Changes to win/Makefile.in.

382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
...
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
	bn_mp_div_d.${OBJEXT} \
	bn_mp_div_2.${OBJEXT} \
	bn_mp_div_2d.${OBJEXT} \
	bn_mp_div_3.${OBJEXT} \
	bn_mp_exch.${OBJEXT} \
	bn_mp_expt_d.${OBJEXT} \
	bn_mp_expt_d_ex.${OBJEXT} \
	bn_mp_get_bit.${OBJEXT} \
	bn_mp_get_int.${OBJEXT} \
	bn_mp_get_long.${OBJEXT} \
	bn_mp_get_long_long.${OBJEXT} \
	bn_mp_grow.${OBJEXT} \
	bn_mp_init.${OBJEXT} \
	bn_mp_init_copy.${OBJEXT} \
	bn_mp_init_multi.${OBJEXT} \
................................................................................
	bn_mp_set_long.${OBJEXT} \
	bn_mp_set_long_long.${OBJEXT} \
	bn_mp_shrink.${OBJEXT} \
	bn_mp_sqr.${OBJEXT} \
	bn_mp_sqrt.${OBJEXT} \
	bn_mp_sub.${OBJEXT} \
	bn_mp_sub_d.${OBJEXT} \
	bn_mp_tc_and.${OBJEXT} \
	bn_mp_tc_div_2d.${OBJEXT} \
	bn_mp_tc_or.${OBJEXT} \
	bn_mp_tc_xor.${OBJEXT} \
	bn_mp_to_unsigned_bin.${OBJEXT} \
	bn_mp_to_unsigned_bin_n.${OBJEXT} \
	bn_mp_toom_mul.${OBJEXT} \
	bn_mp_toom_sqr.${OBJEXT} \
	bn_mp_toradix_n.${OBJEXT} \
	bn_mp_unsigned_bin_size.${OBJEXT} \
	bn_mp_xor.${OBJEXT} \






|







 







<
<
|
<







382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
...
417
418
419
420
421
422
423


424

425
426
427
428
429
430
431
	bn_mp_div_d.${OBJEXT} \
	bn_mp_div_2.${OBJEXT} \
	bn_mp_div_2d.${OBJEXT} \
	bn_mp_div_3.${OBJEXT} \
	bn_mp_exch.${OBJEXT} \
	bn_mp_expt_d.${OBJEXT} \
	bn_mp_expt_d_ex.${OBJEXT} \
	bn_s_mp_get_bit.${OBJEXT} \
	bn_mp_get_int.${OBJEXT} \
	bn_mp_get_long.${OBJEXT} \
	bn_mp_get_long_long.${OBJEXT} \
	bn_mp_grow.${OBJEXT} \
	bn_mp_init.${OBJEXT} \
	bn_mp_init_copy.${OBJEXT} \
	bn_mp_init_multi.${OBJEXT} \
................................................................................
	bn_mp_set_long.${OBJEXT} \
	bn_mp_set_long_long.${OBJEXT} \
	bn_mp_shrink.${OBJEXT} \
	bn_mp_sqr.${OBJEXT} \
	bn_mp_sqrt.${OBJEXT} \
	bn_mp_sub.${OBJEXT} \
	bn_mp_sub_d.${OBJEXT} \


	bn_mp_signed_rsh.${OBJEXT} \

	bn_mp_to_unsigned_bin.${OBJEXT} \
	bn_mp_to_unsigned_bin_n.${OBJEXT} \
	bn_mp_toom_mul.${OBJEXT} \
	bn_mp_toom_sqr.${OBJEXT} \
	bn_mp_toradix_n.${OBJEXT} \
	bn_mp_unsigned_bin_size.${OBJEXT} \
	bn_mp_xor.${OBJEXT} \

Changes to win/makefile.vc.

274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
...
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
	$(TMP_DIR)\bn_mp_div_d.obj \
	$(TMP_DIR)\bn_mp_div_2.obj \
	$(TMP_DIR)\bn_mp_div_2d.obj \
	$(TMP_DIR)\bn_mp_div_3.obj \
	$(TMP_DIR)\bn_mp_exch.obj \
	$(TMP_DIR)\bn_mp_expt_d.obj \
	$(TMP_DIR)\bn_mp_expt_d_ex.obj \
	$(TMP_DIR)\bn_mp_get_bit.obj \
	$(TMP_DIR)\bn_mp_get_int.obj \
	$(TMP_DIR)\bn_mp_get_long.obj \
	$(TMP_DIR)\bn_mp_get_long_long.obj \
	$(TMP_DIR)\bn_mp_grow.obj \
	$(TMP_DIR)\bn_mp_init.obj \
	$(TMP_DIR)\bn_mp_init_copy.obj \
	$(TMP_DIR)\bn_mp_init_multi.obj \
................................................................................
	$(TMP_DIR)\bn_mp_set_long.obj \
	$(TMP_DIR)\bn_mp_set_long_long.obj \
	$(TMP_DIR)\bn_mp_shrink.obj \
	$(TMP_DIR)\bn_mp_sqr.obj \
	$(TMP_DIR)\bn_mp_sqrt.obj \
	$(TMP_DIR)\bn_mp_sub.obj \
	$(TMP_DIR)\bn_mp_sub_d.obj \
	$(TMP_DIR)\bn_mp_tc_and.obj \
	$(TMP_DIR)\bn_mp_tc_div_2d.obj \
	$(TMP_DIR)\bn_mp_tc_or.obj \
	$(TMP_DIR)\bn_mp_tc_xor.obj \
	$(TMP_DIR)\bn_mp_to_unsigned_bin.obj \
	$(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \
	$(TMP_DIR)\bn_mp_toom_mul.obj \
	$(TMP_DIR)\bn_mp_toom_sqr.obj \
	$(TMP_DIR)\bn_mp_toradix_n.obj \
	$(TMP_DIR)\bn_mp_unsigned_bin_size.obj \
	$(TMP_DIR)\bn_mp_xor.obj \






|







 







<
<
|
<







274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
...
309
310
311
312
313
314
315


316

317
318
319
320
321
322
323
	$(TMP_DIR)\bn_mp_div_d.obj \
	$(TMP_DIR)\bn_mp_div_2.obj \
	$(TMP_DIR)\bn_mp_div_2d.obj \
	$(TMP_DIR)\bn_mp_div_3.obj \
	$(TMP_DIR)\bn_mp_exch.obj \
	$(TMP_DIR)\bn_mp_expt_d.obj \
	$(TMP_DIR)\bn_mp_expt_d_ex.obj \
	$(TMP_DIR)\bn_s_mp_get_bit.obj \
	$(TMP_DIR)\bn_mp_get_int.obj \
	$(TMP_DIR)\bn_mp_get_long.obj \
	$(TMP_DIR)\bn_mp_get_long_long.obj \
	$(TMP_DIR)\bn_mp_grow.obj \
	$(TMP_DIR)\bn_mp_init.obj \
	$(TMP_DIR)\bn_mp_init_copy.obj \
	$(TMP_DIR)\bn_mp_init_multi.obj \
................................................................................
	$(TMP_DIR)\bn_mp_set_long.obj \
	$(TMP_DIR)\bn_mp_set_long_long.obj \
	$(TMP_DIR)\bn_mp_shrink.obj \
	$(TMP_DIR)\bn_mp_sqr.obj \
	$(TMP_DIR)\bn_mp_sqrt.obj \
	$(TMP_DIR)\bn_mp_sub.obj \
	$(TMP_DIR)\bn_mp_sub_d.obj \


	$(TMP_DIR)\bn_mp_signed_rsh.obj \

	$(TMP_DIR)\bn_mp_to_unsigned_bin.obj \
	$(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \
	$(TMP_DIR)\bn_mp_toom_mul.obj \
	$(TMP_DIR)\bn_mp_toom_sqr.obj \
	$(TMP_DIR)\bn_mp_toradix_n.obj \
	$(TMP_DIR)\bn_mp_unsigned_bin_size.obj \
	$(TMP_DIR)\bn_mp_xor.obj \

Changes to win/tclWinFCmd.c.

1951
1952
1953
1954
1955
1956
1957
1958
1959



















































































































1960
1961
1962
1963
1964
1965
	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }

    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}
 
/*



















































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */








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






1951
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
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
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
2018
2019
2020
2021
2022
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
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }

    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpCreateTemporaryDirectory --
 *
 *	Creates a temporary directory, possibly based on the supplied bits and
 *	pieces of template supplied in the arguments.
 *
 * Results:
 *	An object (refcount 0) containing the name of the newly-created
 *	directory, or NULL on failure.
 *
 * Side effects:
 *	Accesses the native filesystem. Makes a directory.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclpCreateTemporaryDirectory(
    Tcl_Obj *dirObj,
    Tcl_Obj *basenameObj)
{
    Tcl_DString base, name;	/* Contains WCHARs */
    int baseLen;
    DWORD error;
    WCHAR tempBuf[MAX_PATH + 1];
    DWORD len = GetTempPathW(MAX_PATH, tempBuf);

    /*
     * Build the path in writable memory from the user-supplied pieces and
     * some defaults. First, the parent temporary directory.
     */

    if (dirObj) {
	Tcl_GetString(dirObj);
	if (dirObj->length < 1) {
	    goto useSystemTemp;
	}
	Tcl_WinUtfToTChar(Tcl_GetString(dirObj), -1, &base);
	if (dirObj->bytes[dirObj->length - 1] != '\\') {
	    TclUtfToWCharDString("\\", -1, &base);
	}
    } else {
    useSystemTemp:
	Tcl_DStringInit(&base);
	Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
    }

    /*
     * Next, the base of the directory name.
     */

#define DEFAULT_TEMP_DIR_PREFIX	"tcl"
#define SUFFIX_LENGTH	8

    if (basenameObj) {
	Tcl_WinUtfToTChar(Tcl_GetString(basenameObj), -1, &name);
	TclDStringAppendDString(&base, &name);
	Tcl_DStringFree(&name);
    } else {
	TclUtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base);
    }
    TclUtfToWCharDString("_", -1, &base);

    /*
     * Now we keep on trying random suffixes until we get one that works
     * (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that
     * SUFFIX_LENGTH is longer than on Unix because we expect to be not on a
     * case-sensitive filesystem.
     */

    baseLen = Tcl_DStringLength(&base);
    do {
	char tempbuf[SUFFIX_LENGTH + 1];
	int i;
	static const char randChars[] =
	    "QWERTYUIOPASDFGHJKLZXCVBNM1234567890";
	static const int numRandChars = sizeof(randChars) - 1;

	/*
	 * Put a random suffix on the end.
	 */

	error = ERROR_SUCCESS;
	tempbuf[SUFFIX_LENGTH] = '\0';
	for (i = 0 ; i < SUFFIX_LENGTH; i++) {
	    tempbuf[i] = randChars[(int) (rand() % numRandChars)];
	}
	Tcl_DStringSetLength(&base, baseLen);
	TclUtfToWCharDString(tempbuf, -1, &base);
    } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)
	    && (error = GetLastError()) == ERROR_ALREADY_EXISTS);

    /*
     * Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and
     * ERROR_ACCESS_DENIED.
     */

    if (error != ERROR_SUCCESS) {
	TclWinConvertError(error);
	Tcl_DStringFree(&base);
	return NULL;
    }

    /*
     * We actually made the directory, so we're done! Report what we made back
     * as a (clean) Tcl_Obj.
     */

    Tcl_WinTCharToUtf((LPCWSTR) Tcl_DStringValue(&base), -1, &name);
    Tcl_DStringFree(&base);
    return TclDStringToObj(&name);
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */