Tcl Source Code

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

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

Overview
Comment:
[kennykb-numerics-branch]
* generic/tclBasic.c: Revised implementation of the ceil(.) and * generic/tclInt.h: floor(.) math functions in light of the * generic/tclStrToD.c: revised comparison operators, so that it is always true that ($x <= ceil($x)) and ($x >= floor($x)). The simple approach of "convert to double and call ceil() or floor()" could not guarantee that.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | kennykb-numerics-branch
Files: files | file ages | folders
SHA1:9cbb2232b785a1cb2fac4bc151bcc71bf2b3e6ce
User & Date: dgp 2005-08-24 21:49:22
Context
2005-08-25
14:58
[kennykb-numerics-branch]
* generic/tclBasic.c: Extended the domain of round(.) t...
check-in: 9bfc46124e user: dgp tags: kennykb-numerics-branch
2005-08-24
21:49
[kennykb-numerics-branch]
* generic/tclBasic.c: Revised implementation of the cei...
check-in: 9cbb2232b7 user: dgp tags: kennykb-numerics-branch
18:56
corrected TRACE bugs, overflowed negative #s, and bad test constraints check-in: 57f3c9f065 user: kennykb tags: kennykb-numerics-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.

10
11
12
13
14
15
16







17
18
19
20
21
22
23
	* tests/binary.test (binary-65.*): Added missing 'ieeeFloatingPoint' to
	large/small significand tests.
	* tests/expr.test (expr-45.*) Added missing braces around expressions.
	
2005-08-24  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]








	* generic/tclExecute.c:	Bug fix: TclBignumToDouble return -Inf when
	appropriate.  Removed declarations of removed routines.

	* generic/tclExecute.c:	Revised the type promotion rules of the
	comparison operators so that they form proper equivalence classes
	over the set of numeric strings.







>
>
>
>
>
>
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
	* tests/binary.test (binary-65.*): Added missing 'ieeeFloatingPoint' to
	large/small significand tests.
	* tests/expr.test (expr-45.*) Added missing braces around expressions.
	
2005-08-24  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclBasic.c:	Revised implementation of the ceil(.) and
	* generic/tclInt.h:	floor(.) math functions in light of the
	* generic/tclStrToD.c:	revised comparison operators, so that it
	is always true that ($x <= ceil($x)) and ($x >= floor($x)).  The	
	simple approach of "convert to double and call ceil() or floor()"
	could not guarantee that.

	* generic/tclExecute.c:	Bug fix: TclBignumToDouble return -Inf when
	appropriate.  Removed declarations of removed routines.

	* generic/tclExecute.c:	Revised the type promotion rules of the
	comparison operators so that they form proper equivalence classes
	over the set of numeric strings.

Changes to generic/tclBasic.c.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
52
53
54
55
56
57
58


59
60
61
62


63
64
65
66
67
68
69
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
....
4951
4952
4953
4954
4955
4956
4957










































































4958
4959
4960
4961
4962
4963
4964
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136.2.26 2005/08/23 19:22:12 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
static void	OldMathFuncDeleteProc _ANSI_ARGS_((ClientData));

static int	ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprBoolFunc _ANSI_ARGS_((ClientData clientData,


		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprEntierFunc _ANSI_ARGS_((ClientData clientData,


		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprIntFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprRandFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
................................................................................
BuiltinFuncDef BuiltinFuncTable[] = {
    { "::tcl::mathfunc::abs",	ExprAbsFunc,	NULL 			},
    { "::tcl::mathfunc::acos",	ExprUnaryFunc,	(ClientData) acos 	},
    { "::tcl::mathfunc::asin",	ExprUnaryFunc,	(ClientData) asin 	},
    { "::tcl::mathfunc::atan",	ExprUnaryFunc,	(ClientData) atan 	},
    { "::tcl::mathfunc::atan2",	ExprBinaryFunc,	(ClientData) atan2 	},
    { "::tcl::mathfunc::bool",	ExprBoolFunc,	NULL			},
    { "::tcl::mathfunc::ceil",	ExprUnaryFunc,	(ClientData) ceil 	},
    { "::tcl::mathfunc::cos",	ExprUnaryFunc,	(ClientData) cos 	},
    { "::tcl::mathfunc::cosh",	ExprUnaryFunc,	(ClientData) cosh	},
    { "::tcl::mathfunc::double",ExprDoubleFunc,	NULL			},
    { "::tcl::mathfunc::entier",ExprEntierFunc,	NULL			},
    { "::tcl::mathfunc::exp",	ExprUnaryFunc,	(ClientData) exp	},
    { "::tcl::mathfunc::floor",	ExprUnaryFunc,	(ClientData) floor 	},
    { "::tcl::mathfunc::fmod",	ExprBinaryFunc,	(ClientData) fmod	},
    { "::tcl::mathfunc::hypot",	ExprBinaryFunc,	(ClientData) hypot 	},
    { "::tcl::mathfunc::int",	ExprIntFunc,	NULL			},
    { "::tcl::mathfunc::log",	ExprUnaryFunc,	(ClientData) log 	},
    { "::tcl::mathfunc::log10",	ExprUnaryFunc,  (ClientData) log10 	},
    { "::tcl::mathfunc::pow",	ExprBinaryFunc,	(ClientData) pow 	},
    { "::tcl::mathfunc::rand",	ExprRandFunc,	NULL			},
................................................................................
 *	and leaves an error message in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */











































































static int
ExprUnaryFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes one double argument and returns a
				 * double result. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the







|







 







>
>




>
>







 







|





|







 







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







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
...
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
....
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
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
5038
5039
5040
5041
5042
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.136.2.27 2005/08/24 21:49:22 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
static void	OldMathFuncDeleteProc _ANSI_ARGS_((ClientData));

static int	ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprBoolFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprCeilFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprEntierFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprFloorFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprIntFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprRandFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
static int	ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
................................................................................
BuiltinFuncDef BuiltinFuncTable[] = {
    { "::tcl::mathfunc::abs",	ExprAbsFunc,	NULL 			},
    { "::tcl::mathfunc::acos",	ExprUnaryFunc,	(ClientData) acos 	},
    { "::tcl::mathfunc::asin",	ExprUnaryFunc,	(ClientData) asin 	},
    { "::tcl::mathfunc::atan",	ExprUnaryFunc,	(ClientData) atan 	},
    { "::tcl::mathfunc::atan2",	ExprBinaryFunc,	(ClientData) atan2 	},
    { "::tcl::mathfunc::bool",	ExprBoolFunc,	NULL			},
    { "::tcl::mathfunc::ceil",	ExprCeilFunc,	NULL		 	},
    { "::tcl::mathfunc::cos",	ExprUnaryFunc,	(ClientData) cos 	},
    { "::tcl::mathfunc::cosh",	ExprUnaryFunc,	(ClientData) cosh	},
    { "::tcl::mathfunc::double",ExprDoubleFunc,	NULL			},
    { "::tcl::mathfunc::entier",ExprEntierFunc,	NULL			},
    { "::tcl::mathfunc::exp",	ExprUnaryFunc,	(ClientData) exp	},
    { "::tcl::mathfunc::floor",	ExprFloorFunc,	NULL		 	},
    { "::tcl::mathfunc::fmod",	ExprBinaryFunc,	(ClientData) fmod	},
    { "::tcl::mathfunc::hypot",	ExprBinaryFunc,	(ClientData) hypot 	},
    { "::tcl::mathfunc::int",	ExprIntFunc,	NULL			},
    { "::tcl::mathfunc::log",	ExprUnaryFunc,	(ClientData) log 	},
    { "::tcl::mathfunc::log10",	ExprUnaryFunc,  (ClientData) log10 	},
    { "::tcl::mathfunc::pow",	ExprBinaryFunc,	(ClientData) pow 	},
    { "::tcl::mathfunc::rand",	ExprRandFunc,	NULL			},
................................................................................
 *	and leaves an error message in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ExprCeilFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes one double argument and returns a
				 * double result. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter list */
{
    int code;
    double d;
    mp_int big;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big)));
	mp_clear(&big);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
    }
    return TCL_OK;
}

static int
ExprFloorFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes one double argument and returns a
				 * double result. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */
    int objc;			/* Actual parameter count */
    Tcl_Obj *CONST *objv;	/* Actual parameter list */
{
    int code;
    double d;
    mp_int big;

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }
    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }
#endif
    if (code != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big)));
	mp_clear(&big);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
    }
    return TCL_OK;
}

static int
ExprUnaryFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Contains the address of a procedure that
				 * takes one double argument and returns a
				 * double result. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the

Changes to generic/tclInt.h.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1962
1963
1964
1965
1966
1967
1968

1969
1970
1971
1972
1973
1974
1975
....
1999
2000
2001
2002
2003
2004
2005

2006
2007
2008
2009
2010
2011
2012
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.32 2005/08/23 19:15:40 kennykb Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
			    CONST char *bytes, int length, int limit,
			    CONST char *ellipsis));
MODULE_SCOPE void	TclAppendObjToErrorInfo _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_Obj *objPtr));
MODULE_SCOPE int	TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
MODULE_SCOPE double     TclBignumToDouble _ANSI_ARGS_((mp_int* bignum));

MODULE_SCOPE int	TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *value));
MODULE_SCOPE void	TclCleanupLiteralTable _ANSI_ARGS_((
			    Tcl_Interp* interp, LiteralTable* tablePtr));
MODULE_SCOPE int	TclDoubleDigits _ANSI_ARGS_((char* buf,
						     double value,
						     int* signum));
................................................................................
MODULE_SCOPE void	TclFinalizeLock _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeNotifier _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeObjects _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizePreserve _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeSynchronization _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeThreadData _ANSI_ARGS_((void));

MODULE_SCOPE void	TclFormatNaN _ANSI_ARGS_((double value, char* buffer));
MODULE_SCOPE int	TclFSFileAttrIndex _ANSI_ARGS_((Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr));
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE int	TclGetEncodingFromObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr));
MODULE_SCOPE int        TclGetNamespaceFromObj _ANSI_ARGS_((







|







 







>







 







>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
....
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.33 2005/08/24 21:49:22 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
			    CONST char *bytes, int length, int limit,
			    CONST char *ellipsis));
MODULE_SCOPE void	TclAppendObjToErrorInfo _ANSI_ARGS_((
			    Tcl_Interp *interp, Tcl_Obj *objPtr));
MODULE_SCOPE int	TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
MODULE_SCOPE double     TclBignumToDouble _ANSI_ARGS_((mp_int* bignum));
MODULE_SCOPE double	TclCeil _ANSI_ARGS_((mp_int* a));
MODULE_SCOPE int	TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *value));
MODULE_SCOPE void	TclCleanupLiteralTable _ANSI_ARGS_((
			    Tcl_Interp* interp, LiteralTable* tablePtr));
MODULE_SCOPE int	TclDoubleDigits _ANSI_ARGS_((char* buf,
						     double value,
						     int* signum));
................................................................................
MODULE_SCOPE void	TclFinalizeLock _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeNotifier _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeObjects _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizePreserve _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeSynchronization _ANSI_ARGS_((void));
MODULE_SCOPE void	TclFinalizeThreadData _ANSI_ARGS_((void));
MODULE_SCOPE double	TclFloor _ANSI_ARGS_((mp_int* a));
MODULE_SCOPE void	TclFormatNaN _ANSI_ARGS_((double value, char* buffer));
MODULE_SCOPE int	TclFSFileAttrIndex _ANSI_ARGS_((Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr));
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE int	TclGetEncodingFromObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr));
MODULE_SCOPE int        TclGetNamespaceFromObj _ANSI_ARGS_((

Changes to generic/tclStrToD.c.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
....
2258
2259
2260
2261
2262
2263
2264













































































2265
2266
2267
2268
2269
2270
2271
 *	interconversion among 'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.33 2005/08/24 18:56:32 kennykb Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>
................................................................................

    if (a->sign == MP_ZPOS) {
	return r;
    } else {
	return -r;
    }
}













































































 
/*
 *----------------------------------------------------------------------
 *
 * BignumToBiasedFrExp --
 *
 *	Convert an arbitrary-precision integer to a native floating







|







 







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







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
....
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
 *	interconversion among 'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.34 2005/08/24 21:49:23 dgp Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>
................................................................................

    if (a->sign == MP_ZPOS) {
	return r;
    } else {
	return -r;
    }
}

double
TclCeil(mp_int *a)	/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;

    mp_init(&b);
    if (a->sign == MP_NEG) {
	mp_neg(a, &b);
	r = -TclFloor(&b);
    } else {
	int bits = mp_count_bits(a);

	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
	    r = HUGE_VAL;
	} else {
	    int i, exact = 1, shift = mantBits - bits;

	    if (shift > 0) {
		mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_int d;
		mp_init(&d);
		mp_div_2d(a, -shift, &b, &d);
		exact = mp_iszero(&d);
		mp_clear(&d);
	    } else {
		mp_copy(a, &b);
	    }
	    if (!exact) {
		mp_add_d(&b, 1, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}

double
TclFloor(mp_int *a)	/* Integer to convert. */
{
    double r = 0.0;
    mp_int b;

    mp_init(&b);
    if (a->sign == MP_NEG) {
	mp_neg(a, &b);
	r = -TclCeil(&b);
    } else {
	int bits = mp_count_bits(a);

	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
	    r = DBL_MAX;
	} else {
	    int i, shift = mantBits - bits;

	    if (shift > 0) {
		mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_div_2d(a, -shift, &b, NULL);
	    } else {
		mp_copy(a, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}
 
/*
 *----------------------------------------------------------------------
 *
 * BignumToBiasedFrExp --
 *
 *	Convert an arbitrary-precision integer to a native floating