Content-Security-Policy: default-src 'none' Content-Type: text/plain; charset=UTF-8 Content-Length: 133145 Content-Disposition: inline; filename="tclStrToD.c" Last-Modified: Wed, 21 Aug 2024 13:16:17 GMT Expires: Sat, 19 Aug 2034 13:16:17 GMT ETag: "66640ea3d605fee3881aaa69e97a53b71207c933" /* * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions * to/from floating-point in Tcl. They include TclParseNumber, which * parses numbers from strings; TclDoubleDigits, which formats numbers * into strings of digits, and procedures for 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. */ #include "tclInt.h" #include "tommath.h" #include /* * Define KILL_OCTAL to suppress interpretation of numbers with leading zero * as octal. (Ceterum censeo: numeros octonarios delendos esse.) */ #undef KILL_OCTAL /* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. */ #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) # define IEEE_FLOATING_POINT #endif /* * Rounding controls. (Thanks a lot, Intel!) */ #ifdef __i386 /* * gcc on x86 needs access to rounding controls, because of a questionable * feature where it retains intermediate results as IEEE 'long double' values * somewhat unpredictably. It is tempting to include fpu_control.h, but that * file exists only on Linux; it is missing on Cygwin and MinGW. Most gcc-isms * and ix86-isms are factored out here. */ #if defined(__GNUC__) typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); #define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) #define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) # define FPU_IEEE_ROUNDING 0x027f # define ADJUST_FPU_CONTROL_WORD #define TCL_IEEE_DOUBLE_ROUNDING \ fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \ fpu_control_t oldRoundingMode; \ _FPU_GETCW(oldRoundingMode); \ _FPU_SETCW(roundTo53Bits) #define TCL_DEFAULT_DOUBLE_ROUNDING \ _FPU_SETCW(oldRoundingMode) /* * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ #elif defined(__sun) #include #define TCL_IEEE_DOUBLE_ROUNDING \ ieee_flags("set","precision","double",NULL) #define TCL_DEFAULT_DOUBLE_ROUNDING \ ieee_flags("clear","precision",NULL,NULL) /* * Other platforms are assumed to always operate in full IEEE mode, so we make * the macros to go in and out of that mode do nothing. */ #else /* !__GNUC__ && !__sun */ #define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) #define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) #endif #else /* !__i386 */ #define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) #define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) #endif /* * MIPS floating-point units need special settings in control registers to use * gradual underflow as we expect. This fix is for the MIPSpro compiler. */ #if defined(__sgi) && defined(_COMPILER_VERSION) #include #endif /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa # define NAN_START 0x7ff4 # define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else # define NAN_START 0x7ff8 # define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* * Constants used by this file (most of which are only ever calculated at * runtime). */ /* Magic constants */ #define LOG10_2 0.3010299956639812 #define TWO_OVER_3LOG10 0.28952965460216784 #define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 /* * Definitions of the parts of an IEEE754-format floating point number. */ #define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ #define EXP_MASK 0x7ff00000 /* Mask for the exponent field in the first * word of a double. */ #define EXP_SHIFT 20 /* Shift count to make the exponent an * integer. */ #define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) /* Hidden 1 bit for the significand. */ #define HI_ORDER_SIG_MASK 0x000fffff /* Mask for the high-order part of the * significand in the first word of a * double. */ #define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ | 0xffffffff) /* Mask for the 52-bit significand. */ #define FP_PRECISION 53 /* Number of bits of significand plus the * hidden bit. */ #define EXPONENT_BIAS 0x3ff /* Bias of the exponent 0. */ /* * Derived quantities. */ #define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */ #define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */ #define BLETCH 0x10 /* Highest power of two that is greater than * DBL_MAX_10_EXP, divided by 16. */ #define DIGIT_GROUP 8 /* floor(DIGIT_BIT*log(2)/log(10)) */ /* * Union used to dismantle floating point numbers. */ typedef union Double { struct { #ifdef WORDS_BIGENDIAN int word0; int word1; #else int word1; int word0; #endif } w; double d; Tcl_WideUInt q; } Double; static int maxpow10_wide; /* The powers of ten that can be represented * exactly as wide integers. */ static Tcl_WideUInt *pow10_wide; #define MAXPOW 22 static double pow10vals[MAXPOW+1]; /* The powers of ten that can be represented * exactly as IEEE754 doubles. */ static int mmaxpow; /* Largest power of ten that can be * represented exactly in a 'double'. */ static int log10_DIGIT_MAX; /* The number of decimal digits that fit in an * mp_digit. */ static int log2FLT_RADIX; /* Logarithm of the floating point radix. */ static int mantBits; /* Number of bits in a double's significand */ static mp_int pow5[9]; /* Table of powers of 5**(2**n), up to * 5**256 */ static double tiny = 0.0; /* The smallest representable double. */ static int maxDigits; /* The maximum number of digits to the left of * the decimal point of a double. */ static int minDigits; /* The maximum number of digits to the right * of the decimal point in a double. */ static const double pow_10_2_n[] = { /* Inexact higher powers of ten. */ 1.0, 100.0, 10000.0, 1.0e+8, 1.0e+16, 1.0e+32, 1.0e+64, 1.0e+128, 1.0e+256 }; static int n770_fp; /* Flag is 1 on Nokia N770 floating point. * Nokia's floating point has the words * reversed: if big-endian is 7654 3210, * and little-endian is 0123 4567, * then Nokia's FP is 4567 0123; * little-endian within the 32-bit words but * big-endian between them. */ /* * Table of powers of 5 that are small enough to fit in an mp_digit. */ static const mp_digit dpow5[13] = { 1, 5, 25, 125, 625, 3125, 15625, 78125, 390625, 1953125, 9765625, 48828125, 244140625 }; /* * Table of powers: pow5_13[n] = 5**(13*2**(n+1)) */ static mp_int pow5_13[5]; /* Table of powers: 5**13, 5**26, 5**52, * 5**104, 5**208 */ static const double tens[] = { 1e00, 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09, 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20, 1e21, 1e22 }; static const int itens [] = { 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000 }; static const double bigtens[] = { 1e016, 1e032, 1e064, 1e128, 1e256 }; #define N_BIGTENS 5 static const int log2pow5[27] = { 01, 3, 5, 7, 10, 12, 14, 17, 19, 21, 24, 26, 28, 31, 33, 35, 38, 40, 42, 45, 47, 49, 52, 54, 56, 59, 61 }; #define N_LOG2POW5 27 static const Tcl_WideUInt wuipow5[27] = { (Tcl_WideUInt) 1, /* 5**0 */ (Tcl_WideUInt) 5, (Tcl_WideUInt) 25, (Tcl_WideUInt) 125, (Tcl_WideUInt) 625, (Tcl_WideUInt) 3125, /* 5**5 */ (Tcl_WideUInt) 3125*5, (Tcl_WideUInt) 3125*25, (Tcl_WideUInt) 3125*125, (Tcl_WideUInt) 3125*625, (Tcl_WideUInt) 3125*3125, /* 5**10 */ (Tcl_WideUInt) 3125*3125*5, (Tcl_WideUInt) 3125*3125*25, (Tcl_WideUInt) 3125*3125*125, (Tcl_WideUInt) 3125*3125*625, (Tcl_WideUInt) 3125*3125*3125, /* 5**15 */ (Tcl_WideUInt) 3125*3125*3125*5, (Tcl_WideUInt) 3125*3125*3125*25, (Tcl_WideUInt) 3125*3125*3125*125, (Tcl_WideUInt) 3125*3125*3125*625, (Tcl_WideUInt) 3125*3125*3125*3125, /* 5**20 */ (Tcl_WideUInt) 3125*3125*3125*3125*5, (Tcl_WideUInt) 3125*3125*3125*3125*25, (Tcl_WideUInt) 3125*3125*3125*3125*125, (Tcl_WideUInt) 3125*3125*3125*3125*625, (Tcl_WideUInt) 3125*3125*3125*3125*3125, /* 5**25 */ (Tcl_WideUInt) 3125*3125*3125*3125*3125*5 /* 5**26 */ }; /* * Static functions defined in this file. */ static int AccumulateDecimalDigit(unsigned, int, Tcl_WideUInt *, mp_int *, int); static double MakeHighPrecisionDouble(int signum, mp_int *significand, int nSigDigs, int exponent); static double MakeLowPrecisionDouble(int signum, Tcl_WideUInt significand, int nSigDigs, int exponent); #ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); #endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); static void MulPow5(mp_int *, unsigned, mp_int *); static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, int *); static void TakeAbsoluteValue(Double *, int *); static char * FormatInfAndNaN(Double *, int *, char **); static char * FormatZero(int *, char **); static int ApproximateLog10(Tcl_WideUInt, int, int); static int BetterLog10(double, int, int *); static void ComputeScale(int, int, int *, int *, int *, int *); static void SetPrecisionLimits(int, int, int *, int *, int *, int *); static char * BumpUp(char *, char *, int *); static int AdjustRange(double *, int); static char * ShorteningQuickFormat(double, int, int, double, char *, int *); static char * StrictQuickFormat(double, int, int, double, char *, int *); static char * QuickConversion(double, int, int, int, int, int, int, int *, char **); static void CastOutPowersOf2(int *, int *, int *); static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, int, int, int *, char **); static int ShouldBankerRoundUpPowD(mp_int *, int, int); static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, int, int, int, mp_int *); static char * ShorteningBignumConversionPowD(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversionPowD(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int b5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static int ShouldBankerRoundUp(mp_int *, mp_int *, int); static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, mp_int *, int, int, mp_int *); static char * ShorteningBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static double BignumToBiasedFrExp(const mp_int *big, int *machexp); static double Pow10TimesFrExp(int exponent, double fraction, int *machexp); static double SafeLdExp(double fraction, int exponent); #ifdef IEEE_FLOATING_POINT static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); #endif /* *---------------------------------------------------------------------- * * TclParseNumber -- * * Scans bytes, interpreted as characters in Tcl's internal encoding, and * parses the longest prefix that is the string representation of a * number in a format recognized by Tcl. * * The arguments bytes, numBytes, and objPtr are the inputs which * determine the string to be parsed. If bytes is non-NULL, it points to * the first byte to be scanned. If bytes is NULL, then objPtr must be * non-NULL, and the string representation of objPtr will be scanned * (generated first, if necessary). The numBytes argument determines the * number of bytes to be scanned. If numBytes is negative, the first NUL * byte encountered will terminate the scan. If numBytes is non-negative, * then no more than numBytes bytes will be scanned. * * The argument flags is an input that controls the numeric formats * recognized by the parser. The flag bits are: * * - TCL_PARSE_INTEGER_ONLY: accept only integer values; reject * strings that denote floating point values (or accept only the * leading portion of them that are integer values). * - TCL_PARSE_SCAN_PREFIXES: ignore the prefixes 0b and 0o that are * not part of the [scan] command's vocabulary. Use only in * combination with TCL_PARSE_INTEGER_ONLY. * - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether * or not a prefix is present that would lead to octal parsing. * Use only in combination with TCL_PARSE_INTEGER_ONLY. * - TCL_PARSE_HEXADECIMAL_ONLY: parse only in the hexadecimal format, * whether or not a prefix is present that would lead to * hexadecimal parsing. Use only in combination with * TCL_PARSE_INTEGER_ONLY. * - TCL_PARSE_DECIMAL_ONLY: parse only in the decimal format, no * matter whether a 0 prefix would normally force a different * base. * - TCL_PARSE_NO_WHITESPACE: reject any leading/trailing whitespace * * The arguments interp and expected are inputs that control error * message generation. If interp is NULL, no error message will be * generated. If interp is non-NULL, then expected must also be non-NULL. * When TCL_ERROR is returned, an error message will be left in the * result of interp, and the expected argument will appear in the error * message as the thing TclParseNumber expected, but failed to find in * the string. * * The arguments objPtr and endPtrPtr as well as the return code are the * outputs. * * When the parser cannot find any prefix of the string that matches a * format it is looking for, TCL_ERROR is returned and an error message * may be generated and returned as described above. The contents of * objPtr will not be changed. If endPtrPtr is non-NULL, a pointer to the * character in the string that terminated the scan will be written to * *endPtrPtr. * * When the parser determines that the entire string matches a format it * is looking for, TCL_OK is returned, and if objPtr is non-NULL, then * the internal rep and Tcl_ObjType of objPtr are set to the "canonical" * numeric value that matches the scanned string. If endPtrPtr is not * NULL, a pointer to the end of the string will be written to *endPtrPtr * (that is, either bytes+numBytes or a pointer to a terminating NUL * byte). * * When the parser determines that a partial string matches a format it * is looking for, the value of endPtrPtr determines what happens: * * - If endPtrPtr is NULL, then TCL_ERROR is returned, with error message * generation as above. * * - If endPtrPtr is non-NULL, then TCL_OK is returned and objPtr * internals are set as above. Also, a pointer to the first * character following the parsed numeric string is written to * *endPtrPtr. * * In some cases where the string being scanned is the string rep of * objPtr, this routine can leave objPtr in an inconsistent state where * its string rep and its internal rep do not agree. In these cases the * internal rep will be in agreement with only some substring of the * string rep. This might happen if the caller passes in a non-NULL bytes * value that points somewhere into the string rep. It might happen if * the caller passes in a numBytes value that limits the scan to only a * prefix of the string rep. Or it might happen if a non-NULL value of * endPtrPtr permits a TCL_OK return from only a partial string match. It * is the responsibility of the caller to detect and correct such * inconsistencies when they can and do arise. * * Results: * Returns a standard Tcl result. * * Side effects: * The string representaton of objPtr may be generated. * * The internal representation and Tcl_ObjType of objPtr may be changed. * This may involve allocation and/or freeing of memory. * *---------------------------------------------------------------------- */ int TclParseNumber( Tcl_Interp *interp, /* Used for error reporting. May be NULL. */ Tcl_Obj *objPtr, /* Object to receive the internal rep. */ const char *expected, /* Description of the type of number the * caller expects to be able to parse * ("integer", "boolean value", etc.). */ const char *bytes, /* Pointer to the start of the string to * scan. */ int numBytes, /* Maximum number of bytes to scan, see * above. */ const char **endPtrPtr, /* Place to store pointer to the character * that terminated the scan. */ int flags) /* Flags governing the parse. */ { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, ZERO_O, ZERO_B, BINARY, HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY #ifdef IEEE_FLOATING_POINT , sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH #endif } state = INITIAL; enum State acceptState = INITIAL; int signum = 0; /* Sign of the number being parsed. */ Tcl_WideUInt significandWide = 0; /* Significand of the number being parsed (if * no overflow). */ mp_int significandBig; /* Significand of the number being parsed (if * it overflows significandWide). */ int significandOverflow = 0;/* Flag==1 iff significandBig is used. */ Tcl_WideUInt octalSignificandWide = 0; /* Significand of an octal number; needed * because we don't know whether a number with * a leading zero is octal or decimal until * we've scanned forward to a '.' or 'e'. */ mp_int octalSignificandBig; /* Significand of octal number once * octalSignificandWide overflows. */ int octalSignificandOverflow = 0; /* Flag==1 if octalSignificandBig is used. */ int numSigDigs = 0; /* Number of significant digits in the decimal * significand. */ int numTrailZeros = 0; /* Number of trailing zeroes at the current * point in the parse. */ int numDigitsAfterDp = 0; /* Number of digits scanned after the decimal * point. */ int exponentSignum = 0; /* Signum of the exponent of a floating point * number. */ long exponent = 0; /* Exponent of a floating point number. */ const char *p; /* Pointer to next character to scan. */ size_t len; /* Number of characters remaining after p. */ const char *acceptPoint; /* Pointer to position after last character in * an acceptable number. */ size_t acceptLen; /* Number of characters following that * point. */ int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ int explicitOctal = 0; #define ALL_BITS (~(Tcl_WideUInt)0) #define MOST_BITS (ALL_BITS >> 1) /* * Initialize bytes to start of the object's string rep if the caller * didn't pass anything else. */ if (bytes == NULL) { bytes = TclGetString(objPtr); } p = bytes; len = numBytes; acceptPoint = p; acceptLen = len; while (1) { char c = len ? *p : '\0'; switch (state) { case INITIAL: /* * Initial state. Acceptable characters are +, -, digits, period, * I, N, and whitespace. */ if (TclIsSpaceProc(c)) { if (flags & TCL_PARSE_NO_WHITESPACE) { goto endgame; } break; } else if (c == '+') { state = SIGNUM; break; } else if (c == '-') { signum = 1; state = SIGNUM; break; } /* FALLTHROUGH */ case SIGNUM: /* * Scanned a leading + or -. Acceptable characters are digits, * period, I, and N. */ if (c == '0') { if (flags & TCL_PARSE_DECIMAL_ONLY) { state = DECIMAL; } else { state = ZERO; } break; } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) { goto zerox; } else if (flags & TCL_PARSE_BINARY_ONLY) { goto zerob; } else if (flags & TCL_PARSE_OCTAL_ONLY) { goto zeroo; } else if (isdigit(UCHAR(c))) { significandWide = c - '0'; numSigDigs = 1; state = DECIMAL; break; } else if (flags & TCL_PARSE_INTEGER_ONLY) { goto endgame; } else if (c == '.') { state = LEADING_RADIX_POINT; break; } else if (c == 'I' || c == 'i') { state = sI; break; #ifdef IEEE_FLOATING_POINT } else if (c == 'N' || c == 'n') { state = sN; break; #endif } goto endgame; case ZERO: /* * Scanned a leading zero (perhaps with a + or -). Acceptable * inputs are digits, period, X, b, and E. If 8 or 9 is * encountered, the number can't be octal. This state and the * OCTAL state differ only in whether they recognize 'X' and 'b'. */ acceptState = state; acceptPoint = p; acceptLen = len; if (c == 'x' || c == 'X') { state = ZERO_X; break; } if (flags & TCL_PARSE_HEXADECIMAL_ONLY) { goto zerox; } if (flags & TCL_PARSE_SCAN_PREFIXES) { goto zeroo; } if (c == 'b' || c == 'B') { state = ZERO_B; break; } if (flags & TCL_PARSE_BINARY_ONLY) { goto zerob; } if (c == 'o' || c == 'O') { explicitOctal = 1; state = ZERO_O; break; } #ifdef KILL_OCTAL goto decimal; #endif /* FALLTHROUGH */ case OCTAL: /* * Scanned an optional + or -, followed by a string of octal * digits. Acceptable inputs are more digits, period, or E. If 8 * or 9 is encountered, commit to floating point. */ acceptState = state; acceptPoint = p; acceptLen = len; /* FALLTHROUGH */ case ZERO_O: zeroo: if (c == '0') { numTrailZeros++; state = OCTAL; break; } else if (c >= '1' && c <= '7') { if (objPtr != NULL) { shift = 3 * (numTrailZeros + 1); significandOverflow = AccumulateDecimalDigit( (unsigned)(c-'0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); if (!octalSignificandOverflow) { /* * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check for * too large shifts first. */ if ((octalSignificandWide != 0) && (((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > (~(Tcl_WideUInt)0 >> shift)))) { octalSignificandOverflow = 1; TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } } if (!octalSignificandOverflow) { octalSignificandWide = (octalSignificandWide << shift) + (c - '0'); } else { mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), &octalSignificandBig); } } if (numSigDigs != 0) { numSigDigs += numTrailZeros+1; } else { numSigDigs = 1; } numTrailZeros = 0; state = OCTAL; break; } /* FALLTHROUGH */ case BAD_OCTAL: if (explicitOctal) { /* * No forgiveness for bad digits in explicitly octal numbers. */ goto endgame; } if (flags & TCL_PARSE_INTEGER_ONLY) { /* * No seeking floating point when parsing only integer. */ goto endgame; } #ifndef KILL_OCTAL /* * Scanned a number with a leading zero that contains an 8, 9, * radix point or E. This is an invalid octal number, but might * still be floating point. */ if (c == '0') { numTrailZeros++; state = BAD_OCTAL; break; } else if (isdigit(UCHAR(c))) { if (objPtr != NULL) { significandOverflow = AccumulateDecimalDigit( (unsigned)(c-'0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); } if (numSigDigs != 0) { numSigDigs += (numTrailZeros + 1); } else { numSigDigs = 1; } numTrailZeros = 0; state = BAD_OCTAL; break; } else if (c == '.') { state = FRACTION; break; } else if (c == 'E' || c == 'e') { state = EXPONENT_START; break; } #endif goto endgame; /* * Scanned 0x. If state is HEXADECIMAL, scanned at least one * character following the 0x. The only acceptable inputs are * hexadecimal digits. */ case HEXADECIMAL: acceptState = state; acceptPoint = p; acceptLen = len; /* FALLTHROUGH */ case ZERO_X: zerox: if (c == '0') { numTrailZeros++; state = HEXADECIMAL; break; } else if (isdigit(UCHAR(c))) { d = (c-'0'); } else if (c >= 'A' && c <= 'F') { d = (c-'A'+10); } else if (c >= 'a' && c <= 'f') { d = (c-'a'+10); } else { goto endgame; } if (objPtr != NULL) { shift = 4 * (numTrailZeros + 1); if (!significandOverflow) { /* * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check for too * large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + d; } else { mp_mul_2d(&significandBig, shift, &significandBig); mp_add_d(&significandBig, (mp_digit) d, &significandBig); } } numTrailZeros = 0; state = HEXADECIMAL; break; case BINARY: acceptState = state; acceptPoint = p; acceptLen = len; case ZERO_B: zerob: if (c == '0') { numTrailZeros++; state = BINARY; break; } else if (c != '1') { goto endgame; } if (objPtr != NULL) { shift = numTrailZeros + 1; if (!significandOverflow) { /* * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check for too * large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + 1; } else { mp_mul_2d(&significandBig, shift, &significandBig); mp_add_d(&significandBig, (mp_digit) 1, &significandBig); } } numTrailZeros = 0; state = BINARY; break; case DECIMAL: /* * Scanned an optional + or - followed by a string of decimal * digits. */ #ifdef KILL_OCTAL decimal: #endif acceptState = state; acceptPoint = p; acceptLen = len; if (c == '0') { numTrailZeros++; state = DECIMAL; break; } else if (isdigit(UCHAR(c))) { if (objPtr != NULL) { significandOverflow = AccumulateDecimalDigit( (unsigned)(c - '0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); } numSigDigs += numTrailZeros+1; numTrailZeros = 0; state = DECIMAL; break; } else if (flags & TCL_PARSE_INTEGER_ONLY) { goto endgame; } else if (c == '.') { state = FRACTION; break; } else if (c == 'E' || c == 'e') { state = EXPONENT_START; break; } goto endgame; /* * Found a decimal point. If no digits have yet been scanned, E is * not allowed; otherwise, it introduces the exponent. If at least * one digit has been found, we have a possible complete number. */ case FRACTION: acceptState = state; acceptPoint = p; acceptLen = len; if (c == 'E' || c=='e') { state = EXPONENT_START; break; } /* FALLTHROUGH */ case LEADING_RADIX_POINT: if (c == '0') { numDigitsAfterDp++; numTrailZeros++; state = FRACTION; break; } else if (isdigit(UCHAR(c))) { numDigitsAfterDp++; if (objPtr != NULL) { significandOverflow = AccumulateDecimalDigit( (unsigned)(c-'0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); } if (numSigDigs != 0) { numSigDigs += numTrailZeros+1; } else { numSigDigs = 1; } numTrailZeros = 0; state = FRACTION; break; } goto endgame; case EXPONENT_START: /* * Scanned the E at the start of an exponent. Make sure a legal * character follows before using the C library strtol routine, * which allows whitespace. */ if (c == '+') { state = EXPONENT_SIGNUM; break; } else if (c == '-') { exponentSignum = 1; state = EXPONENT_SIGNUM; break; } /* FALLTHROUGH */ case EXPONENT_SIGNUM: /* * Found the E at the start of the exponent, followed by a sign * character. */ if (isdigit(UCHAR(c))) { exponent = c - '0'; state = EXPONENT; break; } goto endgame; case EXPONENT: /* * Found an exponent with at least one digit. Accumulate it, * making sure to hard-pin it to LONG_MAX on overflow. */ acceptState = state; acceptPoint = p; acceptLen = len; if (isdigit(UCHAR(c))) { if (exponent < (LONG_MAX - 9) / 10) { exponent = 10 * exponent + (c - '0'); } else { exponent = LONG_MAX; } state = EXPONENT; break; } goto endgame; /* * Parse out INFINITY by simply spelling it out. INF is accepted * as an abbreviation; other prefices are not. */ case sI: if (c == 'n' || c == 'N') { state = sIN; break; } goto endgame; case sIN: if (c == 'f' || c == 'F') { state = sINF; break; } goto endgame; case sINF: acceptState = state; acceptPoint = p; acceptLen = len; if (c == 'i' || c == 'I') { state = sINFI; break; } goto endgame; case sINFI: if (c == 'n' || c == 'N') { state = sINFIN; break; } goto endgame; case sINFIN: if (c == 'i' || c == 'I') { state = sINFINI; break; } goto endgame; case sINFINI: if (c == 't' || c == 'T') { state = sINFINIT; break; } goto endgame; case sINFINIT: if (c == 'y' || c == 'Y') { state = sINFINITY; break; } goto endgame; /* * Parse NaN's. */ #ifdef IEEE_FLOATING_POINT case sN: if (c == 'a' || c == 'A') { state = sNA; break; } goto endgame; case sNA: if (c == 'n' || c == 'N') { state = sNAN; break; } goto endgame; case sNAN: acceptState = state; acceptPoint = p; acceptLen = len; if (c == '(') { state = sNANPAREN; break; } goto endgame; /* * Parse NaN(hexdigits) */ case sNANHEX: if (c == ')') { state = sNANFINISH; break; } /* FALLTHROUGH */ case sNANPAREN: if (TclIsSpaceProc(c)) { break; } if (numSigDigs < 13) { if (c >= '0' && c <= '9') { d = c - '0'; } else if (c >= 'a' && c <= 'f') { d = 10 + c - 'a'; } else if (c >= 'A' && c <= 'F') { d = 10 + c - 'A'; } else { goto endgame; } numSigDigs++; significandWide = (significandWide << 4) + d; state = sNANHEX; break; } goto endgame; case sNANFINISH: #endif case sINFINITY: acceptState = state; acceptPoint = p; acceptLen = len; goto endgame; } p++; len--; } endgame: if (acceptState == INITIAL) { /* * No numeric string at all found. */ status = TCL_ERROR; if (endPtrPtr != NULL) { *endPtrPtr = p; } } else { /* * Back up to the last accepting state in the lexer. */ p = acceptPoint; len = acceptLen; if (!(flags & TCL_PARSE_NO_WHITESPACE)) { /* * Accept trailing whitespace. */ while (len != 0 && TclIsSpaceProc(*p)) { p++; len--; } } if (endPtrPtr == NULL) { if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) { status = TCL_ERROR; } } else { *endPtrPtr = p; } } /* * Generate and store the appropriate internal rep. */ if (status == TCL_OK && objPtr != NULL) { TclFreeIntRep(objPtr); switch (acceptState) { case SIGNUM: case BAD_OCTAL: case ZERO_X: case ZERO_O: case ZERO_B: case LEADING_RADIX_POINT: case EXPONENT_START: case EXPONENT_SIGNUM: case sI: case sIN: case sINFI: case sINFIN: case sINFINI: case sINFINIT: #ifdef IEEE_FLOATING_POINT case sN: case sNA: case sNANPAREN: case sNANHEX: Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'", acceptState, bytes); #endif case BINARY: shift = numTrailZeros; if (!significandOverflow && significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { significandWide <<= shift; } else { mp_mul_2d(&significandBig, shift, &significandBig); } } goto returnInteger; case HEXADECIMAL: /* * Returning a hex integer. Final scaling step. */ shift = 4 * numTrailZeros; if (!significandOverflow && significandWide !=0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { significandWide <<= shift; } else { mp_mul_2d(&significandBig, shift, &significandBig); } } goto returnInteger; case OCTAL: /* * Returning an octal integer. Final scaling step. */ shift = 3 * numTrailZeros; if (!octalSignificandOverflow && octalSignificandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || octalSignificandWide > (MOST_BITS + signum) >> shift)) { octalSignificandOverflow = 1; TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } if (shift) { if (!octalSignificandOverflow) { octalSignificandWide <<= shift; } else { mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); } } if (!octalSignificandOverflow) { if (octalSignificandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { #ifndef TCL_WIDE_INT_IS_LONG if (octalSignificandWide <= (MOST_BITS + signum)) { objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; } else { objPtr->internalRep.wideValue = (Tcl_WideInt) octalSignificandWide; } break; } #endif TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.longValue = - (long) octalSignificandWide; } else { objPtr->internalRep.longValue = (long) octalSignificandWide; } } } if (octalSignificandOverflow) { if (signum) { mp_neg(&octalSignificandBig, &octalSignificandBig); } TclSetBignumIntRep(objPtr, &octalSignificandBig); } break; case ZERO: case DECIMAL: significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1, &significandWide, &significandBig, significandOverflow); if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { if (significandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { #ifndef TCL_WIDE_INT_IS_LONG if (significandWide <= MOST_BITS+signum) { objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; } else { objPtr->internalRep.wideValue = (Tcl_WideInt) significandWide; } break; } #endif TclBNInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.longValue = - (long) significandWide; } else { objPtr->internalRep.longValue = (long) significandWide; } } } if (significandOverflow) { if (signum) { mp_neg(&significandBig, &significandBig); } TclSetBignumIntRep(objPtr, &significandBig); } break; case FRACTION: case EXPONENT: /* * Here, we're parsing a floating-point number. 'significandWide' * or 'significandBig' contains the exact significand, according * to whether 'significandOverflow' is set. The desired floating * point value is significand * 10**k, where * k = numTrailZeros+exponent-numDigitsAfterDp. */ objPtr->typePtr = &tclDoubleType; if (exponentSignum) { exponent = -exponent; } if (!significandOverflow) { objPtr->internalRep.doubleValue = MakeLowPrecisionDouble( signum, significandWide, numSigDigs, numTrailZeros + exponent - numDigitsAfterDp); } else { objPtr->internalRep.doubleValue = MakeHighPrecisionDouble( signum, &significandBig, numSigDigs, numTrailZeros + exponent - numDigitsAfterDp); } break; case sINF: case sINFINITY: if (signum) { objPtr->internalRep.doubleValue = -HUGE_VAL; } else { objPtr->internalRep.doubleValue = HUGE_VAL; } objPtr->typePtr = &tclDoubleType; break; #ifdef IEEE_FLOATING_POINT case sNAN: case sNANFINISH: objPtr->internalRep.doubleValue = MakeNaN(signum,significandWide); objPtr->typePtr = &tclDoubleType; break; #endif case INITIAL: /* This case only to silence compiler warning. */ Tcl_Panic("TclParseNumber: state INITIAL can't happen here"); } } /* * Format an error message when an invalid number is encountered. */ if (status != TCL_OK) { if (interp != NULL) { Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"", expected); Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); if (state == BAD_OCTAL) { Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1); } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); } } /* * Free memory. */ if (octalSignificandOverflow) { mp_clear(&octalSignificandBig); } if (significandOverflow) { mp_clear(&significandBig); } return status; } /* *---------------------------------------------------------------------- * * AccumulateDecimalDigit -- * * Consume a decimal digit in a number being scanned. * * Results: * Returns 1 if the number has overflowed to a bignum, 0 if it still fits * in a wide integer. * * Side effects: * Updates either the wide or bignum representation. * *---------------------------------------------------------------------- */ static int AccumulateDecimalDigit( unsigned digit, /* Digit being scanned. */ int numZeros, /* Count of zero digits preceding the digit * being scanned. */ Tcl_WideUInt *wideRepPtr, /* Representation of the partial number as a * wide integer. */ mp_int *bignumRepPtr, /* Representation of the partial number as a * bignum. */ int bignumFlag) /* Flag == 1 if the number overflowed previous * to this digit. */ { int i, n; Tcl_WideUInt w; /* * Try wide multiplication first. */ if (!bignumFlag) { w = *wideRepPtr; if (w == 0) { /* * There's no need to multiply if the multiplicand is zero. */ *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { /* * Wide multiplication will overflow. Expand the number to a * bignum and fall through into the bignum case. */ TclBNInitBignumFromWideUInt(bignumRepPtr, w); } else { /* * Wide multiplication. */ *wideRepPtr = w * pow10_wide[numZeros+1] + digit; return 0; } } /* * Bignum multiplication. */ if (numZeros < log10_DIGIT_MAX) { /* * Up to about 8 zeros - single digit multiplication. */ mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1], bignumRepPtr); mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr); } else { /* * More than single digit multiplication. Multiply by the appropriate * small powers of 5, and then shift. Large strings of zeroes are * eaten 256 at a time; this is less efficient than it could be, but * seems implausible. We presume that DIGIT_BIT is at least 27. The * first multiplication, by up to 10**7, is done with a one-DIGIT * multiply (this presumes that DIGIT_BIT >= 24). */ n = numZeros + 1; mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr); for (i=3; i<=7; ++i) { if (n & (1 << i)) { mp_mul(bignumRepPtr, pow5+i, bignumRepPtr); } } while (n >= 256) { mp_mul(bignumRepPtr, pow5+8, bignumRepPtr); n -= 256; } mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr); mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr); } return 1; } /* *---------------------------------------------------------------------- * * MakeLowPrecisionDouble -- * * Makes the double precision number, signum*significand*10**exponent. * * Results: * Returns the constructed number. * * Common cases, where there are few enough digits that the number can be * represented with at most roundoff, are handled specially here. If the * number requires more than one rounded operation to compute, the code * promotes the significand to a bignum and calls MakeHighPrecisionDouble * to do it instead. * *---------------------------------------------------------------------- */ static double MakeLowPrecisionDouble( int signum, /* 1 if the number is negative, 0 otherwise */ Tcl_WideUInt significand, /* Significand of the number. */ int numSigDigs, /* Number of digits in the significand. */ int exponent) /* Power of ten. */ { double retval; /* Value of the number. */ mp_int significandBig; /* Significand expressed as a bignum. */ /* * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 * ulp, so we need to change rounding mode to 53-bits. */ TCL_IEEE_DOUBLE_ROUNDING; /* * Test for the easy cases. */ if (numSigDigs <= QUICK_MAX) { if (exponent >= 0) { if (exponent <= mmaxpow) { /* * The significand is an exact integer, and so is * 10**exponent. The product will be correct to within 1/2 ulp * without special handling. */ retval = (double) ((Tcl_WideInt)significand * pow10vals[exponent]); goto returnValue; } else { int diff = QUICK_MAX - numSigDigs; if (exponent-diff <= mmaxpow) { /* * 10**exponent is not an exact integer, but * 10**(exponent-diff) is exact, and so is * significand*10**diff, so we can still compute the value * with only one roundoff. */ volatile double factor = (double) ((Tcl_WideInt)significand * pow10vals[diff]); retval = factor * pow10vals[exponent-diff]; goto returnValue; } } } else { if (exponent >= -mmaxpow) { /* * 10**-exponent is an exact integer, and so is the * significand. Compute the result by one division, again with * only one rounding. */ retval = (double) ((Tcl_WideInt)significand / pow10vals[-exponent]); goto returnValue; } } } /* * All the easy cases have failed. Promote ths significand to bignum and * call MakeHighPrecisionDouble to do it the hard way. */ TclBNInitBignumFromWideUInt(&significandBig, significand); retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs, exponent); mp_clear(&significandBig); /* * Come here to return the computed value. */ returnValue: if (signum) { retval = -retval; } /* * On gcc on x86, restore the floating point mode word. */ TCL_DEFAULT_DOUBLE_ROUNDING; return retval; } /* *---------------------------------------------------------------------- * * MakeHighPrecisionDouble -- * * Makes the double precision number, signum*significand*10**exponent. * * Results: * Returns the constructed number. * * MakeHighPrecisionDouble is used when arbitrary-precision arithmetic is * needed to ensure correct rounding. It begins by calculating a * low-precision approximation to the desired number, and then refines * the answer in high precision. * *---------------------------------------------------------------------- */ static double MakeHighPrecisionDouble( int signum, /* 1=negative, 0=nonnegative. */ mp_int *significand, /* Exact significand of the number. */ int numSigDigs, /* Number of significant digits. */ int exponent) /* Power of 10 by which to multiply. */ { double retval; int machexp; /* Machine exponent of a power of 10. */ /* * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 * ulp, so we need to change rounding mode to 53-bits. */ TCL_IEEE_DOUBLE_ROUNDING; /* * Quick checks for over/underflow. */ if (numSigDigs+exponent-1 > maxDigits) { retval = HUGE_VAL; goto returnValue; } if (numSigDigs+exponent-1 < minDigits) { retval = 0; goto returnValue; } /* * Develop a first approximation to the significand. It is tempting simply * to force bignum to double, but that will overflow on input numbers like * 1.[string repeat 0 1000]1; while this is a not terribly likely * scenario, we still have to deal with it. Use fraction and exponent * instead. Once we have the significand, multiply by 10**exponent. Test * for overflow. Convert back to a double, and test for underflow. */ retval = BignumToBiasedFrExp(significand, &machexp); retval = Pow10TimesFrExp(exponent, retval, &machexp); if (machexp > DBL_MAX_EXP*log2FLT_RADIX) { retval = HUGE_VAL; goto returnValue; } retval = SafeLdExp(retval, machexp); if (tiny == 0.0) { tiny = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits); } if (retval < tiny) { retval = tiny; } /* * Refine the result twice. (The second refinement should be necessary * only if the best approximation is a power of 2 minus 1/2 ulp). */ retval = RefineApproximation(retval, significand, exponent); retval = RefineApproximation(retval, significand, exponent); /* * Come here to return the computed value. */ returnValue: if (signum) { retval = -retval; } /* * On gcc on x86, restore the floating point mode word. */ TCL_DEFAULT_DOUBLE_ROUNDING; return retval; } /* *---------------------------------------------------------------------- * * MakeNaN -- * * Makes a "Not a Number" given a set of bits to put in the tag bits * * Note that a signalling NaN is never returned. * *---------------------------------------------------------------------- */ #ifdef IEEE_FLOATING_POINT static double MakeNaN( int signum, /* Sign bit (1=negative, 0=nonnegative. */ Tcl_WideUInt tags) /* Tag bits to put in the NaN. */ { union { Tcl_WideUInt iv; double dv; } theNaN; theNaN.iv = tags; theNaN.iv &= (((Tcl_WideUInt) 1) << 51) - 1; if (signum) { theNaN.iv |= ((Tcl_WideUInt) (0x8000 | NAN_START)) << 48; } else { theNaN.iv |= ((Tcl_WideUInt) NAN_START) << 48; } if (n770_fp) { theNaN.iv = Nokia770Twiddle(theNaN.iv); } return theNaN.dv; } #endif /* *---------------------------------------------------------------------- * * RefineApproximation -- * * Given a poor approximation to a floating point number, returns a * better one. (The better approximation is correct to within 1 ulp, and * is entirely correct if the poor approximation is correct to 1 ulp.) * * Results: * Returns the improved result. * *---------------------------------------------------------------------- */ static double RefineApproximation( double approxResult, /* Approximate result of conversion. */ mp_int *exactSignificand, /* Integer significand. */ int exponent) /* Power of 10 to multiply by significand. */ { int M2, M5; /* Powers of 2 and of 5 needed to put the * decimal and binary numbers over a common * denominator. */ double significand; /* Sigificand of the binary number. */ int binExponent; /* Exponent of the binary number. */ int msb; /* Most significant bit position of an * intermediate result. */ int nDigits; /* Number of mp_digit's in an intermediate * result. */ mp_int twoMv; /* Approx binary value expressed as an exact * integer scaled by the multiplier 2M. */ mp_int twoMd; /* Exact decimal value expressed as an exact * integer scaled by the multiplier 2M. */ int scale; /* Scale factor for M. */ int multiplier; /* Power of two to scale M. */ double num, den; /* Numerator and denominator of the correction * term. */ double quot; /* Correction term. */ double minincr; /* Lower bound on the absolute value of the * correction term. */ int roundToEven = 0; /* Flag == TRUE if we need to invoke * "round to even" functionality */ double rteSignificand; /* Significand of the round-to-even result */ int rteExponent; /* Exponent of the round-to-even result */ Tcl_WideInt rteSigWide; /* Wide integer version of the significand * for testing evenness */ int i; /* * The first approximation is always low. If we find that it's HUGE_VAL, * we're done. */ if (approxResult == HUGE_VAL) { return approxResult; } /* * Find a common denominator for the decimal and binary fractions. The * common denominator will be 2**M2 + 5**M5. */ significand = frexp(approxResult, &binExponent); i = mantBits - binExponent; if (i < 0) { M2 = 0; } else { M2 = i; } if (exponent > 0) { M5 = 0; } else { M5 = -exponent; if (M5 - 1 > M2) { M2 = M5 - 1; } } /* * The floating point number is significand*2**binExponent. Compute the * large integer significand*2**(binExponent+M2+1). The 2**-1 bit of the * significand (the most significant) corresponds to the * 2**(binExponent+M2 + 1) bit of 2*M2*v. Allocate enough digits to hold * that quantity, then convert the significand to a large integer, scaled * appropriately. Then multiply by the appropriate power of 5. */ msb = binExponent + M2; /* 1008 */ nDigits = msb / DIGIT_BIT + 1; mp_init_size(&twoMv, nDigits); i = (msb % DIGIT_BIT + 1); twoMv.used = nDigits; significand *= SafeLdExp(1.0, i); while (--nDigits >= 0) { twoMv.dp[nDigits] = (mp_digit) significand; significand -= (mp_digit) significand; significand = SafeLdExp(significand, DIGIT_BIT); } for (i = 0; i <= 8; ++i) { if (M5 & (1 << i)) { mp_mul(&twoMv, pow5+i, &twoMv); } } /* * Collect the decimal significand as a high precision integer. The least * significant bit corresponds to bit M2+exponent+1 so it will need to be * shifted left by that many bits after being multiplied by * 5**(M5+exponent). */ mp_init_copy(&twoMd, exactSignificand); for (i=0; i<=8; ++i) { if ((M5 + exponent) & (1 << i)) { mp_mul(&twoMd, pow5+i, &twoMd); } } mp_mul_2d(&twoMd, M2+exponent+1, &twoMd); mp_sub(&twoMd, &twoMv, &twoMd); /* * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction * term. Because 2M may well overflow a double, we need to scale the * denominator by a factor of 2**binExponent-mantBits. */ scale = binExponent - mantBits - 1; mp_set(&twoMv, 1); for (i=0; i<=8; ++i) { if (M5 & (1 << i)) { mp_mul(&twoMv, pow5+i, &twoMv); } } multiplier = M2 + scale + 1; if (multiplier > 0) { mp_mul_2d(&twoMv, multiplier, &twoMv); } else if (multiplier < 0) { mp_div_2d(&twoMv, -multiplier, &twoMv, NULL); } switch (mp_cmp_mag(&twoMd, &twoMv)) { case MP_LT: /* * If the result is less than unity, the error is less than 1/2 unit in * the last place, so there's no correction to make. */ mp_clear(&twoMd); mp_clear(&twoMv); return approxResult; case MP_EQ: /* * If the result is exactly unity, we need to round to even. */ roundToEven = 1; break; case MP_GT: break; } if (roundToEven) { rteSignificand = frexp(approxResult, &rteExponent); rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION); if ((rteSigWide & 1) == 0) { return approxResult; } } /* * Convert the numerator and denominator of the corrector term accurately * to floating point numbers. */ num = TclBignumToDouble(&twoMd); den = TclBignumToDouble(&twoMv); quot = SafeLdExp(num/den, scale); minincr = SafeLdExp(1.0, binExponent-mantBits); if (quot<0. && quot>-minincr) { quot = -minincr; } else if (quot>0. && quot>= 1; ++r; } if (p != result) { mp_copy(p, result); } } /* *---------------------------------------------------------------------- * * NormalizeRightward -- * * Shifts a number rightward until it is odd (that is, until the least * significant bit is nonzero. * * Results: * Returns the number of bit positions by which the number was shifted. * * Side effects: * Shifts the number in place; *wPtr is replaced by the shifted number. * *---------------------------------------------------------------------- */ inline static int NormalizeRightward( Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ { int rv = 0; Tcl_WideUInt w = *wPtr; if (!(w & (Tcl_WideUInt) 0xffffffff)) { w >>= 32; rv += 32; } if (!(w & (Tcl_WideUInt) 0xffff)) { w >>= 16; rv += 16; } if (!(w & (Tcl_WideUInt) 0xff)) { w >>= 8; rv += 8; } if (!(w & (Tcl_WideUInt) 0xf)) { w >>= 4; rv += 4; } if (!(w & 0x3)) { w >>= 2; rv += 2; } if (!(w & 0x1)) { w >>= 1; ++rv; } *wPtr = w; return rv; } /* *---------------------------------------------------------------------- * * RequiredPrecision -- * * Determines the number of bits needed to hold an intger. * * Results: * Returns the position of the most significant bit (0 - 63). Returns 0 * if the number is zero. * *---------------------------------------------------------------------- */ static int RequiredPrecision( Tcl_WideUInt w) /* Number to interrogate. */ { int rv; unsigned long wi; if (w & ((Tcl_WideUInt) 0xffffffff << 32)) { wi = (unsigned long) (w >> 32); rv = 32; } else { wi = (unsigned long) w; rv = 0; } if (wi & 0xffff0000) { wi >>= 16; rv += 16; } if (wi & 0xff00) { wi >>= 8; rv += 8; } if (wi & 0xf0) { wi >>= 4; rv += 4; } if (wi & 0xc) { wi >>= 2; rv += 2; } if (wi & 0x2) { wi >>= 1; ++rv; } if (wi & 0x1) { ++rv; } return rv; } /* *---------------------------------------------------------------------- * * DoubleToExpAndSig -- * * Separates a 'double' into exponent and significand. * * Side effects: * Stores the significand in '*significand' and the exponent in '*expon' * so that dv == significand * 2.0**expon, and significand is odd. Also * stores the position of the leftmost 1-bit in 'significand' in 'bits'. * *---------------------------------------------------------------------- */ inline static void DoubleToExpAndSig( double dv, /* Number to convert. */ Tcl_WideUInt *significand, /* OUTPUT: Significand of the number. */ int *expon, /* OUTPUT: Exponent to multiply the number * by. */ int *bits) /* OUTPUT: Number of significant bits. */ { Double d; /* Number being converted. */ Tcl_WideUInt z; /* Significand under construction. */ int de; /* Exponent of the number. */ int k; /* Bit count. */ d.d = dv; /* * Extract exponent and significand. */ de = (d.w.word0 & EXP_MASK) >> EXP_SHIFT; z = d.q & SIG_MASK; if (de != 0) { z |= HIDDEN_BIT; k = NormalizeRightward(&z); *bits = FP_PRECISION - k; *expon = k + (de - EXPONENT_BIAS) - (FP_PRECISION-1); } else { k = NormalizeRightward(&z); *expon = k + (de - EXPONENT_BIAS) - (FP_PRECISION-1) + 1; *bits = RequiredPrecision(z); } *significand = z; } /* *---------------------------------------------------------------------- * * TakeAbsoluteValue -- * * Takes the absolute value of a 'double' including 0, Inf and NaN * * Side effects: * The 'double' in *d is replaced with its absolute value. The signum is * stored in 'sign': 1 for negative, 0 for nonnegative. * *---------------------------------------------------------------------- */ inline static void TakeAbsoluteValue( Double *d, /* Number to replace with absolute value. */ int *sign) /* Place to put the signum. */ { if (d->w.word0 & SIGN_BIT) { *sign = 1; d->w.word0 &= ~SIGN_BIT; } else { *sign = 0; } } /* *---------------------------------------------------------------------- * * FormatInfAndNaN -- * * Bailout for formatting infinities and Not-A-Number. * * Results: * Returns one of the strings 'Infinity' and 'NaN'. The string returned * must be freed by the caller using 'ckfree'. * * Side effects: * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating * NUL byte of the string if 'endPtr' is not NULL. * *---------------------------------------------------------------------- */ inline static char * FormatInfAndNaN( Double *d, /* Exceptional number to format. */ int *decpt, /* Decimal point to set to a bogus value. */ char **endPtr) /* Pointer to the end of the formatted data */ { char *retval; *decpt = 9999; if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { retval = ckalloc(9); strcpy(retval, "Infinity"); if (endPtr) { *endPtr = retval + 8; } } else { retval = ckalloc(4); strcpy(retval, "NaN"); if (endPtr) { *endPtr = retval + 3; } } return retval; } /* *---------------------------------------------------------------------- * * FormatZero -- * * Bailout to format a zero floating-point number. * * Results: * Returns the constant string "0" * * Side effects: * Stores 1 in '*decpt' and puts a pointer to the NUL byte terminating * the string in '*endPtr' if 'endPtr' is not NULL. * *---------------------------------------------------------------------- */ inline static char * FormatZero( int *decpt, /* Location of the decimal point. */ char **endPtr) /* Pointer to the end of the formatted data */ { char *retval = ckalloc(2); strcpy(retval, "0"); if (endPtr) { *endPtr = retval+1; } *decpt = 0; return retval; } /* *---------------------------------------------------------------------- * * ApproximateLog10 -- * * Computes a two-term Taylor series approximation to the common log of a * number, and computes the number's binary log. * * Results: * Return an approximation to floor(log10(bw*2**be)) that is either exact * or 1 too high. * *---------------------------------------------------------------------- */ inline static int ApproximateLog10( Tcl_WideUInt bw, /* Integer significand of the number. */ int be, /* Power of two to scale bw. */ int bbits) /* Number of bits of precision in bw. */ { int i; /* Log base 2 of the number. */ int k; /* Floor(Log base 10 of the number) */ double ds; /* Mantissa of the number. */ Double d2; /* * Compute i and d2 such that d = d2*2**i, and 1 < d2 < 2. * Compute an approximation to log10(d), * log10(d) ~ log10(2) * i + log10(1.5) * + (significand-1.5)/(1.5 * log(10)) */ d2.q = bw << (FP_PRECISION - bbits) & SIG_MASK; d2.w.word0 |= (EXPONENT_BIAS) << EXP_SHIFT; i = be + bbits - 1; ds = (d2.d - 1.5) * TWO_OVER_3LOG10 + LOG10_3HALVES_PLUS_FUDGE + LOG10_2 * i; k = (int) ds; if (k > ds) { --k; } return k; } /* *---------------------------------------------------------------------- * * BetterLog10 -- * * Improves the result of ApproximateLog10 for numbers in the range * 1 .. 10**(TEN_PMAX)-1 * * Side effects: * Sets k_check to 0 if the new result is known to be exact, and to 1 if * it may still be one too high. * * Results: * Returns the improved approximation to log10(d). * *---------------------------------------------------------------------- */ inline static int BetterLog10( double d, /* Original number to format. */ int k, /* Characteristic(Log base 10) of the * number. */ int *k_check) /* Flag == 1 if k is inexact. */ { /* * Performance hack. If k is in the range 0..TEN_PMAX, then we can use a * powers-of-ten table to check it. */ if (k >= 0 && k <= TEN_PMAX) { if (d < tens[k]) { k--; } *k_check = 0; } else { *k_check = 1; } return k; } /* *---------------------------------------------------------------------- * * ComputeScale -- * * Prepares to format a floating-point number as decimal. * * Parameters: * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. The * significand of x requires bbits bits to represent. * * Results: * Determines integers b2, b5, s2, s5 so that sig*2**b2*5**b5/2**s2*2**s5 * exactly represents the value of the x/10**k. This value will lie in * the range [1 .. 10), and allows for computing successive digits by * multiplying sig%10 by 10. * *---------------------------------------------------------------------- */ inline static void ComputeScale( int be, /* Exponent part of number: d = bw * 2**be. */ int k, /* Characteristic of log10(number). */ int *b2, /* OUTPUT: Power of 2 in the numerator. */ int *b5, /* OUTPUT: Power of 5 in the numerator. */ int *s2, /* OUTPUT: Power of 2 in the denominator. */ int *s5) /* OUTPUT: Power of 5 in the denominator. */ { /* * Scale numerator and denominator powers of 2 so that the input binary * number is the ratio of integers. */ if (be <= 0) { *b2 = 0; *s2 = -be; } else { *b2 = be; *s2 = 0; } /* * Scale numerator and denominator so that the output decimal number is * the ratio of integers. */ if (k >= 0) { *b5 = 0; *s5 = k; *s2 += k; } else { *b2 -= k; *b5 = -k; *s5 = 0; } } /* *---------------------------------------------------------------------- * * SetPrecisionLimits -- * * Determines how many digits of significance should be computed (and, * hence, how much memory need be allocated) for formatting a floating * point number. * * Given that 'k' is floor(log10(x)): * if 'shortest' format is used, there will be at most 18 digits in the * result. * if 'F' format is used, there will be at most 'ndigits' + k + 1 digits * if 'E' format is used, there will be exactly 'ndigits' digits. * * Side effects: * Adjusts '*ndigitsPtr' to have a valid value. Stores the maximum memory * allocation needed in *iPtr. Sets '*iLimPtr' to the limiting number of * digits to convert if k has been guessed correctly, and '*iLim1Ptr' to * the limiting number of digits to convert if k has been guessed to be * one too high. * *---------------------------------------------------------------------- */ inline static void SetPrecisionLimits( int convType, /* Type of conversion: TCL_DD_SHORTEST, * TCL_DD_STEELE0, TCL_DD_E_FMT, * TCL_DD_F_FMT. */ int k, /* Floor(log10(number to convert)) */ int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be * adjusted if needed). */ int *iPtr, /* OUT: Maximum number of digits to return. */ int *iLimPtr, /* OUT: Number of digits of significance if * the bignum method is used.*/ int *iLim1Ptr) /* OUT: Number of digits of significance if * the quick method is used. */ { switch (convType) { case TCL_DD_SHORTEST0: case TCL_DD_STEELE0: *iLimPtr = *iLim1Ptr = -1; *iPtr = 18; *ndigitsPtr = 0; break; case TCL_DD_E_FORMAT: if (*ndigitsPtr <= 0) { *ndigitsPtr = 1; } *iLimPtr = *iLim1Ptr = *iPtr = *ndigitsPtr; break; case TCL_DD_F_FORMAT: *iPtr = *ndigitsPtr + k + 1; *iLimPtr = *iPtr; *iLim1Ptr = *iPtr - 1; if (*iPtr <= 0) { *iPtr = 1; } break; default: *iPtr = -1; *iLimPtr = -1; *iLim1Ptr = -1; Tcl_Panic("impossible conversion type in TclDoubleDigits"); } } /* *---------------------------------------------------------------------- * * BumpUp -- * * Increases a string of digits ending in a series of nines to designate * the next higher number. xxxxb9999... -> xxxx(b+1)0000... * * Results: * Returns a pointer to the end of the adjusted string. * * Side effects: * In the case that the string consists solely of '999999', sets it to * "1" and moves the decimal point (*kPtr) one place to the right. * *---------------------------------------------------------------------- */ inline static char * BumpUp( char *s, /* Cursor pointing one past the end of the * string. */ char *retval, /* Start of the string of digits. */ int *kPtr) /* Position of the decimal point. */ { while (*--s == '9') { if (s == retval) { ++(*kPtr); *s = '1'; return s+1; } } ++*s; ++s; return s; } /* *---------------------------------------------------------------------- * * AdjustRange -- * * Rescales a 'double' in preparation for formatting it using the 'quick' * double-to-string method. * * Results: * Returns the precision that has been lost in the prescaling as a count * of units in the least significant place. * *---------------------------------------------------------------------- */ inline static int AdjustRange( double *dPtr, /* INOUT: Number to adjust. */ int k) /* IN: floor(log10(d)) */ { int ieps; /* Number of roundoff errors that have * accumulated. */ double d = *dPtr; /* Number to adjust. */ double ds; int i, j, j1; ieps = 2; if (k > 0) { /* * The number must be reduced to bring it into range. */ ds = tens[k & 0xf]; j = k >> 4; if (j & BLETCH) { j &= (BLETCH-1); d /= bigtens[N_BIGTENS - 1]; ieps++; } i = 0; for (; j != 0; j>>=1) { if (j & 1) { ds *= bigtens[i]; ++ieps; } ++i; } d /= ds; } else if ((j1 = -k) != 0) { /* * The number must be increased to bring it into range. */ d *= tens[j1 & 0xf]; i = 0; for (j = j1>>4; j; j>>=1) { if (j & 1) { ieps++; d *= bigtens[i]; } ++i; } } *dPtr = d; return ieps; } /* *---------------------------------------------------------------------- * * ShorteningQuickFormat -- * * Returns a 'quick' format of a double precision number to a string of * digits, preferring a shorter string of digits if the shorter string is * still within 1/2 ulp of the number. * * Results: * Returns the string of digits. Returns NULL if the 'quick' method fails * and the bignum method must be used. * * Side effects: * Stores the position of the decimal point at '*kPtr'. * *---------------------------------------------------------------------- */ inline static char * ShorteningQuickFormat( double d, /* Number to convert. */ int k, /* floor(log10(d)) */ int ilim, /* Number of significant digits to return. */ double eps, /* Estimated roundoff error. */ char *retval, /* Buffer to receive the digit string. */ int *kPtr) /* Pointer to stash the position of the * decimal point. */ { char *s = retval; /* Cursor in the return value. */ int digit; /* Current digit. */ int i; eps = 0.5 / tens[ilim-1] - eps; i = 0; for (;;) { /* * Convert a digit. */ digit = (int) d; d -= digit; *s++ = '0' + digit; /* * Truncate the conversion if the string of digits is within 1/2 ulp * of the actual value. */ if (d < eps) { *kPtr = k; return s; } if ((1. - d) < eps) { *kPtr = k; return BumpUp(s, retval, kPtr); } /* * Bail out if the conversion fails to converge to a sufficiently * precise value. */ if (++i >= ilim) { return NULL; } /* * Bring the next digit to the integer part. */ eps *= 10; d *= 10.0; } } /* *---------------------------------------------------------------------- * * StrictQuickFormat -- * * Convert a double precision number of a string of a precise number of * digits, using the 'quick' double precision method. * * Results: * Returns the digit string, or NULL if the bignum method must be used to * do the formatting. * * Side effects: * Stores the position of the decimal point in '*kPtr'. * *---------------------------------------------------------------------- */ inline static char * StrictQuickFormat( double d, /* Number to convert. */ int k, /* floor(log10(d)) */ int ilim, /* Number of significant digits to return. */ double eps, /* Estimated roundoff error. */ char *retval, /* Start of the digit string. */ int *kPtr) /* Pointer to stash the position of the * decimal point. */ { char *s = retval; /* Cursor in the return value. */ int digit; /* Current digit of the answer. */ int i; eps *= tens[ilim-1]; i = 1; for (;;) { /* * Extract a digit. */ digit = (int) d; d -= digit; if (d == 0.0) { ilim = i; } *s++ = '0' + digit; /* * When the given digit count is reached, handle trailing strings of 0 * and 9. */ if (i == ilim) { if (d > 0.5 + eps) { *kPtr = k; return BumpUp(s, retval, kPtr); } else if (d < 0.5 - eps) { while (*--s == '0') { /* do nothing */ } s++; *kPtr = k; return s; } else { return NULL; } } /* * Advance to the next digit. */ ++i; d *= 10.0; } } /* *---------------------------------------------------------------------- * * QuickConversion -- * * Converts a floating point number the 'quick' way, when only a limited * number of digits is required and floating point arithmetic can * therefore be used for the intermediate results. * * Results: * Returns the converted string, or NULL if the bignum method must be * used. * *---------------------------------------------------------------------- */ inline static char * QuickConversion( double e, /* Number to format. */ int k, /* floor(log10(d)), approximately. */ int k_check, /* 0 if k is exact, 1 if it may be too high */ int flags, /* Flags passed to dtoa: * TCL_DD_SHORTEN_FLAG */ int len, /* Length of the return value. */ int ilim, /* Number of digits to store. */ int ilim1, /* Number of digits to store if we misguessed * k. */ int *decpt, /* OUTPUT: Location of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the terminal null * byte. */ { int ieps; /* Number of 1-ulp roundoff errors that have * accumulated in the calculation. */ Double eps; /* Estimated roundoff error. */ char *retval; /* Returned string. */ char *end; /* Pointer to the terminal null byte in the * returned string. */ volatile double d; /* Workaround for a bug in mingw gcc 3.4.5 */ /* * Bring d into the range [1 .. 10). */ ieps = AdjustRange(&e, k); d = e; /* * If the guessed value of k didn't get d into range, adjust it by one. If * that leaves us outside the range in which quick format is accurate, * bail out. */ if (k_check && d < 1. && ilim > 0) { if (ilim1 < 0) { return NULL; } ilim = ilim1; --k; d *= 10.0; ++ieps; } /* * Compute estimated roundoff error. */ eps.d = ieps * d + 7.; eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT; /* * Handle the peculiar case where the result has no significant digits. */ retval = ckalloc(len + 1); if (ilim == 0) { d -= 5.; if (d > eps.d) { *retval = '1'; *decpt = k; return retval; } else if (d < -eps.d) { *decpt = k; return retval; } else { ckfree(retval); return NULL; } } /* * Format the digit string. */ if (flags & TCL_DD_SHORTEN_FLAG) { end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt); } else { end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt); } if (end == NULL) { ckfree(retval); return NULL; } *end = '\0'; if (endPtr != NULL) { *endPtr = end; } return retval; } /* *---------------------------------------------------------------------- * * CastOutPowersOf2 -- * * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers of 2 * from numerator and denominator in preparation for the 'bignum' method * of floating point conversion. * *---------------------------------------------------------------------- */ inline static void CastOutPowersOf2( int *b2, /* Power of 2 to multiply the significand. */ int *m2, /* Power of 2 to multiply 1/2 ulp. */ int *s2) /* Power of 2 to multiply the common * denominator. */ { int i; if (*m2 > 0 && *s2 > 0) { /* Find the smallest power of 2 in the * numerator. */ if (*m2 < *s2) { /* Find the lowest common denominator. */ i = *m2; } else { i = *s2; } *b2 -= i; /* Reduce to lowest terms. */ *m2 -= i; *s2 -= i; } } /* *---------------------------------------------------------------------- * * ShorteningInt64Conversion -- * * Converts a double-precision number to the shortest string of digits * that reconverts exactly to the given number, or to 'ilim' digits if * that will yield a shorter result. The numerator and denominator in * David Gay's conversion algorithm are known to fit in Tcl_WideUInt, * giving considerably faster arithmetic than mp_int's. * * Results: * Returns the string of significant decimal digits, in newly allocated * memory * * Side effects: * Stores the location of the decimal point in '*decpt' and the location * of the terminal null byte in '*endPtr'. * *---------------------------------------------------------------------- */ inline static char * ShorteningInt64Conversion( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int m2plus, int m2minus, int m5, /* Scale factors for 1/2 ulp in the numerator * (will be different if bw == 1. */ int s2, int s5, /* Scale factors for the denominator. */ int k, /* Number of output digits before the decimal * point. */ int len, /* Number of digits to allocate. */ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { char *retval = ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; /* Denominator of the fraction being * converted. */ Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result is * within roundoff of being exact. */ int digit; /* Current output digit. */ char *s = retval; /* Cursor in the output buffer. */ int i; /* Current position in the output buffer. */ /* * Adjust if the logarithm was guessed wrong. */ if (b < S) { b = 10 * b; ++m2plus; ++m2minus; ++m5; ilim = ilim1; --k; } /* * Compute roundoff ranges. */ mplus = wuipow5[m5] << m2plus; mminus = wuipow5[m5] << m2minus; /* * Loop through the digits. */ i = 1; for (;;) { digit = (int)(b / S); if (digit > 10) { Tcl_Panic("wrong digit!"); } b = b % S; /* * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ if (b < mplus || (b == mplus && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. */ if (2 * b > S || (2 * b == S && (digit & 1) != 0)) { ++digit; if (digit == 10) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } } /* * Stash the current digit. */ *s++ = '0' + digit; break; } /* * Does one plus the current digit put us within roundoff of the * number? */ if (b > S - mminus || (b == S - mminus && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } ++digit; *s++ = '0' + digit; break; } /* * Have we converted all the requested digits? */ *s++ = '0' + digit; if (i == ilim) { if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); } break; } /* * Advance to the next digit. */ b = 10 * b; mplus = 10 * mplus; mminus = 10 * mminus; ++i; } /* * Endgame - store the location of the decimal point and the end of the * string. */ *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } return retval; } /* *---------------------------------------------------------------------- * * StrictInt64Conversion -- * * Converts a double-precision number to a fixed-length string of 'ilim' * digits that reconverts exactly to the given number. ('ilim' should be * replaced with 'ilim1' in the case where log10(d) has been * overestimated). The numerator and denominator in David Gay's * conversion algorithm are known to fit in Tcl_WideUInt, giving * considerably faster arithmetic than mp_int's. * * Results: * Returns the string of significant decimal digits, in newly allocated * memory * * Side effects: * Stores the location of the decimal point in '*decpt' and the location * of the terminal null byte in '*endPtr'. * *---------------------------------------------------------------------- */ inline static char * StrictInt64Conversion( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int s2, int s5, /* Scale factors for the denominator. */ int k, /* Number of output digits before the decimal * point. */ int len, /* Number of digits to allocate. */ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { char *retval = ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; /* Denominator of the fraction being * converted. */ int digit; /* Current output digit. */ char *s = retval; /* Cursor in the output buffer. */ int i; /* Current position in the output buffer. */ /* * Adjust if the logarithm was guessed wrong. */ if (b < S) { b = 10 * b; ilim = ilim1; --k; } /* * Loop through the digits. */ i = 1; for (;;) { digit = (int)(b / S); if (digit > 10) { Tcl_Panic("wrong digit!"); } b = b % S; /* * Have we converted all the requested digits? */ *s++ = '0' + digit; if (i == ilim) { if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); } else { while (*--s == '0') { /* do nothing */ } ++s; } break; } /* * Advance to the next digit. */ b = 10 * b; ++i; } /* * Endgame - store the location of the decimal point and the end of the * string. */ *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } return retval; } /* *---------------------------------------------------------------------- * * ShouldBankerRoundUpPowD -- * * Test whether bankers' rounding should round a digit up. Assumption is * made that the denominator of the fraction being tested is a power of * 2**DIGIT_BIT. * * Results: * Returns 1 iff the fraction is more than 1/2, or if the fraction is * exactly 1/2 and the digit is odd. * *---------------------------------------------------------------------- */ inline static int ShouldBankerRoundUpPowD( mp_int *b, /* Numerator of the fraction. */ int sd, /* Denominator is 2**(sd*DIGIT_BIT). */ int isodd) /* 1 if the digit is odd, 0 if even. */ { int i; static const mp_digit topbit = 1 << (DIGIT_BIT - 1); if (b->used < sd || (b->dp[sd-1] & topbit) == 0) { return 0; } if (b->dp[sd-1] != topbit) { return 1; } for (i = sd-2; i >= 0; --i) { if (b->dp[i] != 0) { return 1; } } return isodd; } /* *---------------------------------------------------------------------- * * ShouldBankerRoundUpToNextPowD -- * * Tests whether bankers' rounding will round down in the "denominator is * a power of 2**MP_DIGIT" case. * * Results: * Returns 1 if the rounding will be performed - which increases the * digit by one - and 0 otherwise. * *---------------------------------------------------------------------- */ inline static int ShouldBankerRoundUpToNextPowD( mp_int *b, /* Numerator of the fraction. */ mp_int *m, /* Numerator of the rounding tolerance. */ int sd, /* Common denominator is 2**(sd*DIGIT_BIT). */ int convType, /* Conversion type: STEELE defeats * round-to-even (not sure why one wants to do * this; I copied it from Gay). FIXME */ int isodd, /* 1 if the integer significand is odd. */ mp_int *temp) /* Work area for the calculation. */ { int i; /* * Compare B and S-m - which is the same as comparing B+m and S - which we * do by computing b+m and doing a bitwhack compare against * 2**(DIGIT_BIT*sd) */ mp_add(b, m, temp); if (temp->used <= sd) { /* Too few digits to be > s */ return 0; } if (temp->used > sd+1 || temp->dp[sd] > 1) { /* >= 2s */ return 1; } for (i = sd-1; i >= 0; --i) { /* Check for ==s */ if (temp->dp[i] != 0) { /* > s */ return 1; } } if (convType == TCL_DD_STEELE0) { /* Biased rounding. */ return 0; } return isodd; } /* *---------------------------------------------------------------------- * * ShorteningBignumConversionPowD -- * * Converts a double-precision number to the shortest string of digits * that reconverts exactly to the given number, or to 'ilim' digits if * that will yield a shorter result. The denominator in David Gay's * conversion algorithm is known to be a power of 2**DIGIT_BIT, and hence * the division in the main loop may be replaced by a digit shift and * mask. * * Results: * Returns the string of significant decimal digits, in newly allocated * memory * * Side effects: * Stores the location of the decimal point in '*decpt' and the location * of the terminal null byte in '*endPtr'. * *---------------------------------------------------------------------- */ inline static char * ShorteningBignumConversionPowD( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int m2plus, int m2minus, int m5, /* Scale factors for 1/2 ulp in the numerator * (will be different if bw == 1). */ int sd, /* Scale factor for the denominator. */ int k, /* Number of output digits before the decimal * point. */ int len, /* Number of digits to allocate. */ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { char *retval = ckalloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ mp_int mplus, mminus; /* Bounds for roundoff. */ mp_digit digit; /* Current output digit. */ char *s = retval; /* Cursor in the output buffer. */ int i; /* Index in the output buffer. */ mp_int temp; int r1; /* * b = bw * 2**b2 * 5**b5 * mminus = 5**m5 */ TclBNInitBignumFromWideUInt(&b, bw); mp_init_set_int(&mminus, 1); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); /* * Adjust if the logarithm was guessed wrong. */ if (b.used <= sd) { mp_mul_d(&b, 10, &b); ++m2plus; ++m2minus; ++m5; ilim = ilim1; --k; } /* * mminus = 5**m5 * 2**m2minus * mplus = 5**m5 * 2**m2plus */ mp_mul_2d(&mminus, m2minus, &mminus); MulPow5(&mminus, m5, &mminus); if (m2plus > m2minus) { mp_init_copy(&mplus, &mminus); mp_mul_2d(&mplus, m2plus-m2minus, &mplus); } mp_init(&temp); /* * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) * by mp_digit extraction. */ i = 0; for (;;) { if (b.used <= sd) { digit = 0; } else { digit = b.dp[sd]; if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } --b.used; mp_clamp(&b); } /* * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); if (r1 == MP_LT || (r1 == MP_EQ && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. */ if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { ++digit; if (digit == 10) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } } /* * Stash the last digit. */ *s++ = '0' + digit; break; } /* * Does one plus the current digit put us within roundoff of the * number? */ if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType, dPtr->w.word1 & 1, &temp)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } ++digit; *s++ = '0' + digit; break; } /* * Have we converted all the requested digits? */ *s++ = '0' + digit; if (i == ilim) { if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { s = BumpUp(s, retval, &k); } break; } /* * Advance to the next digit. */ mp_mul_d(&b, 10, &b); mp_mul_d(&mminus, 10, &mminus); if (m2plus > m2minus) { mp_mul_2d(&mminus, m2plus-m2minus, &mplus); } ++i; } /* * Endgame - store the location of the decimal point and the end of the * string. */ if (m2plus > m2minus) { mp_clear(&mplus); } mp_clear_multi(&b, &mminus, &temp, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } return retval; } /* *---------------------------------------------------------------------- * * StrictBignumConversionPowD -- * * Converts a double-precision number to a fixed-lengt string of 'ilim' * digits (or 'ilim1' if log10(d) has been overestimated). The * denominator in David Gay's conversion algorithm is known to be a power * of 2**DIGIT_BIT, and hence the division in the main loop may be * replaced by a digit shift and mask. * * Results: * Returns the string of significant decimal digits, in newly allocated * memory. * * Side effects: * Stores the location of the decimal point in '*decpt' and the location * of the terminal null byte in '*endPtr'. * *---------------------------------------------------------------------- */ inline static char * StrictBignumConversionPowD( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int sd, /* Scale factor for the denominator. */ int k, /* Number of output digits before the decimal * point. */ int len, /* Number of digits to allocate. */ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { char *retval = ckalloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ mp_digit digit; /* Current output digit. */ char *s = retval; /* Cursor in the output buffer. */ int i; /* Index in the output buffer. */ mp_int temp; /* * b = bw * 2**b2 * 5**b5 */ TclBNInitBignumFromWideUInt(&b, bw); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); /* * Adjust if the logarithm was guessed wrong. */ if (b.used <= sd) { mp_mul_d(&b, 10, &b); ilim = ilim1; --k; } mp_init(&temp); /* * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) * by mp_digit extraction. */ i = 1; for (;;) { if (b.used <= sd) { digit = 0; } else { digit = b.dp[sd]; if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } --b.used; mp_clamp(&b); } /* * Have we converted all the requested digits? */ *s++ = '0' + digit; if (i == ilim) { if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { s = BumpUp(s, retval, &k); } while (*--s == '0') { /* do nothing */ } ++s; break; } /* * Advance to the next digit. */ mp_mul_d(&b, 10, &b); ++i; } /* * Endgame - store the location of the decimal point and the end of the * string. */ mp_clear_multi(&b, &temp, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } return retval; } /* *---------------------------------------------------------------------- * * ShouldBankerRoundUp -- * * Tests whether a digit should be rounded up or down when finishing * bignum-based floating point conversion. * * Results: * Returns 1 if the number needs to be rounded up, 0 otherwise. * *---------------------------------------------------------------------- */ inline static int ShouldBankerRoundUp( mp_int *twor, /* 2x the remainder from thd division that * produced the last digit. */ mp_int *S, /* Denominator. */ int isodd) /* Flag == 1 if the last digit is odd. */ { int r = mp_cmp_mag(twor, S); switch (r) { case MP_LT: return 0; case MP_EQ: return isodd; case MP_GT: return 1; } Tcl_Panic("in ShouldBankerRoundUp, trichotomy fails!"); return 0; } /* *---------------------------------------------------------------------- * * ShouldBankerRoundUpToNext -- * * Tests whether the remainder is great enough to force rounding to the * next higher digit. * * Results: * Returns 1 if the number should be rounded up, 0 otherwise. * *---------------------------------------------------------------------- */ inline static int ShouldBankerRoundUpToNext( mp_int *b, /* Remainder from the division that produced * the last digit. */ mp_int *m, /* Numerator of the rounding tolerance. */ mp_int *S, /* Denominator. */ int convType, /* Conversion type: STEELE0 defeats * round-to-even. (Not sure why one would want * this; I coped it from Gay). FIXME */ int isodd, /* 1 if the integer significand is odd. */ mp_int *temp) /* Work area needed for the calculation. */ { int r; /* * Compare b and S-m: this is the same as comparing B+m and S. */ mp_add(b, m, temp); r = mp_cmp_mag(temp, S); switch(r) { case MP_LT: return 0; case MP_EQ: if (convType == TCL_DD_STEELE0) { return 0; } else { return isodd; } case MP_GT: return 1; } Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!"); return 0; } /* *---------------------------------------------------------------------- * * ShorteningBignumConversion -- * * Convert a floating point number to a variable-length digit string * using the multiprecision method. * * Results: * Returns the string of digits. * * Side effects: * Stores the position of the decimal point in *decpt. Stores a pointer * to the end of the number in *endPtr. * *---------------------------------------------------------------------- */ inline static char * ShorteningBignumConversion( Double *dPtr, /* Original number being converted. */ int convType, /* Conversion type. */ Tcl_WideUInt bw, /* Integer significand and exponent. */ int b2, /* Scale factor for the significand. */ int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */ int s2, int s5, /* Scale factors for denominator. */ int k, /* Guessed position of the decimal point. */ int len, /* Size of the digit buffer to allocate. */ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { char *retval = ckalloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ mp_int mminus; /* 1/2 ulp below the result. */ mp_int mplus; /* 1/2 ulp above the result. */ mp_int S; /* Denominator of the result. */ mp_int dig; /* Current digit of the result. */ int digit; /* Current digit of the result. */ mp_int temp; /* Work area. */ int minit = 1; /* Fudge factor for when we misguess k. */ int i; int r1; /* * b = bw * 2**b2 * 5**b5 * S = 2**s2 * 5*s5 */ TclBNInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set_int(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* * Handle the case where we guess the position of the decimal point wrong. */ if (mp_cmp_mag(&b, &S) == MP_LT) { mp_mul_d(&b, 10, &b); minit = 10; ilim =ilim1; --k; } /* * mminus = 2**m2minus * 5**m5 */ mp_init_set_int(&mminus, minit); mp_mul_2d(&mminus, m2minus, &mminus); if (m2plus > m2minus) { mp_init_copy(&mplus, &mminus); mp_mul_2d(&mplus, m2plus-m2minus, &mplus); } mp_init(&temp); /* * Loop through the digits. */ mp_init(&dig); i = 1; for (;;) { mp_div(&b, &S, &dig, &b); if (dig.used > 1 || dig.dp[0] >= 10) { Tcl_Panic("wrong digit!"); } digit = dig.dp[0]; /* * Does the current digit leave us with a remainder small enough to * round to it? */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); if (r1 == MP_LT || (r1 == MP_EQ && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { ++digit; if (digit == 10) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } } *s++ = '0' + digit; break; } /* * Does the current digit leave us with a remainder large enough to * commit to rounding up to the next higher digit? */ if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, dPtr->w.word1 & 1, &temp)) { ++digit; if (digit == 10) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } *s++ = '0' + digit; break; } /* * Have we converted all the requested digits? */ *s++ = '0' + digit; if (i == ilim) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { s = BumpUp(s, retval, &k); } break; } /* * Advance to the next digit. */ if (s5 > 0) { /* * Can possibly shorten the denominator. */ mp_mul_2d(&b, 1, &b); mp_mul_2d(&mminus, 1, &mminus); if (m2plus > m2minus) { mp_mul_2d(&mplus, 1, &mplus); } mp_div_d(&S, 5, &S, NULL); --s5; /* * IDEA: It might possibly be a win to fall back to int64 * arithmetic here if S < 2**64/10. But it's a win only for * a fairly narrow range of magnitudes so perhaps not worth * bothering. We already know that we shorten the * denominator by at least 1 mp_digit, perhaps 2, as we do * the conversion for 17 digits of significance. * Possible savings: * 10**26 1 trip through loop before fallback possible * 10**27 1 trip * 10**28 2 trips * 10**29 3 trips * 10**30 4 trips * 10**31 5 trips * 10**32 6 trips * 10**33 7 trips * 10**34 8 trips * 10**35 9 trips * 10**36 10 trips * 10**37 11 trips * 10**38 12 trips * 10**39 13 trips * 10**40 14 trips * 10**41 15 trips * 10**42 16 trips * thereafter no gain. */ } else { mp_mul_d(&b, 10, &b); mp_mul_d(&mminus, 10, &mminus); if (m2plus > m2minus) { mp_mul_2d(&mplus, 10, &mplus); } } ++i; } /* * Endgame - store the location of the decimal point and the end of the * string. */ if (m2plus > m2minus) { mp_clear(&mplus); } mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } return retval; } /* *---------------------------------------------------------------------- * * StrictBignumConversion -- * * Convert a floating point number to a fixed-length digit string using * the multiprecision method. * * Results: * Returns the string of digits. * * Side effects: * Stores the position of the decimal point in *decpt. Stores a pointer * to the end of the number in *endPtr. * *---------------------------------------------------------------------- */ inline static char * StrictBignumConversion( Double *dPtr, /* Original number being converted. */ int convType, /* Conversion type. */ Tcl_WideUInt bw, /* Integer significand and exponent. */ int b2, /* Scale factor for the significand. */ int s2, int s5, /* Scale factors for denominator. */ int k, /* Guessed position of the decimal point. */ int len, /* Size of the digit buffer to allocate. */ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { char *retval = ckalloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ mp_int S; /* Denominator of the result. */ mp_int dig; /* Current digit of the result. */ int digit; /* Current digit of the result. */ mp_int temp; /* Work area. */ int g; /* Size of the current digit ground. */ int i, j; /* * b = bw * 2**b2 * 5**b5 * S = 2**s2 * 5*s5 */ mp_init_multi(&temp, &dig, NULL); TclBNInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set_int(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* * Handle the case where we guess the position of the decimal point wrong. */ if (mp_cmp_mag(&b, &S) == MP_LT) { mp_mul_d(&b, 10, &b); ilim =ilim1; --k; } /* * Convert the leading digit. */ i = 0; mp_div(&b, &S, &dig, &b); if (dig.used > 1 || dig.dp[0] >= 10) { Tcl_Panic("wrong digit!"); } digit = dig.dp[0]; /* * Is a single digit all that was requested? */ *s++ = '0' + digit; if (++i >= ilim) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { s = BumpUp(s, retval, &k); } } else { for (;;) { /* * Shift by a group of digits. */ g = ilim - i; if (g > DIGIT_GROUP) { g = DIGIT_GROUP; } if (s5 >= g) { mp_div_d(&S, dpow5[g], &S, NULL); s5 -= g; } else if (s5 > 0) { mp_div_d(&S, dpow5[s5], &S, NULL); mp_mul_d(&b, dpow5[g - s5], &b); s5 = 0; } else { mp_mul_d(&b, dpow5[g], &b); } mp_mul_2d(&b, g, &b); /* * As with the shortening bignum conversion, it's possible at this * point that we will have reduced the denominator to less than * 2**64/10, at which point it would be possible to fall back to * to int64 arithmetic. But the potential payoff is tremendously * less - unless we're working in F format - because we know that * three groups of digits will always suffice for %#.17e, the * longest format that doesn't introduce empty precision. * * Extract the next group of digits. */ mp_div(&b, &S, &dig, &b); if (dig.used > 1) { Tcl_Panic("wrong digit!"); } digit = dig.dp[0]; for (j = g-1; j >= 0; --j) { int t = itens[j]; *s++ = digit / t + '0'; digit %= t; } i += g; /* * Have we converted all the requested digits? */ if (i == ilim) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { s = BumpUp(s, retval, &k); } break; } } } while (*--s == '0') { /* do nothing */ } ++s; /* * Endgame - store the location of the decimal point and the end of the * string. */ mp_clear_multi(&b, &S, &temp, &dig, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } return retval; } /* *---------------------------------------------------------------------- * * TclDoubleDigits -- * * Core of Tcl's conversion of double-precision floating point numbers to * decimal. * * Results: * Returns a newly-allocated string of digits. * * Side effects: * Sets *decpt to the index of the character in the string before the * place that the decimal point should go. If 'endPtr' is not NULL, sets * endPtr to point to the terminating '\0' byte of the string. Sets *sign * to 1 if a minus sign should be printed with the number, or 0 if a plus * sign (or no sign) should appear. * * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: * TCL_DD_SHORTEST - This is the default for floating point conversion if * ::tcl_precision is 0. It constructs the shortest string of * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. * TCL_DD_STEELE - This value is not recommended and may be removed in * the future. It follows the conversion algorithm outlined in * "How to Print Floating-Point Numbers Accurately" by Guy * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, * pp. 112-126]. This rule has the effect of rendering 1e23 as * 9.9999999999999999e22 - which is a 'better' approximation in * the sense that it will reconvert correctly even if a * subsequent input conversion is 'round up' or 'round down' * rather than 'round to nearest', but is surprising otherwise. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format * conversion (or for default floating->string if tcl_precision * is not 0). It constructs a string of at most 'ndigits' digits, * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it * also returns fewer digits if the shorter string will still * reconvert without loss to the given input number. In any case, * strings of trailing zeroes are suppressed. * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f format * conversion. It requests that conversion proceed until * 'ndigits' digits after the decimal point have been converted. * It is possible for this format to result in a zero-length * string if the number is sufficiently small. Again, it is * permissible for TCL_DD_F_FORMAT to return fewer digits for a * number that converts exactly, and changing the argument to * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow the routine * also to return fewer digits if the shorter string will still * reconvert without loss to the given input number. Strings of * trailing zeroes are suppressed. * * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag requires * all calculations to be done in exact arithmetic. Normally, E and F * format with fewer than about 14 digits will be done with a quick * floating point approximation and fall back on the exact arithmetic * only if the input number is close enough to the midpoint between two * decimal strings that more precision is needed to resolve which string * is correct. * * The value stored in the 'decpt' argument on return may be negative * (indicating that the decimal point falls to the left of the string) or * greater than the length of the string. In addition, the value -9999 is used * as a sentinel to indicate that the string is one of the special values * "Infinity" and "NaN", and that no decimal point should be inserted. * *---------------------------------------------------------------------- */ char * TclDoubleDigits( double dv, /* Number to convert. */ int ndigits, /* Number of digits requested. */ int flags, /* Conversion flags. */ int *decpt, /* OUTPUT: Position of the decimal point. */ int *sign, /* OUTPUT: 1 if the result is negative. */ char **endPtr) /* OUTPUT: If not NULL, receives a pointer to * one character beyond the end of the * returned string. */ { int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); /* Type of conversion being performed: * TCL_DD_SHORTEST0, TCL_DD_STEELE0, * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */ Double d; /* Union for deconstructing doubles. */ Tcl_WideUInt bw; /* Integer significand. */ int be; /* Power of 2 by which b must be multiplied */ int bbits; /* Number of bits needed to represent b. */ int denorm; /* Flag == 1 iff the input number was * denormalized. */ int k; /* Estimate of floor(log10(d)). */ int k_check; /* Flag == 1 if d is near enough to a power of * ten that k must be checked. */ int b2, b5, s2, s5; /* Powers of 2 and 5 in the numerator and * denominator of intermediate results. */ int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number to * convert if log10(d) has been * overestimated. */ char *retval; /* Return value from this function. */ int i = -1; /* * Put the input number into a union for bit-whacking. */ d.d = dv; /* * Handle the cases of negative numbers (by taking the absolute value: * this includes -Inf and -NaN!), infinity, Not a Number, and zero. */ TakeAbsoluteValue(&d, sign); if ((d.w.word0 & EXP_MASK) == EXP_MASK) { return FormatInfAndNaN(&d, decpt, endPtr); } if (d.d == 0.0) { return FormatZero(decpt, endPtr); } /* * Unpack the floating point into a wide integer and an exponent. * Determine the number of bits that the big integer requires, and compute * a quick approximation (which may be one too high) of ceil(log10(d.d)). */ denorm = ((d.w.word0 & EXP_MASK) == 0); DoubleToExpAndSig(d.d, &bw, &be, &bbits); k = ApproximateLog10(bw, be, bbits); k = BetterLog10(d.d, k, &k_check); /* At this point, we have: * d is the number to convert. * bw are significand and exponent: d == bw*2**be, * bbits is the length of bw: 2**bbits-1 <= bw < 2**bbits * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 if we * know that k is exactly ceil(log10(d)) and 1 if we need to check. * We want a rational number * r = b * 10**(1-k) = bw * 2**b2 * 5**b5 / (2**s2 / 5**s5), * with b2, b5, s2, s5 >= 0. Note that the most significant decimal * digit is floor(r) and that successive digits can be obtained by * setting r <- 10*floor(r) (or b <= 10 * (b % S)). Find appropriate * b2, b5, s2, s5. */ ComputeScale(be, k, &b2, &b5, &s2, &s5); /* * Correct an incorrect caller-supplied 'ndigits'. Also determine: * i = The maximum number of decimal digits that will be returned in the * formatted string. This is k + 1 + ndigits for F format, 18 for * shortest and Steele, and ndigits for E format. * ilim = The number of significant digits to convert if k has been * guessed correctly. This is -1 for shortest and Steele (which * stop when all significance has been lost), 'ndigits' for E * format, and 'k + 1 + ndigits' for F format. * ilim1 = The minimum number of significant digits to convert if k has * been guessed 1 too high. This, too, is -1 for shortest and * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F * format. */ SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); /* * Try to do low-precision conversion in floating point rather than * resorting to expensive multiprecision arithmetic. */ if (ilim >= 0 && ilim <= QUICK_MAX && !(flags & TCL_DD_NO_QUICK)) { retval = QuickConversion(d.d, k, k_check, flags, i, ilim, ilim1, decpt, endPtr); if (retval != NULL) { return retval; } } /* * For shortening conversions, determine the upper and lower bounds for * the remainder at which we can stop. * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the high * side, and * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the low * side. * We may need to increase s2 to put m2plus, m2minus, b2 over a common * denominator. */ if (flags & TCL_DD_SHORTEN_FLAG) { int m2minus = b2; int m2plus; int m5 = b5; int len = i; /* * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) is 1/2 unit * in the least significant place of the floating point number. */ if (denorm) { i = be + EXPONENT_BIAS + (FP_PRECISION-1); } else { i = 1 + FP_PRECISION - bbits; } b2 += i; s2 += i; /* * Reduce the fractions to lowest terms, since the above calculation * may have left excess powers of 2 in numerator and denominator. */ CastOutPowersOf2(&b2, &m2minus, &s2); /* * In the special case where bw==1, the nearest floating point number * to it on the low side is 1/4 ulp below it. Adjust accordingly. */ m2plus = m2minus; if (!denorm && bw == 1) { ++b2; ++s2; ++m2plus; } if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision * operations. (This will be true for all numbers in the range * [1.0e-3 .. 1.0e+24]). */ return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus, m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* * The denominator is a power of 2, so we can replace division by * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, * and adjust m2 and b2 accordingly. Then we launch into a version * of the comparison that's specialized for the 'power of mp_digit * in the denominator' case. */ if (s2 % DIGIT_BIT != 0) { int delta = DIGIT_BIT - (s2 % DIGIT_BIT); b2 += delta; m2plus += delta; m2minus += delta; s2 += delta; } return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* * Alas, there's no helpful special case; use full-up bignum * arithmetic for the conversion. */ return ShorteningBignumConversion(&d, convType, bw, b2, m2plus, m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } else { /* * Non-shortening conversion. */ int len = i; /* * Reduce numerator and denominator to lowest terms. */ if (b2 >= s2 && s2 > 0) { b2 -= s2; s2 = 0; } else if (s2 >= b2 && b2 > 0) { s2 -= b2; b2 = 0; } if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision * operations. */ return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* * The denominator is a power of 2, so we can replace division by * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, * and adjust m2 and b2 accordingly. Then we launch into a version * of the comparison that's specialized for the 'power of mp_digit * in the denominator' case. */ if (s2 % DIGIT_BIT != 0) { int delta = DIGIT_BIT - (s2 % DIGIT_BIT); b2 += delta; s2 += delta; } return StrictBignumConversionPowD(&d, convType, bw, b2, b5, s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* * There are no helpful special cases, but at least we know in * advance how many digits we will convert. We can run the * conversion in steps of DIGIT_GROUP digits, so as to have many * fewer mp_int divisions. */ return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } } /* *---------------------------------------------------------------------- * * TclInitDoubleConversion -- * * Initializes constants that are needed for conversions to and from * 'double' * * Results: * None. * * Side effects: * The log base 2 of the floating point radix, the number of bits in a * double mantissa, and a table of the powers of five and ten are * computed and stored. * *---------------------------------------------------------------------- */ void TclInitDoubleConversion(void) { int i; int x; Tcl_WideUInt u; double d; #ifdef IEEE_FLOATING_POINT union { double dv; Tcl_WideUInt iv; } bitwhack; #endif #if defined(__sgi) && defined(_COMPILER_VERSION) union fpc_csr mipsCR; mipsCR.fc_word = get_fpc_csr(); mipsCR.fc_struct.flush = 0; set_fpc_csr(mipsCR.fc_word); #endif /* * Initialize table of powers of 10 expressed as wide integers. */ maxpow10_wide = (int) floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.)); pow10_wide = ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); u = 1; for (i = 0; i < maxpow10_wide; ++i) { pow10_wide[i] = u; u *= 10; } pow10_wide[i] = u; /* * Determine how many bits of precision a double has, and how many decimal * digits that represents. */ if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) { Tcl_Panic("This code doesn't work on a decimal machine!"); } log2FLT_RADIX--; mantBits = DBL_MANT_DIG * log2FLT_RADIX; d = 1.0; /* * Initialize a table of powers of ten that can be exactly represented in * a double. */ x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log(5.0)); if (x < MAXPOW) { mmaxpow = x; } else { mmaxpow = MAXPOW; } for (i=0 ; i<=mmaxpow ; ++i) { pow10vals[i] = d; d *= 10.0; } /* * Initialize a table of large powers of five. */ for (i=0; i<9; ++i) { mp_init(pow5 + i); } mp_set(pow5, 5); for (i=0; i<8; ++i) { mp_sqr(pow5+i, pow5+i+1); } mp_init_set_int(pow5_13, 1220703125); for (i = 1; i < 5; ++i) { mp_init(pow5_13 + i); mp_sqr(pow5_13 + i - 1, pow5_13 + i); } /* * Determine the number of decimal digits to the left and right of the * decimal point in the largest and smallest double, the smallest double * that differs from zero, and the number of mp_digits needed to represent * the significand of a double. */ maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX) + 0.5 * log(10.)) / log(10.)); minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG) * log((double) FLT_RADIX) / log(10.)); log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.)); /* * Nokia 770's software-emulated floating point is "middle endian": the * bytes within a 32-bit word are little-endian (like the native * integers), but the two words of a 'double' are presented most * significant word first. */ #ifdef IEEE_FLOATING_POINT bitwhack.dv = 1.000000238418579; /* 3ff0 0000 4000 0000 */ if ((bitwhack.iv >> 32) == 0x3ff00000) { n770_fp = 0; } else if ((bitwhack.iv & 0xffffffff) == 0x3ff00000) { n770_fp = 1; } else { Tcl_Panic("unknown floating point word order on this machine"); } #endif } /* *---------------------------------------------------------------------- * * TclFinalizeDoubleConversion -- * * Cleans up this file on exit. * * Results: * None * * Side effects: * Memory allocated by TclInitDoubleConversion is freed. * *---------------------------------------------------------------------- */ void TclFinalizeDoubleConversion(void) { int i; ckfree(pow10_wide); for (i=0; i<9; ++i) { mp_clear(pow5 + i); } for (i=0; i < 5; ++i) { mp_clear(pow5_13 + i); } } /* *---------------------------------------------------------------------- * * Tcl_InitBignumFromDouble -- * * Extracts the integer part of a double and converts it to an arbitrary * precision integer. * * Results: * None. * * Side effects: * Initializes the bignum supplied, and stores the converted number in * it. * *---------------------------------------------------------------------- */ int Tcl_InitBignumFromDouble( Tcl_Interp *interp, /* For error message. */ double d, /* Number to convert. */ mp_int *b) /* Place to store the result. */ { double fract; int expt; /* * Infinite values can't convert to bignum. */ if (TclIsInfinite(d)) { if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } fract = frexp(d,&expt); if (expt <= 0) { mp_init(b); mp_zero(b); } else { Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; TclBNInitBignumFromWideInt(b, w); if (shift < 0) { mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { mp_mul_2d(b, shift, b); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclBignumToDouble -- * * Convert an arbitrary-precision integer to a native floating point * number. * * Results: * Returns the converted number. Sets errno to ERANGE if the number is * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble( const mp_int *a) /* Integer to convert. */ { mp_int b; int bits, shift, i, lsb; double r; /* * We need a 'mantBits'-bit significand. Determine what shift will * give us that. */ bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { errno = ERANGE; if (a->sign == MP_ZPOS) { return HUGE_VAL; } else { return -HUGE_VAL; } } shift = mantBits - bits; /* * If shift > 0, shift the significand left by the requisite number of * bits. If shift == 0, the significand is already exactly 'mantBits' * in length. If shift < 0, we will need to shift the significand right * by the requisite number of bits, and round it. If the '1-shift' * least significant bits are 0, but the 'shift'th bit is nonzero, * then the significand lies exactly between two values and must be * 'rounded to even'. */ mp_init(&b); if (shift == 0) { mp_copy(a, &b); } else if (shift > 0) { mp_mul_2d(a, shift, &b); } else if (shift < 0) { lsb = mp_cnt_lsb(a); if (lsb == -1-shift) { /* * Round to even */ mp_div_2d(a, -shift, &b, NULL); if (mp_isodd(&b)) { if (b.sign == MP_ZPOS) { mp_add_d(&b, 1, &b); } else { mp_sub_d(&b, 1, &b); } } } else { /* * Ordinary rounding */ mp_div_2d(a, -1-shift, &b, NULL); if (b.sign == MP_ZPOS) { mp_add_d(&b, 1, &b); } else { mp_sub_d(&b, 1, &b); } mp_div_2d(&b, 1, &b, NULL); } } /* * Accumulate the result, one mp_digit at a time. */ r = 0.0; for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, DIGIT_BIT) + b.dp[i]; } mp_clear(&b); /* * Scale the result to the correct number of bits. */ r = ldexp(r, bits - mantBits); /* * Return the result with the appropriate sign. */ if (a->sign == MP_ZPOS) { return r; } else { return -r; } } /* *---------------------------------------------------------------------- * * TclCeil -- * * Computes the smallest floating point number that is at least the * mp_int argument. * * Results: * Returns the floating point number. * *---------------------------------------------------------------------- */ double TclCeil( const mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); if (mp_cmp_d(a, 0) == MP_LT) { 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; } /* *---------------------------------------------------------------------- * * TclFloor -- * * Computes the largest floating point number less than or equal to the * mp_int argument. * * Results: * Returns the floating point value. * *---------------------------------------------------------------------- */ double TclFloor( const mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); if (mp_cmp_d(a, 0) == MP_LT) { 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 point * number in the range [0.5,1) times a power of two. NOTE: Intentionally * converts to a number that's a few ulp too small, so that * RefineApproximation will not overflow near the high end of the * machine's arithmetic range. * * Results: * Returns the converted number. * * Side effects: * Stores the exponent of two in 'machexp'. * *---------------------------------------------------------------------- */ static double BignumToBiasedFrExp( const mp_int *a, /* Integer to convert. */ int *machexp) /* Power of two. */ { mp_int b; int bits; int shift; int i; double r; /* * Determine how many bits we need, and extract that many from the input. * Round to nearest unit in the last place. */ bits = mp_count_bits(a); shift = mantBits - 2 - bits; mp_init(&b); 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); } /* * Accumulate the result, one mp_digit at a time. */ r = 0.0; for (i=b.used-1; i>=0; --i) { r = ldexp(r, DIGIT_BIT) + b.dp[i]; } mp_clear(&b); /* * Return the result with the appropriate sign. */ *machexp = bits - mantBits + 2; return ((a->sign == MP_ZPOS) ? r : -r); } /* *---------------------------------------------------------------------- * * Pow10TimesFrExp -- * * Multiply a power of ten by a number expressed as fraction and * exponent. * * Results: * Returns the significand of the result. * * Side effects: * Overwrites the 'machexp' parameter with the exponent of the result. * * Assumes that 'exponent' is such that 10**exponent would be a double, even * though 'fraction*10**(machexp+exponent)' might overflow. * *---------------------------------------------------------------------- */ static double Pow10TimesFrExp( int exponent, /* Power of 10 to multiply by. */ double fraction, /* Significand of multiplicand. */ int *machexp) /* On input, exponent of multiplicand. On * output, exponent of result. */ { int i, j; int expt = *machexp; double retval = fraction; if (exponent > 0) { /* * Multiply by 10**exponent. */ retval = frexp(retval * pow10vals[exponent&0xf], &j); expt += j; for (i=4; i<9; ++i) { if (exponent & (1<> 32) & 0xffffffff) | (w << 32)); } #endif /* *---------------------------------------------------------------------- * * TclNokia770Doubles -- * * Transpose the two words of a number for Nokia 770 floating point * handling. * *---------------------------------------------------------------------- */ int TclNokia770Doubles(void) { return n770_fp; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ '>2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 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 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 
/*
 * tclNamesp.c --
 *
 *	Contains support for namespaces, which provide a separate context of
 *	commands and global variables. The global :: namespace is the
 *	traditional Tcl "global" scope. Other namespaces are created as
 *	children of the global namespace. These other namespaces contain
 *	special-purpose commands and variables for packages.
 *
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2002-2005 Donal K. Fellows.
 * Copyright (c) 2006 Neil Madden.
 * Contributions from Don Porter, NIST, 2007. (not subject to US copyright)
 *
 * Originally implemented by
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclCompile.h" /* for TclLogCommandInfo visibility */

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.
 */

typedef struct ThreadSpecificData {
    long numNsCreated;		/* Count of the number of namespaces created
				 * within the thread. This value is used as a
				 * unique id for each namespace. Cannot be
				 * per-interp because the nsId is used to
				 * distinguish objects which can be passed
				 * around between interps in the same thread,
				 * but does not need to be global because
				 * object internal reps are always per-thread
				 * anyway. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * This structure contains a cached pointer to a namespace that is the result
 * of resolving the namespace's name in some other namespace. It is the
 * internal representation for a nsName object. It contains the pointer along
 * with some information that is used to check the cached pointer's validity.
 */

typedef struct ResolvedNsName {
    Namespace *nsPtr;		/* A cached pointer to the Namespace that the
				 * name resolved to. */
    Namespace *refNsPtr;	/* Points to the namespace context in which
				 * the name was resolved. NULL if the name is
				 * fully qualified and thus the resolution
				 * does not depend on the context. */
    int refCount;		/* Reference count: 1 for each nsName object
				 * that has a pointer to this ResolvedNsName
				 * structure as its internal rep. This
				 * structure can be freed when refCount
				 * becomes zero. */
} ResolvedNsName;

/*
 * Declarations for functions local to this file:
 */

static void		DeleteImportedCmd(ClientData clientData);
static int		DoImport(Tcl_Interp *interp,
			    Namespace *nsPtr, Tcl_HashEntry *hPtr,
			    const char *cmdName, const char *pattern,
			    Namespace *importNsPtr, int allowOverwrite);
static void		DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr);
static char *		ErrorCodeRead(ClientData clientData,Tcl_Interp *interp,
			    const char *name1, const char *name2, int flags);
static char *		ErrorInfoRead(ClientData clientData,Tcl_Interp *interp,
			    const char *name1, const char *name2, int flags);
static char *		EstablishErrorCodeTraces(ClientData clientData,
			    Tcl_Interp *interp, const char *name1,
			    const char *name2, int flags);
static char *		EstablishErrorInfoTraces(ClientData clientData,
			    Tcl_Interp *interp, const char *name1,
			    const char *name2, int flags);
static void		FreeNsNameInternalRep(Tcl_Obj *objPtr);
static int		GetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
static int		InvokeImportedCmd(ClientData clientData,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		InvokeImportedNRCmd(ClientData clientData,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceChildrenCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceCurrentCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NRNamespaceEvalCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static void		NamespaceFree(Namespace *nsPtr);
static int		NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceInscopeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NRNamespaceInscopeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespacePathCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceQualifiersCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceUnknownCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		UnlinkNsPath(Namespace *nsPtr);

static Tcl_NRPostProc NsEval_Callback;

/*
 * This structure defines a Tcl object type that contains a namespace
 * reference. It is used in commands that take the name of a namespace as an
 * argument. The namespace reference is resolved, and the result in cached in
 * the object.
 */

static const Tcl_ObjType nsNameType = {
    "nsName",			/* the type's name */
    FreeNsNameInternalRep,	/* freeIntRepProc */
    DupNsNameInternalRep,	/* dupIntRepProc */
    NULL,			/* updateStringProc */
    SetNsNameFromAny		/* setFromAnyProc */
};

/*
 * Array of values describing how to implement each standard subcommand of the
 * "namespace" command.
 */

static const EnsembleImplMap defaultNamespaceMap[] = {
    {"children",   NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
    {"code",	   NamespaceCodeCmd,	TclCompileNamespaceCodeCmd, NULL, NULL, 0},
    {"current",	   NamespaceCurrentCmd,	TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
    {"delete",	   NamespaceDeleteCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"ensemble",   TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
    {"eval",	   NamespaceEvalCmd,	NULL, NRNamespaceEvalCmd, NULL, 0},
    {"exists",	   NamespaceExistsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"export",	   NamespaceExportCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"forget",	   NamespaceForgetCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"import",	   NamespaceImportCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"inscope",	   NamespaceInscopeCmd,	NULL, NRNamespaceInscopeCmd, NULL, 0},
    {"origin",	   NamespaceOriginCmd,	TclCompileNamespaceOriginCmd, NULL, NULL, 0},
    {"parent",	   NamespaceParentCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
    {"path",	   NamespacePathCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
    {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
    {"tail",	   NamespaceTailCmd,	TclCompileNamespaceTailCmd, NULL, NULL, 0},
    {"unknown",	   NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
    {"upvar",	   NamespaceUpvarCmd,	TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
    {"which",	   NamespaceWhichCmd,	TclCompileNamespaceWhichCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, NULL, 0}
};

/*
 *----------------------------------------------------------------------
 *
 * TclInitNamespaceSubsystem --
 *
 *	This function is called to initialize all the structures that are used
 *	by namespaces on a per-process basis.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclInitNamespaceSubsystem(void)
{
    /*
     * Does nothing for now.
     */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCurrentNamespace --
 *
 *	Returns a pointer to an interpreter's currently active namespace.
 *
 * Results:
 *	Returns a pointer to the interpreter's current namespace.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_GetCurrentNamespace(
    register Tcl_Interp *interp)/* Interpreter whose current namespace is
				 * being queried. */
{
    return TclGetCurrentNamespace(interp);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetGlobalNamespace --
 *
 *	Returns a pointer to an interpreter's global :: namespace.
 *
 * Results:
 *	Returns a pointer to the specified interpreter's global namespace.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_GetGlobalNamespace(
    register Tcl_Interp *interp)/* Interpreter whose global namespace should
				 * be returned. */
{
    return TclGetGlobalNamespace(interp);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PushCallFrame --
 *
 *	Pushes a new call frame onto the interpreter's Tcl call stack. Called
 *	when executing a Tcl procedure or a "namespace eval" or "namespace
 *	inscope" command.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result object) if something goes wrong.
 *
 * Side effects:
 *	Modifies the interpreter's Tcl call stack.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PushCallFrame(
    Tcl_Interp *interp,		/* Interpreter in which the new call frame is
				 * to be pushed. */
    Tcl_CallFrame *callFramePtr,/* Points to a call frame structure to push.
				 * Storage for this has already been allocated
				 * by the caller; typically this is the
				 * address of a CallFrame structure allocated
				 * on the caller's C stack. The call frame
				 * will be initialized by this function. The
				 * caller can pop the frame later with
				 * Tcl_PopCallFrame, and it is responsible for
				 * freeing the frame's storage. */
    Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame
				 * will execute. If NULL, the interpreter's
				 * current namespace will be used. */
    int isProcCallFrame)	/* If nonzero, the frame represents a called
				 * Tcl procedure and may have local vars. Vars
				 * will ordinarily be looked up in the frame.
				 * If new variables are created, they will be
				 * created in the frame. If 0, the frame is
				 * for a "namespace eval" or "namespace
				 * inscope" command and var references are
				 * treated as references to namespace
				 * variables. */
{
    Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = (CallFrame *) callFramePtr;
    register Namespace *nsPtr;

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;

	/*
	 * TODO: Examine whether it would be better to guard based on NS_DYING
	 * or NS_KILLED. It appears that these are not tested because they can
	 * be set in a global interp that has been [namespace delete]d, but
	 * which never really completely goes away because of lingering global
	 * things like ::errorInfo and [::unknown] and hidden commands.
	 * Review of those designs might permit stricter checking here.
	 */

	if (nsPtr->flags & NS_DEAD) {
	    Tcl_Panic("Trying to push call frame for dead namespace");
	    /*NOTREACHED*/
	}
    }

    nsPtr->activationCount++;
    framePtr->nsPtr = nsPtr;
    framePtr->isProcCallFrame = isProcCallFrame;
    framePtr->objc = 0;
    framePtr->objv = NULL;
    framePtr->callerPtr = iPtr->framePtr;
    framePtr->callerVarPtr = iPtr->varFramePtr;
    if (iPtr->varFramePtr != NULL) {
	framePtr->level = (iPtr->varFramePtr->level + 1);
    } else {
	framePtr->level = 0;
    }
    framePtr->procPtr = NULL;		/* no called procedure */
    framePtr->varTablePtr = NULL;	/* and no local variables */
    framePtr->numCompiledLocals = 0;
    framePtr->compiledLocals = NULL;
    framePtr->clientData = NULL;
    framePtr->localCachePtr = NULL;
    framePtr->tailcallPtr = NULL;
    
    /*
     * Push the new call frame onto the interpreter's stack of procedure call
     * frames making it the current frame.
     */

    iPtr->framePtr = framePtr;
    iPtr->varFramePtr = framePtr;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PopCallFrame --
 *
 *	Removes a call frame from the Tcl call stack for the interpreter.
 *	Called to remove a frame previously pushed by Tcl_PushCallFrame.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Modifies the call stack of the interpreter. Resets various fields of
 *	the popped call frame. If a namespace has been deleted and has no more
 *	activations on the call stack, the namespace is destroyed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_PopCallFrame(
    Tcl_Interp *interp)		/* Interpreter with call frame to pop. */
{
    register Interp *iPtr = (Interp *) interp;
    register CallFrame *framePtr = iPtr->framePtr;
    Namespace *nsPtr;

    /*
     * It's important to remove the call frame from the interpreter's stack of
     * call frames before deleting local variables, so that traces invoked by
     * the variable deletion don't see the partially-deleted frame.
     */

    if (framePtr->callerPtr) {
	iPtr->framePtr = framePtr->callerPtr;
	iPtr->varFramePtr = framePtr->callerVarPtr;
    } else {
	/* Tcl_PopCallFrame: trying to pop rootCallFrame! */
    }

    if (framePtr->varTablePtr != NULL) {
	TclDeleteVars(iPtr, framePtr->varTablePtr);
	ckfree(framePtr->varTablePtr);
	framePtr->varTablePtr = NULL;
    }
    if (framePtr->numCompiledLocals > 0) {
	TclDeleteCompiledLocalVars(iPtr, framePtr);
	if (--framePtr->localCachePtr->refCount == 0) {
	    TclFreeLocalCache(interp, framePtr->localCachePtr);
	}
	framePtr->localCachePtr = NULL;
    }

    /*
     * Decrement the namespace's count of active call frames. If the namespace
     * is "dying" and there are no more active call frames, call
     * Tcl_DeleteNamespace to destroy it.
     */

    nsPtr = framePtr->nsPtr;
    nsPtr->activationCount--;
    if ((nsPtr->flags & NS_DYING)
	    && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;

    if (framePtr->tailcallPtr) {
	TclSetTailcall(interp, framePtr->tailcallPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushStackFrame --
 *
 *	Allocates a new call frame in the interpreter's execution stack, then
 *	pushes it onto the interpreter's Tcl call stack. Called when executing
 *	a Tcl procedure or a "namespace eval" or "namespace inscope" command.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result object) if something goes wrong.
 *
 * Side effects:
 *	Modifies the interpreter's Tcl call stack.
 *
 *----------------------------------------------------------------------
 */

int
TclPushStackFrame(
    Tcl_Interp *interp,		/* Interpreter in which the new call frame is
				 * to be pushed. */
    Tcl_CallFrame **framePtrPtr,/* Place to store a pointer to the stack
				 * allocated call frame. */
    Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame
				 * will execute. If NULL, the interpreter's
				 * current namespace will be used. */
    int isProcCallFrame)	/* If nonzero, the frame represents a called
				 * Tcl procedure and may have local vars. Vars
				 * will ordinarily be looked up in the frame.
				 * If new variables are created, they will be
				 * created in the frame. If 0, the frame is
				 * for a "namespace eval" or "namespace
				 * inscope" command and var references are
				 * treated as references to namespace
				 * variables. */
{
    *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame));
    return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
	    isProcCallFrame);
}

void
TclPopStackFrame(
    Tcl_Interp *interp)		/* Interpreter with call frame to pop. */
{
    CallFrame *freePtr = ((Interp *) interp)->framePtr;

    Tcl_PopCallFrame(interp);
    TclStackFree(interp, freePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * EstablishErrorCodeTraces --
 *
 *	Creates traces on the ::errorCode variable to keep its value
 *	consistent with the expectations of legacy code.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Read and unset traces are established on ::errorCode.
 *
 *----------------------------------------------------------------------
 */

static char *
EstablishErrorCodeTraces(
    ClientData clientData,
    Tcl_Interp *interp,
    const char *name1,
    const char *name2,
    int flags)
{
    Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
	    ErrorCodeRead, NULL);
    Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
	    EstablishErrorCodeTraces, NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ErrorCodeRead --
 *
 *	Called when the ::errorCode variable is read. Copies the current value
 *	of the interp's errorCode field into ::errorCode.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
ErrorCodeRead(
    ClientData clientData,
    Tcl_Interp *interp,
    const char *name1,
    const char *name2,
    int flags)
{
    Interp *iPtr = (Interp *) interp;

    if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
	return NULL;
    }
    if (iPtr->errorCode) {
	Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
		iPtr->errorCode, TCL_GLOBAL_ONLY);
	return NULL;
    }
    if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) {
	Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
		Tcl_NewObj(), TCL_GLOBAL_ONLY);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * EstablishErrorInfoTraces --
 *
 *	Creates traces on the ::errorInfo variable to keep its value
 *	consistent with the expectations of legacy code.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Read and unset traces are established on ::errorInfo.
 *
 *----------------------------------------------------------------------
 */

static char *
EstablishErrorInfoTraces(
    ClientData clientData,
    Tcl_Interp *interp,
    const char *name1,
    const char *name2,
    int flags)
{
    Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
	    ErrorInfoRead, NULL);
    Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
	    EstablishErrorInfoTraces, NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ErrorInfoRead --
 *
 *	Called when the ::errorInfo variable is read. Copies the current value
 *	of the interp's errorInfo field into ::errorInfo.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
ErrorInfoRead(
    ClientData clientData,
    Tcl_Interp *interp,
    const char *name1,
    const char *name2,
    int flags)
{
    Interp *iPtr = (Interp *) interp;

    if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
	return NULL;
    }
    if (iPtr->errorInfo) {
	Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
		iPtr->errorInfo, TCL_GLOBAL_ONLY);
	return NULL;
    }
    if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) {
	Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
		Tcl_NewObj(), TCL_GLOBAL_ONLY);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateNamespace --
 *
 *	Creates a new namespace with the given name. If there is no active
 *	namespace (i.e., the interpreter is being initialized), the global ::
 *	namespace is created and returned.
 *
 * Results:
 *	Returns a pointer to the new namespace if successful. If the namespace
 *	already exists or if another error occurs, this routine returns NULL,
 *	along with an error message in the interpreter's result object.
 *
 * Side effects:
 *	If the name contains "::" qualifiers and a parent namespace does not
 *	already exist, it is automatically created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_CreateNamespace(
    Tcl_Interp *interp,		/* Interpreter in which a new namespace is
				 * being created. Also used for error
				 * reporting. */
    const char *name,		/* Name for the new namespace. May be a
				 * qualified name with names of ancestor
				 * namespaces separated by "::"s. */
    ClientData clientData,	/* One-word value to store with namespace. */
    Tcl_NamespaceDeleteProc *deleteProc)
				/* Function called to delete client data when
				 * the namespace is deleted. NULL if no
				 * function should be called. */
{
    Interp *iPtr = (Interp *) interp;
    register Namespace *nsPtr, *ancestorPtr;
    Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
    Namespace *globalNsPtr = iPtr->globalNsPtr;
    const char *simpleName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer1, buffer2;
    Tcl_DString *namePtr, *buffPtr;
    int newEntry, nameLen;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    const char *nameStr;
    Tcl_DString tmpBuffer;

    Tcl_DStringInit(&tmpBuffer);

    /*
     * If there is no active namespace, the interpreter is being initialized.
     */

    if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
	/*
	 * Treat this namespace as the global namespace, and avoid looking for
	 * a parent.
	 */

	parentPtr = NULL;
	simpleName = "";
	goto doCreate;
    }

    /*
     * Ensure that there are no trailing colons as that causes chaos when a
     * deleteProc is specified. [Bug d614d63989]
     */

    if (deleteProc != NULL) {
	nameStr = name + strlen(name) - 2;
	if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') {
	    Tcl_DStringAppend(&tmpBuffer, name, -1);
	    while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0
		    && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') {
		Tcl_DStringSetLength(&tmpBuffer, nameLen-1);
	    }
	    name = Tcl_DStringValue(&tmpBuffer);
	}
    }

    /*
     * If we've ended up with an empty string now, we're attempting to create
     * the global namespace despite the global namespace existing. That's
     * naughty!
     */

    if (*name == '\0') {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
                " \"\": only global namespace can have empty name", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
		"CREATEGLOBAL", NULL);
	Tcl_DStringFree(&tmpBuffer);
	return NULL;
    }

    /*
     * Find the parent for the new namespace.
     */

    TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN,
	    &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);

    /*
     * If the unqualified name at the end is empty, there were trailing "::"s
     * after the namespace's name which we ignore. The new namespace was
     * already (recursively) created and is pointed to by parentPtr.
     */

    if (*simpleName == '\0') {
	Tcl_DStringFree(&tmpBuffer);
	return (Tcl_Namespace *) parentPtr;
    }

    /*
     * Check for a bad namespace name and make sure that the name does not
     * already exist in the parent namespace.
     */

    if (
#ifndef BREAK_NAMESPACE_COMPAT
	Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
#else
	parentPtr->childTablePtr != NULL &&
	Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
#endif
    ) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"can't create namespace \"%s\": already exists", name));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
		"CREATEEXISTING", NULL);
	Tcl_DStringFree(&tmpBuffer);
	return NULL;
    }

    /*
     * Create the new namespace and root it in its parent. Increment the count
     * of namespaces created.
     */

  doCreate:
    nsPtr = ckalloc(sizeof(Namespace));
    nameLen = strlen(simpleName) + 1;
    nsPtr->name = ckalloc(nameLen);
    memcpy(nsPtr->name, simpleName, nameLen);
    nsPtr->fullName = NULL;		/* Set below. */
    nsPtr->clientData = clientData;
    nsPtr->deleteProc = deleteProc;
    nsPtr->parentPtr = parentPtr;
#ifndef BREAK_NAMESPACE_COMPAT
    Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
#else
    nsPtr->childTablePtr = NULL;
#endif
    nsPtr->nsId = ++(tsdPtr->numNsCreated);
    nsPtr->interp = interp;
    nsPtr->flags = 0;
    nsPtr->activationCount = 0;
    nsPtr->refCount = 0;
    Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
    TclInitVarHashTable(&nsPtr->varTable, nsPtr);
    nsPtr->exportArrayPtr = NULL;
    nsPtr->numExportPatterns = 0;
    nsPtr->maxExportPatterns = 0;
    nsPtr->cmdRefEpoch = 0;
    nsPtr->resolverEpoch = 0;
    nsPtr->cmdResProc = NULL;
    nsPtr->varResProc = NULL;
    nsPtr->compiledVarResProc = NULL;
    nsPtr->exportLookupEpoch = 0;
    nsPtr->ensembles = NULL;
    nsPtr->unknownHandlerPtr = NULL;
    nsPtr->commandPathLength = 0;
    nsPtr->commandPathArray = NULL;
    nsPtr->commandPathSourceList = NULL;
    nsPtr->earlyDeleteProc = NULL;

    if (parentPtr != NULL) {
	entryPtr = Tcl_CreateHashEntry(
		TclGetNamespaceChildTable((Tcl_Namespace *) parentPtr),
		simpleName, &newEntry);
	Tcl_SetHashValue(entryPtr, nsPtr);
    } else {
	/*
	 * In the global namespace create traces to maintain the ::errorInfo
	 * and ::errorCode variables.
	 */

	iPtr->globalNsPtr = nsPtr;
	EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
	EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
    }

    /*
     * Build the fully qualified name for this namespace.
     */

    Tcl_DStringInit(&buffer1);
    Tcl_DStringInit(&buffer2);
    namePtr = &buffer1;
    buffPtr = &buffer2;
    for (ancestorPtr = nsPtr; ancestorPtr != NULL;
	    ancestorPtr = ancestorPtr->parentPtr) {
	if (ancestorPtr != globalNsPtr) {
	    register Tcl_DString *tempPtr = namePtr;

	    TclDStringAppendLiteral(buffPtr, "::");
	    Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
	    TclDStringAppendDString(buffPtr, namePtr);

	    /*
	     * Clear the unwanted buffer or we end up appending to previous
	     * results, making the namespace fullNames of nested namespaces
	     * very wrong (and strange).
	     */

	    TclDStringClear(namePtr);

	    /*
	     * Now swap the buffer pointers so that we build in the other
	     * buffer. This is faster than repeated copying back and forth
	     * between buffers.
	     */

	    namePtr = buffPtr;
	    buffPtr = tempPtr;
	}
    }

    name = Tcl_DStringValue(namePtr);
    nameLen = Tcl_DStringLength(namePtr);
    nsPtr->fullName = ckalloc(nameLen + 1);
    memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1);

    Tcl_DStringFree(&buffer1);
    Tcl_DStringFree(&buffer2);
    Tcl_DStringFree(&tmpBuffer);

    /*
     * If compilation of commands originating from the parent NS is
     * suppressed, suppress it for commands originating in this one too.
     */

    if (nsPtr->parentPtr != NULL &&
	    nsPtr->parentPtr->flags & NS_SUPPRESS_COMPILATION) {
	nsPtr->flags |= NS_SUPPRESS_COMPILATION;
    }

    /*
     * Return a pointer to the new namespace.
     */

    return (Tcl_Namespace *) nsPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteNamespace --
 *
 *	Deletes a namespace and all of the commands, variables, and other
 *	namespaces within it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	When a namespace is deleted, it is automatically removed as a child of
 *	its parent namespace. Also, all its commands, variables and child
 *	namespaces are deleted.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteNamespace(
    Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
{
    register Namespace *nsPtr = (Namespace *) namespacePtr;
    Interp *iPtr = (Interp *) nsPtr->interp;
    Namespace *globalNsPtr = (Namespace *)
	    TclGetGlobalNamespace((Tcl_Interp *) iPtr);
    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Command *cmdPtr;

    /*
     * Give anyone interested - notably TclOO - a chance to use this namespace
     * normally despite the fact that the namespace is going to go. Allows the
     * calling of destructors. Will only be called once (unless re-established
     * by the called function). [Bug 2950259]
     *
     * Note that setting this field requires access to the internal definition
     * of namespaces, so it should only be accessed by code that knows about
     * being careful with reentrancy.
     */

    if (nsPtr->earlyDeleteProc != NULL) {
	Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc;

	nsPtr->earlyDeleteProc = NULL;
	nsPtr->activationCount++;
	earlyDeleteProc(nsPtr->clientData);
	nsPtr->activationCount--;
    }

    /*
     * Delete all coroutine commands now: break the circular ref cycle between
     * the namespace and the coroutine command [Bug 2724403]. This code is
     * essentially duplicated in TclTeardownNamespace() for all other
     * commands. Don't optimize to Tcl_NextHashEntry() because of traces.
     *
     * NOTE: we could avoid traversing the ns's command list by keeping a
     * separate list of coros.
     */

    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	    entryPtr != NULL;) {
	cmdPtr = Tcl_GetHashValue(entryPtr);
	if (cmdPtr->nreProc == TclNRInterpCoroutine) {
	    Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
		    (Tcl_Command) cmdPtr);
	    entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	} else {
	    entryPtr = Tcl_NextHashEntry(&search);
	}
    }

    /*
     * If the namespace has associated ensemble commands, delete them first.
     * This leaves the actual contents of the namespace alone (unless they are
     * linked ensemble commands, of course). Note that this code is actually
     * reentrant so command delete traces won't purturb things badly.
     */

    while (nsPtr->ensembles != NULL) {
	EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles;

	/*
	 * Splice out and link to indicate that we've already been killed.
	 */

	nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
	ensemblePtr->next = ensemblePtr;
	Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
    }

    /*
     * If the namespace has a registered unknown handler (TIP 181), then free
     * it here.
     */

    if (nsPtr->unknownHandlerPtr != NULL) {
	Tcl_DecrRefCount(nsPtr->unknownHandlerPtr);
	nsPtr->unknownHandlerPtr = NULL;
    }

    /*
     * If the namespace is on the call frame stack, it is marked as "dying"
     * (NS_DYING is OR'd into its flags): the namespace can't be looked up by
     * name but its commands and variables are still usable by those active
     * call frames. When all active call frames referring to the namespace
     * have been popped from the Tcl stack, Tcl_PopCallFrame will call this
     * function again to delete everything in the namespace. If no nsName
     * objects refer to the namespace (i.e., if its refCount is zero), its
     * commands and variables are deleted and the storage for its namespace
     * structure is freed. Otherwise, if its refCount is nonzero, the
     * namespace's commands and variables are deleted but the structure isn't
     * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
     * namespace resolution code to recognize that the namespace is "deleted".
     * The structure's storage is freed by FreeNsNameInternalRep when its
     * refCount reaches 0.
     */

    if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
	nsPtr->flags |= NS_DYING;
	if (nsPtr->parentPtr != NULL) {
	    entryPtr = Tcl_FindHashEntry(
		    TclGetNamespaceChildTable((Tcl_Namespace *)
			    nsPtr->parentPtr), nsPtr->name);
	    if (entryPtr != NULL) {
		Tcl_DeleteHashEntry(entryPtr);
	    }
	}
	nsPtr->parentPtr = NULL;
    } else if (!(nsPtr->flags & NS_KILLED)) {
	/*
	 * Delete the namespace and everything in it. If this is the global
	 * namespace, then clear it but don't free its storage unless the
	 * interpreter is being torn down. Set the NS_KILLED flag to avoid
	 * recursive calls here - if the namespace is really in the process of
	 * being deleted, ignore any second call.
	 */

	nsPtr->flags |= (NS_DYING|NS_KILLED);

	TclTeardownNamespace(nsPtr);

	if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
	    /*
	     * If this is the global namespace, then it may have residual
	     * "errorInfo" and "errorCode" variables for errors that occurred
	     * while it was being torn down. Try to clear the variable list
	     * one last time.
	     */

	    TclDeleteNamespaceVars(nsPtr);

#ifndef BREAK_NAMESPACE_COMPAT
	    Tcl_DeleteHashTable(&nsPtr->childTable);
#else
	    if (nsPtr->childTablePtr != NULL) {
		Tcl_DeleteHashTable(nsPtr->childTablePtr);
		ckfree(nsPtr->childTablePtr);
	    }
#endif
	    Tcl_DeleteHashTable(&nsPtr->cmdTable);

	    /*
	     * If the reference count is 0, then discard the namespace.
	     * Otherwise, mark it as "dead" so that it can't be used.
	     */

	    if (nsPtr->refCount == 0) {
		NamespaceFree(nsPtr);
	    } else {
		nsPtr->flags |= NS_DEAD;
	    }
	} else {
	    /*
	     * Restore the ::errorInfo and ::errorCode traces.
	     */

	    EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
	    EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);

	    /*
	     * We didn't really kill it, so remove the KILLED marks, so it can
	     * get killed later, avoiding mem leaks.
	     */

	    nsPtr->flags &= ~(NS_DYING|NS_KILLED);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclTeardownNamespace --
 *
 *	Used internally to dismantle and unlink a namespace when it is
 *	deleted. Divorces the namespace from its parent, and deletes all
 *	commands, variables, and child namespaces.
 *
 *	This is kept separate from Tcl_DeleteNamespace so that the global
 *	namespace can be handled specially.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes this namespace from its parent's child namespace hashtable.
 *	Deletes all commands, variables and namespaces in this namespace.
 *
 *----------------------------------------------------------------------
 */

void
TclTeardownNamespace(
    register Namespace *nsPtr)	/* Points to the namespace to be dismantled
				 * and unlinked from its parent. */
{
    Interp *iPtr = (Interp *) nsPtr->interp;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_Namespace *childNsPtr;
    Tcl_Command cmd;
    int i;

    /*
     * Start by destroying the namespace's variable table, since variables
     * might trigger traces. Variable table should be cleared but not freed!
     * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards.
     */

    TclDeleteNamespaceVars(nsPtr);
    TclInitVarHashTable(&nsPtr->varTable, nsPtr);

    /*
     * Delete all commands in this namespace. Be careful when traversing the
     * hash table: when each command is deleted, it removes itself from the
     * command table.
     *
     * Don't optimize to Tcl_NextHashEntry() because of traces.
     */

    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
	    entryPtr != NULL;
	    entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
	cmd = Tcl_GetHashValue(entryPtr);
	Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
    }
    Tcl_DeleteHashTable(&nsPtr->cmdTable);
    Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);

    /*
     * Remove the namespace from its parent's child hashtable.
     */

    if (nsPtr->parentPtr != NULL) {
	entryPtr = Tcl_FindHashEntry(
		TclGetNamespaceChildTable((Tcl_Namespace *)
			nsPtr->parentPtr), nsPtr->name);
	if (entryPtr != NULL) {
	    Tcl_DeleteHashEntry(entryPtr);
	}
    }
    nsPtr->parentPtr = NULL;

    /*
     * Delete the namespace path if one is installed.
     */

    if (nsPtr->commandPathLength != 0) {
	UnlinkNsPath(nsPtr);
	nsPtr->commandPathLength = 0;
    }
    if (nsPtr->commandPathSourceList != NULL) {
	NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;

	do {
	    if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) {
		nsPathPtr->creatorNsPtr->cmdRefEpoch++;
	    }
	    nsPathPtr->nsPtr = NULL;
	    nsPathPtr = nsPathPtr->nextPtr;
	} while (nsPathPtr != NULL);
	nsPtr->commandPathSourceList = NULL;
    }

    /*
     * Delete all the child namespaces.
     *
     * BE CAREFUL: When each child is deleted, it will divorce itself from its
     * parent. You can't traverse a hash table properly if its elements are
     * being deleted. We use only the Tcl_FirstHashEntry function to be safe.
     *
     * Don't optimize to Tcl_NextHashEntry() because of traces.
     */

#ifndef BREAK_NAMESPACE_COMPAT
    for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
	    entryPtr != NULL;
	    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
	childNsPtr = Tcl_GetHashValue(entryPtr);
	Tcl_DeleteNamespace(childNsPtr);
    }
#else
    if (nsPtr->childTablePtr != NULL) {
	for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
		entryPtr != NULL;
		entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr,&search)) {
	    childNsPtr = Tcl_GetHashValue(entryPtr);
	    Tcl_DeleteNamespace(childNsPtr);
	}
    }
#endif

    /*
     * Free the namespace's export pattern array.
     */

    if (nsPtr->exportArrayPtr != NULL) {
	for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
	    ckfree(nsPtr->exportArrayPtr[i]);
	}
	ckfree(nsPtr->exportArrayPtr);
	nsPtr->exportArrayPtr = NULL;
	nsPtr->numExportPatterns = 0;
	nsPtr->maxExportPatterns = 0;
    }

    /*
     * Free any client data associated with the namespace.
     */

    if (nsPtr->deleteProc != NULL) {
	nsPtr->deleteProc(nsPtr->clientData);
    }
    nsPtr->deleteProc = NULL;
    nsPtr->clientData = NULL;

    /*
     * Reset the namespace's id field to ensure that this namespace won't be
     * interpreted as valid by, e.g., the cache validation code for cached
     * command references in Tcl_GetCommandFromObj.
     */

    nsPtr->nsId = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceFree --
 *
 *	Called after a namespace has been deleted, when its reference count
 *	reaches 0. Frees the data structure representing the namespace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
NamespaceFree(
    register Namespace *nsPtr)	/* Points to the namespace to free. */
{
    /*
     * Most of the namespace's contents are freed when the namespace is
     * deleted by Tcl_DeleteNamespace. All that remains is to free its names
     * (for error messages), and the structure itself.
     */

    ckfree(nsPtr->name);
    ckfree(nsPtr->fullName);
    ckfree(nsPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclNsDecrRefCount --
 *
 *	Drops a reference to a namespace and frees it if the namespace has
 *	been deleted and the last reference has just been dropped.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclNsDecrRefCount(
    Namespace *nsPtr)
{
    nsPtr->refCount--;
    if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
	NamespaceFree(nsPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Export --
 *
 *	Makes all the commands matching a pattern available to later be
 *	imported from the namespace specified by namespacePtr (or the current
 *	namespace if namespacePtr is NULL). The specified pattern is appended
 *	onto the namespace's export pattern list, which is optionally cleared
 *	beforehand.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result) if something goes wrong.
 *
 * Side effects:
 *	Appends the export pattern onto the namespace's export list.
 *	Optionally reset the namespace's export pattern list.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Export(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Namespace *namespacePtr,/* Points to the namespace from which commands
				 * are to be exported. NULL for the current
				 * namespace. */
    const char *pattern,	/* String pattern indicating which commands to
				 * export. This pattern may not include any
				 * namespace qualifiers; only commands in the
				 * specified namespace may be exported. */
    int resetListFirst)		/* If nonzero, resets the namespace's export
				 * list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
    Namespace *nsPtr, *exportNsPtr, *dummyPtr;
    Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    const char *simplePattern;
    char *patternCpy;
    int neededElems, len, i;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) currNsPtr;
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * If resetListFirst is true (nonzero), clear the namespace's export
     * pattern list.
     */

    if (resetListFirst) {
	if (nsPtr->exportArrayPtr != NULL) {
	    for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
		ckfree(nsPtr->exportArrayPtr[i]);
	    }
	    ckfree(nsPtr->exportArrayPtr);
	    nsPtr->exportArrayPtr = NULL;
	    TclInvalidateNsCmdLookup(nsPtr);
	    nsPtr->numExportPatterns = 0;
	    nsPtr->maxExportPatterns = 0;
	}
    }

    /*
     * Check that the pattern doesn't have namespace qualifiers.
     */

    TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
	    &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
                " \"%s\": pattern can't specify a namespace", pattern));
	Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
	return TCL_ERROR;
    }

    /*
     * Make sure that we don't already have the pattern in the array
     */

    if (nsPtr->exportArrayPtr != NULL) {
	for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
	    if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
		/*
		 * The pattern already exists in the list.
		 */

		return TCL_OK;
	    }
	}
    }

    /*
     * Make sure there is room in the namespace's pattern array for the new
     * pattern.
     */

    neededElems = nsPtr->numExportPatterns + 1;
    if (neededElems > nsPtr->maxExportPatterns) {
	nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
		2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
	nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr,
		sizeof(char *) * nsPtr->maxExportPatterns);
    }

    /*
     * Add the pattern to the namespace's array of export patterns.
     */

    len = strlen(pattern);
    patternCpy = ckalloc(len + 1);
    memcpy(patternCpy, pattern, (unsigned) len + 1);

    nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
    nsPtr->numExportPatterns++;

    /*
     * The list of commands actually exported from the namespace might have
     * changed (probably will have!) However, we do not need to recompute this
     * just yet; next time we need the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(nsPtr);

    return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendExportList --
 *
 *	Appends onto the argument object the list of export patterns for the
 *	specified namespace.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case the object
 *	referenced by objPtr has each export pattern appended to it. If an
 *	error occurs, TCL_ERROR is returned and the interpreter's result holds
 *	an error message.
 *
 * Side effects:
 *	If necessary, the object referenced by objPtr is converted into a list
 *	object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppendExportList(
    Tcl_Interp *interp,		/* Interpreter used for error reporting. */
    Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
				 * pattern list is appended onto objPtr. NULL
				 * for the current namespace. */
    Tcl_Obj *objPtr)		/* Points to the Tcl object onto which the
				 * export pattern list is appended. */
{
    Namespace *nsPtr;
    int i, result;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * Append the export pattern list onto objPtr.
     */

    for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
	result = Tcl_ListObjAppendElement(interp, objPtr,
		Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Import --
 *
 *	Imports all of the commands matching a pattern into the namespace
 *	specified by namespacePtr (or the current namespace if contextNsPtr is
 *	NULL). This is done by creating a new command (the "imported command")
 *	that points to the real command in its original namespace.
 *
 *	If matching commands are on the autoload path but haven't been loaded
 *	yet, this command forces them to be loaded, then creates the links to
 *	them.
 *
 * Results:
 *	Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *	message in the interpreter's result) if something goes wrong.
 *
 * Side effects:
 *	Creates new commands in the importing namespace. These indirect calls
 *	back to the real command and are deleted if the real commands are
 *	deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Import(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Namespace *namespacePtr,/* Points to the namespace into which the
				 * commands are to be imported. NULL for the
				 * current namespace. */
    const char *pattern,	/* String pattern indicating which commands to
				 * import. This pattern should be qualified by
				 * the name of the namespace from which to
				 * import the command(s). */
    int allowOverwrite)		/* If nonzero, allow existing commands to be
				 * overwritten by imported commands. If 0,
				 * return an error if an imported cmd
				 * conflicts with an existing one. */
{
    Namespace *nsPtr, *importNsPtr, *dummyPtr;
    const char *simplePattern;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * First, invoke the "auto_import" command with the pattern being
     * imported. This command is part of the Tcl library. It looks for
     * imported commands in autoloaded libraries and loads them in. That way,
     * they will be found when we try to create links below.
     *
     * Note that we don't just call Tcl_EvalObjv() directly because we do not
     * want absence of the command to be a failure case.
     */

    if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
	Tcl_Obj *objv[2];
	int result;

	TclNewLiteralStringObj(objv[0], "auto_import");
	objv[1] = Tcl_NewStringObj(pattern, -1);

	Tcl_IncrRefCount(objv[0]);
	Tcl_IncrRefCount(objv[1]);
	result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(objv[0]);
	Tcl_DecrRefCount(objv[1]);

	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }

    /*
     * From the pattern, find the namespace from which we are importing and
     * get the simple pattern (no namespace qualifiers or ::'s) at the end.
     */

    if (strlen(pattern) == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
	Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
	return TCL_ERROR;
    }
    TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
	    &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if (importNsPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "unknown namespace in import pattern \"%s\"", pattern));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
	return TCL_ERROR;
    }
    if (importNsPtr == nsPtr) {
	if (pattern == simplePattern) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "no namespace specified in import pattern \"%s\"",
                    pattern));
	    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "import pattern \"%s\" tries to import from namespace"
                    " \"%s\" into itself", pattern, importNsPtr->name));
	    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Scan through the command table in the source namespace and look for
     * exported commands that match the string pattern. Create an "imported
     * command" in the current namespace for each imported command; these
     * commands redirect their invocations to the "real" command.
     */

    if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) {
	hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern);
	if (hPtr == NULL) {
	    return TCL_OK;
	}
	return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
		importNsPtr, allowOverwrite);
    }
    for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
	    (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
	char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);

	if (Tcl_StringMatch(cmdName, simplePattern) &&
		DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
		allowOverwrite) == TCL_ERROR) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * DoImport --
 *
 *	Import a particular command from one namespace into another. Helper
 *	for Tcl_Import().
 *
 * Results:
 *	Standard Tcl result code. If TCL_ERROR, appends an error message to
 *	the interpreter result.
 *
 * Side effects:
 *	A new command is created in the target namespace unless this is a
 *	reimport of exactly the same command as before.
 *
 *----------------------------------------------------------------------
 */

static int
DoImport(
    Tcl_Interp *interp,
    Namespace *nsPtr,
    Tcl_HashEntry *hPtr,
    const char *cmdName,
    const char *pattern,
    Namespace *importNsPtr,
    int allowOverwrite)
{
    int i = 0, exported = 0;
    Tcl_HashEntry *found;

    /*
     * The command cmdName in the source namespace matches the pattern. Check
     * whether it was exported. If it wasn't, we ignore it.
     */

    while (!exported && (i < importNsPtr->numExportPatterns)) {
	exported |= Tcl_StringMatch(cmdName,
		importNsPtr->exportArrayPtr[i++]);
    }
    if (!exported) {
	return TCL_OK;
    }

    /*
     * Unless there is a name clash, create an imported command in the current
     * namespace that refers to cmdPtr.
     */

    found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
    if ((found == NULL) || allowOverwrite) {
	/*
	 * Create the imported command and its client data. To create the new
	 * command in the current namespace, generate a fully qualified name
	 * for it.
	 */

	Tcl_DString ds;
	Tcl_Command importedCmd;
	ImportedCmdData *dataPtr;
	Command *cmdPtr;
	ImportRef *refPtr;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	if (nsPtr != ((Interp *) interp)->globalNsPtr) {
	    TclDStringAppendLiteral(&ds, "::");
	}
	Tcl_DStringAppend(&ds, cmdName, -1);

	/*
	 * Check whether creating the new imported command in the current
	 * namespace would create a cycle of imported command references.
	 */

	cmdPtr = Tcl_GetHashValue(hPtr);
	if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
	    Command *overwrite = Tcl_GetHashValue(found);
	    Command *linkCmd = cmdPtr;

	    while (linkCmd->deleteProc == DeleteImportedCmd) {
		dataPtr = linkCmd->objClientData;
		linkCmd = dataPtr->realCmdPtr;
		if (overwrite == linkCmd) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                            "import pattern \"%s\" would create a loop"
                            " containing command \"%s\"",
                            pattern, Tcl_DStringValue(&ds)));
		    Tcl_DStringFree(&ds);
		    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
		    return TCL_ERROR;
		}
	    }
	}

	dataPtr = ckalloc(sizeof(ImportedCmdData));
	importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
		InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
		DeleteImportedCmd);
	dataPtr->realCmdPtr = cmdPtr;
	dataPtr->selfPtr = (Command *) importedCmd;
	dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
	Tcl_DStringFree(&ds);

	/*
	 * Create an ImportRef structure describing this new import command
	 * and add it to the import ref list in the "real" command.
	 */

	refPtr = ckalloc(sizeof(ImportRef));
	refPtr->importedCmdPtr = (Command *) importedCmd;
	refPtr->nextPtr = cmdPtr->importRefPtr;
	cmdPtr->importRefPtr = refPtr;
    } else {
	Command *overwrite = Tcl_GetHashValue(found);

	if (overwrite->deleteProc == DeleteImportedCmd) {
	    ImportedCmdData *dataPtr = overwrite->objClientData;

	    if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) {
		/*
		 * Repeated import of same command is acceptable.
		 */

		return TCL_OK;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "can't import command \"%s\": already exists", cmdName));
	Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForgetImport --
 *
 *	Deletes commands previously imported into the namespace indicated.
 *	The by namespacePtr, or the current namespace of interp, when
 *	namespacePtr is NULL. The pattern controls which imported commands are
 *	deleted. A simple pattern, one without namespace separators, matches
 *	the current command names of imported commands in the namespace.
 *	Matching imported commands are deleted. A qualified pattern is
 *	interpreted as deletion selection on the basis of where the command is
 *	imported from. The original command and "first link" command for each
 *	imported command are determined, and they are matched against the
 *	pattern. A match leads to deletion of the imported command.
 *
 * Results:
 *	Returns TCL_ERROR and records an error message in the interp result if
 *	a namespace qualified pattern refers to a namespace that does not
 *	exist. Otherwise, returns TCL_OK.
 *
 * Side effects:
 *	May delete commands.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ForgetImport(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Namespace *namespacePtr,/* Points to the namespace from which
				 * previously imported commands should be
				 * removed. NULL for current namespace. */
    const char *pattern)	/* String pattern indicating which imported
				 * commands to remove. */
{
    Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
    const char *simplePattern;
    char *cmdName;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    } else {
	nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * Parse the pattern into its namespace-qualification (if any) and the
     * simple pattern.
     */

    TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
	    &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);

    if (sourceNsPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"unknown namespace in namespace forget pattern \"%s\"",
		pattern));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
	return TCL_ERROR;
    }

    if (strcmp(pattern, simplePattern) == 0) {
	/*
	 * The pattern is simple. Delete any imported commands that match it.
	 */

	if (TclMatchIsTrivial(simplePattern)) {
	    hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
	    if (hPtr != NULL) {
		Command *cmdPtr = Tcl_GetHashValue(hPtr);

		if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) {
		    Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
		}
	    }
	    return TCL_OK;
	}
	for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
		(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
	    Command *cmdPtr = Tcl_GetHashValue(hPtr);

	    if (cmdPtr->deleteProc != DeleteImportedCmd) {
		continue;
	    }
	    cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
	    if (Tcl_StringMatch(cmdName, simplePattern)) {
		Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
	    }
	}
	return TCL_OK;
    }

    /*
     * The pattern was namespace-qualified.
     */

    for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
	    hPtr = Tcl_NextHashEntry(&search)) {
	Tcl_CmdInfo info;
	Tcl_Command token = Tcl_GetHashValue(hPtr);
	Tcl_Command origin = TclGetOriginalCommand(token);

	if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
	    continue;			/* Not an imported command. */
	}
	if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
	    /*
	     * Original not in namespace we're matching. Check the first link
	     * in the import chain.
	     */

	    Command *cmdPtr = (Command *) token;
	    ImportedCmdData *dataPtr = cmdPtr->objClientData;
	    Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;

	    if (firstToken == origin) {
		continue;
	    }
	    Tcl_GetCommandInfoFromToken(firstToken, &info);
	    if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
		continue;
	    }
	    origin = firstToken;
	}
	if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){
	    Tcl_DeleteCommandFromToken(interp, token);
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetOriginalCommand --
 *
 *	An imported command is created in an namespace when a "real" command
 *	is imported from another namespace. If the specified command is an
 *	imported command, this function returns the original command it refers
 *	to.
 *
 * Results:
 *	If the command was imported into a sequence of namespaces a, b,...,n
 *	where each successive namespace just imports the command from the
 *	previous namespace, this function returns the Tcl_Command token in the
 *	first namespace, a. Otherwise, if the specified command is not an
 *	imported command, the function returns NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclGetOriginalCommand(
    Tcl_Command command)	/* The imported command for which the original
				 * command should be returned. */
{
    register Command *cmdPtr = (Command *) command;
    ImportedCmdData *dataPtr;

    if (cmdPtr->deleteProc != DeleteImportedCmd) {
	return NULL;
    }

    while (cmdPtr->deleteProc == DeleteImportedCmd) {
	dataPtr = cmdPtr->objClientData;
	cmdPtr = dataPtr->realCmdPtr;
    }
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * InvokeImportedCmd --
 *
 *	Invoked by Tcl whenever the user calls an imported command that was
 *	created by Tcl_Import. Finds the "real" command (in another
 *	namespace), and passes control to it.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result object is set to an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InvokeImportedNRCmd(
    ClientData clientData,	/* Points to the imported command's
				 * ImportedCmdData structure. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    ImportedCmdData *dataPtr = clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;

    TclSkipTailcall(interp);
    return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}

static int
InvokeImportedCmd(
    ClientData clientData,	/* Points to the imported command's
				 * ImportedCmdData structure. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData,
	    objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteImportedCmd --
 *
 *	Invoked by Tcl whenever an imported command is deleted. The "real"
 *	command keeps a list of all the imported commands that refer to it, so
 *	those imported commands can be deleted when the real command is
 *	deleted. This function removes the imported command reference from the
 *	real command's list, and frees up the memory associated with the
 *	imported command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the imported command from the real command's import list.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteImportedCmd(
    ClientData clientData)	/* Points to the imported command's
				 * ImportedCmdData structure. */
{
    ImportedCmdData *dataPtr = clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;
    Command *selfPtr = dataPtr->selfPtr;
    register ImportRef *refPtr, *prevPtr;

    prevPtr = NULL;
    for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
	    refPtr = refPtr->nextPtr) {
	if (refPtr->importedCmdPtr == selfPtr) {
	    /*
	     * Remove *refPtr from real command's list of imported commands
	     * that refer to it.
	     */

	    if (prevPtr == NULL) { /* refPtr is first in list. */
		realCmdPtr->importRefPtr = refPtr->nextPtr;
	    } else {
		prevPtr->nextPtr = refPtr->nextPtr;
	    }
	    ckfree(refPtr);
	    ckfree(dataPtr);
	    return;
	}
	prevPtr = refPtr;
    }

    Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceForQualName --
 *
 *	Given a qualified name specifying a command, variable, or namespace,
 *	and a namespace in which to resolve the name, this function returns a
 *	pointer to the namespace that contains the item. A qualified name
 *	consists of the "simple" name of an item qualified by the names of an
 *	arbitrary number of containing namespace separated by "::"s. If the
 *	qualified name starts with "::", it is interpreted absolutely from the
 *	global namespace. Otherwise, it is interpreted relative to the
 *	namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is
 *	NULL, the name is interpreted relative to the current namespace.
 *
 *	A relative name like "foo::bar::x" can be found starting in either the
 *	current namespace or in the global namespace. So each search usually
 *	follows two tracks, and two possible namespaces are returned. If the
 *	function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path
 *	failed.
 *
 *	If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
 *	sought only in the global :: namespace. The alternate search (also)
 *	starting from the global namespace is ignored and *altNsPtrPtr is set
 *	NULL.
 *
 *	If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is
 *	sought only in the namespace specified by cxtNsPtr. The alternate
 *	search starting from the global namespace is ignored and *altNsPtrPtr
 *	is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are
 *	specified, TCL_GLOBAL_ONLY is ignored and the search starts from the
 *	namespace specified by cxtNsPtr.
 *
 *	If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components
 *	of the qualified name that cannot be found are automatically created
 *	within their specified parent. This makes sure that functions like
 *	Tcl_CreateCommand always succeed. There is no alternate search path,
 *	so *altNsPtrPtr is set NULL.
 *
 *	If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as
 *	a reference to a namespace, and the entire qualified name is followed.
 *	If the name is relative, the namespace is looked up only in the
 *	current namespace. A pointer to the namespace is stored in *nsPtrPtr
 *	and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS
 *	is not specified, only the leading components are treated as namespace
 *	names, and a pointer to the simple name of the final component is
 *	stored in *simpleNamePtr.
 *
 * Results:
 *	It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
 *	namespaces which represent the last (containing) namespace in the
 *	qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr
 *	to NULL, then the search along that path failed. The function also
 *	stores a pointer to the simple name of the final component in
 *	*simpleNamePtr. If the qualified name is "::" or was treated as a
 *	namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer
 *	to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
 *	*simpleNamePtr to point to an empty string.
 *
 *	If there is an error, this function returns TCL_ERROR. If "flags"
 *	contains TCL_LEAVE_ERR_MSG, an error message is returned in the
 *	interpreter's result object. Otherwise, the interpreter's result
 *	object is left unchanged.
 *
 *	*actualCxtPtrPtr is set to the actual context namespace. It is set to
 *	the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL,
 *	it is set to the current namespace context.
 *
 *	For backwards compatibility with the TclPro byte code loader, this
 *	function always returns TCL_OK.
 *
 * Side effects:
 *	If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be
 *	created.
 *
 *----------------------------------------------------------------------
 */

int
TclGetNamespaceForQualName(
    Tcl_Interp *interp,		/* Interpreter in which to find the namespace
				 * containing qualName. */
    const char *qualName,	/* A namespace-qualified name of an command,
				 * variable, or namespace. */
    Namespace *cxtNsPtr,	/* The namespace in which to start the search
				 * for qualName's namespace. If NULL start
				 * from the current namespace. Ignored if
				 * TCL_GLOBAL_ONLY is set. */
    int flags,			/* Flags controlling the search: an OR'd
				 * combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and
				 * TCL_CREATE_NS_IF_UNKNOWN. */
    Namespace **nsPtrPtr,	/* Address where function stores a pointer to
				 * containing namespace if qualName is found
				 * starting from *cxtNsPtr or, if
				 * TCL_GLOBAL_ONLY is set, if qualName is
				 * found in the global :: namespace. NULL is
				 * stored otherwise. */
    Namespace **altNsPtrPtr,	/* Address where function stores a pointer to
				 * containing namespace if qualName is found
				 * starting from the global :: namespace.
				 * NULL is stored if qualName isn't found
				 * starting from :: or if the TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS,
				 * TCL_CREATE_NS_IF_UNKNOWN flag is set. */
    Namespace **actualCxtPtrPtr,/* Address where function stores a pointer to
				 * the actual namespace from which the search
				 * started. This is either cxtNsPtr, the ::
				 * namespace if TCL_GLOBAL_ONLY was specified,
				 * or the current namespace if cxtNsPtr was
				 * NULL. */
    const char **simpleNamePtr) /* Address where function stores the simple
				 * name at end of the qualName, or NULL if
				 * qualName is "::" or the flag
				 * TCL_FIND_ONLY_NS was specified. */
{
    Interp *iPtr = (Interp *) interp;
    Namespace *nsPtr = cxtNsPtr;
    Namespace *altNsPtr;
    Namespace *globalNsPtr = iPtr->globalNsPtr;
    const char *start, *end;
    const char *nsName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer;
    int len;

    /*
     * Determine the context namespace nsPtr in which to start the primary
     * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was
     * specified, search from the global namespace. Otherwise, use the
     * namespace given in cxtNsPtr, or if that is NULL, use the current
     * namespace context. Note that we always treat two or more adjacent ":"s
     * as a namespace separator.
     */

    if (flags & TCL_GLOBAL_ONLY) {
	nsPtr = globalNsPtr;
    } else if (nsPtr == NULL) {
	nsPtr = iPtr->varFramePtr->nsPtr;
    }

    start = qualName;			/* Points to start of qualifying
					 * namespace. */
    if ((*qualName == ':') && (*(qualName+1) == ':')) {
	start = qualName+2;		/* Skip over the initial :: */
	while (*start == ':') {
	    start++;			/* Skip over a subsequent : */
	}
	nsPtr = globalNsPtr;
	if (*start == '\0') {		/* qualName is just two or more
					 * ":"s. */
	    *nsPtrPtr = globalNsPtr;
	    *altNsPtrPtr = NULL;
	    *actualCxtPtrPtr = globalNsPtr;
	    *simpleNamePtr = start;	/* Points to empty string. */
	    return TCL_OK;
	}
    }
    *actualCxtPtrPtr = nsPtr;

    /*
     * Start an alternate search path starting with the global namespace.
     * However, if the starting context is the global namespace, or if the
     * flag is set to search only the namespace *cxtNsPtr, ignore the
     * alternate search path.
     */

    altNsPtr = globalNsPtr;
    if ((nsPtr == globalNsPtr)
	    || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) {
	altNsPtr = NULL;
    }

    /*
     * Loop to resolve each namespace qualifier in qualName.
     */

    Tcl_DStringInit(&buffer);
    end = start;
    while (*start != '\0') {
	/*
	 * Find the next namespace qualifier (i.e., a name ending in "::") or
	 * the end of the qualified name (i.e., a name ending in "\0"). Set
	 * len to the number of characters, starting from start, in the name;
	 * set end to point after the "::"s or at the "\0".
	 */

	len = 0;
	for (end = start;  *end != '\0';  end++) {
	    if ((*end == ':') && (*(end+1) == ':')) {
		end += 2;		/* Skip over the initial :: */
		while (*end == ':') {
		    end++;		/* Skip over the subsequent : */
		}
		break;			/* Exit for loop; end is after ::'s */
	    }
	    len++;
	}

	if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) {
	    /*
	     * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS
	     * was specified, look this up as a namespace. Otherwise, start is
	     * the name of a cmd or var and we are done.
	     */

	    if (flags & TCL_FIND_ONLY_NS) {
		nsName = start;
	    } else {
		*nsPtrPtr = nsPtr;
		*altNsPtrPtr = altNsPtr;
		*simpleNamePtr = start;
		Tcl_DStringFree(&buffer);
		return TCL_OK;
	    }
	} else {
	    /*
	     * start points to the beginning of a namespace qualifier ending
	     * in "::". end points to the start of a name in that namespace
	     * that might be empty. Copy the namespace qualifier to a buffer
	     * so it can be null terminated. We can't modify the incoming
	     * qualName since it may be a string constant.
	     */

	    TclDStringClear(&buffer);
	    Tcl_DStringAppend(&buffer, start, len);
	    nsName = Tcl_DStringValue(&buffer);
	}

	/*
	 * Look up the namespace qualifier nsName in the current namespace
	 * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
	 * create that qualifying namespace. This is needed for functions like
	 * Tcl_CreateCommand that cannot fail.
	 */

	if (nsPtr != NULL) {
#ifndef BREAK_NAMESPACE_COMPAT
	    entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
#else
	    if (nsPtr->childTablePtr == NULL) {
		entryPtr = NULL;
	    } else {
		entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
	    }
#endif
	    if (entryPtr != NULL) {
		nsPtr = Tcl_GetHashValue(entryPtr);
	    } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
		Tcl_CallFrame *framePtr;

		(void) TclPushStackFrame(interp, &framePtr,
			(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);

		nsPtr = (Namespace *)
			Tcl_CreateNamespace(interp, nsName, NULL, NULL);
		TclPopStackFrame(interp);

		if (nsPtr == NULL) {
		    Tcl_Panic("Could not create namespace '%s'", nsName);
		}
	    } else {			/* Namespace not found and was not
					 * created. */
		nsPtr = NULL;
	    }
	}

	/*
	 * Look up the namespace qualifier in the alternate search path too.
	 */

	if (altNsPtr != NULL) {
#ifndef BREAK_NAMESPACE_COMPAT
	    entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
#else
	    if (altNsPtr->childTablePtr != NULL) {
		entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
	    } else {
		entryPtr = NULL;
	    }
#endif
	    if (entryPtr != NULL) {
		altNsPtr = Tcl_GetHashValue(entryPtr);
	    } else {
		altNsPtr = NULL;
	    }
	}

	/*
	 * If both search paths have failed, return NULL results.
	 */

	if ((nsPtr == NULL) && (altNsPtr == NULL)) {
	    *nsPtrPtr = NULL;
	    *altNsPtrPtr = NULL;
	    *simpleNamePtr = NULL;
	    Tcl_DStringFree(&buffer);
	    return TCL_OK;
	}

	start = end;
    }

    /*
     * We ignore trailing "::"s in a namespace name, but in a command or
     * variable name, trailing "::"s refer to the cmd or var named {}.
     */

    if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) {
	*simpleNamePtr = NULL;		/* Found namespace name. */
    } else {
	*simpleNamePtr = end;		/* Found cmd/var: points to empty
					 * string. */
    }

    /*
     * As a special case, if we are looking for a namespace and qualName is ""
     * and the current active namespace (nsPtr) is not the global namespace,
     * return NULL (no namespace was found). This is because namespaces can
     * not have empty names except for the global namespace.
     */

    if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0')
	    && (nsPtr != globalNsPtr)) {
	nsPtr = NULL;
    }

    *nsPtrPtr = nsPtr;
    *altNsPtrPtr = altNsPtr;
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindNamespace --
 *
 *	Searches for a namespace.
 *
 * Results:
 *	Returns a pointer to the namespace if it is found. Otherwise, returns
 *	NULL and leaves an error message in the interpreter's result object if
 *	"flags" contains TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Namespace *
Tcl_FindNamespace(
    Tcl_Interp *interp,		/* The interpreter in which to find the
				 * namespace. */
    const char *name,		/* Namespace name. If it starts with "::",
				 * will be looked up in global namespace.
				 * Else, looked up first in contextNsPtr
				 * (current namespace if contextNsPtr is
				 * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or
				 * if the name starts with "::". Otherwise,
				 * points to namespace in which to resolve
				 * name; if NULL, look up name in the current
				 * namespace. */
    register int flags)		/* Flags controlling namespace lookup: an OR'd
				 * combination of TCL_GLOBAL_ONLY and
				 * TCL_LEAVE_ERR_MSG flags. */
{
    Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
    const char *dummy;

    /*
     * Find the namespace(s) that contain the specified namespace name. Add
     * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its
     * last component, a namespace.
     */

    TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
	    flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);

    if (nsPtr != NULL) {
	return (Tcl_Namespace *) nsPtr;
    }

    if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "unknown namespace \"%s\"", name));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindCommand --
 *
 *	Searches for a command.
 *
 * Results:
 *	Returns a token for the command if it is found. Otherwise, if it can't
 *	be found or there is an error, returns NULL and leaves an error
 *	message in the interpreter's result object if "flags" contains
 *	TCL_LEAVE_ERR_MSG.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
Tcl_FindCommand(
    Tcl_Interp *interp,		/* The interpreter in which to find the
				 * command and to report errors. */
    const char *name,		/* Command's name. If it starts with "::",
				 * will be looked up in global namespace.
				 * Else, looked up first in contextNsPtr
				 * (current namespace if contextNsPtr is
				 * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set.
				 * Otherwise, points to namespace in which to
				 * resolve name. If NULL, look up name in the
				 * current namespace. */
    int flags)			/* An OR'd combination of flags:
				 * TCL_GLOBAL_ONLY (look up name only in
				 * global namespace), TCL_NAMESPACE_ONLY (look
				 * up only in contextNsPtr, or the current
				 * namespace if contextNsPtr is NULL), and
				 * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
				 * and TCL_NAMESPACE_ONLY are given,
				 * TCL_GLOBAL_ONLY is ignored. */
{
    Interp *iPtr = (Interp *) interp;
    Namespace *cxtNsPtr;
    register Tcl_HashEntry *entryPtr;
    register Command *cmdPtr;
    const char *simpleName;
    int result;

    /*
     * If this namespace has a command resolver, then give it first crack at
     * the command resolution. If the interpreter has any command resolvers,
     * consult them next. The command resolver functions may return a
     * Tcl_Command value, they may signal to continue onward, or they may
     * signal an error.
     */

    if ((flags & TCL_GLOBAL_ONLY) || !strncmp(name, "::", 2)) {
	cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
    } else if (contextNsPtr != NULL) {
	cxtNsPtr = (Namespace *) contextNsPtr;
    } else {
	cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    }

    if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
	ResolverScheme *resPtr = iPtr->resolverPtr;
	Tcl_Command cmd;

	if (cxtNsPtr->cmdResProc) {
	    result = cxtNsPtr->cmdResProc(interp, name,
		    (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
	} else {
	    result = TCL_CONTINUE;
	}

	while (result == TCL_CONTINUE && resPtr) {
	    if (resPtr->cmdResProc) {
		result = resPtr->cmdResProc(interp, name,
			(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
	    }
	    resPtr = resPtr->nextPtr;
	}

	if (result == TCL_OK) {
	    return cmd;
	} else if (result != TCL_CONTINUE) {
	    return NULL;
	}
    }

    /*
     * Find the namespace(s) that contain the command.
     */

    cmdPtr = NULL;
    if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
	    && !(flags & TCL_NAMESPACE_ONLY)) {
	int i;
	Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;

	(void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
		TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		&simpleName);
	if ((realNsPtr != NULL) && (simpleName != NULL)) {
	    if ((cxtNsPtr == realNsPtr)
		    || !(realNsPtr->flags & NS_DYING)) {
		entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
		if (entryPtr != NULL) {
		    cmdPtr = Tcl_GetHashValue(entryPtr);
		}
	    }
	}

	/*
	 * Next, check along the path.
	 */

	for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
	    pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
	    if (pathNsPtr == NULL) {
		continue;
	    }
	    (void) TclGetNamespaceForQualName(interp, name, pathNsPtr,
		    TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		    &simpleName);
	    if ((realNsPtr != NULL) && (simpleName != NULL)
		    && !(realNsPtr->flags & NS_DYING)) {
		entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
		if (entryPtr != NULL) {
		    cmdPtr = Tcl_GetHashValue(entryPtr);
		}
	    }
	}

	/*
	 * If we've still not found the command, look in the global namespace
	 * as a last resort.
	 */

	if (cmdPtr == NULL) {
	    (void) TclGetNamespaceForQualName(interp, name, NULL,
		    TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
		    &simpleName);
	    if ((realNsPtr != NULL) && (simpleName != NULL)
		    && !(realNsPtr->flags & NS_DYING)) {
		entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
		if (entryPtr != NULL) {
		    cmdPtr = Tcl_GetHashValue(entryPtr);
		}
	    }
	}
    } else {
	Namespace *nsPtr[2];
	register int search;

	TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
		flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);

	/*
	 * Look for the command in the command table of its namespace. Be sure
	 * to check both possible search paths: from the specified namespace
	 * context and from the global namespace.
	 */

	for (search = 0;  (search < 2) && (cmdPtr == NULL);  search++) {
	    if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
		entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
			simpleName);
		if (entryPtr != NULL) {
		    cmdPtr = Tcl_GetHashValue(entryPtr);
		}
	    }
	}
    }

    if (cmdPtr != NULL) {
	return (Tcl_Command) cmdPtr;
    }

    if (flags & TCL_LEAVE_ERR_MSG) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "unknown command \"%s\"", name));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclResetShadowedCmdRefs --
 *
 *	Called when a command is added to a namespace to check for existing
 *	command references that the new command may invalidate. Consider the
 *	following cases that could happen when you add a command "foo" to a
 *	namespace "b":
 *	   1. It could shadow a command named "foo" at the global scope. If
 *	      it does, all command references in the namespace "b" are
 *	      suspect.
 *	   2. Suppose the namespace "b" resides in a namespace "a". Then to
 *	      "a" the new command "b::foo" could shadow another command
 *	      "b::foo" in the global namespace. If so, then all command
 *	      references in "a" * are suspect.
 *	The same checks are applied to all parent namespaces, until we reach
 *	the global :: namespace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If the new command shadows an existing command, the cmdRefEpoch
 *	counter is incremented in each namespace that sees the shadow. This
 *	invalidates all command references that were previously cached in that
 *	namespace. The next time the commands are used, they are resolved from
 *	scratch.
 *
 *----------------------------------------------------------------------
 */

void
TclResetShadowedCmdRefs(
    Tcl_Interp *interp,		/* Interpreter containing the new command. */
    Command *newCmdPtr)		/* Points to the new command. */
{
    char *cmdName;
    Tcl_HashEntry *hPtr;
    register Namespace *nsPtr;
    Namespace *trailNsPtr, *shadowNsPtr;
    Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
    int found, i;
    int trailFront = -1;
    int trailSize = 5;		/* Formerly NUM_TRAIL_ELEMS. */
    Namespace **trailPtr = TclStackAlloc(interp,
	    trailSize * sizeof(Namespace *));

    /*
     * Start at the namespace containing the new command, and work up through
     * the list of parents. Stop just before the global namespace, since the
     * global namespace can't "shadow" its own entries.
     *
     * The namespace "trail" list we build consists of the names of each
     * namespace that encloses the new command, in order from outermost to
     * innermost: for example, "a" then "b". Each iteration of this loop
     * eventually extends the trail upwards by one namespace, nsPtr. We use
     * this trail list to see if nsPtr (e.g. "a" in 2. above) could have
     * now-invalid cached command references. This will happen if nsPtr
     * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that
     * there is a identically-named sequence of child namespaces starting from
     * :: (e.g. "::b") whose tail namespace contains a command also named
     * cmdName.
     */

    cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
    for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ;
	    nsPtr=nsPtr->parentPtr) {
	/*
	 * Find the maximal sequence of child namespaces contained in nsPtr
	 * such that there is a identically-named sequence of child namespaces
	 * starting from ::. shadowNsPtr will be the tail of this sequence, or
	 * the deepest namespace under :: that might contain a command now
	 * shadowed by cmdName. We check below if shadowNsPtr actually
	 * contains a command cmdName.
	 */

	found = 1;
	shadowNsPtr = globalNsPtr;

	for (i = trailFront;  i >= 0;  i--) {
	    trailNsPtr = trailPtr[i];
#ifndef BREAK_NAMESPACE_COMPAT
	    hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
		    trailNsPtr->name);
#else
	    if (shadowNsPtr->childTablePtr != NULL) {
		hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
			trailNsPtr->name);
	    } else {
		hPtr = NULL;
	    }
#endif
	    if (hPtr != NULL) {
		shadowNsPtr = Tcl_GetHashValue(hPtr);
	    } else {
		found = 0;
		break;
	    }
	}

	/*
	 * If shadowNsPtr contains a command named cmdName, we invalidate all
	 * of the command refs cached in nsPtr. As a boundary case,
	 * shadowNsPtr is initially :: and we check for case 1. above.
	 */

	if (found) {
	    hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
	    if (hPtr != NULL) {
		nsPtr->cmdRefEpoch++;
		TclInvalidateNsPath(nsPtr);

		/*
		 * If the shadowed command was compiled to bytecodes, we
		 * invalidate all the bytecodes in nsPtr, to force a new
		 * compilation. We use the resolverEpoch to signal the need
		 * for a fresh compilation of every bytecode.
		 */

		if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL){
		    nsPtr->resolverEpoch++;
		}
	    }
	}

	/*
	 * Insert nsPtr at the front of the trail list: i.e., at the end of
	 * the trailPtr array.
	 */

	trailFront++;
	if (trailFront == trailSize) {
	    int newSize = 2 * trailSize;

	    trailPtr = TclStackRealloc(interp, trailPtr,
		    newSize * sizeof(Namespace *));
	    trailSize = newSize;
	}
	trailPtr[trailFront] = nsPtr;
    }
    TclStackFree(interp, trailPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceFromObj, GetNamespaceFromObj --
 *
 *	Gets the namespace specified by the name in a Tcl_Obj.
 *
 * Results:
 *	Returns TCL_OK if the namespace was resolved successfully, and stores
 *	a pointer to the namespace in the location specified by nsPtrPtr. If
 *	the namespace can't be found, or anything else goes wrong, this
 *	function returns TCL_ERROR and writes an error message to interp,
 *	if non-NULL.
 *
 * Side effects:
 *	May update the internal representation for the object, caching the
 *	namespace reference. The next time this function is called, the
 *	namespace value can be found quickly.
 *
 *----------------------------------------------------------------------
 */

int
TclGetNamespaceFromObj(
    Tcl_Interp *interp,		/* The current interpreter. */
    Tcl_Obj *objPtr,		/* The object to be resolved as the name of a
				 * namespace. */
    Tcl_Namespace **nsPtrPtr)	/* Result namespace pointer goes here. */
{
    if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) {
	const char *name = TclGetString(objPtr);

	if ((name[0] == ':') && (name[1] == ':')) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "namespace \"%s\" not found", name));
	} else {
	    /*
	     * Get the current namespace name.
	     */

	    NamespaceCurrentCmd(NULL, interp, 1, NULL);
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "namespace \"%s\" not found in \"%s\"", name,
		    Tcl_GetStringResult(interp)));
	}
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

static int
GetNamespaceFromObj(
    Tcl_Interp *interp,		/* The current interpreter. */
    Tcl_Obj *objPtr,		/* The object to be resolved as the name of a
				 * namespace. */
    Tcl_Namespace **nsPtrPtr)	/* Result namespace pointer goes here. */
{
    ResolvedNsName *resNamePtr;
    Namespace *nsPtr, *refNsPtr;

    if (objPtr->typePtr == &nsNameType) {
	/*
	 * Check that the ResolvedNsName is still valid; avoid letting the ref
	 * cross interps.
	 */

	resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
	nsPtr = resNamePtr->nsPtr;
	refNsPtr = resNamePtr->refNsPtr;
	if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
		(!refNsPtr || ((interp == refNsPtr->interp) &&
		(refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){
	    *nsPtrPtr = (Tcl_Namespace *) nsPtr;
	    return TCL_OK;
	}
    }
    if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
	resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
	*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitNamespaceCmd --
 *
 *	This function is called to create the "namespace" Tcl command. See the
 *	user documentation for details on what it does.
 *
 * Results:
 *	Handle for the namespace command, or NULL on failure.
 *
 * Side effects:
 *	none
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclInitNamespaceCmd(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap);
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceChildrenCmd --
 *
 *	Invoked to implement the "namespace children" command that returns a
 *	list containing the fully-qualified names of the child namespaces of a
 *	given namespace. Handles the following syntax:
 *
 *	    namespace children ?name? ?pattern?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceChildrenCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    Namespace *nsPtr, *childNsPtr;
    Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
    const char *pattern = NULL;
    Tcl_DString buffer;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_Obj *listPtr, *elemPtr;

    /*
     * Get a pointer to the specified namespace, or the current namespace.
     */

    if (objc == 1) {
	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    } else if ((objc == 2) || (objc == 3)) {
	if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){
	    return TCL_ERROR;
	}
	nsPtr = (Namespace *) namespacePtr;
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?");
	return TCL_ERROR;
    }

    /*
     * Get the glob-style pattern, if any, used to narrow the search.
     */

    Tcl_DStringInit(&buffer);
    if (objc == 3) {
	const char *name = TclGetString(objv[2]);

	if ((*name == ':') && (*(name+1) == ':')) {
	    pattern = name;
	} else {
	    Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
	    if (nsPtr != globalNsPtr) {
		TclDStringAppendLiteral(&buffer, "::");
	    }
	    Tcl_DStringAppend(&buffer, name, -1);
	    pattern = Tcl_DStringValue(&buffer);
	}
    }

    /*
     * Create a list containing the full names of all child namespaces whose
     * names match the specified pattern, if any.
     */

    listPtr = Tcl_NewListObj(0, NULL);
    if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
	unsigned int length = strlen(nsPtr->fullName);

	if (strncmp(pattern, nsPtr->fullName, length) != 0) {
	    goto searchDone;
	}
	if (
#ifndef BREAK_NAMESPACE_COMPAT
	    Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL
#else
	    nsPtr->childTablePtr != NULL &&
	    Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL
#endif
	) {
	    Tcl_ListObjAppendElement(interp, listPtr,
		    Tcl_NewStringObj(pattern, -1));
	}
	goto searchDone;
    }
#ifndef BREAK_NAMESPACE_COMPAT
    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
#else
    if (nsPtr->childTablePtr == NULL) {
	goto searchDone;
    }
    entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
    while (entryPtr != NULL) {
	childNsPtr = Tcl_GetHashValue(entryPtr);
	if ((pattern == NULL)
		|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
	    elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
	    Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
	}
	entryPtr = Tcl_NextHashEntry(&search);
    }

  searchDone:
    Tcl_SetObjResult(interp, listPtr);
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceCodeCmd --
 *
 *	Invoked to implement the "namespace code" command to capture the
 *	namespace context of a command. Handles the following syntax:
 *
 *	    namespace code arg
 *
 *	Here "arg" can be a list. "namespace code arg" produces a result
 *	equivalent to that produced by the command
 *
 *	    list ::namespace inscope [namespace current] $arg
 *
 *	However, if "arg" is itself a scoped value starting with "::namespace
 *	inscope", then the result is just "arg".
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this function returns an error message as the
 *	result in the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceCodeCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Namespace *currNsPtr;
    Tcl_Obj *listPtr, *objPtr;
    register const char *arg;
    int length;

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

    /*
     * If "arg" is already a scoped value, then return it directly.
     * Take care to only check for scoping in precisely the style that
     * [::namespace code] generates it.  Anything more forgiving can have
     * the effect of failing in namespaces that contain their own custom
     " "namespace" command.  [Bug 3202171].
     */

    arg = TclGetStringFromObj(objv[1], &length);
    if (*arg==':' && length > 20 
	    && strncmp(arg, "::namespace inscope ", 20) == 0) {
	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }

    /*
     * Otherwise, construct a scoped command by building a list with
     * "namespace inscope", the full name of the current namespace, and the
     * argument "arg". By constructing a list, we ensure that scoped commands
     * are interpreted properly when they are executed later, by the
     * "namespace inscope" command.
     */

    TclNewObj(listPtr);
    TclNewLiteralStringObj(objPtr, "::namespace");
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
    TclNewLiteralStringObj(objPtr, "inscope");
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
	TclNewLiteralStringObj(objPtr, "::");
    } else {
	objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
    }
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    Tcl_ListObjAppendElement(interp, listPtr, objv[1]);

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceCurrentCmd --
 *
 *	Invoked to implement the "namespace current" command which returns the
 *	fully-qualified name of the current namespace. Handles the following
 *	syntax:
 *
 *	    namespace current
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceCurrentCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    register Namespace *currNsPtr;

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

    /*
     * The "real" name of the global namespace ("::") is the null string, but
     * we return "::" for it as a convenience to programmers. Note that "" and
     * "::" are treated as synonyms by the namespace code so that it is still
     * easy to do things like:
     *
     *    namespace [namespace current]::bar { ... }
     */

    currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceDeleteCmd --
 *
 *	Invoked to implement the "namespace delete" command to delete
 *	namespace(s). Handles the following syntax:
 *
 *	    namespace delete ?name name...?
 *
 *	Each name identifies a namespace. It may include a sequence of
 *	namespace qualifiers separated by "::"s. If a namespace is found, it
 *	is deleted: all variables and procedures contained in that namespace
 *	are deleted. If that namespace is being used on the call stack, it is
 *	kept alive (but logically deleted) until it is removed from the call
 *	stack: that is, it can no longer be referenced by name but any
 *	currently executing procedure that refers to it is allowed to do so
 *	until the procedure returns. If the namespace can't be found, this
 *	function returns an error. If no namespaces are specified, this
 *	command does nothing.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Deletes the specified namespaces. If anything goes wrong, this
 *	function returns an error message in the interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceDeleteCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    const char *name;
    register int i;

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

    /*
     * Destroying one namespace may cause another to be destroyed. Break this
     * into two passes: first check to make sure that all namespaces on the
     * command line are valid, and report any errors.
     */

    for (i = 1;  i < objc;  i++) {
	name = TclGetString(objv[i]);
	namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
	if ((namespacePtr == NULL)
		|| (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "unknown namespace \"%s\" in namespace delete command",
		    TclGetString(objv[i])));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
		    TclGetString(objv[i]), NULL);
	    return TCL_ERROR;
	}
    }

    /*
     * Okay, now delete each namespace.
     */

    for (i = 1;  i < objc;  i++) {
	name = TclGetString(objv[i]);
	namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0);
	if (namespacePtr) {
	    Tcl_DeleteNamespace(namespacePtr);
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceEvalCmd --
 *
 *	Invoked to implement the "namespace eval" command. Executes commands
 *	in a namespace. If the namespace does not already exist, it is
 *	created. Handles the following syntax:
 *
 *	    namespace eval name arg ?arg...?
 *
 *	If more than one arg argument is specified, the command that is
 *	executed is the result of concatenating the arguments together with a
 *	space between each argument.
 *
 * Results:
 *	Returns TCL_OK if the namespace is found and the commands are executed
 *	successfully. Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns the result of the command in the interpreter's result object.
 *	If anything goes wrong, this function returns an error message as the
 *	result.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceEvalCmd(
    ClientData clientData,	/* Arbitrary value passed to cmd. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
	    objv);
}

static int
NRNamespaceEvalCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    CmdFrame *invoker;
    int word;
    Tcl_Namespace *namespacePtr;
    CallFrame *framePtr, **framePtrPtr;
    Tcl_Obj *objPtr;
    int result;

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

    /*
     * Try to resolve the namespace reference, caching the result in the
     * namespace object along the way.
     */

    result = GetNamespaceFromObj(interp, objv[1], &namespacePtr);

    /*
     * If the namespace wasn't found, try to create it.
     */

    if (result == TCL_ERROR) {
	const char *name = TclGetString(objv[1]);

	namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL);
	if (namespacePtr == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Make the specified namespace the current namespace and evaluate the
     * command(s).
     */

    /* This is needed to satisfy GCC 3.3's strict aliasing rules */
    framePtrPtr = &framePtr;
    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
	    namespacePtr, /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
	return TCL_ERROR;
    }

    if (iPtr->ensembleRewrite.sourceObjs == NULL) {
	framePtr->objc = objc;
	framePtr->objv = objv;
    } else {
	framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
		- iPtr->ensembleRewrite.numInsertedObjs;
	framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
    }

    if (objc == 3) {
	/*
	 * TIP #280: Make actual argument location available to eval'd script.
	 */

	objPtr = objv[2];
	invoker = iPtr->cmdFramePtr;
	word = 3;
	TclArgumentGet(interp, objPtr, &invoker, &word);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc-2, objv+2);
	invoker = NULL;
	word = 0;
    }

    /*
     * TIP #280: Make invoking context available to eval'd script.
     */

    TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval",
	    NULL, NULL);
    return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
}

static int
NsEval_Callback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Namespace *namespacePtr = data[0];

    if (result == TCL_ERROR) {
	int length = strlen(namespacePtr->fullName);
	int limit = 200;
	int overflow = (length > limit);
	char *cmd = data[1];

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (in namespace %s \"%.*s%s\" script line %d)",
		cmd,
		(overflow ? limit : length), namespacePtr->fullName,
		(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceExistsCmd --
 *
 *	Invoked to implement the "namespace exists" command that returns true
 *	if the given namespace currently exists, and false otherwise. Handles
 *	the following syntax:
 *
 *	    namespace exists name
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceExistsCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;

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

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
	    GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceExportCmd --
 *
 *	Invoked to implement the "namespace export" command that specifies
 *	which commands are exported from a namespace. The exported commands
 *	are those that can be imported into another namespace using "namespace
 *	import". Both commands defined in a namespace and commands the
 *	namespace has imported can be exported by a namespace. This command
 *	has the following syntax:
 *
 *	    namespace export ?-clear? ?pattern pattern...?
 *
 *	Each pattern may contain "string match"-style pattern matching special
 *	characters, but the pattern may not include any namespace qualifiers:
 *	that is, the pattern must specify commands in the current (exporting)
 *	namespace. The specified patterns are appended onto the namespace's
 *	list of export patterns.
 *
 *	To reset the namespace's export pattern list, specify the "-clear"
 *	flag.
 *
 *	If there are no export patterns and the "-clear" flag isn't given,
 *	this command returns the namespace's current export list.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceExportCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int firstArg, i;

    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?");
	return TCL_ERROR;
    }

    /*
     * If no pattern arguments are given, and "-clear" isn't specified, return
     * the namespace's current export pattern list.
     */

    if (objc == 1) {
	Tcl_Obj *listPtr = Tcl_NewObj();

	(void) Tcl_AppendExportList(interp, NULL, listPtr);
	Tcl_SetObjResult(interp, listPtr);
	return TCL_OK;
    }

    /*
     * Process the optional "-clear" argument.
     */

    firstArg = 1;
    if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) {
	Tcl_Export(interp, NULL, "::", 1);
	Tcl_ResetResult(interp);
	firstArg++;
    }

    /*
     * Add each pattern to the namespace's export pattern list.
     */

    for (i = firstArg;  i < objc;  i++) {
	int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceForgetCmd --
 *
 *	Invoked to implement the "namespace forget" command to remove imported
 *	commands from a namespace. Handles the following syntax:
 *
 *	    namespace forget ?pattern pattern...?
 *
 *	Each pattern is a name like "foo::*" or "a::b::x*". That is, the
 *	pattern may include the special pattern matching characters recognized
 *	by the "string match" command, but only in the command name at the end
 *	of the qualified name; the special pattern characters may not appear
 *	in a namespace name. All of the commands that match that pattern are
 *	checked to see if they have an imported command in the current
 *	namespace that refers to the matched command. If there is an alias, it
 *	is removed.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Imported commands are removed from the current namespace. If anything
 *	goes wrong, this function returns an error message in the
 *	interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceForgetCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *pattern;
    register int i, result;

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

    for (i = 1;  i < objc;  i++) {
	pattern = TclGetString(objv[i]);
	result = Tcl_ForgetImport(interp, NULL, pattern);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceImportCmd --
 *
 *	Invoked to implement the "namespace import" command that imports
 *	commands into a namespace. Handles the following syntax:
 *
 *	    namespace import ?-force? ?pattern pattern...?
 *
 *	Each pattern is a namespace-qualified name like "foo::*", "a::b::x*",
 *	or "bar::p". That is, the pattern may include the special pattern
 *	matching characters recognized by the "string match" command, but only
 *	in the command name at the end of the qualified name; the special
 *	pattern characters may not appear in a namespace name. All of the
 *	commands that match the pattern and which are exported from their
 *	namespace are made accessible from the current namespace context. This
 *	is done by creating a new "imported command" in the current namespace
 *	that points to the real command in its original namespace; when the
 *	imported command is called, it invokes the real command.
 *
 *	If an imported command conflicts with an existing command, it is
 *	treated as an error. But if the "-force" option is included, then
 *	existing commands are overwritten by the imported commands.
 *
 *	If there are no pattern arguments and the "-force" flag isn't given,
 *	this command returns the list of commands currently imported in
 *	the current namespace.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Adds imported commands to the current namespace. If anything goes
 *	wrong, this function returns an error message in the interpreter's
 *	result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceImportCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int allowOverwrite = 0;
    const char *string, *pattern;
    register int i, result;
    int firstArg;

    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?");
	return TCL_ERROR;
    }

    /*
     * Skip over the optional "-force" as the first argument.
     */

    firstArg = 1;
    if (firstArg < objc) {
	string = TclGetString(objv[firstArg]);
	if ((*string == '-') && (strcmp(string, "-force") == 0)) {
	    allowOverwrite = 1;
	    firstArg++;
	}
    } else {
	/*
	 * When objc == 1, command is just [namespace import]. Introspection
	 * form to return list of imported commands.
	 */

	Tcl_HashEntry *hPtr;
	Tcl_HashSearch search;
	Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
	Tcl_Obj *listPtr;

	TclNewObj(listPtr);
	for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    Command *cmdPtr = Tcl_GetHashValue(hPtr);

	    if (cmdPtr->deleteProc == DeleteImportedCmd) {
		Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
			Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1));
	    }
	}
	Tcl_SetObjResult(interp, listPtr);
	return TCL_OK;
    }

    /*
     * Handle the imports for each of the patterns.
     */

    for (i = firstArg;  i < objc;  i++) {
	pattern = TclGetString(objv[i]);
	result = Tcl_Import(interp, NULL, pattern, allowOverwrite);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceInscopeCmd --
 *
 *	Invoked to implement the "namespace inscope" command that executes a
 *	script in the context of a particular namespace. This command is not
 *	expected to be used directly by programmers; calls to it are generated
 *	implicitly when programs use "namespace code" commands to register
 *	callback scripts. Handles the following syntax:
 *
 *	    namespace inscope name arg ?arg...?
 *
 *	The "namespace inscope" command is much like the "namespace eval"
 *	command except that it has lappend semantics and the namespace must
 *	already exist. It treats the first argument as a list, and appends any
 *	arguments after the first onto the end as proper list elements. For
 *	example,
 *
 *	    namespace inscope ::foo {a b} c d e
 *
 *	is equivalent to
 *
 *	    namespace eval ::foo [concat {a b} [list c d e]]
 *
 *	This lappend semantics is important because many callback scripts are
 *	actually prefixes.
 *
 * Results:
 *	Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure.
 *
 * Side effects:
 *	Returns a result in the Tcl interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceInscopeCmd(
    ClientData clientData,	/* Arbitrary value passed to cmd. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
	    objv);
}

static int
NRNamespaceInscopeCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Namespace *namespacePtr;
    CallFrame *framePtr, **framePtrPtr;
    register Interp *iPtr = (Interp *) interp;
    int i, result;
    Tcl_Obj *cmdObjPtr;

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

    /*
     * Resolve the namespace reference.
     */

    if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Make the specified namespace the current namespace.
     */

    framePtrPtr = &framePtr;		/* This is needed to satisfy GCC's
					 * strict aliasing rules. */
    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
	    namespacePtr, /*isProcCallFrame*/ 0);
    if (result != TCL_OK) {
	return result;
    }

    if (iPtr->ensembleRewrite.sourceObjs == NULL) {
	framePtr->objc = objc;
	framePtr->objv = objv;
    } else {
	framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
		- iPtr->ensembleRewrite.numInsertedObjs;
	framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
    }

    /*
     * Execute the command. If there is just one argument, just treat it as a
     * script and evaluate it. Otherwise, create a list from the arguments
     * after the first one, then concatenate the first argument and the list
     * of extra arguments to form the command to evaluate.
     */

    if (objc == 3) {
	cmdObjPtr = objv[2];
    } else {
	Tcl_Obj *concatObjv[2];
	register Tcl_Obj *listPtr;

	listPtr = Tcl_NewListObj(0, NULL);
	for (i = 3;  i < objc;  i++) {
	    if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){
		Tcl_DecrRefCount(listPtr);	/* Free unneeded obj. */
		return TCL_ERROR;
	    }
	}

	concatObjv[0] = objv[2];
	concatObjv[1] = listPtr;
	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
	Tcl_DecrRefCount(listPtr);    /* We're done with the list object. */
    }

    TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope",
	    NULL, NULL);
    return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceOriginCmd --
 *
 *	Invoked to implement the "namespace origin" command to return the
 *	fully-qualified name of the "real" command to which the specified
 *	"imported command" refers. Handles the following syntax:
 *
 *	    namespace origin name
 *
 * Results:
 *	An imported command is created in an namespace when that namespace
 *	imports a command from another namespace. If a command is imported
 *	into a sequence of namespaces a, b,...,n where each successive
 *	namespace just imports the command from the previous namespace, this
 *	command returns the fully-qualified name of the original command in
 *	the first namespace, a. If "name" does not refer to an alias, its
 *	fully-qualified name is returned. The returned name is stored in the
 *	interpreter's result object. This function returns TCL_OK if
 *	successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this function returns an error message in the
 *	interpreter's result object.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceOriginCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Command command, origCommand;
    Tcl_Obj *resultPtr;

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

    command = Tcl_GetCommandFromObj(interp, objv[1]);
    if (command == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "invalid command name \"%s\"", TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
		TclGetString(objv[1]), NULL);
	return TCL_ERROR;
    }
    origCommand = TclGetOriginalCommand(command);
    TclNewObj(resultPtr);
    if (origCommand == NULL) {
	/*
	 * The specified command isn't an imported command. Return the
	 * command's name qualified by the full name of the namespace it was
	 * defined in.
	 */

	Tcl_GetCommandFullName(interp, command, resultPtr);
    } else {
	Tcl_GetCommandFullName(interp, origCommand, resultPtr);
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceParentCmd --
 *
 *	Invoked to implement the "namespace parent" command that returns the
 *	fully-qualified name of the parent namespace for a specified
 *	namespace. Handles the following syntax:
 *
 *	    namespace parent ?name?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceParentCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Namespace *nsPtr;

    if (objc == 1) {
	nsPtr = TclGetCurrentNamespace(interp);
    } else if (objc == 2) {
	if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "?name?");
	return TCL_ERROR;
    }

    /*
     * Report the parent of the specified namespace.
     */

    if (nsPtr->parentPtr != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		nsPtr->parentPtr->fullName, -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespacePathCmd --
 *
 *	Invoked to implement the "namespace path" command that reads and
 *	writes the current namespace's command resolution path. Has one
 *	optional argument: if present, it is a list of named namespaces to set
 *	the path to, and if absent, the current path should be returned.
 *	Handles the following syntax:
 *
 *	    namespace path ?nsList?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong
 *	(most notably if the namespace list contains the name of something
 *	other than a namespace). In the successful-exit case, may set the
 *	interpreter result to the list of names of the namespaces on the
 *	current namespace's path.
 *
 * Side effects:
 *	May update the namespace path (triggering a recomputing of all command
 *	names that depend on the namespace for resolution).
 *
 *----------------------------------------------------------------------
 */

static int
NamespacePathCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    int i, nsObjc, result = TCL_ERROR;
    Tcl_Obj **nsObjv;
    Tcl_Namespace **namespaceList = NULL;

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

    /*
     * If no path is given, return the current path.
     */

    if (objc == 1) {
	Tcl_Obj *resultObj = Tcl_NewObj();

	for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	    if (nsPtr->commandPathArray[i].nsPtr != NULL) {
		Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
			nsPtr->commandPathArray[i].nsPtr->fullName, -1));
	    }
	}
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;
    }

    /*
     * There is a path given, so parse it into an array of namespace pointers.
     */

    if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
	goto badNamespace;
    }
    if (nsObjc != 0) {
	namespaceList = TclStackAlloc(interp,
		sizeof(Tcl_Namespace *) * nsObjc);

	for (i=0 ; i<nsObjc ; i++) {
	    if (TclGetNamespaceFromObj(interp, nsObjv[i],
		    &namespaceList[i]) != TCL_OK) {
		goto badNamespace;
	    }
	}
    }

    /*
     * Now we have the list of valid namespaces, install it as the path.
     */

    TclSetNsPath(nsPtr, nsObjc, namespaceList);

    result = TCL_OK;
  badNamespace:
    if (namespaceList != NULL) {
	TclStackFree(interp, namespaceList);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetNsPath --
 *
 *	Sets the namespace command name resolution path to the given list of
 *	namespaces. If the list is empty (of zero length) the path is set to
 *	empty and the default old-style behaviour of command name resolution
 *	is used.
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Invalidates the command name resolution caches for any command
 *	resolved in the given namespace.
 *
 *----------------------------------------------------------------------
 */

void
TclSetNsPath(
    Namespace *nsPtr,		/* Namespace whose path is to be set. */
    int pathLength,		/* Length of pathAry. */
    Tcl_Namespace *pathAry[])	/* Array of namespaces that are the path. */
{
    if (pathLength != 0) {
	NamespacePathEntry *tmpPathArray =
		ckalloc(sizeof(NamespacePathEntry) * pathLength);
	int i;

	for (i=0 ; i<pathLength ; i++) {
	    tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
	    tmpPathArray[i].creatorNsPtr = nsPtr;
	    tmpPathArray[i].prevPtr = NULL;
	    tmpPathArray[i].nextPtr =
		    tmpPathArray[i].nsPtr->commandPathSourceList;
	    if (tmpPathArray[i].nextPtr != NULL) {
		tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i];
	    }
	    tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i];
	}
	if (nsPtr->commandPathLength != 0) {
	    UnlinkNsPath(nsPtr);
	}
	nsPtr->commandPathArray = tmpPathArray;
    } else {
	if (nsPtr->commandPathLength != 0) {
	    UnlinkNsPath(nsPtr);
	}
    }

    nsPtr->commandPathLength = pathLength;
    nsPtr->cmdRefEpoch++;
    nsPtr->resolverEpoch++;
}

/*
 *----------------------------------------------------------------------
 *
 * UnlinkNsPath --
 *
 *	Delete the given namespace's command name resolution path. Only call
 *	if the path is non-empty. Caller must reset the counter containing the
 *	path size.
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Deletes the array of path entries and unlinks those path entries from
 *	the target namespace's list of interested namespaces.
 *
 *----------------------------------------------------------------------
 */

static void
UnlinkNsPath(
    Namespace *nsPtr)
{
    int i;
    for (i=0 ; i<nsPtr->commandPathLength ; i++) {
	NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];

	if (nsPathPtr->prevPtr != NULL) {
	    nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
	}
	if (nsPathPtr->nextPtr != NULL) {
	    nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr;
	}
	if (nsPathPtr->nsPtr != NULL) {
	    if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) {
		nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr;
	    }
	}
    }
    ckfree(nsPtr->commandPathArray);
}

/*
 *----------------------------------------------------------------------
 *
 * TclInvalidateNsPath --
 *
 *	Invalidate the name resolution caches for all names looked up in
 *	namespaces whose name path includes the given namespace.
 *
 * Results:
 *	nothing
 *
 * Side effects:
 *	Increments the command reference epoch in each namespace whose path
 *	includes the given namespace. This causes any cached resolved names
 *	whose root cacheing context starts at that namespace to be recomputed
 *	the next time they are used.
 *
 *----------------------------------------------------------------------
 */

void
TclInvalidateNsPath(
    Namespace *nsPtr)
{
    NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;

    while (nsPathPtr != NULL) {
	if (nsPathPtr->nsPtr != NULL) {
	    nsPathPtr->creatorNsPtr->cmdRefEpoch++;
	}
	nsPathPtr = nsPathPtr->nextPtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceQualifiersCmd --
 *
 *	Invoked to implement the "namespace qualifiers" command that returns
 *	any leading namespace qualifiers in a string. These qualifiers are
 *	namespace names separated by "::"s. For example, for "::foo::p" this
 *	command returns "::foo", and for "::" it returns "". This command is
 *	the complement of the "namespace tail" command. Note that this command
 *	does not check whether the "namespace" names are, in fact, the names
 *	of currently defined namespaces. Handles the following syntax:
 *
 *	    namespace qualifiers string
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceQualifiersCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    register const char *name, *p;
    int length;

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

    /*
     * Find the end of the string, then work backward and find the start of
     * the last "::" qualifier.
     */

    name = TclGetString(objv[1]);
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p >= name) {
	if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
	    p -= 2;			/* Back up over the :: */
	    while ((p >= name) && (*p == ':')) {
		p--;			/* Back up over the preceeding : */
	    }
	    break;
	}
    }

    if (p >= name) {
	length = p-name+1;
	Tcl_SetObjResult(interp, Tcl_NewStringObj(name, length));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceUnknownCmd --
 *
 *	Invoked to implement the "namespace unknown" command (TIP 181) that
 *	sets or queries a per-namespace unknown command handler. This handler
 *	is called when command lookup fails (current and global ns). The
 *	default handler for the global namespace is ::unknown. The default
 *	handler for other namespaces is to call the global namespace unknown
 *	handler. Passing an empty list results in resetting the handler to its
 *	default.
 *
 *	    namespace unknown ?handler?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If no handler is specified, returns a result in the interpreter's
 *	result object, otherwise it sets the unknown handler pointer in the
 *	current namespace to the script fragment provided. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceUnknownCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Namespace *currNsPtr;
    Tcl_Obj *resultPtr;
    int rc;

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

    currNsPtr = TclGetCurrentNamespace(interp);

    if (objc == 1) {
	/*
	 * Introspection - return the current namespace handler.
	 */

	resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr);
	if (resultPtr == NULL) {
	    TclNewObj(resultPtr);
	}
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]);
	if (rc == TCL_OK) {
	    Tcl_SetObjResult(interp, objv[1]);
	}
	return rc;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetNamespaceUnknownHandler --
 *
 *	Returns the unknown command handler registered for the given
 *	namespace.
 *
 * Results:
 *	Returns the current unknown command handler, or NULL if none exists
 *	for the namespace.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetNamespaceUnknownHandler(
    Tcl_Interp *interp,		/* The interpreter in which the namespace
				 * exists. */
    Tcl_Namespace *nsPtr)	/* The namespace. */
{
    Namespace *currNsPtr = (Namespace *) nsPtr;

    if (currNsPtr->unknownHandlerPtr == NULL &&
	    currNsPtr == ((Interp *) interp)->globalNsPtr) {
	/*
	 * Default handler for global namespace is "::unknown". For all other
	 * namespaces, it is NULL (which falls back on the global unknown
	 * handler).
	 */

	TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
	Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
    }
    return currNsPtr->unknownHandlerPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetNamespaceUnknownHandler --
 *
 *	Sets the unknown command handler for the given namespace to the
 *	command prefix passed.
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Sets the namespace unknown command handler. If the passed in handler
 *	is NULL or an empty list, then the handler is reset to its default. If
 *	an error occurs, then an error message is left in the interpreter
 *	result.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SetNamespaceUnknownHandler(
    Tcl_Interp *interp,		/* Interpreter in which the namespace
				 * exists. */
    Tcl_Namespace *nsPtr,	/* Namespace which is being updated. */
    Tcl_Obj *handlerPtr)	/* The new handler, or NULL to reset. */
{
    int lstlen = 0;
    Namespace *currNsPtr = (Namespace *) nsPtr;

    /*
     * Ensure that we check for errors *first* before we change anything.
     */

    if (handlerPtr != NULL) {
	if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
	    /*
	     * Not a list.
	     */

	    return TCL_ERROR;
	}
	if (lstlen > 0) {
	    /*
	     * We are going to be saving this handler. Increment the reference
	     * count before decrementing the refcount on the previous handler,
	     * so that nothing strange can happen if we are told to set the
	     * handler to the previous value.
	     */

	    Tcl_IncrRefCount(handlerPtr);
	}
    }

    /*
     * Remove old handler next.
     */

    if (currNsPtr->unknownHandlerPtr != NULL) {
	Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr);
    }

    /*
     * Install the new handler.
     */

    if (lstlen > 0) {
	/*
	 * Just store the handler. It already has the correct reference count.
	 */

	currNsPtr->unknownHandlerPtr = handlerPtr;
    } else {
	/*
	 * If NULL or an empty list is passed, this resets to the default
	 * handler.
	 */

	currNsPtr->unknownHandlerPtr = NULL;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceTailCmd --
 *
 *	Invoked to implement the "namespace tail" command that returns the
 *	trailing name at the end of a string with "::" namespace qualifiers.
 *	These qualifiers are namespace names separated by "::"s. For example,
 *	for "::foo::p" this command returns "p", and for "::" it returns "".
 *	This command is the complement of the "namespace qualifiers" command.
 *	Note that this command does not check whether the "namespace" names
 *	are, in fact, the names of currently defined namespaces. Handles the
 *	following syntax:
 *
 *	    namespace tail string
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceTailCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    register const char *name, *p;

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

    /*
     * Find the end of the string, then work backward and find the last "::"
     * qualifier.
     */

    name = TclGetString(objv[1]);
    for (p = name;  *p != '\0';  p++) {
	/* empty body */
    }
    while (--p > name) {
	if ((*p == ':') && (*(p-1) == ':')) {
	    p++;			/* Just after the last "::" */
	    break;
	}
    }

    if (p >= name) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceUpvarCmd --
 *
 *	Invoked to implement the "namespace upvar" command, that creates
 *	variables in the current scope linked to variables in another
 *	namespace. Handles the following syntax:
 *
 *	    namespace upvar ns otherVar myVar ?otherVar myVar ...?
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Creates new variables in the current scope, linked to the
 *	corresponding variables in the stipulated nmamespace. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceUpvarCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Namespace *nsPtr, *savedNsPtr;
    Var *otherPtr, *arrayPtr;
    const char *myName;

    if (objc < 2 || (objc & 1)) {
	Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?");
	return TCL_ERROR;
    }

    if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    objc -= 2;
    objv += 2;

    for (; objc>0 ; objc-=2, objv+=2) {
	/*
	 * Locate the other variable.
	 */

	savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
	iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
	otherPtr = TclObjLookupVarEx(interp, objv[0], NULL,
		(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
		/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
	if (otherPtr == NULL) {
	    return TCL_ERROR;
	}

	/*
	 * Create the new variable and link it to otherPtr.
	 */

	myName = TclGetString(objv[1]);
	if (TclPtrMakeUpvar(interp, otherPtr, myName, 0, -1) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NamespaceWhichCmd --
 *
 *	Invoked to implement the "namespace which" command that returns the
 *	fully-qualified name of a command or variable. If the specified
 *	command or variable does not exist, it returns "". Handles the
 *	following syntax:
 *
 *	    namespace which ?-command? ?-variable? name
 *
 * Results:
 *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything goes
 *	wrong, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceWhichCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const opts[] = {
	"-command", "-variable", NULL
    };
    int lookupType = 0;
    Tcl_Obj *resultPtr;

    if (objc < 2 || objc > 3) {
    badArgs:
	Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name");
	return TCL_ERROR;
    } else if (objc == 3) {
	/*
	 * Look for a flag controlling the lookup.
	 */

	if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0,
		&lookupType) != TCL_OK) {
	    /*
	     * Preserve old style of error message!
	     */

	    Tcl_ResetResult(interp);
	    goto badArgs;
	}
    }

    TclNewObj(resultPtr);
    switch (lookupType) {
    case 0: {				/* -command */
	Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]);

	if (cmd != NULL) {
	    Tcl_GetCommandFullName(interp, cmd, resultPtr);
	}
	break;
    }
    case 1: {				/* -variable */
	Tcl_Var var = Tcl_FindNamespaceVar(interp,
		TclGetString(objv[objc-1]), NULL, /*flags*/ 0);

	if (var != NULL) {
	    Tcl_GetVariableFullName(interp, var, resultPtr);
	}
	break;
    }
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeNsNameInternalRep --
 *
 *	Frees the resources associated with a nsName object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Decrements the ref count of any Namespace structure pointed to by the
 *	nsName's internal representation. If there are no more references to
 *	the namespace, it's structure will be freed.
 *
 *----------------------------------------------------------------------
 */

static void
FreeNsNameInternalRep(
    register Tcl_Obj *objPtr)	/* nsName object with internal representation
				 * to free. */
{
    ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;

    /*
     * Decrement the reference count of the namespace. If there are no more
     * references, free it up.
     */

    resNamePtr->refCount--;
    if (resNamePtr->refCount == 0) {
	/*
	 * Decrement the reference count for the cached namespace. If the
	 * namespace is dead, and there are no more references to it, free
	 * it.
	 */

	TclNsDecrRefCount(resNamePtr->nsPtr);
	ckfree(resNamePtr);
    }
    objPtr->typePtr = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DupNsNameInternalRep --
 *
 *	Initializes the internal representation of a nsName object to a copy
 *	of the internal representation of another nsName object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	copyPtr's internal rep is set to refer to the same namespace
 *	referenced by srcPtr's internal rep. Increments the ref count of the
 *	ResolvedNsName structure used to hold the namespace reference.
 *
 *----------------------------------------------------------------------
 */

static void
DupNsNameInternalRep(
    Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
    register Tcl_Obj *copyPtr)	/* Object with internal rep to set. */
{
    ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1;

    copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
    resNamePtr->refCount++;
    copyPtr->typePtr = &nsNameType;
}

/*
 *----------------------------------------------------------------------
 *
 * SetNsNameFromAny --
 *
 *	Attempt to generate a nsName internal representation for a Tcl object.
 *
 * Results:
 *	Returns TCL_OK if the value could be converted to a proper namespace
 *	reference. Otherwise, it returns TCL_ERROR, along with an error
 *	message in the interpreter's result object.
 *
 * Side effects:
 *	If successful, the object is made a nsName object. Its internal rep is
 *	set to point to a ResolvedNsName, which contains a cached pointer to
 *	the Namespace. Reference counts are kept on both the ResolvedNsName
 *	and the Namespace, so we can keep track of their usage and free them
 *	when appropriate.
 *
 *----------------------------------------------------------------------
 */

static int
SetNsNameFromAny(
    Tcl_Interp *interp,		/* Points to the namespace in which to resolve
				 * name. Also used for error reporting if not
				 * NULL. */
    register Tcl_Obj *objPtr)	/* The object to convert. */
{
    const char *dummy;
    Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
    register ResolvedNsName *resNamePtr;
    const char *name;

    if (interp == NULL) {
	return TCL_ERROR;
    }

    name = TclGetString(objPtr);
    TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
	     &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);

    /*
     * If we found a namespace, then create a new ResolvedNsName structure
     * that holds a reference to it.
     */

    if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
	/*
	 * Our failed lookup proves any previously cached nsName intrep is no
	 * longer valid. Get rid of it so we no longer waste memory storing
	 * it, nor time determining its invalidity again and again.
	 */

	if (objPtr->typePtr == &nsNameType) {
	    TclFreeIntRep(objPtr);
	}
	return TCL_ERROR;
    }

    nsPtr->refCount++;
    resNamePtr = ckalloc(sizeof(ResolvedNsName));
    resNamePtr->nsPtr = nsPtr;
    if ((name[0] == ':') && (name[1] == ':')) {
	resNamePtr->refNsPtr = NULL;
    } else {
	resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    }
    resNamePtr->refCount = 1;
    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
    objPtr->typePtr = &nsNameType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceCommandTable --
 *
 *	Returns the hash table of commands.
 *
 * Results:
 *	Pointer to the hash table.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashTable *
TclGetNamespaceCommandTable(
    Tcl_Namespace *nsPtr)
{
    return &((Namespace *) nsPtr)->cmdTable;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceChildTable --
 *
 *	Returns the hash table of child namespaces.
 *
 * Results:
 *	Pointer to the hash table.
 *
 * Side effects:
 *	Might allocate memory.
 *
 *----------------------------------------------------------------------
 */

Tcl_HashTable *
TclGetNamespaceChildTable(
    Tcl_Namespace *nsPtr)
{
    Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
    return &nPtr->childTable;
#else
    if (nPtr->childTablePtr == NULL) {
	nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
    }
    return nPtr->childTablePtr;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclLogCommandInfo --
 *
 *	This function is invoked after an error occurs in an interpreter. It
 *	adds information to iPtr->errorInfo/errorStack fields to describe the
 *	command that was being executed when the error occurred. When pc and
 *	tosPtr are non-NULL, conveying a bytecode execution "inner context",
 *	and the offending instruction is suitable, that inner context is
 *	recorded in errorStack.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information about the command is added to errorInfo/errorStack and the
 *	line number stored internally in the interpreter is set.
 *
 *----------------------------------------------------------------------
 */

void
TclLogCommandInfo(
    Tcl_Interp *interp,		/* Interpreter in which to log information. */
    const char *script,		/* First character in script containing
				 * command (must be <= command). */
    const char *command,	/* First character in command that generated
				 * the error. */
    int length,			/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
    const unsigned char *pc,    /* Current pc of bytecode execution context */
    Tcl_Obj **tosPtr)		/* Current stack of bytecode execution
				 * context */
{
    register const char *p;
    Interp *iPtr = (Interp *) interp;
    int overflow, limit = 150;
    Var *varPtr, *arrayPtr;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this command;
	 * we shouldn't add anything more.
	 */

	return;
    }

    if (command != NULL) {
	/*
	 * Compute the line number where the error occurred.
	 */

	iPtr->errorLine = 1;
	for (p = script; p != command; p++) {
	    if (*p == '\n') {
		iPtr->errorLine++;
	    }
	}

	if (length < 0) {
	    length = strlen(command);
	}
	overflow = (length > limit);
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
		? "while executing" : "invoked from within"),
		(overflow ? limit : length), command,
		(overflow ? "..." : "")));

	varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
		NULL, 0, 0, &arrayPtr);
	if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
	    /*
	     * Should not happen.
	     */

	    return;
	} else {
	    Tcl_HashEntry *hPtr
		    = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
	    VarTrace *tracePtr = Tcl_GetHashValue(hPtr);

	    if (tracePtr->traceProc != EstablishErrorInfoTraces) {
		/*
		 * The most recent trace set on ::errorInfo is not the one the
		 * core itself puts on last. This means some other code is
		 * tracing the variable, and the additional trace(s) might be
		 * write traces that expect the timing of writes to
		 * ::errorInfo that existed Tcl releases before 8.5. To
		 * satisfy that compatibility need, we write the current
		 * -errorinfo value to the ::errorInfo variable.
		 */

		Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
			TCL_GLOBAL_ONLY);
	    }
	}
    }

    /*
     * TIP #348
     */

    if (Tcl_IsShared(iPtr->errorStack)) {
	Tcl_Obj *newObj;
	    
	newObj = Tcl_DuplicateObj(iPtr->errorStack);
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	int len;

	iPtr->resetErrorStack = 0;
	Tcl_ListObjLength(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list intrep as much as possible.
	 */

	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
	if (pc != NULL) {
	    Tcl_Obj *innerContext;

	    innerContext = TclGetInnerContext(interp, pc, tosPtr);
	    if (innerContext != NULL) {
		Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
			iPtr->innerLiteral);
		Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
	    }
	} else if (command != NULL) {
	    Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
		    iPtr->innerLiteral);
	    Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
		    Tcl_NewStringObj(command, length));
	}
    } 

    if (!iPtr->framePtr->objc) {
	/*
	 * Special frame, nothing to report.
	 */
    } else if (iPtr->varFramePtr != iPtr->framePtr) {
	/*
	 * uplevel case, [lappend errorstack UP $relativelevel]
	 */

	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
		iPtr->framePtr->level - iPtr->varFramePtr->level));
    } else if (iPtr->framePtr != iPtr->rootFramePtr) {
	/*
	 * normal case, [lappend errorstack CALL [info level 0]]
	 */

	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
		iPtr->framePtr->objc, iPtr->framePtr->objv));
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclErrorStackResetIf --
 *
 *	The TIP 348 reset/no-bc part of TLCI, for specific use by
 *	TclCompileSyntaxError.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Reset errorstack if it needs be, and in that case remember the
 *	passed-in error message as inner context.
 *
 *----------------------------------------------------------------------
 */

void
TclErrorStackResetIf(
    Tcl_Interp *interp,
    const char *msg,
    int length)
{
    Interp *iPtr = (Interp *) interp;

    if (Tcl_IsShared(iPtr->errorStack)) {
	Tcl_Obj *newObj;
	    
	newObj = Tcl_DuplicateObj(iPtr->errorStack);
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	int len;

	iPtr->resetErrorStack = 0;
	Tcl_ListObjLength(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list intrep as much as possible.
	 */

	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
	Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
	Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
		Tcl_NewStringObj(msg, length));
    } 
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LogCommandInfo --
 *
 *	This function is invoked after an error occurs in an interpreter. It
 *	adds information to iPtr->errorInfo/errorStack fields to describe the
 *	command that was being executed when the error occurred.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information about the command is added to errorInfo/errorStack and the
 *	line number stored internally in the interpreter is set.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_LogCommandInfo(
    Tcl_Interp *interp,		/* Interpreter in which to log information. */
    const char *script,		/* First character in script containing
				 * command (must be <= command). */
    const char *command,	/* First character in command that generated
				 * the error. */
    int length)			/* Number of bytes in command (-1 means use
				 * all bytes up to first null byte). */
{
    TclLogCommandInfo(interp, script, command, length, NULL, NULL);
}


/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * End:
 */
generated by cgit v0.12 at 2024-08-21 13:16:18 (GMT)