Tcl Source Code

2005-09-27  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tcl.h:	Changed name of the new Tcl_Obj intrep field
	* generic/tclObj.c:	from "bignumValue" to "ptrAndLongRep" as
	* generic/tclProc.c:	described in TIP 237, and more suitable for
	other more general uses.

2005-09-26  Kevin Kenny  <[email protected]>

	[kennykb-numerics-branch] Merge updates from HEAD.
	
2005-09-26  Kevin Kenny  <[email protected]>

	* libtommath/:                   Updated to release 0.36.

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.191.2.11 2005/09/27 18:42:54 dgp Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"

	Tcl_WideInt wideValue;	/*   - a long long value */
	struct {		/*   - internal rep as two pointers */
	    VOID *ptr1;
	    VOID *ptr2;
	} twoPtrValue;
	struct {		/*   - internal rep as a wide int, tightly
				 *     packed fields */
	    VOID *ptr;		/* Pointer to digits */
	    unsigned long value;/* Alloc, used, and signum packed into a
				 * single word */
	} ptrAndLongRep;
    } internalRep;
} Tcl_Obj;

/*
 * Macros to increment and decrement a Tcl_Obj's reference count, and to test
 * whether an object is shared (i.e. has reference count > 1). Note: clients
 * should use Tcl_DecrRefCount() when they are finished using an object, and

 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.72.2.39 2005/09/27 18:42:54 dgp Exp $
 */

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

#define BIGNUM_AUTO_NARROW 1

 * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
 */

#define PACK_BIGNUM(bignum, objPtr) \
    if ((bignum).used > 0x7fff) { \
	mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
	*temp = bignum; \
	(objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \
	(objPtr)->internalRep.ptrAndLongRep.value = -1; \
    } else { \
	if ((bignum).alloc > 0x7fff) { \
	    mp_shrink(&(bignum)); \
	} \

	(objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \
	(objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \
		| ((bignum).alloc << 15) | ((bignum).used)); \

    }

#define UNPACK_BIGNUM(objPtr, bignum) \
    if ((objPtr)->internalRep.ptrAndLongRep.value == -1) { \
	(bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \
    } else { \
	(bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \
	(bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \
	(bignum).alloc = \
		((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \
	(bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \
    }

/*
 * Prototypes for procedures defined later in this file:
 */

static int		ParseBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));

	    *boolPtr = (d != 0.0);
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclBignumType) {
#ifdef BIGNUM_AUTO_NARROW
	    *boolPtr = 1;
#else
	    *boolPtr = ((objPtr->internalRep.ptrAndLongRep.value & 0x7fff)!=0);
#endif
	    return TCL_OK;
	}
#ifndef NO_WIDE_TYPE
	if (objPtr->typePtr == &tclWideIntType) {
	    *boolPtr = (objPtr->internalRep.wideValue != 0);
	    return TCL_OK;

static void
FreeBignum(Tcl_Obj *objPtr)
{
    mp_int toFree;		/* Bignum to free */

    UNPACK_BIGNUM(objPtr, toFree);
    mp_clear(&toFree);
    if (objPtr->internalRep.ptrAndLongRep.value < 0) {
	ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DupBignum --

 * 	the mp_int value depending on the copy flag value passed in.
 *
 * Results:
 *	Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
 *
 * Side effects:
 *	A copy of bignum is stored in *bignumValue, which is expected to be
 *	uninitialized or cleared.  If conversion fails, and the 'interp'
 *	argument is not NULL, an error message is stored in the interpreter
 *	result.
 *
 *----------------------------------------------------------------------
 */

int

		UNPACK_BIGNUM(objPtr, temp);
		mp_init_copy(bignumValue, &temp);
	    } else {
		if (Tcl_IsShared(objPtr)) {
		    Tcl_Panic("Tcl_GetBignumAndClearObj called on shared Tcl_Obj");
		}
		UNPACK_BIGNUM(objPtr, *bignumValue);
		objPtr->internalRep.ptrAndLongRep.ptr = NULL;
		objPtr->internalRep.ptrAndLongRep.value = 0;
		objPtr->typePtr = NULL;
		if (objPtr->bytes == NULL) {
		    TclInitStringRep(objPtr, NULL, 0);
		}
	    }
	    return TCL_OK;
	}

/*
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures, including
 *	the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.66.2.8 2005/09/27 18:42:54 dgp Exp $
 */

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

/*
 * Prototypes for static functions in this file

	    if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
		goto levelError;
	    }

	    /*
	     * Cache for future reference.
	     *
	     * TODO: Use the new ptrAndLongRep intrep
	     */

	    TclFreeIntRep(objPtr);
	    objPtr->typePtr = &levelReferenceType;
	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0;
	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
	} else if (isdigit(UCHAR(*name))) { /* INTL: digit */
	    if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
		return -1;
	    }

	    /*
	     * Cache for future reference.
	     *
	     * TODO: Use the new ptrAndLongRep intrep
	     */

	    TclFreeIntRep(objPtr);
	    objPtr->typePtr = &levelReferenceType;
	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1;
	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
	    level = curLevel - level;