Tcl Source Code

Check-in [a92f73b21e]
Login

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

Overview
Comment:merge 8.7
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | tip-367
Files: files | file ages | folders
SHA3-256: a92f73b21e5d1e307cdb1d7a1b74e476086f95fd71b5526630566a4cfb994b1c
User & Date: dgp 2019-04-12 20:15:37.668
Context
2019-04-14
14:17
Implement TIP 367 check-in: 48745adfd3 user: dkf tags: core-8-branch
2019-04-12
20:15
merge 8.7 Closed-Leaf check-in: a92f73b21e user: dgp tags: tip-367
2019-04-11
20:37
Merge 8.6 check-in: 2a6c012bff user: jan.nijtmans tags: core-8-branch
2019-03-30
12:54
Added documentation check-in: b7911ee099 user: dkf tags: tip-367
Changes
Unified Diff Ignore Whitespace Patch
Changes to .travis.yml.
154
155
156
157
158
159
160
















161
162
163
164
165
166
167
          packages:
            - gcc-mingw-w64-base
            - binutils-mingw-w64-i686
            - gcc-mingw-w64-i686
            - gcc-mingw-w64
            - gcc-multilib
            - wine
















      env:
        - BUILD_DIR=win
        - CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=6"
        - NO_DIRECT_TEST=1
    - os: linux
      dist: xenial
      compiler: i686-w64-mingw32-gcc







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







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
          packages:
            - gcc-mingw-w64-base
            - binutils-mingw-w64-i686
            - gcc-mingw-w64-i686
            - gcc-mingw-w64
            - gcc-multilib
            - wine
      env:
        - BUILD_DIR=win
        - CFGOPT="--host=i686-w64-mingw32 --disable-shared"
        - NO_DIRECT_TEST=1
    - os: linux
      dist: xenial
      compiler: i686-w64-mingw32-gcc
      addons:
        apt:
          packages:
            - gcc-mingw-w64-base
            - binutils-mingw-w64-i686
            - gcc-mingw-w64-i686
            - gcc-mingw-w64
            - gcc-multilib
            - wine
      env:
        - BUILD_DIR=win
        - CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=6"
        - NO_DIRECT_TEST=1
    - os: linux
      dist: xenial
      compiler: i686-w64-mingw32-gcc
207
208
209
210
211
212
213















214
215
216
217
218
219
220
            - gcc-mingw-w64
            - wine
      env:
        - BUILD_DIR=win
        - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
        - NO_DIRECT_TEST=1
    - os: linux















      dist: xenial
      compiler: x86_64-w64-mingw32-gcc
      addons:
        apt:
          packages:
            - gcc-mingw-w64-base
            - binutils-mingw-w64-x86-64







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







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
            - gcc-mingw-w64
            - wine
      env:
        - BUILD_DIR=win
        - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
        - NO_DIRECT_TEST=1
    - os: linux
      dist: xenial
      compiler: x86_64-w64-mingw32-gcc
      addons:
        apt:
          packages:
            - gcc-mingw-w64-base
            - binutils-mingw-w64-x86-64
            - gcc-mingw-w64-x86-64
            - gcc-mingw-w64
            - wine
      env:
        - BUILD_DIR=win
        - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --disable-shared"
        - NO_DIRECT_TEST=1
    - os: linux
      dist: xenial
      compiler: x86_64-w64-mingw32-gcc
      addons:
        apt:
          packages:
            - gcc-mingw-w64-base
            - binutils-mingw-w64-x86-64
Changes to doc/define.n.
280
281
282
283
284
285
286
287

288
289
290
291
292
293
294
.VE TIP524
.TP
\fBdeletemethod\fI name\fR ?\fIname ...\fR?
.
This deletes each of the methods called \fIname\fR from a class. The methods
must have previously existed in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class
(except when they have a call chain through the class being modified).

.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
sets or updates the list of method names that are used to guard whether
method call to instances of the class may be called and what the method's
results are. Each \fImethodName\fR names a single filtering method (which may







|
>







280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
.VE TIP524
.TP
\fBdeletemethod\fI name\fR ?\fIname ...\fR?
.
This deletes each of the methods called \fIname\fR from a class. The methods
must have previously existed in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class
(except when they have a call chain through the class being modified) or the
class object itself.
.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
sets or updates the list of method names that are used to guard whether
method call to instances of the class may be called and what the method's
results are. Each \fImethodName\fR names a single filtering method (which may
306
307
308
309
310
311
312
313

314
315
316
317
318
319
320
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
method must have previously existed in the class, and \fItoName\fR must not
previously refer to a method in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class
(except when they have a call chain through the class being modified). Does

not change the export status of the method; if it was exported before, it will
be afterwards.
.SH "CONFIGURING OBJECTS"
.PP
The following commands are supported in the \fIdefScript\fR for
\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
form:







|
>







307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
method must have previously existed in the class, and \fItoName\fR must not
previously refer to a method in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class
(except when they have a call chain through the class being modified), or the
class object itself. Does
not change the export status of the method; if it was exported before, it will
be afterwards.
.SH "CONFIGURING OBJECTS"
.PP
The following commands are supported in the \fIdefScript\fR for
\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
form:
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
This allows the class of an object to be changed after creation. Note that the
class's constructors are not called when this is done, and so the object may
well be in an inconsistent state unless additional configuration work is done.
.TP
\fBdeletemethod\fI name\fR ?\fIname ...\fR
.
This deletes each of the methods called \fIname\fR from an object. The methods
must have previously existed in that object. Does not affect the classes that

the object is an instance of.

.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
sets or updates the list of method names that are used to guard whether a
method call to the object may be called and what the method's results are.
Each \fImethodName\fR names a single filtering method (which may be exposed or
not exposed); it is not an error for a non-existent method to be named. Note
that the actual list of filters also depends on the filters set upon any
classes that the object is an instance of.
By default, this slot works by appending.
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in an object to \fItoName\fR.
The method must have previously existed in the object, and \fItoName\fR must
not previously refer to a method in that object. Does not affect the classes
that the object is an instance of. Does not change the export status of the


method; if it was exported before, it will be afterwards.
.TP
\fBself \fR
.VS TIP470
This gives the name of the object currently being configured.
.VE TIP470
.SH "PRIVATE METHODS"
.VS TIP500







|
>
|
>

















|
>
>
|







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
472
This allows the class of an object to be changed after creation. Note that the
class's constructors are not called when this is done, and so the object may
well be in an inconsistent state unless additional configuration work is done.
.TP
\fBdeletemethod\fI name\fR ?\fIname ...\fR
.
This deletes each of the methods called \fIname\fR from an object. The methods
must have previously existed in that object (e.g., because it was created
through \fBoo::objdefine method\fR). Does not affect the classes that the
object is an instance of, or remove the exposure of those class-provided
methods in the instance of that class.
.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
sets or updates the list of method names that are used to guard whether a
method call to the object may be called and what the method's results are.
Each \fImethodName\fR names a single filtering method (which may be exposed or
not exposed); it is not an error for a non-existent method to be named. Note
that the actual list of filters also depends on the filters set upon any
classes that the object is an instance of.
By default, this slot works by appending.
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in an object to \fItoName\fR.
The method must have previously existed in the object, and \fItoName\fR must
not previously refer to a method in that object. Does not affect the classes
that the object is an instance of and cannot rename in an instance object the
methods provided by those classes (though a \fBoo::objdefine forward\fRed
method may provide an equivalent capability). Does not change the export
status of the method; if it was exported before, it will be afterwards.
.TP
\fBself \fR
.VS TIP470
This gives the name of the object currently being configured.
.VE TIP470
.SH "PRIVATE METHODS"
.VS TIP500
Changes to doc/info.n.
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
For a frame that corresponds to a level, (to be determined).
.PP
When a command can be traced to its literal definition in some script, e.g.
procedures nested in statically defined procedures, and literal eval scripts in
files or statically defined procedures, its type is \fBsource\fR and its
location is the absolute line number in the script.  Otherwise, its type is
\fBproc\fR and its location is its line number within the body of the
procedure. 
.PP
In contrast, procedure definitions and \fBeval\fR within a dynamically
\fBeval\fRuated environment count line numbers relative to the start of
their script, even if they would be able to count relative to the
start of the outer dynamic script. That type of number usually makes
more sense.
.PP







|







208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
For a frame that corresponds to a level, (to be determined).
.PP
When a command can be traced to its literal definition in some script, e.g.
procedures nested in statically defined procedures, and literal eval scripts in
files or statically defined procedures, its type is \fBsource\fR and its
location is the absolute line number in the script.  Otherwise, its type is
\fBproc\fR and its location is its line number within the body of the
procedure.
.PP
In contrast, procedure definitions and \fBeval\fR within a dynamically
\fBeval\fRuated environment count line numbers relative to the start of
their script, even if they would be able to count relative to the
start of the outer dynamic script. That type of number usually makes
more sense.
.PP
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
\fBinfo object\fI subcommand object\fR ?\fIarg ...\fR
.
Returns information about the object named \fIobject\fR. \fIsubcommand\fR is
described \fBOBJECT INTROSPECTION\fR below.
.TP
\fBinfo patchlevel\fR
.
Returns the value of the global variable \fBtcl_patchLevel\fR, in which the 
exact version of the Tcl library initially stored.
.TP
\fBinfo procs \fR?\fIpattern\fR?
.
Returns the names of all visible procedures. If \fIpattern\fR is given, returns
only those names that match according to \fBstring match\fR.  Only the final
component in \fIpattern\fR is actually considered a pattern.  Any qualifying







|







296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
\fBinfo object\fI subcommand object\fR ?\fIarg ...\fR
.
Returns information about the object named \fIobject\fR. \fIsubcommand\fR is
described \fBOBJECT INTROSPECTION\fR below.
.TP
\fBinfo patchlevel\fR
.
Returns the value of the global variable \fBtcl_patchLevel\fR, in which the
exact version of the Tcl library initially stored.
.TP
\fBinfo procs \fR?\fIpattern\fR?
.
Returns the names of all visible procedures. If \fIpattern\fR is given, returns
only those names that match according to \fBstring match\fR.  Only the final
component in \fIpattern\fR is actually considered a pattern.  Any qualifying
Changes to doc/interp.n.
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
\fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR??
.
Controls whether frame-level stack information is captured in the
slave interpreter identified by \fIpath\fR.  If no arguments are
given, option and current setting are returned.  If \fB\-frame\fR
is given, the debug setting is set to the given boolean if provided
and the current setting is returned.
This only effects the output of \fBinfo frame\fR, in that exact
frame-level information for command invocation at the bytecode level
is only captured with this setting on.
.RS
.PP
For example, with code like
.PP
.CS







|







197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
\fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR??
.
Controls whether frame-level stack information is captured in the
slave interpreter identified by \fIpath\fR.  If no arguments are
given, option and current setting are returned.  If \fB\-frame\fR
is given, the debug setting is set to the given boolean if provided
and the current setting is returned.
This only affects the output of \fBinfo frame\fR, in that exact
frame-level information for command invocation at the bytecode level
is only captured with this setting on.
.RS
.PP
For example, with code like
.PP
.CS
Changes to generic/tclCmdAH.c.
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
int
Tcl_ExitObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int value;

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

    if (objc == 1) {
	value = 0;
    } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
	return TCL_ERROR;
    }
    Tcl_Exit(value);
    /*NOTREACHED*/
    return TCL_OK;		/* Better not ever reach this! */
}

/*
 *----------------------------------------------------------------------
 *







|








|


|







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
int
Tcl_ExitObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_WideInt value;

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

    if (objc == 1) {
	value = 0;
    } else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) {
	return TCL_ERROR;
    }
    Tcl_Exit((int)value);
    /*NOTREACHED*/
    return TCL_OK;		/* Better not ever reach this! */
}

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclCmdMZ.c.
4368
4369
4370
4371
4372
4373
4374





4375
4376
4377
4378
4379
4380
4381

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

    #ifdef TCL_WIDE_CLICKS
	/* convert execution time in wide clicks to microsecs */
	middle *= TclpWideClickInMicrosec();
    #endif






	/* if not calibrate */
	if (!calibrate) {
	    /* minimize influence of measurement overhead */
	    if (overhead > 0) {
		/* estimate the time of overhead (microsecs) */
		Tcl_WideUInt curOverhead = overhead * count;







>
>
>
>
>







4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386

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

    #ifdef TCL_WIDE_CLICKS
	/* convert execution time in wide clicks to microsecs */
	middle *= TclpWideClickInMicrosec();
    #endif

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

	/* if not calibrate */
	if (!calibrate) {
	    /* minimize influence of measurement overhead */
	    if (overhead > 0) {
		/* estimate the time of overhead (microsecs) */
		Tcl_WideUInt curOverhead = overhead * count;
4421
4422
4423
4424
4425
4426
4427

4428
4429

4430



4431
4432
4433
4434
4435
4436
4437
	    } else {
		objs[4] = Tcl_NewWideIntObj(val);
	    }
	} else {
	    objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000);
	}


	/* estimated net execution time (in millisecs) */
	if (!calibrate) {

	    objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000);



	    TclNewLiteralStringObj(objs[7], "nett-ms");
	}

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







>


>
|
>
>
>







4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
	    } 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).
	*/
Changes to generic/tclExecute.c.
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
	if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
	    type1 = 0;
	} else if (type1 == TCL_NUMBER_BIG) {
	    /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
	    /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */
	    Tcl_WideInt w;

	    if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
		type1 = TCL_NUMBER_INT;
	    }
	}
	TclNewIntObj(objResultPtr, type1);
	TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
	NEXT_INST_F(1, 1, 1);








|







5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
	if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
	    type1 = 0;
	} else if (type1 == TCL_NUMBER_BIG) {
	    /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
	    /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */
	    Tcl_WideInt w;

	    if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
		type1 = TCL_NUMBER_INT;
	    }
	}
	TclNewIntObj(objResultPtr, type1);
	TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
	NEXT_INST_F(1, 1, 1);

8395
8396
8397
8398
8399
8400
8401

8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424

		wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base];
		WIDE_RESULT(wResult);
	    }
	}

    overflowExpon:

	Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
	if ((big2.used > 1)
#if DIGIT_BIT > 28
		|| ((big2.used == 1) && (big2.dp[0] >= (1<<28)))
#endif
	) {
	    mp_clear(&big2);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "exponent too large", -1));
	    return GENERAL_ARITHMETIC_ERROR;
	}
	Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
	mp_init(&bigResult);
	mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1);
	mp_clear(&big1);
	mp_clear(&big2);
	BIG_RESULT(&bigResult);
    }

    case INST_ADD:
    case INST_SUB:
    case INST_MULT:
    case INST_DIV:







>
|
<
|
|
<
<
<






|

<







8395
8396
8397
8398
8399
8400
8401
8402
8403

8404
8405



8406
8407
8408
8409
8410
8411
8412
8413

8414
8415
8416
8417
8418
8419
8420

		wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base];
		WIDE_RESULT(wResult);
	    }
	}

    overflowExpon:

	if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)

		|| (value2Ptr->typePtr != &tclIntType)
		|| (Tcl_WideUInt)w2 >= (1<<28)) {



	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "exponent too large", -1));
	    return GENERAL_ARITHMETIC_ERROR;
	}
	Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
	mp_init(&bigResult);
	mp_expt_d_ex(&big1, w2, &bigResult, 1);
	mp_clear(&big1);

	BIG_RESULT(&bigResult);
    }

    case INST_ADD:
    case INST_SUB:
    case INST_MULT:
    case INST_DIV:
Changes to generic/tclProcess.c.
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
	if (result != TCL_OK) {
	    return result;
	}
	dict = Tcl_NewDictObj();
	Tcl_MutexLock(&infoTablesMutex);
	for (i = 0; i < numPids; i++) {
	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
	    if (result != TCL_OK) {
		Tcl_MutexUnlock(&infoTablesMutex);
		Tcl_DecrRefCount(dict);
		return result;
	    }

	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));







|







536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
	if (result != TCL_OK) {
	    return result;
	}
	dict = Tcl_NewDictObj();
	Tcl_MutexLock(&infoTablesMutex);
	for (i = 0; i < numPids; i++) {
	    result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
	    if (result != TCL_OK) {
		Tcl_MutexUnlock(&infoTablesMutex);
		Tcl_DecrRefCount(dict);
		return result;
	    }

	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664

	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
	if (result != TCL_OK) {
	    return result;
	}
	Tcl_MutexLock(&infoTablesMutex);
	for (i = 0; i < numPids; i++) {
	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
	    if (result != TCL_OK) {
		Tcl_MutexUnlock(&infoTablesMutex);
		return result;
	    }

	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
	    if (!entry) {







|







650
651
652
653
654
655
656
657
658
659
660
661
662
663
664

	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
	if (result != TCL_OK) {
	    return result;
	}
	Tcl_MutexLock(&infoTablesMutex);
	for (i = 0; i < numPids; i++) {
	    result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
	    if (result != TCL_OK) {
		Tcl_MutexUnlock(&infoTablesMutex);
		return result;
	    }

	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
	    if (!entry) {
Changes to generic/tclTest.c.
48
49
50
51
52
53
54

55
56
57
58
59
60
61
/*
 * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
 * the results of the various deletion callbacks.
 */

static Tcl_DString delString;
static Tcl_Interp *delInterp;


/*
 * One of the following structures exists for each asynchronous handler
 * created by the "testasync" command".
 */

typedef struct TestAsyncHandler {







>







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
/*
 * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
 * the results of the various deletion callbacks.
 */

static Tcl_DString delString;
static Tcl_Interp *delInterp;
static const Tcl_ObjType *properByteArrayType;

/*
 * One of the following structures exists for each asynchronous handler
 * created by the "testasync" command".
 */

typedef struct TestAsyncHandler {
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576





577
578
579
580
581
582
583
 *----------------------------------------------------------------------
 */

int
Tcltest_Init(
    Tcl_Interp *interp)		/* Interpreter for application. */
{
    Tcl_Obj *listPtr;
    Tcl_Obj **objv;
    int objc, index;
    static const char *const specialOptions[] = {
	"-appinitprocerror", "-appinitprocdeleteinterp",
	"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
    };

    if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_OOInitStubs(interp) == NULL) {
	return TCL_ERROR;
    }
    /* TIP #268: Full patchlevel instead of just major.minor */

    if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
	return TCL_ERROR;
    }






    /*
     * Create additional commands and math functions for testing Tcl.
     */

    Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);







<
|




















>
>
>
>
>







549
550
551
552
553
554
555

556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
 *----------------------------------------------------------------------
 */

int
Tcltest_Init(
    Tcl_Interp *interp)		/* Interpreter for application. */
{

    Tcl_Obj **objv, *objPtr;
    int objc, index;
    static const char *const specialOptions[] = {
	"-appinitprocerror", "-appinitprocdeleteinterp",
	"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
    };

    if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_OOInitStubs(interp) == NULL) {
	return TCL_ERROR;
    }
    /* TIP #268: Full patchlevel instead of just major.minor */

    if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
	return TCL_ERROR;
    }

    objPtr = Tcl_NewStringObj("abc", 3);
    (void)Tcl_GetByteArrayFromObj(objPtr, &index);
    properByteArrayType = objPtr->typePtr;
    Tcl_DecrRefCount(objPtr);

    /*
     * Create additional commands and math functions for testing Tcl.
     */

    Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
    }
#endif

    /*
     * Check for special options used in ../tests/main.test
     */

    listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
    if (listPtr != NULL) {
	if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
		TCL_EXACT, &index) == TCL_OK)) {
	    switch (index) {
	    case 0:
		return TCL_ERROR;







|
|
|







741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
    }
#endif

    /*
     * Check for special options used in ../tests/main.test
     */

    objPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
    if (objPtr != NULL) {
	if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
		TCL_EXACT, &index) == TCL_OK)) {
	    switch (index) {
	    case 0:
		return TCL_ERROR;
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021




5022
5023
5024
5025
5026
5027
5028
static int
TestbytestringObjCmd(
    void *unused,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    int n;
    const char *p;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
	return TCL_ERROR;
    }
    p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n);




    Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







>
>
>
>







5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
static int
TestbytestringObjCmd(
    void *unused,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    int n = 0;
    const char *p;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
	return TCL_ERROR;
    }
    p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n);
    if ((p == NULL) || !Tcl_FetchIntRep(objv[1], properByteArrayType)) {
	Tcl_AppendResult(interp, "testbytestring expects bytes", NULL);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclTestObj.c.
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
	 * has ref count 1 (i.e. the object is unshared) we can modify that
	 * object directly. Otherwise, if RC>1 (i.e. the object is shared),
	 * we must create a new object to modify/set and decrement the old
	 * formerly-shared object's ref count. This is "copy on write".
	 */

	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else if (strcmp(subCmd, "get") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {







|

|







381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
	 * has ref count 1 (i.e. the object is unshared) we can modify that
	 * object directly. Otherwise, if RC>1 (i.e. the object is shared),
	 * we must create a new object to modify/set and decrement the old
	 * formerly-shared object's ref count. This is "copy on write".
	 */

	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else if (strcmp(subCmd, "get") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
	    return TCL_ERROR;
	}
	if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
				  &boolValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be set, get, or not", NULL);
	return TCL_ERROR;







|

|







406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
	    return TCL_ERROR;
	}
	if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
				  &boolValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (!Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be set, get, or not", NULL);
	return TCL_ERROR;
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
TestintobjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int intValue, varIndex, i;
    long longValue;
    const char *index, *subCmd, *string;
    Tcl_Obj **varPtr;

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







|







654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
TestintobjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int intValue, varIndex, i;
    Tcl_WideInt wideValue;
    const char *index, *subCmd, *string;
    Tcl_Obj **varPtr;

    if (objc < 3) {
	wrongNumArgs:
	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
	return TCL_ERROR;
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
	}
	intValue = i;
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetIntObj(varPtr[varIndex], intValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
	}
    } else if (strcmp(subCmd, "setlong") == 0) {
	if (objc != 4) {
	    goto wrongNumArgs;
	}
	string = Tcl_GetString(objv[3]);
	if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
	    return TCL_ERROR;
	}
	intValue = i;
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], intValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else if (strcmp(subCmd, "setmaxlong") == 0) {
	long maxLong = LONG_MAX;
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], maxLong);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxLong));
	}
    } else if (strcmp(subCmd, "ismaxlong") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		((longValue == LONG_MAX)? "1" : "0"), -1);
    } else if (strcmp(subCmd, "get") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}







|














|
|




|

|

|






|



|







709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
	}
	intValue = i;
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetIntObj(varPtr[varIndex], intValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
	}
    } else if (strcmp(subCmd, "setint") == 0) {
	if (objc != 4) {
	    goto wrongNumArgs;
	}
	string = Tcl_GetString(objv[3]);
	if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
	    return TCL_ERROR;
	}
	intValue = i;
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], intValue);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else if (strcmp(subCmd, "setmax") == 0) {
	Tcl_WideInt maxWide = WIDE_MAX;
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
	    Tcl_SetWideIntObj(varPtr[varIndex], maxWide);
	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide));
	}
    } else if (strcmp(subCmd, "ismax") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
	if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		((wideValue == WIDE_MAX)? "1" : "0"), -1);
    } else if (strcmp(subCmd, "get") == 0) {
	if (objc != 3) {
	    goto wrongNumArgs;
	}
	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
	    return TCL_ERROR;
	}
Changes to generic/tclTestProcBodyObj.c.
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

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

    version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
	    strcmp(version, packageVersion) == 0));
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c







|







336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

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

    version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
	    strcmp(version, packageVersion) == 0));
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
Changes to generic/tclTomMath.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/* 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.
 *
 * The library is free for all purposes without any express
 * guarantee it works.
 */
#ifndef BN_H_
#define BN_H_

#include "tclTomMathDecls.h"
#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern









|
<







1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
/* 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 "tclTomMathDecls.h"
#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern
124
125
126
127
128
129
130

131
132
133
134
135
136
137
#define MP_ZPOS       0   /* positive integer */
#define MP_NEG        1   /* negative */

#define MP_OKAY       0   /* ok result */
#define MP_MEM        -2  /* out of mem */
#define MP_VAL        -3  /* invalid input */
#define MP_RANGE      MP_VAL


#define MP_YES        1   /* yes response */
#define MP_NO         0   /* no response */

/* Primality generation flags */
#define LTM_PRIME_BBS      0x0001 /* BBS style prime */
#define LTM_PRIME_SAFE     0x0002 /* Safe prime (p-1)/2 == prime */







>







123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
#define MP_ZPOS       0   /* positive integer */
#define MP_NEG        1   /* negative */

#define MP_OKAY       0   /* ok result */
#define MP_MEM        -2  /* out of mem */
#define MP_VAL        -3  /* invalid input */
#define MP_RANGE      MP_VAL
#define MP_ITER       -4  /* Max. iterations reached */

#define MP_YES        1   /* yes response */
#define MP_NO         0   /* no response */

/* Primality generation flags */
#define LTM_PRIME_BBS      0x0001 /* BBS style prime */
#define LTM_PRIME_SAFE     0x0002 /* Safe prime (p-1)/2 == prime */
342
343
344
345
346
347
348
349
350
351
352




353
354
355

356
357

358
359
360
361
362
363
364
/* Counts the number of lsbs which are zero before the first zero bit */
/*
int mp_cnt_lsb(const mp_int *a);
*/

/* I Love Earth! */

/* makes a pseudo-random int of a given size */
/*
int mp_rand(mp_int *a, int digits);
*/





#ifdef MP_PRNG_ENABLE_LTM_RNG
/* as last resort we will fall back to libtomcrypt's rng_get_bytes()

 * in case you don't use libtomcrypt or use it w/o rng_get_bytes()
 * you have to implement it somewhere else, as it's required */

extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
extern void (*ltm_rng_callback)(void);
#endif

/* ---> binary operations <--- */
/* c = a XOR b  */
/*







|



>
>
>
>


|
>
|
<
>







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
/* Counts the number of lsbs which are zero before the first zero bit */
/*
int mp_cnt_lsb(const mp_int *a);
*/

/* I Love Earth! */

/* makes a pseudo-random mp_int of a given size */
/*
int mp_rand(mp_int *a, int digits);
*/
/* makes a pseudo-random small int of a given size */
/*
int mp_rand_digit(mp_digit *r);
*/

#ifdef MP_PRNG_ENABLE_LTM_RNG
/* A last resort to provide random data on systems without any of the other
 * implemented ways to gather entropy.
 * It is compatible with `rng_get_bytes()` from libtomcrypt so you could

 * provide that one and then set `ltm_rng = rng_get_bytes;` */
extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
extern void (*ltm_rng_callback)(void);
#endif

/* ---> binary operations <--- */
/* c = a XOR b  */
/*
687
688
689
690
691
692
693
694
695
696
697







698
699
700
701
702
703
704
/* This gives [for a given bit size] the number of trials required
 * such that Miller-Rabin gives a prob of failure lower than 2^-96
 */
/*
int mp_prime_rabin_miller_trials(int size);
*/

/* performs t rounds of Miller-Rabin on "a" using the first
 * t prime bases.  Also performs an initial sieve of trial
 * division.  Determines if "a" is prime with probability
 * of error no more than (1/4)**t.







 *
 * Sets result to 1 if probably prime, 0 otherwise
 */
/*
int mp_prime_is_prime(const mp_int *a, int t, int *result);
*/








|
|


>
>
>
>
>
>
>







692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
/* This gives [for a given bit size] the number of trials required
 * such that Miller-Rabin gives a prob of failure lower than 2^-96
 */
/*
int mp_prime_rabin_miller_trials(int size);
*/

/* performs t random rounds of Miller-Rabin on "a" additional to
 * bases 2 and 3.  Also performs an initial sieve of trial
 * division.  Determines if "a" is prime with probability
 * of error no more than (1/4)**t.
 * Both a strong Lucas-Selfridge to complete the BPSW test
 * and a separate Frobenius test are available at compile time.
 * With t<0 a deterministic test is run for primes up to
 * 318665857834031151167461. With t<13 (abs(t)-13) additional
 * tests with sequential small primes are run starting at 43.
 * Is Fips 186.4 compliant if called with t as computed by
 * mp_prime_rabin_miller_trials();
 *
 * Sets result to 1 if probably prime, 0 otherwise
 */
/*
int mp_prime_is_prime(const mp_int *a, int t, int *result);
*/

Changes to generic/tclTomMathDecls.h.
26
27
28
29
30
31
32
33
34
35
36
37
38





39
40
41
42
43
44
45

#define Tcl_TomMath_InitStubs(interp,version) \
    (TclTomMathInitializeStubs((interp),(version),\
                               TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))

/* Define custom memory allocation for libtommath */

/* MODULE_SCOPE void* XMALLOC( size_t ); */
#define XMALLOC(s) ((void*)ckalloc((size_t)(s)))
/* MODULE_SCOPE void* XREALLOC( void*, size_t ); */
#define XREALLOC(x,s) ((void*)ckrealloc((char*)(x),(size_t)(s)))
/* MODULE_SCOPE void  XFREE( void* ); */
#define XFREE(x) (ckfree((char*)(x)))






/* Rename the global symbols in libtommath to avoid linkage conflicts */

#define bn_reverse TclBN_reverse
#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
#define fast_s_mp_sqr TclBN_fast_s_mp_sqr
#define mp_add TclBN_mp_add







|
|
|
|
|
|
>
>
>
>
>







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

#define Tcl_TomMath_InitStubs(interp,version) \
    (TclTomMathInitializeStubs((interp),(version),\
                               TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))

/* Define custom memory allocation for libtommath */

/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
#define TclBNAlloc(s) ((void*)ckalloc((size_t)(s)))
/* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */
#define TclBNRealloc(x,s) ((void*)ckrealloc((char*)(x),(size_t)(s)))
/* MODULE_SCOPE void  TclBNFree( void* ); */
#define TclBNFree(x) (ckfree((char*)(x)))

#define XMALLOC(size)                   TclBNAlloc(size)
#define XFREE(mem, size)                TclBNFree(mem)
#define XREALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)


/* Rename the global symbols in libtommath to avoid linkage conflicts */

#define bn_reverse TclBN_reverse
#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
#define fast_s_mp_sqr TclBN_fast_s_mp_sqr
#define mp_add TclBN_mp_add
Changes to generic/tclTomMathInterface.c.
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
 */

void
TclInitBignumFromWideInt(
    mp_int *a,			/* Bignum to initialize */
    Tcl_WideInt v)		/* Initial value */
{
	if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) {
		Tcl_Panic("initialization failure in TclInitBignumFromWideInt");
	}
    if (v < 0) {
	mp_set_long_long(a, (Tcl_WideUInt)(-v));
	mp_neg(a, a);
    } else {
	mp_set_long_long(a, (Tcl_WideUInt)v);







|







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
 */

void
TclInitBignumFromWideInt(
    mp_int *a,			/* Bignum to initialize */
    Tcl_WideInt v)		/* Initial value */
{
	if (mp_init(a) != MP_OKAY) {
		Tcl_Panic("initialization failure in TclInitBignumFromWideInt");
	}
    if (v < 0) {
	mp_set_long_long(a, (Tcl_WideUInt)(-v));
	mp_neg(a, a);
    } else {
	mp_set_long_long(a, (Tcl_WideUInt)v);
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
 */

void
TclInitBignumFromWideUInt(
    mp_int *a,			/* Bignum to initialize */
    Tcl_WideUInt v)		/* Initial value */
{
	if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) {
	    Tcl_Panic("initialization failure in TclInitBignumFromWideUInt");
	}
	mp_set_long_long(a, v);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|












139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
 */

void
TclInitBignumFromWideUInt(
    mp_int *a,			/* Bignum to initialize */
    Tcl_WideUInt v)		/* Initial value */
{
	if (mp_init(a) != MP_OKAY) {
	    Tcl_Panic("initialization failure in TclInitBignumFromWideUInt");
	}
	mp_set_long_long(a, v);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclUtil.c.
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Interpreter containing variable. */
    const char *name1,		/* Name of variable. */
    const char *name2,		/* Second part of variable name. */
    int flags)			/* Information about what happened. */
{
    Tcl_Obj *value;
    int prec;
    int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int));

    /*
     * If the variable is unset, then recreate the trace.
     */

    if (flags & TCL_TRACE_UNSETS) {







|







3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Interpreter containing variable. */
    const char *name1,		/* Name of variable. */
    const char *name2,		/* Second part of variable name. */
    int flags)			/* Information about what happened. */
{
    Tcl_Obj *value;
    Tcl_WideInt prec;
    int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int));

    /*
     * If the variable is unset, then recreate the trace.
     */

    if (flags & TCL_TRACE_UNSETS) {
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
     */

    if (Tcl_IsSafe(interp)) {
	return (char *) "can't modify precision from a safe interpreter";
    }
    value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
    if (value == NULL
	    || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK
	    || prec < 0 || prec > TCL_MAX_PREC) {
	return (char *) "improper value for precision";
    }
    *precisionPtr = prec;
    return NULL;
}
#endif /* !TCL_NO_DEPRECATED)*/

/*
 *----------------------------------------------------------------------
 *







|



|







3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
     */

    if (Tcl_IsSafe(interp)) {
	return (char *) "can't modify precision from a safe interpreter";
    }
    value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
    if (value == NULL
	    || Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK
	    || prec < 0 || prec > TCL_MAX_PREC) {
	return (char *) "improper value for precision";
    }
    *precisionPtr = (int)prec;
    return NULL;
}
#endif /* !TCL_NO_DEPRECATED)*/

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclVar.c.
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737








738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
	/*
	 * An indexed local variable.
	 */

	Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);

	if (part1Ptr == cachedNamePtr) {
	    cachedNamePtr = NULL;
	} else {
	    /*
	     * [80304238ac] Trickiness here.  We will store and incr the
	     * refcount on cachedNamePtr.  Trouble is that it's possible
	     * (see test var-22.1) for cachedNamePtr to have an intrep
	     * that contains a stored and refcounted part1Ptr.  This
	     * would be a reference cycle which leads to a memory leak.
	     *
	     * The solution here is to wipe away all intrep(s) in
	     * cachedNamePtr and leave it as string only.  This is
	     * radical and destructive, so a better idea would be welcome.
	     */








	    TclFreeIntRep(cachedNamePtr);

	    /*
	     * Now go ahead and convert it the the "localVarName" type,
	     * since we suspect at least some use of the value as a
	     * varname and we want to resolve it quickly.
	     */
	    LocalSetIntRep(cachedNamePtr, index, NULL);
	}
	LocalSetIntRep(part1Ptr, index, cachedNamePtr);
    } else {
	/*
	 * At least mark part1Ptr as already parsed.
	 */

	ParsedSetIntRep(part1Ptr, NULL, NULL);
    }







|












>
>
>
>
>
>
>
>









<







718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754

755
756
757
758
759
760
761
	/*
	 * An indexed local variable.
	 */

	Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);

	if (part1Ptr == cachedNamePtr) {
	    LocalSetIntRep(part1Ptr, index, NULL);
	} else {
	    /*
	     * [80304238ac] Trickiness here.  We will store and incr the
	     * refcount on cachedNamePtr.  Trouble is that it's possible
	     * (see test var-22.1) for cachedNamePtr to have an intrep
	     * that contains a stored and refcounted part1Ptr.  This
	     * would be a reference cycle which leads to a memory leak.
	     *
	     * The solution here is to wipe away all intrep(s) in
	     * cachedNamePtr and leave it as string only.  This is
	     * radical and destructive, so a better idea would be welcome.
	     */

	    /*
	     * Firstly set cached local var reference (avoid free before set,
	     * see [45b9faf103f2])
	     */
	    LocalSetIntRep(part1Ptr, index, cachedNamePtr);

	    /* Then wipe it */
	    TclFreeIntRep(cachedNamePtr);

	    /*
	     * Now go ahead and convert it the the "localVarName" type,
	     * since we suspect at least some use of the value as a
	     * varname and we want to resolve it quickly.
	     */
	    LocalSetIntRep(cachedNamePtr, index, NULL);
	}

    } else {
	/*
	 * At least mark part1Ptr as already parsed.
	 */

	ParsedSetIntRep(part1Ptr, NULL, NULL);
    }
Changes to generic/tclZlib.c.
418
419
420
421
422
423
424

425
426
427
428
429
430
431
				 * parsed. */
    GzipHeader *headerPtr,	/* Where to store the parsed-out values. */
    int *extraSizePtr)		/* Variable to add the length of header
				 * strings (filename, comment) to. */
{
    Tcl_Obj *value;
    int len, result = TCL_ERROR;

    const char *valueStr;
    Tcl_Encoding latin1enc;
    static const char *const types[] = {
	"binary", "text"
    };

    /*







>







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
				 * parsed. */
    GzipHeader *headerPtr,	/* Where to store the parsed-out values. */
    int *extraSizePtr)		/* Variable to add the length of header
				 * strings (filename, comment) to. */
{
    Tcl_Obj *value;
    int len, result = TCL_ERROR;
    Tcl_WideInt wideValue = 0;
    const char *valueStr;
    Tcl_Encoding latin1enc;
    static const char *const types[] = {
	"binary", "text"
    };

    /*
481
482
483
484
485
486
487
488
489
490
491

492
493
494
495
496
497
498
    /*
     * Ignore the 'size' field, since that is controlled by the size of the
     * input data.
     */

    if (GetValue(interp, dictObj, "time", &value) != TCL_OK) {
	goto error;
    } else if (value != NULL && Tcl_GetLongFromObj(interp, value,
	    (long *) &headerPtr->header.time) != TCL_OK) {
	goto error;
    }


    if (GetValue(interp, dictObj, "type", &value) != TCL_OK) {
	goto error;
    } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types,
	    "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) {
	goto error;
    }







|
|


>







482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
    /*
     * Ignore the 'size' field, since that is controlled by the size of the
     * input data.
     */

    if (GetValue(interp, dictObj, "time", &value) != TCL_OK) {
	goto error;
    } else if (value != NULL && Tcl_GetWideIntFromObj(interp, value,
	    &wideValue) != TCL_OK) {
	goto error;
    }
    headerPtr->header.time = wideValue;

    if (GetValue(interp, dictObj, "type", &value) != TCL_OK) {
	goto error;
    } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types,
	    "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) {
	goto error;
    }
Changes to libtommath/bn_mp_clear.c.
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
   if (a->dp != NULL) {
      /* first zero the digits */
      for (i = 0; i < a->used; i++) {
         a->dp[i] = 0;
      }

      /* free ram */
      XFREE(a->dp);

      /* reset members to make debugging easier */
      a->dp    = NULL;
      a->alloc = a->used = 0;
      a->sign  = MP_ZPOS;
   }
}







|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
   if (a->dp != NULL) {
      /* first zero the digits */
      for (i = 0; i < a->used; i++) {
         a->dp[i] = 0;
      }

      /* free ram */
      XFREE(a->dp, sizeof (mp_digit) * (size_t)a->alloc);

      /* reset members to make debugging easier */
      a->dp    = NULL;
      a->alloc = a->used = 0;
      a->sign  = MP_ZPOS;
   }
}
Changes to libtommath/bn_mp_fwrite.c.
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
   char *buf;
   int err, len, x;

   if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
      return err;
   }

   buf = OPT_CAST(char) XMALLOC((size_t)len);
   if (buf == NULL) {
      return MP_MEM;
   }

   if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) {
      XFREE(buf);
      return err;
   }

   for (x = 0; x < len; x++) {
      if (fputc((int)buf[x], stream) == EOF) {
         XFREE(buf);
         return MP_VAL;
      }
   }

   XFREE(buf);
   return MP_OKAY;
}
#endif

#endif

/* ref:         $Format:%D$ */







|





|





|




|







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
   char *buf;
   int err, len, x;

   if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
      return err;
   }

   buf = (char *) XMALLOC((size_t)len);
   if (buf == NULL) {
      return MP_MEM;
   }

   if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) {
      XFREE(buf, len);
      return err;
   }

   for (x = 0; x < len; x++) {
      if (fputc((int)buf[x], stream) == EOF) {
         XFREE(buf, len);
         return MP_VAL;
      }
   }

   XFREE(buf, len);
   return MP_OKAY;
}
#endif

#endif

/* ref:         $Format:%D$ */
Changes to libtommath/bn_mp_get_double.c.
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
double mp_get_double(const mp_int *a)
{
   int i;
   double d = 0.0, fac = 1.0;
   for (i = 0; i < DIGIT_BIT; ++i) {
      fac *= 2.0;
   }
   for (i = USED(a); i --> 0;) {
      d = (d * fac) + (double)DIGIT(a, i);
   }
   return (mp_isneg(a) != MP_NO) ? -d : d;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */







|
|

|






15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
double mp_get_double(const mp_int *a)
{
   int i;
   double d = 0.0, fac = 1.0;
   for (i = 0; i < DIGIT_BIT; ++i) {
      fac *= 2.0;
   }
   for (i = a->used; i --> 0;) {
      d = (d * fac) + (double)a->dp[i];
   }
   return (a->sign == MP_NEG) ? -d : d;
}
#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
Changes to libtommath/bn_mp_get_long.c.
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

/* get the lower unsigned long of an mp_int, platform dependent */
unsigned long mp_get_long(const mp_int *a)
{
   int i;
   unsigned long res;

   if (a->used == 0) {
      return 0;
   }

   /* get number of digits of the lsb we have to read */
   i = MIN(a->used, ((((int)sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;

   /* get most significant digit of result */
   res = DIGIT(a, i);

#if (ULONG_MAX != 0xffffffffuL) || (DIGIT_BIT < 32)
   while (--i >= 0) {
      res = (res << DIGIT_BIT) | DIGIT(a, i);
   }
#endif
   return res;
}
#endif

/* ref:         $Format:%D$ */







|




|


|

|

|







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

/* get the lower unsigned long of an mp_int, platform dependent */
unsigned long mp_get_long(const mp_int *a)
{
   int i;
   unsigned long res;

   if (IS_ZERO(a)) {
      return 0;
   }

   /* get number of digits of the lsb we have to read */
   i = MIN(a->used, (((CHAR_BIT * (int)sizeof(unsigned long)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;

   /* get most significant digit of result */
   res = (unsigned long)a->dp[i];

#if (ULONG_MAX != 0xFFFFFFFFUL) || (DIGIT_BIT < 32)
   while (--i >= 0) {
      res = (res << DIGIT_BIT) | (unsigned long)a->dp[i];
   }
#endif
   return res;
}
#endif

/* ref:         $Format:%D$ */
Changes to libtommath/bn_mp_get_long_long.c.
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

/* get the lower unsigned long long of an mp_int, platform dependent */
Tcl_WideUInt mp_get_long_long(const mp_int *a)
{
   int i;
   Tcl_WideUInt res;

   if (a->used == 0) {
      return 0;
   }

   /* get number of digits of the lsb we have to read */
   i = MIN(a->used, ((((int)sizeof(Tcl_WideUInt) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;

   /* get most significant digit of result */
   res = DIGIT(a, i);

#if DIGIT_BIT < 64
   while (--i >= 0) {
      res = (res << DIGIT_BIT) | DIGIT(a, i);
   }
#endif
   return res;
}
#endif

/* ref:         $Format:%D$ */







|




|


|



|







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

/* get the lower unsigned long long of an mp_int, platform dependent */
Tcl_WideUInt mp_get_long_long(const mp_int *a)
{
   int i;
   Tcl_WideUInt res;

   if (IS_ZERO(a)) {
      return 0;
   }

   /* get number of digits of the lsb we have to read */
   i = MIN(a->used, (((CHAR_BIT * (int)sizeof(Tcl_WideUInt)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;

   /* get most significant digit of result */
   res = (unsigned long long)a->dp[i];

#if DIGIT_BIT < 64
   while (--i >= 0) {
      res = (res << DIGIT_BIT) | (unsigned long long)a->dp[i];
   }
#endif
   return res;
}
#endif

/* ref:         $Format:%D$ */
Changes to libtommath/bn_mp_grow.c.
25
26
27
28
29
30
31
32


33
34
35
36
37
38
39

      /* reallocate the array a->dp
       *
       * We store the return in a temporary variable
       * in case the operation failed we don't want
       * to overwrite the dp member of a.
       */
      tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)size);


      if (tmp == NULL) {
         /* reallocation failed but "a" is still valid [can be freed] */
         return MP_MEM;
      }

      /* reallocation succeeded so set a->dp */
      a->dp = tmp;







|
>
>







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

      /* reallocate the array a->dp
       *
       * We store the return in a temporary variable
       * in case the operation failed we don't want
       * to overwrite the dp member of a.
       */
      tmp = (mp_digit *) XREALLOC(a->dp,
                                  (size_t)a->alloc * sizeof (mp_digit),
                                  (size_t)size * sizeof(mp_digit));
      if (tmp == NULL) {
         /* reallocation failed but "a" is still valid [can be freed] */
         return MP_MEM;
      }

      /* reallocation succeeded so set a->dp */
      a->dp = tmp;
Changes to libtommath/bn_mp_init.c.
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

/* init a new mp_int */
int mp_init(mp_int *a)
{
   int i;

   /* allocate memory required and clear it */
   a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)MP_PREC);
   if (a->dp == NULL) {
      return MP_MEM;
   }

   /* set the digits to zero */
   for (i = 0; i < MP_PREC; i++) {
      a->dp[i] = 0;







|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

/* init a new mp_int */
int mp_init(mp_int *a)
{
   int i;

   /* allocate memory required and clear it */
   a->dp = (mp_digit *) XMALLOC(MP_PREC * sizeof(mp_digit));
   if (a->dp == NULL) {
      return MP_MEM;
   }

   /* set the digits to zero */
   for (i = 0; i < MP_PREC; i++) {
      a->dp[i] = 0;
Changes to libtommath/bn_mp_init_size.c.
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
{
   int x;

   /* pad size so there are always extra digits */
   size += (MP_PREC * 2) - (size % MP_PREC);

   /* alloc mem */
   a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)size);
   if (a->dp == NULL) {
      return MP_MEM;
   }

   /* set the members */
   a->used  = 0;
   a->alloc = size;







|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
{
   int x;

   /* pad size so there are always extra digits */
   size += (MP_PREC * 2) - (size % MP_PREC);

   /* alloc mem */
   a->dp = (mp_digit *) XMALLOC((size_t)size * sizeof(mp_digit));
   if (a->dp == NULL) {
      return MP_MEM;
   }

   /* set the members */
   a->used  = 0;
   a->alloc = size;
Changes to libtommath/bn_mp_is_square.c.
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
   /* Default to Non-square :) */
   *ret = MP_NO;

   if (arg->sign == MP_NEG) {
      return MP_VAL;
   }

   /* digits used?  (TSD) */
   if (arg->used == 0) {
      return MP_OKAY;
   }

   /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */
   if (rem_128[127u & DIGIT(arg, 0)] == (char)1) {
      return MP_OKAY;
   }

   /* Next check mod 105 (3*5*7) */
   if ((res = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) {
      return res;
   }







<
|




|







45
46
47
48
49
50
51

52
53
54
55
56
57
58
59
60
61
62
63
64
   /* Default to Non-square :) */
   *ret = MP_NO;

   if (arg->sign == MP_NEG) {
      return MP_VAL;
   }


   if (IS_ZERO(arg)) {
      return MP_OKAY;
   }

   /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */
   if (rem_128[127u & arg->dp[0]] == (char)1) {
      return MP_OKAY;
   }

   /* Next check mod 105 (3*5*7) */
   if ((res = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) {
      return res;
   }
Changes to libtommath/bn_mp_prime_random_ex.c.
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
      flags |= LTM_PRIME_BBS;
   }

   /* calc the byte size */
   bsize = (size>>3) + ((size&7)?1:0);

   /* we need a buffer of bsize bytes */
   tmp = OPT_CAST(unsigned char) XMALLOC((size_t)bsize);
   if (tmp == NULL) {
      return MP_MEM;
   }

   /* calc the maskAND value for the MSbyte*/
   maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7)));

   /* calc the maskOR_msb */
   maskOR_msb        = 0;
   maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0;
   if ((flags & LTM_PRIME_2MSB_ON) != 0) {
      maskOR_msb       |= 0x80 >> ((9 - size) & 7);
   }

   /* get the maskOR_lsb */
   maskOR_lsb         = 1;
   if ((flags & LTM_PRIME_BBS) != 0) {
      maskOR_lsb     |= 3;
   }

   do {
      /* read the bytes */
      if (cb(tmp, bsize, dat) != bsize) {
         err = MP_VAL;
         goto error;
      }

      /* work over the MSbyte */
      tmp[0]    &= maskAND;
      tmp[0]    |= 1 << ((size - 1) & 7);

      /* mix in the maskORs */
      tmp[maskOR_msb_offset]   |= maskOR_msb;
      tmp[bsize-1]             |= maskOR_lsb;

      /* read it in */
      if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) {







|





|





|

















|







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
      flags |= LTM_PRIME_BBS;
   }

   /* calc the byte size */
   bsize = (size>>3) + ((size&7)?1:0);

   /* we need a buffer of bsize bytes */
   tmp = (unsigned char *) XMALLOC((size_t)bsize);
   if (tmp == NULL) {
      return MP_MEM;
   }

   /* calc the maskAND value for the MSbyte*/
   maskAND = ((size&7) == 0) ? 0xFF : (unsigned char)(0xFF >> (8 - (size & 7)));

   /* calc the maskOR_msb */
   maskOR_msb        = 0;
   maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0;
   if ((flags & LTM_PRIME_2MSB_ON) != 0) {
      maskOR_msb       |= (unsigned char)(0x80 >> ((9 - size) & 7));
   }

   /* get the maskOR_lsb */
   maskOR_lsb         = 1;
   if ((flags & LTM_PRIME_BBS) != 0) {
      maskOR_lsb     |= 3;
   }

   do {
      /* read the bytes */
      if (cb(tmp, bsize, dat) != bsize) {
         err = MP_VAL;
         goto error;
      }

      /* work over the MSbyte */
      tmp[0]    &= maskAND;
      tmp[0]    |= (unsigned char)(1 << ((size - 1) & 7));

      /* mix in the maskORs */
      tmp[maskOR_msb_offset]   |= maskOR_msb;
      tmp[bsize-1]             |= maskOR_lsb;

      /* read it in */
      if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) {
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
      if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
         goto error;
      }
   }

   err = MP_OKAY;
error:
   XFREE(tmp);
   return err;
}


#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */







|









119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
      if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
         goto error;
      }
   }

   err = MP_OKAY;
error:
   XFREE(tmp, bsize);
   return err;
}


#endif

/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
Changes to libtommath/bn_mp_read_radix.c.
8
9
10
11
12
13
14


15
16
17
18
19
20
21
 * 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
 */



/* read a string [ASCII] in a given radix */
int mp_read_radix(mp_int *a, const char *str, int radix)
{
   int     y, res, neg;
   unsigned pos;
   char    ch;








>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * 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
 */

#define MP_TOUPPER(c) ((((c) >= 'a') && ((c) <= 'z')) ? (((c) + 'A') - 'a') : (c))

/* read a string [ASCII] in a given radix */
int mp_read_radix(mp_int *a, const char *str, int radix)
{
   int     y, res, neg;
   unsigned pos;
   char    ch;

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

   /* process each digit of the string */
   while (*str != '\0') {
      /* if the radix <= 36 the conversion is case insensitive
       * this allows numbers like 1AB and 1ab to represent the same  value
       * [e.g. in hex]
       */
      ch = (radix <= 36) ? (char)toupper((int)*str) : *str;
      pos = (unsigned)(ch - '(');
      if (mp_s_rmap_reverse_sz < pos) {
         break;
      }
      y = (int)mp_s_rmap_reverse[pos];

      /* if the char was found in the map







|







44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

   /* process each digit of the string */
   while (*str != '\0') {
      /* if the radix <= 36 the conversion is case insensitive
       * this allows numbers like 1AB and 1ab to represent the same  value
       * [e.g. in hex]
       */
      ch = (radix <= 36) ? (char)MP_TOUPPER((int)*str) : *str;
      pos = (unsigned)(ch - '(');
      if (mp_s_rmap_reverse_sz < pos) {
         break;
      }
      y = (int)mp_s_rmap_reverse[pos];

      /* if the char was found in the map
Changes to libtommath/bn_mp_set_double.c.
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *
 * SPDX-License-Identifier: Unlicense
 */

#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
int mp_set_double(mp_int *a, double b)
{
   uint64_t frac;
   int exp, res;
   union {
      double   dbl;
      uint64_t bits;
   } cast;
   cast.dbl = b;

   exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFU);
   frac = (cast.bits & ((1ULL << 52) - 1ULL)) | (1ULL << 52);

   if (exp == 0x7FF) { /* +-inf, NaN */







|



|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *
 * SPDX-License-Identifier: Unlicense
 */

#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
int mp_set_double(mp_int *a, double b)
{
   unsigned long long frac;
   int exp, res;
   union {
      double   dbl;
      unsigned long long bits;
   } cast;
   cast.dbl = b;

   exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFU);
   frac = (cast.bits & ((1ULL << 52) - 1ULL)) | (1ULL << 52);

   if (exp == 0x7FF) { /* +-inf, NaN */
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
   }

   res = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a);
   if (res != MP_OKAY) {
      return res;
   }

   if (((cast.bits >> 63) != 0ULL) && (mp_iszero(a) == MP_NO)) {
      SIGN(a) = MP_NEG;
   }

   return MP_OKAY;
}
#else
/* pragma message() not supported by several compilers (in mostly older but still used versions) */
#  ifdef _MSC_VER







|
|







37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
   }

   res = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a);
   if (res != MP_OKAY) {
      return res;
   }

   if (((cast.bits >> 63) != 0ULL) && !IS_ZERO(a)) {
      a->sign = MP_NEG;
   }

   return MP_OKAY;
}
#else
/* pragma message() not supported by several compilers (in mostly older but still used versions) */
#  ifdef _MSC_VER
Changes to libtommath/bn_mp_shrink.c.
19
20
21
22
23
24
25
26


27
28
29
30
31
32
33
   int used = 1;

   if (a->used > 0) {
      used = a->used;
   }

   if (a->alloc != used) {
      if ((tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)used)) == NULL) {


         return MP_MEM;
      }
      a->dp    = tmp;
      a->alloc = used;
   }
   return MP_OKAY;
}







|
>
>







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
   int used = 1;

   if (a->used > 0) {
      used = a->used;
   }

   if (a->alloc != used) {
      if ((tmp = (mp_digit *) XREALLOC(a->dp,
                                       (size_t)a->alloc * sizeof (mp_digit),
                                       (size_t)used * sizeof(mp_digit))) == NULL) {
         return MP_MEM;
      }
      a->dp    = tmp;
      a->alloc = used;
   }
   return MP_OKAY;
}
Changes to libtommath/bn_mp_sqrt.c.
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
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

#ifndef NO_FLOATING_POINT
#include <math.h>



#endif

/* this function is less generic than mp_n_root, simpler and faster */
int mp_sqrt(const mp_int *arg, mp_int *ret)
{
   int res;
   mp_int t1, t2;
   int i, j, k;
#ifndef NO_FLOATING_POINT

   volatile double d;
   mp_digit dig;
#endif

   /* must be positive */
   if (arg->sign == MP_NEG) {
      return MP_VAL;
   }

   /* easy out */
   if (mp_iszero(arg) == MP_YES) {
      mp_zero(ret);
      return MP_OKAY;
   }



   i = (arg->used / 2) - 1;
   j = 2 * i;
   if ((res = mp_init_size(&t1, i+2)) != MP_OKAY) {
      return res;
   }

   if ((res = mp_init(&t2)) != MP_OKAY) {
      goto E2;
   }

   for (k = 0; k < i; ++k) {
      t1.dp[k] = (mp_digit) 0;
   }

#ifndef NO_FLOATING_POINT

   /* Estimate the square root using the hardware floating point unit. */

   d = 0.0;
   for (k = arg->used-1; k >= j; --k) {
      d = ldexp(d, DIGIT_BIT) + (double)(arg->dp[k]);
   }








>
>
>







<

>














>
>















<
<







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
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */

#ifndef NO_FLOATING_POINT
#include <math.h>
#if (DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024)
#define NO_FLOATING_POINT
#endif
#endif

/* this function is less generic than mp_n_root, simpler and faster */
int mp_sqrt(const mp_int *arg, mp_int *ret)
{
   int res;
   mp_int t1, t2;

#ifndef NO_FLOATING_POINT
   int i, j, k;
   volatile double d;
   mp_digit dig;
#endif

   /* must be positive */
   if (arg->sign == MP_NEG) {
      return MP_VAL;
   }

   /* easy out */
   if (mp_iszero(arg) == MP_YES) {
      mp_zero(ret);
      return MP_OKAY;
   }

#ifndef NO_FLOATING_POINT

   i = (arg->used / 2) - 1;
   j = 2 * i;
   if ((res = mp_init_size(&t1, i+2)) != MP_OKAY) {
      return res;
   }

   if ((res = mp_init(&t2)) != MP_OKAY) {
      goto E2;
   }

   for (k = 0; k < i; ++k) {
      t1.dp[k] = (mp_digit) 0;
   }



   /* Estimate the square root using the hardware floating point unit. */

   d = 0.0;
   for (k = arg->used-1; k >= j; --k) {
      d = ldexp(d, DIGIT_BIT) + (double)(arg->dp[k]);
   }

92
93
94
95
96
97
98
99

100
101



102

103
104
105
106
107
108
109
110
   } else {
      t1.used = i+1;
      t1.dp[i] = ((mp_digit) d) - 1;
   }

#else

   /* Estimate the square root as having 1 in the most significant place. */


   t1.used = i + 2;



   t1.dp[i+1] = (mp_digit) 1;

   t1.dp[i] = (mp_digit) 0;

#endif

   /* t1 > 0  */
   if ((res = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) {
      goto E1;
   }







|
>
|
|
>
>
>
|
>
|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
   } else {
      t1.used = i+1;
      t1.dp[i] = ((mp_digit) d) - 1;
   }

#else

   if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) {
      return res;
   }

   if ((res = mp_init(&t2)) != MP_OKAY) {
      goto E2;
   }

   /* First approx. (not very bad for large arg) */
   mp_rshd(&t1, t1.used/2);

#endif

   /* t1 > 0  */
   if ((res = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) {
      goto E1;
   }
Changes to libtommath/tommath_private.h.
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
 *
 * SPDX-License-Identifier: Unlicense
 */
#ifndef TOMMATH_PRIV_H_
#define TOMMATH_PRIV_H_

#include <tommath.h>
#include <ctype.h>

#ifndef MIN
#define MIN(x, y) (((x) < (y)) ? (x) : (y))
#endif

#ifndef MAX
#define MAX(x, y) (((x) > (y)) ? (x) : (y))
#endif

#ifdef __cplusplus
extern "C" {

/* C++ compilers don't like assigning void * to mp_digit * */
#define OPT_CAST(x) (x *)

#else

/* C on the other hand doesn't care */
#define OPT_CAST(x)

#endif

/* define heap macros */
#ifndef XMALLOC
/* default to libc stuff */
#   define XMALLOC   malloc
#   define XFREE     free
#   define XREALLOC  realloc
#elif 0
/* prototypes for our heap functions */
extern void *XMALLOC(size_t n);
extern void *XREALLOC(void *p, size_t n);
extern void XFREE(void *p);
#endif

/* you'll have to tune these... */
#define KARATSUBA_MUL_CUTOFF 80      /* Min. number of digits before Karatsuba multiplication is used. */
#define KARATSUBA_SQR_CUTOFF 120     /* Min. number of digits before Karatsuba squaring is used. */
#define TOOM_MUL_CUTOFF      350     /* no optimal values of these are known yet so set em high */
#define TOOM_SQR_CUTOFF      400

/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY               (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))






/* lowlevel functions, do not call! */
int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c);
int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c);
#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
int fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);







<











<
<
<
<
<
<
<
<
<





|
|
|


|
|
|











>
>
>
>
>







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
 *
 * SPDX-License-Identifier: Unlicense
 */
#ifndef TOMMATH_PRIV_H_
#define TOMMATH_PRIV_H_

#include <tommath.h>


#ifndef MIN
#define MIN(x, y) (((x) < (y)) ? (x) : (y))
#endif

#ifndef MAX
#define MAX(x, y) (((x) > (y)) ? (x) : (y))
#endif

#ifdef __cplusplus
extern "C" {









#endif

/* define heap macros */
#ifndef XMALLOC
/* default to libc stuff */
#   define XMALLOC(size)                   malloc(size)
#   define XFREE(mem, size)                free(mem)
#   define XREALLOC(mem, oldsize, newsize) realloc(mem, newsize)
#elif 0
/* prototypes for our heap functions */
extern void *XMALLOC(size_t size);
extern void *XREALLOC(void *mem, size_t oldsize, size_t newsize);
extern void XFREE(void *mem, size_t size);
#endif

/* you'll have to tune these... */
#define KARATSUBA_MUL_CUTOFF 80      /* Min. number of digits before Karatsuba multiplication is used. */
#define KARATSUBA_SQR_CUTOFF 120     /* Min. number of digits before Karatsuba squaring is used. */
#define TOOM_MUL_CUTOFF      350     /* no optimal values of these are known yet so set em high */
#define TOOM_SQR_CUTOFF      400

/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY               (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))

/* ---> Basic Manipulations <--- */
#define IS_ZERO(a) ((a)->used == 0)
#define IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u))
#define IS_ODD(a)  (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u))

/* lowlevel functions, do not call! */
int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c);
int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c);
#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
int fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
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

extern const char *const mp_s_rmap;
extern const unsigned char mp_s_rmap_reverse[];
extern const size_t mp_s_rmap_reverse_sz;

/* Fancy macro to set an MPI from another type.
 * There are several things assumed:
 *  x is the counter and unsigned
 *  a is the pointer to the MPI
 *  b is the original value that should be set in the MPI.
 */
#define MP_SET_XLONG(func_name, type)                    \
int func_name (mp_int * a, type b)                       \
{                                                        \
  unsigned int  x;                                       \
  int           res;                                     \
                                                         \
  mp_zero (a);                                           \
                                                         \
  /* set four bits at a time */                          \
  for (x = 0; x < (sizeof(type) * 2u); x++) {            \
    /* shift the number up four bits */                  \
    if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) {        \
      return res;                                        \
    }                                                    \
                                                         \
    /* OR in the top four bits of the source */          \
    a->dp[0] |= (mp_digit)(b >> ((sizeof(type) * 8u) - 4u)) & 15uL;\
                                                         \
    /* shift the source up to the next four bits */      \


    b <<= 4;                                             \
                                                         \
    /* ensure that digits are not clamped off */         \
    a->used += 1;                                        \
  }                                                      \
  mp_clamp (a);                                          \
  return MP_OKAY;                                        \
}

#ifdef __cplusplus
}
#endif

#endif


/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */







|






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












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

extern const char *const mp_s_rmap;
extern const unsigned char mp_s_rmap_reverse[];
extern const size_t mp_s_rmap_reverse_sz;

/* Fancy macro to set an MPI from another type.
 * There are several things assumed:
 *  x is the counter
 *  a is the pointer to the MPI
 *  b is the original value that should be set in the MPI.
 */
#define MP_SET_XLONG(func_name, type)                    \
int func_name (mp_int * a, type b)                       \
{                                                        \
   int x = 0;                                            \
   int new_size = (((CHAR_BIT * sizeof(type)) + DIGIT_BIT) - 1) / DIGIT_BIT; \

   int res = mp_grow(a, new_size);                       \




   if (res == MP_OKAY) {                                 \
     mp_zero(a);                                         \
     while (b != 0u) {                                   \


        a->dp[x++] = ((mp_digit)b & MP_MASK);            \


        if ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT) { break; } \
        b >>= ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT ? 0 : DIGIT_BIT); \
     }                                                   \


     a->used = x;                                        \
   }                                                     \
   return res;                                           \

}

#ifdef __cplusplus
}
#endif

#endif


/* ref:         $Format:%D$ */
/* git commit:  $Format:%H$ */
/* commit time: $Format:%ai$ */
Changes to macosx/tclMacOSXFCmd.c.
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
		OSSwapBigToHostInt32(finder->creator));
	break;
    case MACOSX_TYPE_ATTRIBUTE:
	*attributePtrPtr = NewOSTypeObj(
		OSSwapBigToHostInt32(finder->type));
	break;
    case MACOSX_HIDDEN_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewBooleanObj(
		(finder->fdFlags & kFinfoIsInvisible) != 0);
	break;
    case MACOSX_RSRCLENGTH_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize);
	break;
    }
    return TCL_OK;







|







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
		OSSwapBigToHostInt32(finder->creator));
	break;
    case MACOSX_TYPE_ATTRIBUTE:
	*attributePtrPtr = NewOSTypeObj(
		OSSwapBigToHostInt32(finder->type));
	break;
    case MACOSX_HIDDEN_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewWideIntObj(
		(finder->fdFlags & kFinfoIsInvisible) != 0);
	break;
    case MACOSX_RSRCLENGTH_ATTRIBUTE:
	*attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize);
	break;
    }
    return TCL_OK;
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
    OSType *osTypePtr)		/* Place to store resulting OSType. */
{
    int result = TCL_OK;

    if (!TclHasIntRep(objPtr, &tclOSTypeType)) {
	result = SetOSTypeFromAny(interp, objPtr);
    }
    *osTypePtr = (OSType) objPtr->internalRep.longValue;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NewOSTypeObj --







|







576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
    OSType *osTypePtr)		/* Place to store resulting OSType. */
{
    int result = TCL_OK;

    if (!TclHasIntRep(objPtr, &tclOSTypeType)) {
	result = SetOSTypeFromAny(interp, objPtr);
    }
    *osTypePtr = (OSType) objPtr->internalRep.wideValue;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NewOSTypeObj --
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
    const OSType osType)	/* OSType used to initialize the new
				 * object. */
{
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    TclInvalidateStringRep(objPtr);
    objPtr->internalRep.longValue = (long) osType;
    objPtr->typePtr = &tclOSTypeType;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *







|







605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
    const OSType osType)	/* OSType used to initialize the new
				 * object. */
{
    Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    TclInvalidateStringRep(objPtr);
    objPtr->internalRep.wideValue = (Tcl_WideInt) osType;
    objPtr->typePtr = &tclOSTypeType;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670

	memcpy(bytes, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
	osType = (OSType) bytes[0] << 24 |
		 (OSType) bytes[1] << 16 |
		 (OSType) bytes[2] <<  8 |
		 (OSType) bytes[3];
	TclFreeIntRep(objPtr);
	objPtr->internalRep.longValue = (long) osType;
	objPtr->typePtr = &tclOSTypeType;
    }
    Tcl_DStringFree(&ds);
    Tcl_FreeEncoding(encoding);
    return result;
}








|







656
657
658
659
660
661
662
663
664
665
666
667
668
669
670

	memcpy(bytes, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
	osType = (OSType) bytes[0] << 24 |
		 (OSType) bytes[1] << 16 |
		 (OSType) bytes[2] <<  8 |
		 (OSType) bytes[3];
	TclFreeIntRep(objPtr);
	objPtr->internalRep.wideValue = (Tcl_WideInt) osType;
	objPtr->typePtr = &tclOSTypeType;
    }
    Tcl_DStringFree(&ds);
    Tcl_FreeEncoding(encoding);
    return result;
}

690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
static void
UpdateStringOfOSType(
    register Tcl_Obj *objPtr)	/* OSType object whose string rep to
				 * update. */
{
    const int size = TCL_UTF_MAX * 4;
    char *dst = Tcl_InitStringRep(objPtr, NULL, size);
    OSType osType = (OSType) objPtr->internalRep.longValue;
    int written = 0;
    Tcl_Encoding encoding;
    char src[5];

    TclOOM(dst, size);

    src[0] = (char) (osType >> 24);







|







690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
static void
UpdateStringOfOSType(
    register Tcl_Obj *objPtr)	/* OSType object whose string rep to
				 * update. */
{
    const int size = TCL_UTF_MAX * 4;
    char *dst = Tcl_InitStringRep(objPtr, NULL, size);
    OSType osType = (OSType) objPtr->internalRep.wideValue;
    int written = 0;
    Tcl_Encoding encoding;
    char src[5];

    TclOOM(dst, size);

    src[0] = (char) (osType >> 24);
Changes to tests/cmdMZ.test.
311
312
313
314
315
316
317








318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
    # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"

# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test









test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
    time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
    time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
    time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
    expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within







>
>
>
>
>
>
>
>

















|







311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"

# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test

# todo: rewrite this if monotonic clock is provided resp. command "after" 
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
    set usec [expr {$msec * 1000}]
    set stime [clock microseconds]
    while {abs([clock microseconds] - $stime) < $usec} {after 0}
}

test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
    time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
    time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
    time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
    expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
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
407

















408
409
410
411
412
413
414
415
416
417
418
419
} {1 {expected integer but got "b"}}
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.5 {Tcl_TimeRateObjCmd: result format and one iteration} {



    regexp {^\d+.\d+ \ws/# 1 # \d+ #/sec \d+.\d+ nett-ms$} [timerate {} 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
    set m1 [timerate {after 0} 20]
    set m2 [timerate {after 1} 20]
    list \
	[expr {[lindex $m1 0] < [lindex $m2 0]}] \
	[expr {[lindex $m1 0] < 100}] \
	[expr {[lindex $m2 0] >= 500}] \
	[expr {[lindex $m1 2] > 1000}] \
	[expr {[lindex $m2 2] <= 50}] \
	[expr {[lindex $m1 4] > 10000}] \
	[expr {[lindex $m2 4] < 10000}] \
	[expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 50}] \
	[expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 50}]
} [lrepeat 9 1]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
    list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
"timerate {error foo} 1"}}
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 {after 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 {after 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}


















# The tests for Tcl_WhileObjCmd are in while.test

# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return

# Local Variables:
# mode: tcl
# End:







|
>
>
>
|


|
|



|

|
|
|
|
|


















|



|






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












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
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
440
441
442
443
444
445
446
447
} {1 {expected integer but got "b"}}
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}] \
	[expr {[lindex $m2 0] > 100}] \
	[expr {[lindex $m1 2] > 1000}] \
	[expr {[lindex $m2 2] < 1000}] \
	[expr {[lindex $m1 4] > 50000}] \
	[expr {[lindex $m2 4] < 50000}] \
	[expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \
	[expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}]
} [lrepeat 9 1]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
    list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
"timerate {error foo} 1"}}
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

} -body {
    ::apply {{} {
	set cmd try
	$cmd {
	    lindex 5
	} on ok res {}
	set res
    }}
} -result 5


# The tests for Tcl_WhileObjCmd are in while.test

# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/obj.test.
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
test obj-26.1 {UpdateStringOfInt} testobj {
    set result ""
    lappend result [testintobj set 1 512]
    lappend result [testintobj mult10 1]
    lappend result [testintobj get 1]       ;# must update string rep
} {512 5120 5120}

test obj-27.1 {Tcl_NewLongObj} testobj {
    set result ""
    lappend result [testobj freeallvars]
    testintobj setmaxlong 1
    lappend result [testintobj ismaxlong 1]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 1 int 1}

test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testobj newobj 1]
    lappend result [testintobj setlong 1 77]  ;# makes existing obj long int
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} {} 77 int 2}
test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testdoubleobj set 1 12.34]
    lappend result [testintobj setlong 1 77]  ;# makes existing obj long int
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 12.34 77 int 2}

test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} testobj {
    set result ""
    lappend result [testintobj setlong 1 22]
    lappend result [testintobj mult10 1]   ;# gets existing long int rep
} {22 220}
test obj-29.2 {Tcl_GetLongFromObj, convert to long} testobj {
    set result ""
    lappend result [testintobj setlong 1 477]
    lappend result [testintobj div10 1]    ;# must convert to bool
    lappend result [testobj type 1]
} {477 47 int}
test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} testobj {
    set result ""
    lappend result [teststringobj set 1 abc]
    lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
    lappend result $msg
} {abc 1 {expected integer but got "abc"}}
test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} testobj {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
    lappend result $msg
} {{} 1 {expected integer but got ""}}

test obj-30.1 {Ref counting and object deletion, simple types} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testintobj set 1 1024]







|


|
|








|







|




|

|
|

|

|



|


|


|


|







472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
test obj-26.1 {UpdateStringOfInt} testobj {
    set result ""
    lappend result [testintobj set 1 512]
    lappend result [testintobj mult10 1]
    lappend result [testintobj get 1]       ;# must update string rep
} {512 5120 5120}

test obj-27.1 {Tcl_NewWideObj} testobj {
    set result ""
    lappend result [testobj freeallvars]
    testintobj setmax 1
    lappend result [testintobj ismax 1]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 1 int 1}

test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testobj newobj 1]
    lappend result [testintobj setint 1 77]  ;# makes existing obj int
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} {} 77 int 2}
test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testdoubleobj set 1 12.34]
    lappend result [testintobj setint 1 77]  ;# makes existing obj int
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]
} {{} 12.34 77 int 2}

test obj-29.1 {Tcl_GetWideIntFromObj, existing int object} testobj {
    set result ""
    lappend result [testintobj setint 1 22]
    lappend result [testintobj mult10 1]   ;# gets existingint rep
} {22 220}
test obj-29.2 {Tcl_GetWideIntFromObj, convert to int} testobj {
    set result ""
    lappend result [testintobj setint 1 477]
    lappend result [testintobj div10 1]    ;# must convert to bool
    lappend result [testobj type 1]
} {477 47 int}
test obj-29.3 {Tcl_GetWideIntFromObj, error converting to int} testobj {
    set result ""
    lappend result [teststringobj set 1 abc]
    lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int
    lappend result $msg
} {abc 1 {expected integer but got "abc"}}
test obj-29.4 {Tcl_GetWideIntFromObj, error converting from "empty string"} testobj {
    set result ""
    lappend result [testobj newobj 1]
    lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int
    lappend result $msg
} {{} 1 {expected integer but got ""}}

test obj-30.1 {Ref counting and object deletion, simple types} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testintobj set 1 1024]
Changes to tests/oo.test.
1544
1545
1546
1547
1548
1549
1550
























1551
1552
1553
1554
1555
1556
1557
    lappend result [C a] [C b] [C c] -
    oo::define B deletemethod b
    lappend result [C a] [C b] [C c] -
    oo::define B renamemethod a b
    lappend result [C a] [C b] [C c] -
    oo::define B deletemethod b c
    lappend result [C a] [C b] [C c]
























} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}

test oo-11.1 {OO: cleanup} {
    oo::object create foo
    set result [list [catch {oo::object create foo} msg] $msg]
    lappend result [foo destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}







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







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
    lappend result [C a] [C b] [C c] -
    oo::define B deletemethod b
    lappend result [C a] [C b] [C c] -
    oo::define B renamemethod a b
    lappend result [C a] [C b] [C c] -
    oo::define B deletemethod b c
    lappend result [C a] [C b] [C c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
test oo-10.4 {OO: invoke and modify} -setup {
    oo::class create A {
	method a {} {return A.a}
	method b {} {return A.b}
	method c {} {return A.c}
    }
    A create B
    oo::objdefine B {
	method a {} {return [next],B.a}
	method b {} {return [next],B.b}
	method c {} {return [next],B.c}
    }
    set result {}
} -cleanup {
    A destroy
} -body {
    lappend result [B a] [B b] [B c] -
    oo::objdefine B deletemethod b
    lappend result [B a] [B b] [B c] -
    oo::objdefine B renamemethod a b
    lappend result [B a] [B b] [B c] -
    oo::objdefine B deletemethod b c
    lappend result [B a] [B b] [B c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}

test oo-11.1 {OO: cleanup} {
    oo::object create foo
    set result [list [catch {oo::object create foo} msg] $msg]
    lappend result [foo destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
Changes to tests/socket.test.
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]

# Use the maximum of the two latency calculations, but at least 100ms
set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
set latency [expr {$latency > 100 ? $latency : 1000}]
unset t1 t2 s1 s2 lat1 lat2 server

# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#

if {![info exists remoteServerIP]} {







|

|







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]

# Use the maximum of the two latency calculations, but at least 200ms
set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
set latency [expr {$latency > 200 ? $latency : 200}]
unset t1 t2 s1 s2 lat1 lat2 server

# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#

if {![info exists remoteServerIP]} {
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
    set s [socket -server accept 0]
    set sock ""
} -body {
    set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
    vwait sock
    puts $s2 one
    flush $s2
    after idle {set x 1}
    vwait x
    fconfigure $sock -blocking 0
    set result a:[gets $sock]
    lappend result b:[gets $sock]
    fconfigure $sock -blocking 1
    puts $s2 two
    flush $s2







|







668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
    set s [socket -server accept 0]
    set sock ""
} -body {
    set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
    vwait sock
    puts $s2 one
    flush $s2
    after $latency {set x 1}; # Spurious failures in Travis CI, if we do [after idle]
    vwait x
    fconfigure $sock -blocking 0
    set result a:[gets $sock]
    lappend result b:[gets $sock]
    fconfigure $sock -blocking 1
    puts $s2 two
    flush $s2
Changes to tests/utf.test.
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
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
    testnumutfchars ""
} {0}
test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC2\xA2"]
} {1}
test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
} {7}
test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
    testnumutfchars "" 0
} {0}
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC2\xA2"] 2
} {1}
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 10
} {7}
test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC0\x80"] 2
} {1}
# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check
test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xE2\x82\xAC"] 2







|











|







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
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
    testnumutfchars ""
} {0}
test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC2\xA2"]
} {1}
test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\uA2\x4E"]
} {7}
test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
    testnumutfchars "" 0
} {0}
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC2\xA2"] 2
} {1}
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\uA2\x4E"] 10
} {7}
test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xC0\x80"] 2
} {1}
# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check
test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} {
    testnumutfchars [testbytestring "\xE2\x82\xAC"] 2
Changes to unix/tclUnixFCmd.c.
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
static int
SetGroupAttribute(
    Tcl_Interp *interp,		/* The interp for error reporting. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* New group for file. */
{
    long gid;
    int result;
    const char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
	Tcl_DString ds;
	struct group *groupPtr = NULL;
	const char *string;

	string = TclGetString(attributePtr);

	native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);







|



|







1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
static int
SetGroupAttribute(
    Tcl_Interp *interp,		/* The interp for error reporting. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* New group for file. */
{
    Tcl_WideInt gid;
    int result;
    const char *native;

    if (Tcl_GetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
	Tcl_DString ds;
	struct group *groupPtr = NULL;
	const char *string;

	string = TclGetString(attributePtr);

	native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
static int
SetOwnerAttribute(
    Tcl_Interp *interp,		/* The interp for error reporting. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* New owner for file. */
{
    long uid;
    int result;
    const char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
	Tcl_DString ds;
	struct passwd *pwPtr = NULL;
	const char *string;

	string = TclGetString(attributePtr);

	native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);







|



|







1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
static int
SetOwnerAttribute(
    Tcl_Interp *interp,		/* The interp for error reporting. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* New owner for file. */
{
    Tcl_WideInt uid;
    int result;
    const char *native;

    if (Tcl_GetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
	Tcl_DString ds;
	struct passwd *pwPtr = NULL;
	const char *string;

	string = TclGetString(attributePtr);

	native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
static int
SetPermissionsAttribute(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* The attribute to set. */
{
    long mode;
    mode_t newMode;
    int result = TCL_ERROR;
    const char *native;
    const char *modeStringPtr = TclGetString(attributePtr);
    int scanned = TclParseAllWhiteSpace(modeStringPtr, -1);

    /*
     * First supply support for octal number format
     */

    if ((modeStringPtr[scanned] == '0')
	    && (modeStringPtr[scanned+1] >= '0')
	    && (modeStringPtr[scanned+1] <= '7')) {
	/* Leading zero - attempt octal interpretation */
	Tcl_Obj *modeObj;

	TclNewLiteralStringObj(modeObj, "0o");
	Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, -1);
	result = Tcl_GetLongFromObj(NULL, modeObj, &mode);
	Tcl_DecrRefCount(modeObj);
    }
    if (result == TCL_OK
	    || Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
	newMode = (mode_t) (mode & 0x00007FFF);
    } else {
	Tcl_StatBuf buf;

	/*
	 * Try the forms "rwxrwxrwx" and "ugo=rwx"
	 *







|


















|



|







1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
static int
SetPermissionsAttribute(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* The attribute to set. */
{
    Tcl_WideInt mode;
    mode_t newMode;
    int result = TCL_ERROR;
    const char *native;
    const char *modeStringPtr = TclGetString(attributePtr);
    int scanned = TclParseAllWhiteSpace(modeStringPtr, -1);

    /*
     * First supply support for octal number format
     */

    if ((modeStringPtr[scanned] == '0')
	    && (modeStringPtr[scanned+1] >= '0')
	    && (modeStringPtr[scanned+1] <= '7')) {
	/* Leading zero - attempt octal interpretation */
	Tcl_Obj *modeObj;

	TclNewLiteralStringObj(modeObj, "0o");
	Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, -1);
	result = Tcl_GetWideIntFromObj(NULL, modeObj, &mode);
	Tcl_DecrRefCount(modeObj);
    }
    if (result == TCL_OK
	    || Tcl_GetWideIntFromObj(NULL, attributePtr, &mode) == TCL_OK) {
	newMode = (mode_t) (mode & 0x00007FFF);
    } else {
	Tcl_StatBuf buf;

	/*
	 * Try the forms "rwxrwxrwx" and "ugo=rwx"
	 *
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
    ckfree(winPath);

    if (fileAttributes == -1) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewBooleanObj(
	    fileAttributes & attributeArray[objIndex]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes







|
|







2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
    ckfree(winPath);

    if (fileAttributes == -1) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewWideIntObj(
	    (fileAttributes & attributeArray[objIndex]) != 0);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "could not read \"%s\": %s",
		    TclGetString(fileName), Tcl_PosixError(interp)));
	}
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags & UF_IMMUTABLE);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes







|







2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "could not read \"%s\": %s",
		    TclGetString(fileName), Tcl_PosixError(interp)));
	}
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewWideIntObj((statBuf.st_flags & UF_IMMUTABLE) != 0);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes
Changes to win/tclWinFCmd.c.
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
		 */

		attr = 0;
	    }
	}
    }

    *attributePtrPtr = Tcl_NewBooleanObj(attr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertFileNameFormat --







|







1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
		 */

		attr = 0;
	    }
	}
    }

    *attributePtrPtr = Tcl_NewWideIntObj(attr != 0);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertFileNameFormat --