URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclBinary.c] - Rev 1774
Go to most recent revision | Compare with Previous | Blame | View Log
/* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command . * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclBinary.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $ */ #include <math.h> #include "tclInt.h" #include "tclPort.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. */ /* * Prototypes for local procedures defined in this file: */ static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, Tcl_Obj *src, char **cursorPtr)); static Tcl_Obj * ScanNumber _ANSI_ARGS_((char *buffer, int type)); /* *---------------------------------------------------------------------- * * 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. */ char *cursor; /* Current position within result buffer. */ char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ char *buffer; /* Start of data buffer. */ char *errorString, *errorValue, *str; int offset, size, length; Tcl_Obj *resultPtr; static char *subCmds[] = { "format", "scan", (char *) NULL }; enum { BinaryFormat, BinaryScan } index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, (int *) &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case BinaryFormat: 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_GetStringFromObj(objv[2], NULL); arg = 3; offset = length = 0; while (*format != 0) { 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 characters in a single argument. */ if (arg >= objc) { goto badIndex; } if (count == BINARY_ALL) { (void)Tcl_GetStringFromObj(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 '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) { errorString = "number of elements in list does not match count"; goto error; } } offset += count*size; break; case 'x': if (count == BINARY_ALL) { errorString = "cannot use \"*\" in format string with \"x\""; goto 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: { char buf[2]; Tcl_ResetResult(interp); buf[0] = cmd; buf[1] = '\0'; Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad field specifier \"", buf, "\"", NULL); return TCL_ERROR; } } } 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); Tcl_SetObjLength(resultPtr, length); buffer = Tcl_GetStringFromObj(resultPtr, NULL); memset(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_GetStringFromObj(objv[2], NULL); 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' : ' '); str = Tcl_GetStringFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { count = 1; } if (length >= count) { memcpy((VOID *) cursor, (VOID *) str, (size_t) count); } else { memcpy((VOID *) cursor, (VOID *) str, (size_t) length); memset(cursor+length, pad, (size_t) (count - length)); } cursor += count; break; } case 'b': case 'B': { 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++ = (char)(value & 0xff); 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++ = (char)(value & 0xff); value = 0; } } } if ((offset % 8) != 0) { if (cmd == 'B') { value <<= 8 - (offset % 8); } else { value >>= 8 - (offset % 8); } *cursor++ = (char)(value & 0xff); } while (cursor < last) { *cursor++ = '\0'; } break; } case 'h': case 'H': { 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; c = tolower(((unsigned char *) str)[offset]); if ((c >= 'a') && (c <= 'f')) { value |= ((c - 'a' + 10) & 0xf); } else if ((c >= '0') && (c <= '9')) { value |= (c - '0') & 0xf; } else { errorValue = str; goto badValue; } if (offset % 2) { *cursor++ = (char) value; value = 0; } } } else { for (offset = 0; offset < count; offset++) { value >>= 4; c = tolower(((unsigned char *) str)[offset]); if ((c >= 'a') && (c <= 'f')) { value |= ((c - 'a' + 10) << 4) & 0xf0; } else if ((c >= '0') && (c <= '9')) { value |= ((c - '0') << 4) & 0xf0; } else { errorValue = str; goto badValue; } if (offset % 2) { *cursor++ = (char)(value & 0xff); value = 0; } } } if (offset % 2) { if (cmd == 'H') { value <<= 4; } else { value >>= 4; } *cursor++ = (char) value; } while (cursor < last) { *cursor++ = '\0'; } break; } case 'c': case 's': case 'S': case 'i': case 'I': 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 BinaryScan: { int i; Tcl_Obj *valuePtr, *elementPtr; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "value formatString ?varName varName ...?"); return TCL_ERROR; } buffer = Tcl_GetStringFromObj(objv[2], &length); format = Tcl_GetStringFromObj(objv[3], NULL); cursor = buffer; arg = 4; offset = 0; while (*format != 0) { if (!GetFormatSpec(&format, &cmd, &count)) { goto done; } switch (cmd) { case 'a': case 'A': if (arg >= objc) { goto badIndex; } if (count == BINARY_ALL) { count = length - offset; } else { if (count == BINARY_NOCOUNT) { count = 1; } if (count > (length - offset)) { goto done; } } str = buffer + offset; size = count; /* * Trim trailing nulls and spaces, if necessary. */ if (cmd == 'A') { while (size > 0) { if (str[size-1] != '\0' && str[size-1] != ' ') { break; } size--; } } valuePtr = Tcl_NewStringObj(str, size); resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, valuePtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += count; break; case 'b': case 'B': { char *dest; if (arg >= objc) { goto badIndex; } if (count == BINARY_ALL) { count = (length - offset)*8; } else { if (count == BINARY_NOCOUNT) { count = 1; } if (count > (length - offset)*8) { goto done; } } str = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); dest = Tcl_GetStringFromObj(valuePtr, NULL); if (cmd == 'b') { for (i = 0; i < count; i++) { if (i % 8) { value >>= 1; } else { value = *str++; } *dest++ = (char) ((value & 1) ? '1' : '0'); } } else { for (i = 0; i < count; i++) { if (i % 8) { value <<= 1; } else { value = *str++; } *dest++ = (char) ((value & 0x80) ? '1' : '0'); } } resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, valuePtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += (count + 7 ) / 8; break; } case 'h': case 'H': { char *dest; int i; static char hexdigit[] = "0123456789abcdef"; if (arg >= objc) { goto badIndex; } if (count == BINARY_ALL) { count = (length - offset)*2; } else { if (count == BINARY_NOCOUNT) { count = 1; } if (count > (length - offset)*2) { goto done; } } str = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); dest = Tcl_GetStringFromObj(valuePtr, NULL); if (cmd == 'h') { for (i = 0; i < count; i++) { if (i % 2) { value >>= 4; } else { value = *str++; } *dest++ = hexdigit[value & 0xf]; } } else { for (i = 0; i < count; i++) { if (i % 2) { value <<= 4; } else { value = *str++; } *dest++ = hexdigit[(value >> 4) & 0xf]; } } resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, valuePtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ 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 'f': size = sizeof(float); goto scanNumber; case 'd': size = sizeof(double); /* fall through */ scanNumber: if (arg >= objc) { goto badIndex; } if (count == BINARY_NOCOUNT) { if ((length - offset) < size) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd); offset += size; } else { if (count == BINARY_ALL) { count = (length - offset) / size; } if ((length - offset) < (count * size)) { goto done; } valuePtr = Tcl_NewObj(); str = buffer+offset; for (i = 0; i < count; i++) { elementPtr = ScanNumber(str, cmd); str += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); } offset += count*size; } resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, valuePtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ 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) { goto badCount; } if ((count == BINARY_ALL) || (count > length)) { offset = length; } else { offset = count; } break; default: { char buf[2]; Tcl_ResetResult(interp); buf[0] = cmd; buf[1] = '\0'; Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad field specifier \"", buf, "\"", NULL); return TCL_ERROR; } } } /* * Set the result to the last position of the cursor. */ done: Tcl_ResetResult(interp); Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4); 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; error: Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1); 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))) { (*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. */ char **cursorPtr; /* Pointer to index into destination buffer. */ { int value; double dvalue; char cmd = (char)type; if (cmd == 'd' || cmd == '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 (cmd == 'd') { memcpy((*cursorPtr), &dvalue, 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((*cursorPtr), &fvalue, sizeof(float)); (*cursorPtr) += sizeof(float); } } else { if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (cmd == 'c') { *(*cursorPtr)++ = (char)(value & 0xff); } else if (cmd == 's') { *(*cursorPtr)++ = (char)(value & 0xff); *(*cursorPtr)++ = (char)((value >> 8) & 0xff); } else if (cmd == 'S') { *(*cursorPtr)++ = (char)((value >> 8) & 0xff); *(*cursorPtr)++ = (char)(value & 0xff); } else if (cmd == 'i') { *(*cursorPtr)++ = (char)(value & 0xff); *(*cursorPtr)++ = (char)((value >> 8) & 0xff); *(*cursorPtr)++ = (char)((value >> 16) & 0xff); *(*cursorPtr)++ = (char)((value >> 24) & 0xff); } else if (cmd == 'I') { *(*cursorPtr)++ = (char)((value >> 24) & 0xff); *(*cursorPtr)++ = (char)((value >> 16) & 0xff); *(*cursorPtr)++ = (char)((value >> 8) & 0xff); *(*cursorPtr)++ = (char)(value & 0xff); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * 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: * None. * *---------------------------------------------------------------------- */ static Tcl_Obj * ScanNumber(buffer, type) char *buffer; /* Buffer to scan number from. */ int type; /* Format character from "binary scan" */ { int value; /* * 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 ((char) type) { case 'c': value = buffer[0]; if (value & 0x80) { value |= -0x100; } return Tcl_NewLongObj((long)value); case 's': value = (((unsigned char)buffer[0]) + ((unsigned char)buffer[1] << 8)); goto shortValue; case 'S': value = (((unsigned char)buffer[1]) + ((unsigned char)buffer[0] << 8)); shortValue: if (value & 0x8000) { value |= -0x10000; } return Tcl_NewLongObj((long)value); case 'i': value = (((unsigned char)buffer[0]) + ((unsigned char)buffer[1] << 8) + ((unsigned char)buffer[2] << 16) + ((unsigned char)buffer[3] << 24)); goto intValue; case 'I': value = (((unsigned char)buffer[3]) + ((unsigned char)buffer[2] << 8) + ((unsigned char)buffer[1] << 16) + ((unsigned char)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); } return Tcl_NewLongObj((long)value); case 'f': { float fvalue; memcpy(&fvalue, buffer, sizeof(float)); return Tcl_NewDoubleObj(fvalue); } case 'd': { double dvalue; memcpy(&dvalue, buffer, sizeof(double)); return Tcl_NewDoubleObj(dvalue); } } return NULL; }
Go to most recent revision | Compare with Previous | Blame | View Log