WebSVN - Open64 - Blame - Rev 2072 - /sim/fsim/shell/tclsh/generic/tclBinary.c

[/] [sim/] [fsim/] [shell/] [tclsh/] [generic/] [tclBinary.c] - Blame information for rev 2072

Details | Compare with Previous | View Log

/*
 * tclBinary.c --
 *
 *  This file contains the implementation of the "binary" Tcl built-in
 *  command and the Tcl binary data object.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.13.2.4 2005/10/23 22:01:29 msofer Exp $
 */
 
#include "tclInt.h"
#include "tclPort.h"
#include <math.h>
 
/*
 * The following constants are used by GetFormatSpec to indicate various
 * special conditions in the parsing of a format specifier.
 */
 
#define BINARY_ALL -1   /* Use all elements in the argument. */
#define BINARY_NOCOUNT -2 /* No count was specified in format. */
 
/*
 * The following defines the maximum number of different (integer)
 * numbers placed in the object cache by 'binary scan' before it bails
 * out and switches back to Plan A (creating a new object for each
 * value.)  Theoretically, it would be possible to keep the cache
 * about for the values that are already in it, but that makes the
 * code slower in practise when overflow happens, and makes little
 * odds the rest of the time (as measured on my machine.)  It is also
 * slower (on the sample I tried at least) to grow the cache to hold
 * all items we might want to put in it; presumably the extra cost of
 * managing the memory for the enlarged table outweighs the benefit
 * from allocating fewer objects.  This is probably because as the
 * number of objects increases, the likelihood of reuse of any
 * particular one drops, and there is very little gain from larger
 * maximum cache sizes (the value below is chosen to allow caching to
 * work in full with conversion of bytes.) - DKF
 */
 
#define BINARY_SCAN_MAX_CACHE 260
 
/*
 * Prototypes for local procedures defined in this file:
 */
 
static void   DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
          Tcl_Obj *copyPtr));
static int    FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
          Tcl_Obj *src, unsigned char **cursorPtr));
static void   CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to,
          unsigned int length));
static void   FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int    GetFormatSpec _ANSI_ARGS_((char **formatPtr,
          char *cmdPtr, int *countPtr));
static Tcl_Obj *  ScanNumber _ANSI_ARGS_((unsigned char *buffer,
          int type, Tcl_HashTable **numberCachePtr));
static int    SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
          Tcl_Obj *objPtr));
static void   UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
static void   DeleteScanNumberCache _ANSI_ARGS_((
          Tcl_HashTable *numberCachePtr));
 
/*
 * The following object type represents an array of bytes.  An array of
 * bytes is not equivalent to an internationalized string.  Conceptually, a
 * string is an array of 16-bit quantities organized as a sequence of properly
 * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
 * Accessor functions are provided to convert a ByteArray to a String or a
 * String to a ByteArray.  Two or more consecutive bytes in an array of bytes
 * may look like a single UTF-8 character if the array is casually treated as
 * a string.  But obtaining the String from a ByteArray is guaranteed to
 * produced properly formed UTF-8 sequences so that there is a one-to-one
 * map between bytes and characters.
 *
 * Converting a ByteArray to a String proceeds by casting each byte in the
 * array to a 16-bit quantity, treating that number as a Unicode character,
 * and storing the UTF-8 version of that Unicode character in the String.
 * For ByteArrays consisting entirely of values 1..127, the corresponding
 * String representation is the same as the ByteArray representation.
 *
 * Converting a String to a ByteArray proceeds by getting the Unicode
 * representation of each character in the String, casting it to a
 * byte by truncating the upper 8 bits, and then storing the byte in the
 * ByteArray.  Converting from ByteArray to String and back to ByteArray
 * is not lossy, but converting an arbitrary String to a ByteArray may be.
 */
 
Tcl_ObjType tclByteArrayType = {
    "bytearray",
    FreeByteArrayInternalRep,
    DupByteArrayInternalRep,
    UpdateStringOfByteArray,
    SetByteArrayFromAny
};
 
/*
 * The following structure is the internal rep for a ByteArray object.
 * Keeps track of how much memory has been used and how much has been
 * allocated for the byte array to enable growing and shrinking of the
 * ByteArray object with fewer mallocs.
 */
 
typedef struct ByteArray {
    int used;     /* The number of bytes used in the byte
         * array. */
    int allocated;    /* The amount of space actually allocated
         * minus 1 byte. */
    unsigned char bytes[4]; /* The array of bytes.  The actual size of
         * this field depends on the 'allocated' field
         * above. */
} ByteArray;
 
#define BYTEARRAY_SIZE(len) \
    ((unsigned) (sizeof(ByteArray) - 4 + (len)))
#define GET_BYTEARRAY(objPtr) \
    ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
#define SET_BYTEARRAY(objPtr, baPtr) \
    (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)
 
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_NewByteArrayObj --
 *
 *  This procedure is creates a new ByteArray object and initializes
 *  it from the given array of bytes.
 *
 * Results:
 *  The newly create object is returned.  This object will have no
 *  initial string representation.  The returned object has a ref count
 *  of 0.
 *
 * Side effects:
 *  Memory allocated for new object and copy of byte array argument.
 *
 *---------------------------------------------------------------------------
 */
 
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj
 
 
Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
    CONST unsigned char *bytes; /* The array of bytes used to initialize
         * the new object. */
    int length;     /* Length of the array of bytes, which must
         * be >= 0. */
{
    return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
}
 
#else /* if not TCL_MEM_DEBUG */
 
Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
    CONST unsigned char *bytes; /* The array of bytes used to initialize
         * the new object. */
    int length;     /* Length of the array of bytes, which must
         * be >= 0. */
{
    Tcl_Obj *objPtr;
 
    TclNewObj(objPtr);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_DbNewByteArrayObj --
 *
 *  This procedure is normally called when debugging: i.e., when
 *  TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj
 *  above except that it calls Tcl_DbCkalloc directly with the file name
 *  and line number from its caller. This simplifies debugging since then
 *  the [memory active] command will report the correct file name and line
 *  number when reporting objects that haven't been freed.
 *
 *  When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *  result of calling Tcl_NewByteArrayObj.
 *
 * Results:
 *  The newly create object is returned.  This object will have no
 *  initial string representation.  The returned object has a ref count
 *  of 0.
 *
 * Side effects:
 *  Memory allocated for new object and copy of byte array argument.
 *
 *---------------------------------------------------------------------------
 */
 
#ifdef TCL_MEM_DEBUG
 
Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
    CONST unsigned char *bytes; /* The array of bytes used to initialize
         * the new object. */
    int length;     /* Length of the array of bytes, which must
         * be >= 0. */
    CONST char *file;   /* The name of the source file calling this
         * procedure; used for debugging. */
    int line;     /* Line number in the source file; used
         * for debugging. */
{
    Tcl_Obj *objPtr;
 
    TclDbNewObj(objPtr, file, line);
    Tcl_SetByteArrayObj(objPtr, bytes, length);
    return objPtr;
}
 
#else /* if not TCL_MEM_DEBUG */
 
Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
    CONST unsigned char *bytes; /* The array of bytes used to initialize
         * the new object. */
    int length;     /* Length of the array of bytes, which must
         * be >= 0. */
    CONST char *file;   /* The name of the source file calling this
         * procedure; used for debugging. */
    int line;     /* Line number in the source file; used
         * for debugging. */
{
    return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
 
/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetByteArrayObj --
 *
 *  Modify an object to be a ByteArray object and to have the specified
 *  array of bytes as its value.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  The object's old string rep and internal rep is freed.
 *  Memory allocated for copy of byte array argument.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_SetByteArrayObj(objPtr, bytes, length)
    Tcl_Obj *objPtr;    /* Object to initialize as a ByteArray. */
    CONST unsigned char *bytes; /* The array of bytes to use as the new
         * value. */
    int length;     /* Length of the array of bytes, which must
         * be >= 0. */
{
    Tcl_ObjType *typePtr;
    ByteArray *byteArrayPtr;
 
    if (Tcl_IsShared(objPtr)) {
  panic("Tcl_SetByteArrayObj called with shared object");
    }
    typePtr = objPtr->typePtr;
    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
  (*typePtr->freeIntRepProc)(objPtr);
    }
    Tcl_InvalidateStringRep(objPtr);
 
    byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
    byteArrayPtr->used = length;
    byteArrayPtr->allocated = length;
    memcpy((VOID *) byteArrayPtr->bytes, (VOID *) bytes, (size_t) length);
 
    objPtr->typePtr = &tclByteArrayType;
    SET_BYTEARRAY(objPtr, byteArrayPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetByteArrayFromObj --
 *
 *  Attempt to get the array of bytes from the Tcl object.  If the
 *  object is not already a ByteArray object, an attempt will be
 *  made to convert it to one.
 *
 * Results:
 *  Pointer to array of bytes representing the ByteArray object.
 *
 * Side effects:
 *  Frees old internal rep.  Allocates memory for new internal rep.
 *
 *----------------------------------------------------------------------
 */
 
unsigned char *
Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
    Tcl_Obj *objPtr;    /* The ByteArray object. */
    int *lengthPtr;   /* If non-NULL, filled with length of the
         * array of bytes in the ByteArray object. */
{
    ByteArray *baPtr;
 
    SetByteArrayFromAny(NULL, objPtr);
    baPtr = GET_BYTEARRAY(objPtr);
 
    if (lengthPtr != NULL) {
  *lengthPtr = baPtr->used;
    }
    return (unsigned char *) baPtr->bytes;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetByteArrayLength --
 *
 *  This procedure changes the length of the byte array for this
 *  object.  Once the caller has set the length of the array, it
 *  is acceptable to directly modify the bytes in the array up until
 *  Tcl_GetStringFromObj() has been called on this object.
 *
 * Results:
 *  The new byte array of the specified length.
 *
 * Side effects:
 *  Allocates enough memory for an array of bytes of the requested
 *  size.  When growing the array, the old array is copied to the
 *  new array; new bytes are undefined.  When shrinking, the
 *  old array is truncated to the specified length.
 *
 *---------------------------------------------------------------------------
 */
 
unsigned char *
Tcl_SetByteArrayLength(objPtr, length)
    Tcl_Obj *objPtr;    /* The ByteArray object. */
    int length;     /* New length for internal byte array. */
{
    ByteArray *byteArrayPtr, *newByteArrayPtr;
 
    if (Tcl_IsShared(objPtr)) {
  panic("Tcl_SetObjLength called with shared object");
    }
    if (objPtr->typePtr != &tclByteArrayType) {
  SetByteArrayFromAny(NULL, objPtr);
    }
 
    byteArrayPtr = GET_BYTEARRAY(objPtr);
    if (length > byteArrayPtr->allocated) {
  newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
  newByteArrayPtr->used = length;
  newByteArrayPtr->allocated = length;
  memcpy((VOID *) newByteArrayPtr->bytes,
    (VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used);
  ckfree((char *) byteArrayPtr);
  byteArrayPtr = newByteArrayPtr;
  SET_BYTEARRAY(objPtr, byteArrayPtr);
    }
    Tcl_InvalidateStringRep(objPtr);
    byteArrayPtr->used = length;
    return byteArrayPtr->bytes;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * SetByteArrayFromAny --
 *
 *  Generate the ByteArray internal rep from the string rep.
 *
 * Results:
 *  The return value is always TCL_OK.
 *
 * Side effects:
 *  A ByteArray object is stored as the internal rep of objPtr.
 *
 *---------------------------------------------------------------------------
 */
 
static int
SetByteArrayFromAny(interp, objPtr)
    Tcl_Interp *interp;   /* Not used. */
    Tcl_Obj *objPtr;    /* The object to convert to type ByteArray. */
{
    Tcl_ObjType *typePtr;
    int length;
    char *src, *srcEnd;
    unsigned char *dst;
    ByteArray *byteArrayPtr;
    Tcl_UniChar ch;
 
    typePtr = objPtr->typePtr;
    if (typePtr != &tclByteArrayType) {
  src = Tcl_GetStringFromObj(objPtr, &length);
  srcEnd = src + length;
 
  byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
  for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
      src += Tcl_UtfToUniChar(src, &ch);
      *dst++ = (unsigned char) ch;
  }
 
  byteArrayPtr->used = dst - byteArrayPtr->bytes;
  byteArrayPtr->allocated = length;
 
  if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) {
      (*typePtr->freeIntRepProc)(objPtr);
  }
  objPtr->typePtr = &tclByteArrayType;
  SET_BYTEARRAY(objPtr, byteArrayPtr);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * FreeByteArrayInternalRep --
 *
 *  Deallocate the storage associated with a ByteArray data object's
 *  internal representation.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Frees memory.
 *
 *----------------------------------------------------------------------
 */
 
static void
FreeByteArrayInternalRep(objPtr)
    Tcl_Obj *objPtr;    /* Object with internal rep to free. */
{
    ckfree((char *) GET_BYTEARRAY(objPtr));
}
 
/*
 *---------------------------------------------------------------------------
 *
 * DupByteArrayInternalRep --
 *
 *  Initialize the internal representation of a ByteArray Tcl_Obj
 *  to a copy of the internal representation of an existing ByteArray
 *  object.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Allocates memory.
 *
 *---------------------------------------------------------------------------
 */
 
static void
DupByteArrayInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;    /* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;   /* Object with internal rep to set. */
{
    int length;
    ByteArray *srcArrayPtr, *copyArrayPtr;
 
    srcArrayPtr = GET_BYTEARRAY(srcPtr);
    length = srcArrayPtr->used;
 
    copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
    copyArrayPtr->used = length;
    copyArrayPtr->allocated = length;
    memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,
      (size_t) length);
    SET_BYTEARRAY(copyPtr, copyArrayPtr);
 
    copyPtr->typePtr = &tclByteArrayType;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * UpdateStringOfByteArray --
 *
 *  Update the string representation for a ByteArray data object.
 *  Note: This procedure does not invalidate an existing old string rep
 *  so storage will be lost if this has not already been done.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  The object's string is set to a valid string that results from
 *  the ByteArray-to-string conversion.
 *
 *  The object becomes a string object -- the internal rep is
 *  discarded and the typePtr becomes NULL.
 *
 *---------------------------------------------------------------------------
 */
 
static void
UpdateStringOfByteArray(objPtr)
    Tcl_Obj *objPtr;    /* ByteArray object whose string rep to
         * update. */
{
    int i, length, size;
    unsigned char *src;
    char *dst;
    ByteArray *byteArrayPtr;
 
    byteArrayPtr = GET_BYTEARRAY(objPtr);
    src = byteArrayPtr->bytes;
    length = byteArrayPtr->used;
 
    /*
     * How much space will string rep need?
     */
 
    size = length;
    for (i = 0; i < length; i++) {
  if ((src[i] == 0) || (src[i] > 127)) {
      size++;
  }
    }
 
    dst = (char *) ckalloc((unsigned) (size + 1));
    objPtr->bytes = dst;
    objPtr->length = size;
 
    if (size == length) {
  memcpy((VOID *) dst, (VOID *) src, (size_t) size);
  dst[size] = '\0';
    } else {
  for (i = 0; i < length; i++) {
      dst += Tcl_UniCharToUtf(src[i], dst);
  }
  *dst = '\0';
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_BinaryObjCmd --
 *
 *  This procedure implements the "binary" Tcl command.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_BinaryObjCmd(dummy, interp, objc, objv)
    ClientData dummy;   /* Not used. */
    Tcl_Interp *interp;   /* Current interpreter. */
    int objc;     /* Number of arguments. */
    Tcl_Obj *CONST objv[];  /* Argument objects. */
{
    int arg;      /* Index of next argument to consume. */
    int value = 0;    /* Current integer value to be packed.
         * Initialized to avoid compiler warning. */
    char cmd;     /* Current format character. */
    int count;      /* Count associated with current format
         * character. */
    char *format;   /* Pointer to current position in format
         * string. */
    Tcl_Obj *resultPtr;   /* Object holding result buffer. */
    unsigned char *buffer;  /* Start of result buffer. */
    unsigned char *cursor;  /* Current position within result buffer. */
    unsigned char *maxPos;  /* Greatest position within result buffer that
         * cursor has visited.*/
    char *errorString, *errorValue, *str;
    int offset, size, length, index;
    static CONST char *options[] = {
  "format", "scan",   NULL
    };
    enum options {
  BINARY_FORMAT,  BINARY_SCAN
    };
 
    if (objc < 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
  return TCL_ERROR;
    }
 
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
      &index) != TCL_OK) {
      return TCL_ERROR;
    }
 
    switch ((enum options) index) {
  case BINARY_FORMAT: {
      if (objc < 3) {
    Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
    return TCL_ERROR;
      }
 
      /*
       * To avoid copying the data, we format the string in two passes.
       * The first pass computes the size of the output buffer.  The
       * second pass places the formatted data into the buffer.
       */
 
      format = Tcl_GetString(objv[2]);
      arg = 3;
      offset = 0;
      length = 0;
      while (*format != '\0') {
    str = format;
    if (!GetFormatSpec(&format, &cmd, &count)) {
        break;
    }
    switch (cmd) {
        case 'a':
        case 'A':
        case 'b':
        case 'B':
        case 'h':
        case 'H': {
      /*
       * For string-type specifiers, the count corresponds
       * to the number of bytes in a single argument.
       */
 
      if (arg >= objc) {
          goto badIndex;
      }
      if (count == BINARY_ALL) {
          Tcl_GetByteArrayFromObj(objv[arg], &count);
      } else if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      arg++;
      if (cmd == 'a' || cmd == 'A') {
          offset += count;
      } else if (cmd == 'b' || cmd == 'B') {
          offset += (count + 7) / 8;
      } else {
          offset += (count + 1) / 2;
      }
      break;
        }
        case 'c': {
      size = 1;
      goto doNumbers;
        }
        case 's':
        case 'S': {
      size = 2;
      goto doNumbers;
        }
        case 'i':
        case 'I': {
      size = 4;
      goto doNumbers;
        }
        case 'w':
        case 'W': {
      size = 8;
      goto doNumbers;
        }
        case 'f': {
      size = sizeof(float);
      goto doNumbers;
        }
        case 'd': {
      size = sizeof(double);
 
      doNumbers:
      if (arg >= objc) {
          goto badIndex;
      }
 
      /*
       * For number-type specifiers, the count corresponds
       * to the number of elements in the list stored in
       * a single argument.  If no count is specified, then
       * the argument is taken as a single non-list value.
       */
 
      if (count == BINARY_NOCOUNT) {
          arg++;
          count = 1;
      } else {
          int listc;
          Tcl_Obj **listv;
          if (Tcl_ListObjGetElements(interp, objv[arg++],
            &listc, &listv) != TCL_OK) {
        return TCL_ERROR;
          }
          if (count == BINARY_ALL) {
        count = listc;
          } else if (count > listc) {
              Tcl_AppendResult(interp,
          "number of elements in list does not match count",
          (char *) NULL);
        return TCL_ERROR;
          }
      }
      offset += count*size;
      break;
        }
        case 'x': {
      if (count == BINARY_ALL) {
          Tcl_AppendResult(interp,
            "cannot use \"*\" in format string with \"x\"",
            (char *) NULL);
          return TCL_ERROR;
      } else if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      offset += count;
      break;
        }
        case 'X': {
      if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      if ((count > offset) || (count == BINARY_ALL)) {
          count = offset;
      }
      if (offset > length) {
          length = offset;
      }
      offset -= count;
      break;
        }
        case '@': {
      if (offset > length) {
          length = offset;
      }
      if (count == BINARY_ALL) {
          offset = length;
      } else if (count == BINARY_NOCOUNT) {
          goto badCount;
      } else {
          offset = count;
      }
      break;
        }
        default: {
      errorString = str;
      goto badField;
        }
    }
      }
      if (offset > length) {
    length = offset;
      }
      if (length == 0) {
    return TCL_OK;
      }
 
      /*
       * Prepare the result object by preallocating the caclulated
       * number of bytes and filling with nulls.
       */
 
      resultPtr = Tcl_GetObjResult(interp);
      buffer = Tcl_SetByteArrayLength(resultPtr, length);
      memset((VOID *) buffer, 0, (size_t) length);
 
      /*
       * Pack the data into the result object.  Note that we can skip
       * the error checking during this pass, since we have already
       * parsed the string once.
       */
 
      arg = 3;
      format = Tcl_GetString(objv[2]);
      cursor = buffer;
      maxPos = cursor;
      while (*format != 0) {
    if (!GetFormatSpec(&format, &cmd, &count)) {
        break;
    }
    if ((count == 0) && (cmd != '@')) {
        arg++;
        continue;
    }
    switch (cmd) {
        case 'a':
        case 'A': {
      char pad = (char) (cmd == 'a' ? '\0' : ' ');
      unsigned char *bytes;
 
      bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
 
      if (count == BINARY_ALL) {
          count = length;
      } else if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      if (length >= count) {
          memcpy((VOID *) cursor, (VOID *) bytes,
            (size_t) count);
      } else {
          memcpy((VOID *) cursor, (VOID *) bytes,
            (size_t) length);
          memset((VOID *) (cursor + length), pad,
                  (size_t) (count - length));
      }
      cursor += count;
      break;
        }
        case 'b':
        case 'B': {
      unsigned char *last;
 
      str = Tcl_GetStringFromObj(objv[arg++], &length);
      if (count == BINARY_ALL) {
          count = length;
      } else if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      last = cursor + ((count + 7) / 8);
      if (count > length) {
          count = length;
      }
      value = 0;
      errorString = "binary";
      if (cmd == 'B') {
          for (offset = 0; offset < count; offset++) {
        value <<= 1;
        if (str[offset] == '1') {
            value |= 1;
        } else if (str[offset] != '0') {
            errorValue = str;
            goto badValue;
        }
        if (((offset + 1) % 8) == 0) {
            *cursor++ = (unsigned char) value;
            value = 0;
        }
          }
      } else {
          for (offset = 0; offset < count; offset++) {
        value >>= 1;
        if (str[offset] == '1') {
            value |= 128;
        } else if (str[offset] != '0') {
            errorValue = str;
            goto badValue;
        }
        if (!((offset + 1) % 8)) {
            *cursor++ = (unsigned char) value;
            value = 0;
        }
          }
      }
      if ((offset % 8) != 0) {
          if (cmd == 'B') {
        value <<= 8 - (offset % 8);
          } else {
        value >>= 8 - (offset % 8);
          }
          *cursor++ = (unsigned char) value;
      }
      while (cursor < last) {
          *cursor++ = '\0';
      }
      break;
        }
        case 'h':
        case 'H': {
      unsigned char *last;
      int c;
 
      str = Tcl_GetStringFromObj(objv[arg++], &length);
      if (count == BINARY_ALL) {
          count = length;
      } else if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      last = cursor + ((count + 1) / 2);
      if (count > length) {
          count = length;
      }
      value = 0;
      errorString = "hexadecimal";
      if (cmd == 'H') {
          for (offset = 0; offset < count; offset++) {
        value <<= 4;
        if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
            errorValue = str;
            goto badValue;
        }
        c = str[offset] - '0';
        if (c > 9) {
            c += ('0' - 'A') + 10;
        }
        if (c > 16) {
            c += ('A' - 'a');
        }
        value |= (c & 0xf);
        if (offset % 2) {
            *cursor++ = (char) value;
            value = 0;
        }
          }
      } else {
          for (offset = 0; offset < count; offset++) {
        value >>= 4;
 
        if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
            errorValue = str;
            goto badValue;
        }
        c = str[offset] - '0';
        if (c > 9) {
            c += ('0' - 'A') + 10;
        }
        if (c > 16) {
            c += ('A' - 'a');
        }
        value |= ((c << 4) & 0xf0);
        if (offset % 2) {
            *cursor++ = (unsigned char)(value & 0xff);
            value = 0;
        }
          }
      }
      if (offset % 2) {
          if (cmd == 'H') {
        value <<= 4;
          } else {
        value >>= 4;
          }
          *cursor++ = (unsigned char) value;
      }
 
      while (cursor < last) {
          *cursor++ = '\0';
      }
      break;
        }
        case 'c':
        case 's':
        case 'S':
        case 'i':
        case 'I':
        case 'w':
        case 'W':
        case 'd':
        case 'f': {
      int listc, i;
      Tcl_Obj **listv;
 
      if (count == BINARY_NOCOUNT) {
          /*
           * Note that we are casting away the const-ness of
           * objv, but this is safe since we aren't going to
           * modify the array.
           */
 
          listv = (Tcl_Obj**)(objv + arg);
          listc = 1;
          count = 1;
      } else {
          Tcl_ListObjGetElements(interp, objv[arg],
            &listc, &listv);
          if (count == BINARY_ALL) {
        count = listc;
          }
      }
      arg++;
      for (i = 0; i < count; i++) {
          if (FormatNumber(interp, cmd, listv[i], &cursor)
            != TCL_OK) {
        return TCL_ERROR;
          }
      }
      break;
        }
        case 'x': {
      if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      memset(cursor, 0, (size_t) count);
      cursor += count;
      break;
        }
        case 'X': {
      if (cursor > maxPos) {
          maxPos = cursor;
      }
      if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      if ((count == BINARY_ALL)
        || (count > (cursor - buffer))) {
          cursor = buffer;
      } else {
          cursor -= count;
      }
      break;
        }
        case '@': {
      if (cursor > maxPos) {
          maxPos = cursor;
      }
      if (count == BINARY_ALL) {
          cursor = maxPos;
      } else {
          cursor = buffer + count;
      }
      break;
        }
    }
      }
      break;
  }
  case BINARY_SCAN: {
      int i;
      Tcl_Obj *valuePtr, *elementPtr;
      Tcl_HashTable numberCacheHash;
      Tcl_HashTable *numberCachePtr;
 
      if (objc < 4) {
    Tcl_WrongNumArgs(interp, 2, objv,
      "value formatString ?varName varName ...?");
    return TCL_ERROR;
      }
      numberCachePtr = &numberCacheHash;
      Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
      buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
      format = Tcl_GetString(objv[3]);
      cursor = buffer;
      arg = 4;
      offset = 0;
      while (*format != '\0') {
    str = format;
    if (!GetFormatSpec(&format, &cmd, &count)) {
        goto done;
    }
    switch (cmd) {
        case 'a':
        case 'A': {
      unsigned char *src;
 
      if (arg >= objc) {
          DeleteScanNumberCache(numberCachePtr);
          goto badIndex;
      }
      if (count == BINARY_ALL) {
          count = length - offset;
      } else {
          if (count == BINARY_NOCOUNT) {
        count = 1;
          }
          if (count > (length - offset)) {
        goto done;
          }
      }
 
      src = buffer + offset;
      size = count;
 
      /*
       * Trim trailing nulls and spaces, if necessary.
       */
 
      if (cmd == 'A') {
          while (size > 0) {
        if (src[size-1] != '\0' && src[size-1] != ' ') {
            break;
        }
        size--;
          }
      }
      valuePtr = Tcl_NewByteArrayObj(src, size);
      Tcl_IncrRefCount(valuePtr);
      resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
        NULL, valuePtr, TCL_LEAVE_ERR_MSG);
      Tcl_DecrRefCount(valuePtr);
      arg++;
      if (resultPtr == NULL) {
          DeleteScanNumberCache(numberCachePtr);
          return TCL_ERROR;
      }
      offset += count;
      break;
        }
        case 'b':
        case 'B': {
      unsigned char *src;
      char *dest;
 
      if (arg >= objc) {
          DeleteScanNumberCache(numberCachePtr);
          goto badIndex;
      }
      if (count == BINARY_ALL) {
          count = (length - offset) * 8;
      } else {
          if (count == BINARY_NOCOUNT) {
        count = 1;
          }
          if (count > (length - offset) * 8) {
        goto done;
          }
      }
      src = buffer + offset;
      valuePtr = Tcl_NewObj();
      Tcl_SetObjLength(valuePtr, count);
      dest = Tcl_GetString(valuePtr);
 
      if (cmd == 'b') {
          for (i = 0; i < count; i++) {
        if (i % 8) {
            value >>= 1;
        } else {
            value = *src++;
        }
        *dest++ = (char) ((value & 1) ? '1' : '0');
          }
      } else {
          for (i = 0; i < count; i++) {
        if (i % 8) {
            value <<= 1;
        } else {
            value = *src++;
        }
        *dest++ = (char) ((value & 0x80) ? '1' : '0');
          }
      }
 
      Tcl_IncrRefCount(valuePtr);
      resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
        NULL, valuePtr, TCL_LEAVE_ERR_MSG);
      Tcl_DecrRefCount(valuePtr);
      arg++;
      if (resultPtr == NULL) {
          DeleteScanNumberCache(numberCachePtr);
          return TCL_ERROR;
      }
      offset += (count + 7 ) / 8;
      break;
        }
        case 'h':
        case 'H': {
      char *dest;
      unsigned char *src;
      int i;
      static char hexdigit[] = "0123456789abcdef";
 
      if (arg >= objc) {
          DeleteScanNumberCache(numberCachePtr);
          goto badIndex;
      }
      if (count == BINARY_ALL) {
          count = (length - offset)*2;
      } else {
          if (count == BINARY_NOCOUNT) {
        count = 1;
          }
          if (count > (length - offset)*2) {
        goto done;
          }
      }
      src = buffer + offset;
      valuePtr = Tcl_NewObj();
      Tcl_SetObjLength(valuePtr, count);
      dest = Tcl_GetString(valuePtr);
 
      if (cmd == 'h') {
          for (i = 0; i < count; i++) {
        if (i % 2) {
            value >>= 4;
        } else {
            value = *src++;
        }
        *dest++ = hexdigit[value & 0xf];
          }
      } else {
          for (i = 0; i < count; i++) {
        if (i % 2) {
            value <<= 4;
        } else {
            value = *src++;
        }
        *dest++ = hexdigit[(value >> 4) & 0xf];
          }
      }
 
      Tcl_IncrRefCount(valuePtr);
      resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
        NULL, valuePtr, TCL_LEAVE_ERR_MSG);
      Tcl_DecrRefCount(valuePtr);
      arg++;
      if (resultPtr == NULL) {
          DeleteScanNumberCache(numberCachePtr);
          return TCL_ERROR;
      }
      offset += (count + 1) / 2;
      break;
        }
        case 'c': {
      size = 1;
      goto scanNumber;
        }
        case 's':
        case 'S': {
      size = 2;
      goto scanNumber;
        }
        case 'i':
        case 'I': {
      size = 4;
      goto scanNumber;
        }
        case 'w':
        case 'W': {
      size = 8;
      goto scanNumber;
        }
        case 'f': {
      size = sizeof(float);
      goto scanNumber;
        }
        case 'd': {
      unsigned char *src;
 
      size = sizeof(double);
      /* fall through */
 
      scanNumber:
      if (arg >= objc) {
          DeleteScanNumberCache(numberCachePtr);
          goto badIndex;
      }
      if (count == BINARY_NOCOUNT) {
          if ((length - offset) < size) {
        goto done;
          }
          valuePtr = ScanNumber(buffer+offset, cmd,
            &numberCachePtr);
          offset += size;
      } else {
          if (count == BINARY_ALL) {
        count = (length - offset) / size;
          }
          if ((length - offset) < (count * size)) {
        goto done;
          }
          valuePtr = Tcl_NewObj();
          src = buffer+offset;
          for (i = 0; i < count; i++) {
        elementPtr = ScanNumber(src, cmd,
          &numberCachePtr);
        src += size;
        Tcl_ListObjAppendElement(NULL, valuePtr,
          elementPtr);
          }
          offset += count*size;
      }
 
      Tcl_IncrRefCount(valuePtr);
      resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
        NULL, valuePtr, TCL_LEAVE_ERR_MSG);
      Tcl_DecrRefCount(valuePtr);
      arg++;
      if (resultPtr == NULL) {
          DeleteScanNumberCache(numberCachePtr);
          return TCL_ERROR;
      }
      break;
        }
        case 'x': {
      if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      if ((count == BINARY_ALL)
        || (count > (length - offset))) {
          offset = length;
      } else {
          offset += count;
      }
      break;
        }
        case 'X': {
      if (count == BINARY_NOCOUNT) {
          count = 1;
      }
      if ((count == BINARY_ALL) || (count > offset)) {
          offset = 0;
      } else {
          offset -= count;
      }
      break;
        }
        case '@': {
      if (count == BINARY_NOCOUNT) {
          DeleteScanNumberCache(numberCachePtr);
          goto badCount;
      }
      if ((count == BINARY_ALL) || (count > length)) {
          offset = length;
      } else {
          offset = count;
      }
      break;
        }
        default: {
      DeleteScanNumberCache(numberCachePtr);
      errorString = str;
      goto badField;
        }
    }
      }
 
      /*
       * Set the result to the last position of the cursor.
       */
 
      done:
      Tcl_ResetResult(interp);
      Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
      DeleteScanNumberCache(numberCachePtr);
      break;
  }
    }
    return TCL_OK;
 
    badValue:
    Tcl_ResetResult(interp);
    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
      " string but got \"", errorValue, "\" instead", NULL);
    return TCL_ERROR;
 
    badCount:
    errorString = "missing count for \"@\" field specifier";
    goto error;
 
    badIndex:
    errorString = "not enough arguments for all format specifiers";
    goto error;
 
    badField:
    {
  Tcl_UniChar ch;
  char buf[TCL_UTF_MAX + 1];
 
  Tcl_UtfToUniChar(errorString, &ch);
  buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
  Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
  return TCL_ERROR;
    }
 
    error:
    Tcl_AppendResult(interp, errorString, NULL);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetFormatSpec --
 *
 *  This function parses the format strings used in the binary
 *  format and scan commands.
 *
 * Results:
 *  Moves the formatPtr to the start of the next command. Returns
 *  the current command character and count in cmdPtr and countPtr.
 *  The count is set to BINARY_ALL if the count character was '*'
 *  or BINARY_NOCOUNT if no count was specified.  Returns 1 on
 *  success, or 0 if the string did not have a format specifier.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
 
static int
GetFormatSpec(formatPtr, cmdPtr, countPtr)
    char **formatPtr;   /* Pointer to format string. */
    char *cmdPtr;   /* Pointer to location of command char. */
    int *countPtr;    /* Pointer to repeat count value. */
{
    /*
     * Skip any leading blanks.
     */
 
    while (**formatPtr == ' ') {
  (*formatPtr)++;
    }
 
    /*
     * The string was empty, except for whitespace, so fail.
     */
 
    if (!(**formatPtr)) {
  return 0;
    }
 
    /*
     * Extract the command character and any trailing digits or '*'.
     */
 
    *cmdPtr = **formatPtr;
    (*formatPtr)++;
    if (**formatPtr == '*') {
  (*formatPtr)++;
  (*countPtr) = BINARY_ALL;
    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
  (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
    } else {
  (*countPtr) = BINARY_NOCOUNT;
    }
    return 1;
}
 
/*
 *----------------------------------------------------------------------
 *
 * FormatNumber --
 *
 *  This routine is called by Tcl_BinaryObjCmd to format a number
 *  into a location pointed at by cursor.
 *
 * Results:
 *   A standard Tcl result.
 *
 * Side effects:
 *  Moves the cursor to the next location to be written into.
 *
 *----------------------------------------------------------------------
 */
 
static int
FormatNumber(interp, type, src, cursorPtr)
    Tcl_Interp *interp;   /* Current interpreter, used to report
         * errors. */
    int type;     /* Type of number to format. */
    Tcl_Obj *src;   /* Number to format. */
    unsigned char **cursorPtr;  /* Pointer to index into destination buffer. */
{
    long value;
    double dvalue;
    Tcl_WideInt wvalue;
 
    switch (type) {
    case 'd':
    case 'f':
  /*
   * For floating point types, we need to copy the data using
   * memcpy to avoid alignment issues.
   */
 
  if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
      return TCL_ERROR;
  }
  if (type == 'd') {
      /*
       * Can't just memcpy() here. [Bug 1116542]
       */
 
      CopyNumber(&dvalue, *cursorPtr, sizeof(double));
      *cursorPtr += sizeof(double);
  } else {
      float fvalue;
 
      /*
       * Because some compilers will generate floating point exceptions
       * on an overflow cast (e.g. Borland), we restrict the values
       * to the valid range for float.
       */
 
      if (fabs(dvalue) > (double)FLT_MAX) {
    fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
      } else {
    fvalue = (float) dvalue;
      }
      memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
      *cursorPtr += sizeof(float);
  }
  return TCL_OK;
 
  /*
   * Next cases separate from other integer cases because we
   * need a different API to get a wide.
   */
    case 'w':
    case 'W':
  if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
      return TCL_ERROR;
  }
  if (type == 'w') {
      *(*cursorPtr)++ = (unsigned char) wvalue;
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
  } else {
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
      *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
      *(*cursorPtr)++ = (unsigned char) wvalue;
  }
  return TCL_OK;
    default:
  if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
      return TCL_ERROR;
  }
  if (type == 'c') {
      *(*cursorPtr)++ = (unsigned char) value;
  } else if (type == 's') {
      *(*cursorPtr)++ = (unsigned char) value;
      *(*cursorPtr)++ = (unsigned char) (value >> 8);
  } else if (type == 'S') {
      *(*cursorPtr)++ = (unsigned char) (value >> 8);
      *(*cursorPtr)++ = (unsigned char) value;
  } else if (type == 'i') {
      *(*cursorPtr)++ = (unsigned char) value;
      *(*cursorPtr)++ = (unsigned char) (value >> 8);
      *(*cursorPtr)++ = (unsigned char) (value >> 16);
      *(*cursorPtr)++ = (unsigned char) (value >> 24);
  } else if (type == 'I') {
      *(*cursorPtr)++ = (unsigned char) (value >> 24);
      *(*cursorPtr)++ = (unsigned char) (value >> 16);
      *(*cursorPtr)++ = (unsigned char) (value >> 8);
      *(*cursorPtr)++ = (unsigned char) value;
  }
  return TCL_OK;
    }
}
 
/* Ugly workaround for old and broken compiler! */
static void
CopyNumber(from, to, length)
    CONST VOID *from;
    VOID *to;
    unsigned int length;
{
    memcpy(to, from, length);
}
 
/*
 *----------------------------------------------------------------------
 *
 * ScanNumber --
 *
 *  This routine is called by Tcl_BinaryObjCmd to scan a number
 *  out of a buffer.
 *
 * Results:
 *  Returns a newly created object containing the scanned number.
 *  This object has a ref count of zero.
 *
 * Side effects:
 *  Might reuse an object in the number cache, place a new object
 *  in the cache, or delete the cache and set the reference to
 *  it (itself passed in by reference) to NULL.
 *
 *----------------------------------------------------------------------
 */
 
static Tcl_Obj *
ScanNumber(buffer, type, numberCachePtrPtr)
    unsigned char *buffer;  /* Buffer to scan number from. */
    int type;     /* Format character from "binary scan" */
    Tcl_HashTable **numberCachePtrPtr;
        /* Place to look for cache of scanned
         * value objects, or NULL if too many
         * different numbers have been scanned. */
{
    long value;
    Tcl_WideUInt uwvalue;
 
    /*
     * We cannot rely on the compiler to properly sign extend integer values
     * when we cast from smaller values to larger values because we don't know
     * the exact size of the integer types.  So, we have to handle sign
     * extension explicitly by checking the high bit and padding with 1's as
     * needed.
     */
 
    switch (type) {
  case 'c':
      /*
       * Characters need special handling.  We want to produce a
       * signed result, but on some platforms (such as AIX) chars
       * are unsigned.  To deal with this, check for a value that
       * should be negative but isn't.
       */
 
      value = buffer[0];
      if (value & 0x80) {
    value |= -0x100;
      }
      goto returnNumericObject;
 
  case 's':
      value = (long) (buffer[0] + (buffer[1] << 8));
      goto shortValue;
  case 'S':
      value = (long) (buffer[1] + (buffer[0] << 8));
      shortValue:
      if (value & 0x8000) {
    value |= -0x10000;
      }
      goto returnNumericObject;
 
  case 'i':
      value = (long) (buffer[0]
        + (buffer[1] << 8)
        + (buffer[2] << 16)
        + (buffer[3] << 24));
      goto intValue;
  case 'I':
      value = (long) (buffer[3]
        + (buffer[2] << 8)
        + (buffer[1] << 16)
        + (buffer[0] << 24));
      intValue:
      /*
       * Check to see if the value was sign extended properly on
       * systems where an int is more than 32-bits.
       */
 
      if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
    value -= (((unsigned int)1)<<31);
    value -= (((unsigned int)1)<<31);
      }
      returnNumericObject:
      if (*numberCachePtrPtr == NULL) {
    return Tcl_NewLongObj(value);
      } else {
    register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
    register Tcl_HashEntry *hPtr;
    int isNew;
 
    hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
    if (!isNew) {
        return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
    }
    if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {
        /*
         * We've overflowed the cache!  Someone's parsing
         * a LOT of varied binary data in a single call!
         * Bail out by switching back to the old behaviour
         * for the rest of the scan.
         *
         * Note that anyone just using the 'c' conversion
         * (for bytes) cannot trigger this.
         */
        DeleteScanNumberCache(tablePtr);
        *numberCachePtrPtr = NULL;
        return Tcl_NewLongObj(value);
    } else {
        register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
 
        Tcl_IncrRefCount(objPtr);
        Tcl_SetHashValue(hPtr, (ClientData) objPtr);
        return objPtr;
    }
      }
 
      /*
       * Do not cache wide values; they are already too large to
       * use as keys.
       */
  case 'w':
      uwvalue =  ((Tcl_WideUInt) buffer[0])
        | (((Tcl_WideUInt) buffer[1]) << 8)
        | (((Tcl_WideUInt) buffer[2]) << 16)
        | (((Tcl_WideUInt) buffer[3]) << 24)
        | (((Tcl_WideUInt) buffer[4]) << 32)
        | (((Tcl_WideUInt) buffer[5]) << 40)
        | (((Tcl_WideUInt) buffer[6]) << 48)
        | (((Tcl_WideUInt) buffer[7]) << 56);
      return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
  case 'W':
      uwvalue =  ((Tcl_WideUInt) buffer[7])
        | (((Tcl_WideUInt) buffer[6]) << 8)
        | (((Tcl_WideUInt) buffer[5]) << 16)
        | (((Tcl_WideUInt) buffer[4]) << 24)
        | (((Tcl_WideUInt) buffer[3]) << 32)
        | (((Tcl_WideUInt) buffer[2]) << 40)
        | (((Tcl_WideUInt) buffer[1]) << 48)
        | (((Tcl_WideUInt) buffer[0]) << 56);
      return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
 
      /*
       * Do not cache double values; they are already too large
       * to use as keys and the values stored are utterly
       * incompatible too.
       */
  case 'f': {
      float fvalue;
      memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
      return Tcl_NewDoubleObj(fvalue);
  }
  case 'd': {
      double dvalue;
      memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
      return Tcl_NewDoubleObj(dvalue);
  }
    }
    return NULL;
}
 
/*
 *----------------------------------------------------------------------
 *
 * DeleteScanNumberCache --
 *
 *  Deletes the hash table acting as a scan number cache.
 *
 * Results:
 *  None
 *
 * Side effects:
 *  Decrements the reference counts of the objects in the cache.
 *
 *----------------------------------------------------------------------
 */
 
static void
DeleteScanNumberCache(numberCachePtr)
    Tcl_HashTable *numberCachePtr;  /* Pointer to the hash table, or
           * NULL (when the cache has already
           * been deleted due to overflow.) */
{
    Tcl_HashEntry *hEntry;
    Tcl_HashSearch search;
 
    if (numberCachePtr == NULL) {
  return;
    }
 
    hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
    while (hEntry != NULL) {
  register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);
 
  if (value != NULL) {
      Tcl_DecrRefCount(value);
  }
  hEntry = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(numberCachePtr);
}
Line No.	Rev	Author	Line
1	2072	malin	`/*`
2			`* tclBinary.c --`
3			`*`
4			`* This file contains the implementation of the "binary" Tcl built-in`
5			`* command and the Tcl binary data object.`
6			`*`
7			`* Copyright (c) 1997 by Sun Microsystems, Inc.`
8			`* Copyright (c) 1998-1999 by Scriptics Corporation.`
9			`*`
10			`* See the file "license.terms" for information on usage and redistribution`
11			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
12			`*`
13			`* RCS: @(#) $Id: tclBinary.c,v 1.13.2.4 2005/10/23 22:01:29 msofer Exp $`
14			`*/`
15
16			`#include "tclInt.h"`
17			`#include "tclPort.h"`
18			`#include <math.h>`
19
20			`/*`
21			`* The following constants are used by GetFormatSpec to indicate various`
22			`* special conditions in the parsing of a format specifier.`
23			`*/`
24
25			`#define BINARY_ALL -1 /* Use all elements in the argument. */`
26			`#define BINARY_NOCOUNT -2 /* No count was specified in format. */`
27
28			`/*`
29			`* The following defines the maximum number of different (integer)`
30			`* numbers placed in the object cache by 'binary scan' before it bails`
31			`* out and switches back to Plan A (creating a new object for each`
32			`* value.) Theoretically, it would be possible to keep the cache`
33			`* about for the values that are already in it, but that makes the`
34			`* code slower in practise when overflow happens, and makes little`
35			`* odds the rest of the time (as measured on my machine.) It is also`
36			`* slower (on the sample I tried at least) to grow the cache to hold`
37			`* all items we might want to put in it; presumably the extra cost of`
38			`* managing the memory for the enlarged table outweighs the benefit`
39			`* from allocating fewer objects. This is probably because as the`
40			`* number of objects increases, the likelihood of reuse of any`
Subversion Repositories Open64

[/] [sim/] [fsim/] [shell/] [tclsh/] [generic/] [tclBinary.c] - Blame information for rev 2072
