diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2002-02-15 14:28:47 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2002-02-15 14:28:47 (GMT) |
| commit | 66a15c6f8be47c3acbdddffadc67f50dec8a56e6 (patch) | |
| tree | edaf81ee6d40edeacc9f3e2093ddcb2ba302c620 /generic | |
| parent | 2827a2692798a7a0ec46e684a4ccc83afb39859e (diff) | |
| download | tcl-66a15c6f8be47c3acbdddffadc67f50dec8a56e6.zip tcl-66a15c6f8be47c3acbdddffadc67f50dec8a56e6.tar.gz tcl-66a15c6f8be47c3acbdddffadc67f50dec8a56e6.tar.bz2 | |
TIP#72 implementation. See ChangeLog for details.
This version builds clean on Solaris/SPARC, with GCC and CC, both with and
without threads and both in 32-bit and 64-bit mode.
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 460 | ||||
| -rw-r--r-- | generic/tcl.h | 292 | ||||
| -rw-r--r-- | generic/tclBasic.c | 5 | ||||
| -rw-r--r-- | generic/tclBinary.c | 78 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 191 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 28 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 12 | ||||
| -rw-r--r-- | generic/tclCompile.h | 7 | ||||
| -rw-r--r-- | generic/tclDecls.h | 95 | ||||
| -rw-r--r-- | generic/tclExecute.c | 1299 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 16 | ||||
| -rw-r--r-- | generic/tclFileName.c | 28 | ||||
| -rw-r--r-- | generic/tclIO.c | 103 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 13 | ||||
| -rw-r--r-- | generic/tclIOGT.c | 41 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 86 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 227 | ||||
| -rw-r--r-- | generic/tclInt.decls | 191 | ||||
| -rw-r--r-- | generic/tclInt.h | 18 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 10 | ||||
| -rw-r--r-- | generic/tclInterp.c | 4 | ||||
| -rw-r--r-- | generic/tclLink.c | 234 | ||||
| -rw-r--r-- | generic/tclObj.c | 424 | ||||
| -rw-r--r-- | generic/tclParseExpr.c | 6 | ||||
| -rw-r--r-- | generic/tclPipe.c | 4 | ||||
| -rw-r--r-- | generic/tclPort.h | 22 | ||||
| -rw-r--r-- | generic/tclScan.c | 123 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 13 | ||||
| -rw-r--r-- | generic/tclTest.c | 169 | ||||
| -rw-r--r-- | generic/tclTestObj.c | 29 | ||||
| -rw-r--r-- | generic/tclVar.c | 118 |
31 files changed, 3092 insertions, 1254 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 9e6e3b4..915571e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.82 2002/02/10 20:36:33 kennykb Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.83 2002/02/15 14:28:48 dkf Exp $ library tcl @@ -29,12 +29,11 @@ hooks {tclPlat tclInt tclIntPlat} declare 0 generic { int Tcl_PkgProvideEx( Tcl_Interp* interp, CONST char* name, - CONST char* version, ClientData clientData ) + CONST char* version, ClientData clientData ) } declare 1 generic { CONST char * Tcl_PkgRequireEx( Tcl_Interp *interp, CONST char *name, - CONST char *version, - int exact, ClientData *clientDataPtr ) + CONST char *version, int exact, ClientData *clientDataPtr ) } declare 2 generic { void Tcl_Panic(CONST char *format, ...) @@ -56,7 +55,7 @@ declare 7 generic { } declare 8 generic { char * Tcl_DbCkrealloc(char *ptr, unsigned int size, - CONST char *file, int line) + CONST char *file, int line) } # Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix, @@ -64,7 +63,7 @@ declare 8 generic { # compatibility reasons. declare 9 unix { - void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, \ + void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData) } declare 10 unix { @@ -93,7 +92,7 @@ declare 17 generic { Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[]) } declare 18 generic { - int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_ObjType *typePtr) } declare 19 generic { @@ -109,16 +108,16 @@ declare 22 generic { Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, CONST char *file, int line) } declare 23 generic { - Tcl_Obj * Tcl_DbNewByteArrayObj(CONST unsigned char *bytes, int length, \ + Tcl_Obj * Tcl_DbNewByteArrayObj(CONST unsigned char *bytes, int length, CONST char *file, int line) } declare 24 generic { Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, - CONST char *file, int line) + CONST char *file, int line) } declare 25 generic { Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *CONST *objv, - CONST char *file, int line) + CONST char *file, int line) } declare 26 generic { Tcl_Obj * Tcl_DbNewLongObj(long longValue, CONST char *file, int line) @@ -128,7 +127,7 @@ declare 27 generic { } declare 28 generic { Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, - CONST char *file, int line) + CONST char *file, int line) } declare 29 generic { Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr) @@ -140,7 +139,7 @@ declare 31 generic { int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *str, int *boolPtr) } declare 32 generic { - int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr) } declare 33 generic { @@ -150,11 +149,11 @@ declare 34 generic { int Tcl_GetDouble(Tcl_Interp *interp, CONST char *str, double *doublePtr) } declare 35 generic { - int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } declare 36 generic { - int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr) } declare 37 generic { @@ -176,34 +175,34 @@ declare 42 generic { void Tcl_InvalidateStringRep(Tcl_Obj *objPtr) } declare 43 generic { - int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, \ + int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr) } declare 44 generic { - int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, \ + int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr) } declare 45 generic { - int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, \ + int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr) } declare 46 generic { - int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, \ + int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr) } declare 47 generic { - int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *intPtr) + int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + int *lengthPtr) } declare 48 generic { - int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, \ + int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[]) } declare 49 generic { - Tcl_Obj * Tcl_NewBooleanObj(int boolValue) + Tcl_Obj *Tcl_NewBooleanObj(int boolValue) } declare 50 generic { - Tcl_Obj * Tcl_NewByteArrayObj( CONST unsigned char* bytes, - int length ) + Tcl_Obj *Tcl_NewByteArrayObj(CONST unsigned char* bytes, int length) } declare 51 generic { Tcl_Obj * Tcl_NewDoubleObj(double doubleValue) @@ -231,7 +230,7 @@ declare 58 generic { } declare 59 generic { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, CONST unsigned char *bytes, - int length) + int length) } declare 60 generic { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -255,7 +254,7 @@ declare 66 generic { void Tcl_AddErrorInfo(Tcl_Interp *interp, CONST char *message) } declare 67 generic { - void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, \ + void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, int length) } declare 68 generic { @@ -268,7 +267,7 @@ declare 70 generic { void Tcl_AppendResult(Tcl_Interp *interp, ...) } declare 71 generic { - Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, \ + Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, ClientData clientData) } declare 72 generic { @@ -290,11 +289,11 @@ declare 77 generic { char Tcl_Backslash(CONST char *src, int *readPtr) } declare 78 generic { - int Tcl_BadChannelOption(Tcl_Interp *interp, CONST char *optionName, \ + int Tcl_BadChannelOption(Tcl_Interp *interp, CONST char *optionName, CONST char *optionList) } declare 79 generic { - void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, \ + void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 80 generic { @@ -313,17 +312,17 @@ declare 84 generic { int Tcl_ConvertElement(CONST char *src, char *dst, int flags) } declare 85 generic { - int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst, \ + int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst, int flags) } declare 86 generic { - int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd, \ - Tcl_Interp *target, CONST char *targetCmd, int argc, \ + int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd, + Tcl_Interp *target, CONST char *targetCmd, int argc, char * CONST *argv) } declare 87 generic { - int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd, \ - Tcl_Interp *target, CONST char *targetCmd, int objc, \ + int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd, + Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[]) } declare 88 generic { @@ -331,20 +330,20 @@ declare 88 generic { CONST char *chanName, ClientData instanceData, int mask) } declare 89 generic { - void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, \ + void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData) } declare 90 generic { - void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, \ + void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData) } declare 91 generic { - Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, CONST char *cmdName, \ - Tcl_CmdProc *proc, ClientData clientData, \ + Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, CONST char *cmdName, + Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 92 generic { - void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, \ + void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 93 generic { @@ -354,37 +353,37 @@ declare 94 generic { Tcl_Interp * Tcl_CreateInterp(void) } declare 95 generic { - void Tcl_CreateMathFunc(Tcl_Interp *interp, CONST char *name, \ - int numArgs, Tcl_ValueType *argTypes, - Tcl_MathProc *proc, ClientData clientData) + void Tcl_CreateMathFunc(Tcl_Interp *interp, CONST char *name, + int numArgs, Tcl_ValueType *argTypes, + Tcl_MathProc *proc, ClientData clientData) } declare 96 generic { - Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, \ - CONST char *cmdName, \ - Tcl_ObjCmdProc *proc, ClientData clientData, \ + Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, + CONST char *cmdName, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 97 generic { - Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, CONST char *slaveName, \ + Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, CONST char *slaveName, int isSafe) } declare 98 generic { - Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, \ + Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, ClientData clientData) } declare 99 generic { - Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, \ + Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData) } declare 100 generic { void Tcl_DeleteAssocData(Tcl_Interp *interp, CONST char *name) } declare 101 generic { - void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, \ + void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData) } declare 102 generic { - void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, \ + void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData) } declare 103 generic { @@ -397,7 +396,7 @@ declare 105 generic { void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData) } declare 106 generic { - void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, \ + void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 107 generic { @@ -422,7 +421,7 @@ declare 113 generic { void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace) } declare 114 generic { - void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, \ + void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 115 generic { @@ -432,12 +431,10 @@ declare 116 generic { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 generic { - char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *str, \ - int length) + char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *str, int length) } declare 118 generic { - char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, \ - CONST char *string) + char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *string) } declare 119 generic { void Tcl_DStringEndSublist(Tcl_DString *dsPtr) @@ -486,7 +483,7 @@ declare 133 generic { void Tcl_Exit(int status) } declare 134 generic { - int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken, \ + int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken, CONST char *cmdName) } declare 135 generic { @@ -508,7 +505,7 @@ declare 140 generic { int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr) } declare 141 generic { - int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr) } declare 142 generic { @@ -521,7 +518,7 @@ declare 144 generic { void Tcl_FindExecutable(CONST char *argv0) } declare 145 generic { - Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, \ + Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr) } declare 146 generic { @@ -531,28 +528,28 @@ declare 147 generic { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 generic { - int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, \ + int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, char ***argvPtr) } declare 149 generic { - int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, \ + int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 generic { - ClientData Tcl_GetAssocData(Tcl_Interp *interp, CONST char *name, \ + ClientData Tcl_GetAssocData(Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc **procPtr) } declare 151 generic { - Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, CONST char *chanName, \ + Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, CONST char *chanName, int *modePtr) } declare 152 generic { int Tcl_GetChannelBufferSize(Tcl_Channel chan) } declare 153 generic { - int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, \ + int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, ClientData *handlePtr) } declare 154 generic { @@ -565,14 +562,14 @@ declare 156 generic { CONST char * Tcl_GetChannelName(Tcl_Channel chan) } declare 157 generic { - int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, \ + int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, CONST char *optionName, Tcl_DString *dsPtr) } declare 158 generic { Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan) } declare 159 generic { - int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, \ + int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdInfo *infoPtr) } declare 160 generic { @@ -601,7 +598,7 @@ declare 166 generic { # generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { - int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *str, int forWriting, \ + int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *str, int forWriting, int checkUsage, ClientData *filePtr) } # Obsolete. Should now use Tcl_FSGetPathType which is objectified @@ -631,7 +628,7 @@ declare 175 generic { CONST char * Tcl_GetVar(Tcl_Interp *interp, char *varName, int flags) } declare 176 generic { - CONST char * Tcl_GetVar2(Tcl_Interp *interp, char *part1, char *part2, \ + CONST char * Tcl_GetVar2(Tcl_Interp *interp, char *part1, char *part2, int flags) } declare 177 generic { @@ -641,7 +638,7 @@ declare 178 generic { int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 179 generic { - int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName, \ + int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName, CONST char *hiddenCmdToken) } declare 180 generic { @@ -695,29 +692,29 @@ declare 194 generic { void Tcl_NotifyChannel(Tcl_Channel channel, int mask) } declare 195 generic { - Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ + Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 196 generic { - Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ + Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags) } declare 197 {unix win} { - Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, \ + Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel declare 198 generic { - Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, CONST char *fileName, \ + Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, CONST char *fileName, CONST char *modeString, int permissions) } declare 199 generic { - Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, \ + Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, CONST char *address, CONST char *myaddr, int myport, int async) } declare 200 generic { - Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, \ - CONST char *host, Tcl_TcpAcceptProc *acceptProc, \ + Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, + CONST char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData) } declare 201 generic { @@ -757,15 +754,15 @@ declare 212 generic { Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *string) } declare 213 generic { - int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, \ + int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, CONST char *str, CONST char *start) } declare 214 generic { - int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *str, \ + int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *str, CONST char *pattern) } declare 215 generic { - void Tcl_RegExpRange(Tcl_RegExp regexp, int index, \ + void Tcl_RegExpRange(Tcl_RegExp regexp, int index, CONST char **startPtr, CONST char **endPtr) } declare 216 generic { @@ -780,8 +777,9 @@ declare 218 generic { declare 219 generic { int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr) } +# Obsolete declare 220 generic { - int Tcl_Seek(Tcl_Channel chan, int offset, int mode) + int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 generic { int Tcl_ServiceAll(void) @@ -790,18 +788,18 @@ declare 222 generic { int Tcl_ServiceEvent(int flags) } declare 223 generic { - void Tcl_SetAssocData(Tcl_Interp *interp, CONST char *name, \ + void Tcl_SetAssocData(Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 224 generic { void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz) } declare 225 generic { - int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, \ + int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, CONST char *optionName, CONST char *newValue) } declare 226 generic { - int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, \ + int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, CONST Tcl_CmdInfo *infoPtr) } declare 227 generic { @@ -820,7 +818,7 @@ declare 231 generic { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } declare 232 generic { - void Tcl_SetResult(Tcl_Interp *interp, char *str, \ + void Tcl_SetResult(Tcl_Interp *interp, char *str, Tcl_FreeProc *freeProc) } declare 233 generic { @@ -836,11 +834,11 @@ declare 236 generic { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } declare 237 generic { - CONST char * Tcl_SetVar(Tcl_Interp *interp, char *varName, \ + CONST char * Tcl_SetVar(Tcl_Interp *interp, char *varName, CONST char *newValue, int flags) } declare 238 generic { - CONST char * Tcl_SetVar2(Tcl_Interp *interp, char *part1, char *part2, \ + CONST char * Tcl_SetVar2(Tcl_Interp *interp, char *part1, char *part2, CONST char *newValue, int flags) } declare 239 generic { @@ -853,7 +851,7 @@ declare 241 generic { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 generic { - int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, \ + int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, CONST84 char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath @@ -861,25 +859,26 @@ declare 243 generic { void Tcl_SplitPath(CONST char *path, int *argcPtr, CONST84 char ***argvPtr) } declare 244 generic { - void Tcl_StaticPackage(Tcl_Interp *interp, CONST char *pkgName, \ + void Tcl_StaticPackage(Tcl_Interp *interp, CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 generic { int Tcl_StringMatch(CONST char *str, CONST char *pattern) } +# Obsolete declare 246 generic { - int Tcl_Tell(Tcl_Channel chan) + int Tcl_TellOld(Tcl_Channel chan) } declare 247 generic { - int Tcl_TraceVar(Tcl_Interp *interp, char *varName, int flags, \ + int Tcl_TraceVar(Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 248 generic { - int Tcl_TraceVar2(Tcl_Interp *interp, char *part1, char *part2, \ + int Tcl_TraceVar2(Tcl_Interp *interp, char *part1, char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 249 generic { - char * Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name, \ + char * Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name, Tcl_DString *bufferPtr) } declare 250 generic { @@ -898,41 +897,41 @@ declare 254 generic { int Tcl_UnsetVar2(Tcl_Interp *interp, char *part1, char *part2, int flags) } declare 255 generic { - void Tcl_UntraceVar(Tcl_Interp *interp, char *varName, int flags, \ + void Tcl_UntraceVar(Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 256 generic { - void Tcl_UntraceVar2(Tcl_Interp *interp, char *part1, char *part2, \ + void Tcl_UntraceVar2(Tcl_Interp *interp, char *part1, char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 257 generic { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, char *varName) } declare 258 generic { - int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName, char *varName, \ + int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName, char *varName, CONST char *localName, int flags) } declare 259 generic { - int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, char *part1, \ + int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, char *part1, char *part2, CONST char *localName, int flags) } declare 260 generic { int Tcl_VarEval(Tcl_Interp *interp, ...) } declare 261 generic { - ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, char *varName, \ + ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } declare 262 generic { - ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, char *part1, \ - char *part2, int flags, Tcl_VarTraceProc *procPtr, \ + ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, char *part1, + char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } declare 263 generic { int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen) } declare 264 generic { - void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, \ + void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], CONST char *message) } declare 265 generic { @@ -956,20 +955,19 @@ declare 270 generic { } declare 271 generic { CONST char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name, - CONST char *version, int exact) + CONST char *version, int exact) } declare 272 generic { CONST char * Tcl_PkgPresentEx(Tcl_Interp *interp, CONST char *name, - CONST char *version, int exact, - ClientData *clientDataPtr) + CONST char *version, int exact, ClientData *clientDataPtr) } declare 273 generic { int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name, - CONST char *version) + CONST char *version) } declare 274 generic { CONST char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name, - CONST char *version, int exact) + CONST char *version, int exact) } declare 275 generic { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) @@ -1005,9 +1003,8 @@ declare 280 generic { # version into the new one). declare 281 generic { - Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, \ - Tcl_ChannelType *typePtr, ClientData instanceData, \ - int mask, Tcl_Channel prevChan) + Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, Tcl_ChannelType *typePtr, + ClientData instanceData, int mask, Tcl_Channel prevChan) } declare 282 generic { int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan) @@ -1047,7 +1044,7 @@ declare 291 generic { int Tcl_EvalEx(Tcl_Interp *interp, char *script, int numBytes, int flags) } declare 292 generic { - int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ + int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) } declare 293 generic { @@ -1057,13 +1054,13 @@ declare 294 generic { void Tcl_ExitThread(int status) } declare 295 generic { - int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, \ - CONST char *src, int srcLen, int flags, \ - Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 296 generic { - char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, \ + char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, CONST char *src, int srcLen, Tcl_DString *dsPtr) } declare 297 generic { @@ -1088,15 +1085,15 @@ declare 303 generic { void Tcl_GetEncodingNames(Tcl_Interp *interp) } declare 304 generic { - int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, \ - CONST char **tablePtr, int offset, CONST char *msg, int flags, \ + int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, + CONST char **tablePtr, int offset, CONST char *msg, int flags, int *indexPtr) } declare 305 generic { VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) } declare 306 generic { - Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ + Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, int flags) } declare 307 generic { @@ -1112,14 +1109,14 @@ declare 310 generic { void Tcl_ConditionNotify(Tcl_Condition *condPtr) } declare 311 generic { - void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, \ + void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr) } declare 312 generic { int Tcl_NumUtfChars(CONST char *src, int len) } declare 313 generic { - int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, \ + int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag) } declare 314 generic { @@ -1132,14 +1129,14 @@ declare 316 generic { int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name) } declare 317 generic { - Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ + Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, Tcl_Obj *newValuePtr, int flags) } declare 318 generic { void Tcl_ThreadAlert(Tcl_ThreadId threadId) } declare 319 generic { - void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, \ + void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position) } declare 320 generic { @@ -1179,13 +1176,13 @@ declare 331 generic { CONST char * Tcl_UtfPrev(CONST char *src, CONST char *start) } declare 332 generic { - int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, \ - CONST char *src, int srcLen, int flags, \ - Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 333 generic { - char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, \ + char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, CONST char *src, int srcLen, Tcl_DString *dsPtr) } declare 334 generic { @@ -1246,51 +1243,52 @@ declare 352 generic { int Tcl_UniCharLen(CONST Tcl_UniChar *str) } declare 353 generic { - int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,\ - unsigned long n) + int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct, + unsigned long n) } declare 354 generic { - char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, \ + char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, int numChars, Tcl_DString *dsPtr) } declare 355 generic { - Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, \ + Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, int length, Tcl_DString *dsPtr) } declare 356 generic { - Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) + Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, + int flags) } declare 357 generic { - Tcl_Obj *Tcl_EvalTokens (Tcl_Interp *interp, Tcl_Token *tokenPtr, \ + Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) } declare 358 generic { - void Tcl_FreeParse (Tcl_Parse *parsePtr) + void Tcl_FreeParse(Tcl_Parse *parsePtr) } declare 359 generic { - void Tcl_LogCommandInfo (Tcl_Interp *interp, CONST char *script, \ + void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script, CONST char *command, int length) } declare 360 generic { - int Tcl_ParseBraces (Tcl_Interp *interp, char *string, \ + int Tcl_ParseBraces(Tcl_Interp *interp, char *string, int numBytes, Tcl_Parse *parsePtr, int append, char **termPtr) } declare 361 generic { - int Tcl_ParseCommand (Tcl_Interp *interp, char *string, int numBytes, \ + int Tcl_ParseCommand(Tcl_Interp *interp, char *string, int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 generic { - int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes, \ + int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes, Tcl_Parse *parsePtr) } declare 363 generic { - int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes, \ + int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes, Tcl_Parse *parsePtr, int append, char **termPtr) } declare 364 generic { - int Tcl_ParseVarName (Tcl_Interp *interp, char *string, \ - int numBytes, Tcl_Parse *parsePtr, int append) + int Tcl_ParseVarName(Tcl_Interp *interp, char *string, int numBytes, + Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat @@ -1328,7 +1326,7 @@ declare 375 generic { int Tcl_UniCharIsPunct(int ch) } declare 376 generic { - int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, \ + int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *objPtr, int offset, int nmatches, int flags) } declare 377 generic { @@ -1339,26 +1337,26 @@ declare 378 generic { } declare 379 generic { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, - int numChars) + int numChars) } declare 380 generic { - int Tcl_GetCharLength (Tcl_Obj *objPtr) + int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 generic { - Tcl_UniChar Tcl_GetUniChar (Tcl_Obj *objPtr, int index) + Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } declare 382 generic { - Tcl_UniChar * Tcl_GetUnicode (Tcl_Obj *objPtr) + Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 generic { - Tcl_Obj * Tcl_GetRange (Tcl_Obj *objPtr, int first, int last) + Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 generic { - void Tcl_AppendUnicodeToObj (Tcl_Obj *objPtr, - CONST Tcl_UniChar *unicode, int length) + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, + int length) } declare 385 generic { - int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj, \ + int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Obj *patternObj) } declare 386 generic { @@ -1374,32 +1372,32 @@ declare 389 generic { int Tcl_GetChannelNamesEx(Tcl_Interp *interp, CONST char *pattern) } declare 390 generic { - int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp, \ + int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 391 generic { - void Tcl_ConditionFinalize (Tcl_Condition *condPtr) + void Tcl_ConditionFinalize(Tcl_Condition *condPtr) } declare 392 generic { - void Tcl_MutexFinalize (Tcl_Mutex *mutex) + void Tcl_MutexFinalize(Tcl_Mutex *mutex) } declare 393 generic { - int Tcl_CreateThread (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, \ + int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags) } # Introduced in 8.3.2 declare 394 generic { - int Tcl_ReadRaw (Tcl_Channel chan, char *dst, int bytesToRead) + int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead) } declare 395 generic { - int Tcl_WriteRaw (Tcl_Channel chan, CONST char *src, int srcLen) + int Tcl_WriteRaw(Tcl_Channel chan, CONST char *src, int srcLen) } declare 396 generic { - Tcl_Channel Tcl_GetTopChannel (Tcl_Channel chan) + Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan) } declare 397 generic { - int Tcl_ChannelBuffered (Tcl_Channel chan) + int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 generic { CONST char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr) @@ -1408,7 +1406,7 @@ declare 399 generic { Tcl_ChannelTypeVersion Tcl_ChannelVersion(Tcl_ChannelType *chanTypePtr) } declare 400 generic { - Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType \ + Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType *chanTypePtr) } declare 401 generic { @@ -1427,72 +1425,71 @@ declare 405 generic { Tcl_DriverSeekProc * Tcl_ChannelSeekProc(Tcl_ChannelType *chanTypePtr) } declare 406 generic { - Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(Tcl_ChannelType \ + Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(Tcl_ChannelType *chanTypePtr) } declare 407 generic { - Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(Tcl_ChannelType \ + Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(Tcl_ChannelType *chanTypePtr) } declare 408 generic { Tcl_DriverWatchProc * Tcl_ChannelWatchProc(Tcl_ChannelType *chanTypePtr) } declare 409 generic { - Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(Tcl_ChannelType \ + Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(Tcl_ChannelType *chanTypePtr) } declare 410 generic { Tcl_DriverFlushProc * Tcl_ChannelFlushProc(Tcl_ChannelType *chanTypePtr) } declare 411 generic { - Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType \ + Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType *chanTypePtr) } # Introduced in 8.4a2 declare 412 generic { - int Tcl_JoinThread (Tcl_ThreadId id, int* result) + int Tcl_JoinThread(Tcl_ThreadId id, int* result) } declare 413 generic { - int Tcl_IsChannelShared (Tcl_Channel channel) + int Tcl_IsChannelShared(Tcl_Channel channel) } declare 414 generic { - int Tcl_IsChannelRegistered (Tcl_Interp* interp, Tcl_Channel channel) + int Tcl_IsChannelRegistered(Tcl_Interp* interp, Tcl_Channel channel) } declare 415 generic { - void Tcl_CutChannel (Tcl_Channel channel) + void Tcl_CutChannel(Tcl_Channel channel) } declare 416 generic { - void Tcl_SpliceChannel (Tcl_Channel channel) + void Tcl_SpliceChannel(Tcl_Channel channel) } declare 417 generic { - void Tcl_ClearChannelHandlers (Tcl_Channel channel) + void Tcl_ClearChannelHandlers(Tcl_Channel channel) } declare 418 generic { - int Tcl_IsChannelExisting (CONST char* channelName) + int Tcl_IsChannelExisting(CONST char* channelName) } declare 419 generic { - int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,\ + int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct, unsigned long n) } declare 420 generic { - int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *ustr, \ + int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *ustr, CONST Tcl_UniChar *pattern, int nocase) } declare 421 generic { - Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, \ - CONST char *key) + Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key) } declare 422 generic { - Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, \ + Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, CONST char *key, int *newPtr) } declare 423 generic { - void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, \ + void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, Tcl_HashKeyType *typePtr) } @@ -1500,15 +1497,16 @@ declare 424 generic { void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr) } declare 425 generic { - ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, CONST char *varName, \ - int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData) + ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, CONST char *varName, + int flags, Tcl_CommandTraceProc *procPtr, + ClientData prevClientData) } declare 426 generic { - int Tcl_TraceCommand(Tcl_Interp *interp, CONST char *varName, int flags, \ + int Tcl_TraceCommand(Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData) } declare 427 generic { - void Tcl_UntraceCommand(Tcl_Interp *interp, CONST char *varName, \ + void Tcl_UntraceCommand(Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData) } declare 428 generic { @@ -1532,12 +1530,12 @@ declare 433 generic { } # introduced in 8.4a3 declare 434 generic { - Tcl_UniChar * Tcl_GetUnicodeFromObj (Tcl_Obj *objPtr, int *lengthPtr) + Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 435 generic { - int Tcl_GetMathFuncInfo(Tcl_Interp *interp, CONST char *name, \ - int *numArgsPtr, Tcl_ValueType **argTypesPtr, \ - Tcl_MathProc **procPtr, ClientData *clientDataPtr) + int Tcl_GetMathFuncInfo(Tcl_Interp *interp, CONST char *name, + int *numArgsPtr, Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, ClientData *clientDataPtr) } declare 436 generic { Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, CONST char *pattern) @@ -1556,8 +1554,8 @@ declare 440 generic { int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) } declare 441 generic { - int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr, \ - Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) + int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) } declare 442 generic { int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr) @@ -1566,55 +1564,52 @@ declare 443 generic { int Tcl_FSDeleteFile(Tcl_Obj *pathPtr) } declare 444 generic { - int Tcl_FSLoadFile(Tcl_Interp * interp, \ - Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2, \ - Tcl_PackageInitProc ** proc1Ptr, \ - Tcl_PackageInitProc ** proc2Ptr, \ - ClientData * clientDataPtr, \ - Tcl_FSUnloadFileProc **unloadProcPtr) + int Tcl_FSLoadFile(Tcl_Interp * interp, + Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr, + Tcl_FSUnloadFileProc **unloadProcPtr) } declare 445 generic { - int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj * result, \ - Tcl_Obj *pathPtr, \ - CONST char * pattern, Tcl_GlobTypeData * types) + int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result, + Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types) } declare 446 generic { - Tcl_Obj* Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr) + Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr) } declare 447 generic { - int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, \ - int recursive, Tcl_Obj **errorPtr) + int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr) } declare 448 generic { int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) } declare 449 generic { - int Tcl_FSLstat(Tcl_Obj *pathPtr, struct stat *buf) + int Tcl_FSLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) } declare 450 generic { int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval) } declare 451 generic { - int Tcl_FSFileAttrsGet(Tcl_Interp *interp, \ - int index, Tcl_Obj *pathPtr, \ - Tcl_Obj **objPtrRef) + int Tcl_FSFileAttrsGet(Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 452 generic { - int Tcl_FSFileAttrsSet(Tcl_Interp *interp, \ - int index, Tcl_Obj *pathPtr, \ - Tcl_Obj *objPtr) + int Tcl_FSFileAttrsSet(Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr) } declare 453 generic { CONST char ** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 454 generic { - int Tcl_FSStat(Tcl_Obj *pathPtr, struct stat *buf) + int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) } declare 455 generic { int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode) } declare 456 generic { - Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, \ + Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *modeString, int permissions) } declare 457 generic { @@ -1639,10 +1634,12 @@ declare 463 generic { Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr) } declare 464 generic { - Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc, Tcl_Obj *CONST objv[]) + Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc, + Tcl_Obj *CONST objv[]) } declare 465 generic { - ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, Tcl_Filesystem *fsPtr) + ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, + Tcl_Filesystem *fsPtr) } declare 466 generic { Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) @@ -1651,7 +1648,8 @@ declare 467 generic { int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName) } declare 468 generic { - Tcl_Obj* Tcl_FSNewNativePath(Tcl_Obj* fromFilesystem, ClientData clientData) + Tcl_Obj* Tcl_FSNewNativePath(Tcl_Obj* fromFilesystem, + ClientData clientData) } declare 469 generic { CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr) @@ -1675,14 +1673,14 @@ declare 475 generic { ClientData Tcl_FSData(Tcl_Filesystem *fsPtr) } declare 476 generic { - CONST char* Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, \ + CONST char* Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) } declare 477 generic { Tcl_Filesystem* Tcl_FSGetFileSystemForPath(Tcl_Obj* pathObjPtr) } declare 478 generic { - Tcl_PathType Tcl_FSGetPathType (Tcl_Obj *pathObjPtr) + Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathObjPtr) } # New function due to TIP#49 declare 479 generic { @@ -1693,7 +1691,8 @@ declare 480 generic { } # New function due to TIP#56 declare 481 generic { - int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) + int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, + int count) } # New export due to TIP#73 @@ -1720,6 +1719,31 @@ declare 485 generic { CONST Tcl_CmdInfo* infoPtr ) } +### New functions on 64-bit dev branch ### +declare 486 generic { + Tcl_Obj * Tcl_DbNewWideIntObj(Tcl_WideInt wideValue, + CONST char *file, int line) +} +declare 487 generic { + int Tcl_GetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_WideInt *widePtr) +} +declare 488 generic { + Tcl_Obj * Tcl_NewWideIntObj(Tcl_WideInt wideValue) +} +declare 489 generic { + void Tcl_SetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt wideValue) +} +declare 490 generic { + Tcl_StatBuf * Tcl_AllocStatBuf(void) +} +declare 491 generic { + Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode) +} +declare 492 generic { + Tcl_WideInt Tcl_Tell(Tcl_Channel chan) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are @@ -1733,12 +1757,10 @@ interface tclPlat # Added in Tcl 8.1 declare 0 win { - TCHAR * Tcl_WinUtfToTChar(CONST char *str, int len, \ - Tcl_DString *dsPtr) + TCHAR * Tcl_WinUtfToTChar(CONST char *str, int len, Tcl_DString *dsPtr) } declare 1 win { - char * Tcl_WinTCharToUtf(CONST TCHAR *str, int len, \ - Tcl_DString *dsPtr) + char * Tcl_WinTCharToUtf(CONST TCHAR *str, int len, Tcl_DString *dsPtr) } ################## @@ -1757,12 +1779,12 @@ declare 1 mac { char * Tcl_MacConvertTextResource(Handle resource) } declare 2 mac { - int Tcl_MacEvalResource(Tcl_Interp *interp, CONST char *resourceName, \ + int Tcl_MacEvalResource(Tcl_Interp *interp, CONST char *resourceName, int resourceNumber, CONST char *fileName) } declare 3 mac { - Handle Tcl_MacFindResource(Tcl_Interp *interp, long resourceType, \ - CONST char *resourceName, int resourceNumber, \ + Handle Tcl_MacFindResource(Tcl_Interp *interp, long resourceType, + CONST char *resourceName, int resourceNumber, CONST char *resFileRef, int * releaseIt) } @@ -1770,7 +1792,7 @@ declare 3 mac { # character type and creator codes). declare 4 mac { - int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, OSType *osTypePtr) } declare 5 mac { diff --git a/generic/tcl.h b/generic/tcl.h index d9526b7..421e289 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.114 2002/02/10 20:36:34 kennykb Exp $ + * RCS: @(#) $Id: tcl.h,v 1.115 2002/02/15 14:28:48 dkf Exp $ */ #ifndef _TCL @@ -57,7 +57,6 @@ extern "C" { * tools/tcl.wse.in (for windows installer) * tools/tclSplash.bmp (not patchlevel) */ - #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 4 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE @@ -174,13 +173,14 @@ extern "C" { * this file. Resource compilers don't like all the C stuff, like typedefs * and procedure declarations, that occur below. */ - #ifndef RESOURCE_INCLUDED + #ifndef BUFSIZ -#include <stdio.h> +# include <stdio.h> #endif + /* * Definitions that allow Tcl functions with variable numbers of * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS @@ -190,27 +190,25 @@ extern "C" { * string for use in the function definition. TCL_VARARGS_START * initializes the va_list data structure and returns the first argument. */ - #if defined(__STDC__) || defined(HAS_STDARG) # include <stdarg.h> - # define TCL_VARARGS(type, name) (type name, ...) # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #else # include <varargs.h> - # ifdef __cplusplus -# define TCL_VARARGS(type, name) (type name, ...) -# define TCL_VARARGS_DEF(type, name) (type va_alist, ...) +# define TCL_VARARGS(type, name) (type name, ...) +# define TCL_VARARGS_DEF(type, name) (type va_alist, ...) # else -# define TCL_VARARGS(type, name) () -# define TCL_VARARGS_DEF(type, name) (va_alist) +# define TCL_VARARGS(type, name) () +# define TCL_VARARGS_DEF(type, name) (va_alist) # endif # define TCL_VARARGS_START(type, name, list) \ (va_start(list), va_arg(list, type)) #endif + /* * Macros used to declare a function to be exported by a DLL. * Used by Windows, maps to no-op declarations on non-Windows systems. @@ -247,23 +245,22 @@ extern "C" { * storage class will be set to DLLEXPORT. At the end of the header file, the * storage class will be reset to DLLIMPORT. */ - #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT +# define TCL_STORAGE_CLASS DLLEXPORT #else -# ifdef USE_TCL_STUBS -# define TCL_STORAGE_CLASS -# else -# define TCL_STORAGE_CLASS DLLIMPORT -# endif +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif #endif + /* * Definitions that allow this header file to be used either with or * without ANSI C features like function prototypes. */ - #undef _ANSI_ARGS_ #undef CONST #ifndef INLINE @@ -285,11 +282,12 @@ extern "C" { # define CONST84 CONST #endif + /* * Make sure EXTERN isn't defined elsewhere */ #ifdef EXTERN -#undef EXTERN +# undef EXTERN #endif /* EXTERN */ #ifdef __cplusplus @@ -298,57 +296,139 @@ extern "C" { # define EXTERN extern TCL_STORAGE_CLASS #endif + /* * Macro to use instead of "void" for arguments that must have * type "void *" in ANSI C; maps them to type "char *" in * non-ANSI systems. */ #ifndef __WIN32__ -#ifndef VOID -# ifdef __STDC__ -# define VOID void -# else -# define VOID char +# ifndef VOID +# ifdef __STDC__ +# define VOID void +# else +# define VOID char +# endif # endif -#endif #else /* __WIN32__ */ /* * The following code is copied from winnt.h */ -#ifndef VOID -#define VOID void +# ifndef VOID +# define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; -#endif +# endif #endif /* __WIN32__ */ + /* * Miscellaneous declarations. */ - #ifndef NULL -#define NULL 0 +# define NULL 0 #endif #ifndef _CLIENTDATA # if defined(__STDC__) || defined(__cplusplus) || defined(__BORLANDC__) - typedef void *ClientData; +typedef void *ClientData; # else - typedef int *ClientData; +typedef int *ClientData; # endif /* __STDC__ */ -#define _CLIENTDATA +# define _CLIENTDATA #endif + +/* + * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, + * and define Tcl_WideUInt to be the unsigned variant of that type + * (assuming that where we have one, we can have the other.) + * + * At the moment, this only works on Unix systems anyway... + * + * Also defines the following macros: + * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on + * a real 64-bit system.) + * Tcl_WideAsLong - forgetful converter from wideInt to long. + * Tcl_LongAsWide - sign-extending converter from long to wideInt. + * Tcl_WideAsDouble - converter from wideInt to double. + * Tcl_DoubleAsWide - converter from double to wideInt. + * + * The following invariant should hold for any long value 'longVal': + * longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal)) + * + * Note on converting between Tcl_WideInt and strings. This + * implementation (in tclObj.c) depends on the functions strtoull() + * and, where sprintf(...,"%lld",...) does not work, lltostr(). + * Although strtoull() is fairly straight-forward, lltostr() is a most + * unusual function on Solaris8 (taking its operating buffer + * backwards) so any changes you make will need to be done + * cautiously... + */ +#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) +# ifdef __WIN32__ +# define TCL_WIDE_INT_TYPE __int64 +# ifdef __BORLANDC__ +typedef struct stati64 Tcl_StatBuf; +# define TCL_LL_MODIFIER "L" +# define TCL_LL_MODIFIER_SIZE 1 +# else /* __BORLANDC__ */ +typedef struct _stati64 Tcl_StatBuf; +# define TCL_LL_MODIFIER "I64" +# define TCL_LL_MODIFIER_SIZE 3 +# endif /* __BORLANDC__ */ +# else /* __WIN32__ */ +/* + * Don't know what platform it is and configure hasn't been run! Assume + * it has no long long... + */ +# define TCL_WIDE_INT_IS_LONG 1 +# endif /* __WIN32__ */ +#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ +#ifdef TCL_WIDE_INT_IS_LONG +# undef TCL_WIDE_INT_TYPE +# define TCL_WIDE_INT_TYPE long +#endif /* TCL_WIDE_INT_IS_LONG */ + +typedef TCL_WIDE_INT_TYPE Tcl_WideInt; +typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; + +#ifdef TCL_WIDE_INT_IS_LONG +# include <sys/types.h> +typedef struct stat Tcl_StatBuf; +# define Tcl_WideAsLong(val) ((long)(val)) +# define Tcl_LongAsWide(val) ((long)(val)) +# define Tcl_WideAsDouble(val) ((double)((long)(val))) +# define Tcl_DoubleAsWide(val) ((long)((double)(val))) +#else /* TCL_WIDE_INT_IS_LONG */ +# ifndef __WIN32__ +# include <sys/types.h> +# ifdef HAVE_STRUCT_STAT64 +typedef struct stat64 Tcl_StatBuf; +# else +typedef struct stat Tcl_StatBuf; +# endif /* HAVE_STRUCT_STAT64 */ +# define TCL_LL_MODIFIER "ll" +# define TCL_LL_MODIFIER_SIZE 2 +# endif /* !__WIN32__ */ +# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) +# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) +# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) +# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) +#endif /* TCL_WIDE_INT_IS_LONG */ + + /* * This flag controls whether binary compatability is maintained with * extensions built against a previous version of Tcl. This is true * by default. */ #ifndef TCL_PRESERVE_BINARY_COMPATABILITY -#define TCL_PRESERVE_BINARY_COMPATABILITY 1 +# define TCL_PRESERVE_BINARY_COMPATABILITY 1 #endif - + + /* * Data structures defined opaquely in this module. The definitions below * just provide dummy types. A few fields are made visible in Tcl_Interp @@ -401,13 +481,13 @@ typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; + /* * Definition of the interface to procedures implementing threads. * A procedure following this definition is given to each call of * 'Tcl_CreateThread' and will be called as the main fuction of * the new thread created by that call. */ - #ifdef MAC_TCL typedef pascal void *(Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #elif defined __WIN32__ @@ -434,12 +514,10 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #endif - /* * Definition of values for default stacksize and the possible flags to be * given to Tcl_CreateThread. */ - #define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack */ #define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */ #define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */ @@ -447,7 +525,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); /* * Flag values passed to Tcl_GetRegExpFromObj. */ - #define TCL_REG_BASIC 000000 /* BREs (convenience) */ #define TCL_REG_EXTENDED 000001 /* EREs */ #define TCL_REG_ADVF 000002 /* advanced features in EREs */ @@ -467,7 +544,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); * The following flag is experimental and only intended for use by Expect. It * will probably go away in a later release. */ - #define TCL_REG_BOSONLY 002000 /* prepend \A to pattern so it only * matches at the beginning of the * string. */ @@ -475,7 +551,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); /* * Flags values passed to Tcl_RegExpExecObj. */ - #define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */ #define TCL_REG_NOTEOL 0002 /* End of string does not match $. */ @@ -484,7 +559,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); * relative to the start of the match string, not the beginning of the * entire string. */ - typedef struct Tcl_RegExpIndices { long start; /* character offset of first character in match */ long end; /* character offset of first character after the @@ -505,8 +579,8 @@ typedef struct Tcl_RegExpInfo { * Picky compilers complain if this typdef doesn't appear before the * struct's reference in tclDecls.h. */ - -typedef struct stat *Tcl_Stat_; +typedef Tcl_StatBuf *Tcl_Stat_; +typedef struct stat *Tcl_OldStat_; /* * When a TCL command returns, the interpreter contains a result from the @@ -528,7 +602,6 @@ typedef struct stat *Tcl_Stat_; * TCL_CONTINUE Go on to the next iteration of the current loop; * the interpreter's result is meaningless. */ - #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 @@ -540,22 +613,29 @@ typedef struct stat *Tcl_Stat_; /* * Flags to control what substitutions are performed by Tcl_SubstObj(): */ - #define TCL_SUBST_COMMANDS 001 #define TCL_SUBST_VARIABLES 002 #define TCL_SUBST_BACKSLASHES 004 #define TCL_SUBST_ALL 007 + /* * Argument descriptors for math function callbacks in expressions: */ - -typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} Tcl_ValueType; +typedef enum { + TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT +#ifdef TCL_WIDE_INT_IS_LONG + = TCL_INT +#endif +} Tcl_ValueType; typedef struct Tcl_Value { Tcl_ValueType type; /* Indicates intValue or doubleValue is * valid, or both. */ long intValue; /* Integer value. */ double doubleValue; /* Double-precision floating value. */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ +#endif } Tcl_Value; /* @@ -563,9 +643,9 @@ typedef struct Tcl_Value { * reference to Tcl_Obj is encountered in the procedure types declared * below. */ - struct Tcl_Obj; + /* * Procedure types defined by Tcl: */ @@ -635,6 +715,7 @@ typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask, typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd)); typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void)); + /* * The following structure represents a type of object, which is a * particular internal representation for an object plus a set of @@ -660,6 +741,7 @@ typedef struct Tcl_ObjType { * failure. */ } Tcl_ObjType; + /* * One of the following structures exists for each object in the Tcl * system. An object stores a value as either a string, some internal @@ -689,6 +771,7 @@ typedef struct Tcl_Obj { long longValue; /* - an long integer value */ double doubleValue; /* - a double-precision floating value */ VOID *otherValuePtr; /* - another, type-specific value */ + Tcl_WideInt wideValue; /* - a long long value */ struct { /* - internal rep as two pointers */ VOID *ptr1; VOID *ptr2; @@ -696,6 +779,7 @@ typedef struct Tcl_Obj { } internalRep; } Tcl_Obj; + /* * Macros to increment and decrement a Tcl_Obj's reference count, and to * test whether an object is shared (i.e. has reference count > 1). @@ -706,7 +790,6 @@ typedef struct Tcl_Obj { * "obj" twice. This means that you should avoid calling it with an * expression that is expensive to compute or has side effects. */ - void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); @@ -750,14 +833,16 @@ int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); Tcl_DbNewObj(__FILE__, __LINE__) # define Tcl_NewStringObj(bytes, len) \ Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) +# define Tcl_NewWideIntObj(val) \ + Tcl_DbNewWideIntObj(val, __FILE__, __LINE__) #endif /* TCL_MEM_DEBUG */ + /* * The following structure contains the state needed by * Tcl_SaveResult. No-one outside of Tcl should access any of these * fields. This structure is typically allocated on the stack. */ - typedef struct Tcl_SavedResult { char *result; Tcl_FreeProc *freeProc; @@ -793,6 +878,7 @@ typedef struct Tcl_Namespace { * namespace. */ } Tcl_Namespace; + /* * The following structure represents a call frame, or activation record. * A call frame defines a naming context for a procedure call: its local @@ -829,6 +915,7 @@ typedef struct Tcl_CallFrame { char* dummy10; } Tcl_CallFrame; + /* * Information about commands that is returned by Tcl_GetCommandInfo and * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based @@ -843,7 +930,7 @@ typedef struct Tcl_CallFrame { * does string-to-object or object-to-string argument conversions then * calls the other procedure. */ - + typedef struct Tcl_CmdInfo { int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 0 otherwise. @@ -870,7 +957,6 @@ typedef struct Tcl_CmdInfo { * field that clients should use is the string field, accessible via the * macro Tcl_DStringValue. */ - #define TCL_DSTRING_STATIC_SIZE 200 typedef struct Tcl_DString { char *string; /* Points to beginning of string: either @@ -893,7 +979,6 @@ typedef struct Tcl_DString { * be specified in the "tcl_precision" variable, and the number of * bytes of buffer space required by Tcl_PrintDouble. */ - #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) @@ -902,7 +987,6 @@ typedef struct Tcl_DString { * string representation of an integer in base 10 (assuming the existence * of 64-bit integers). */ - #define TCL_INTEGER_SPACE 24 /* @@ -910,14 +994,12 @@ typedef struct Tcl_DString { * output braces (careful! if you change this flag be sure to change * the definitions at the front of tclUtil.c). */ - #define TCL_DONT_USE_BRACES 1 /* * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow * abbreviated strings. */ - #define TCL_EXACT 1 /* @@ -925,7 +1007,6 @@ typedef struct Tcl_DString { * WARNING: these bit choices must not conflict with the bit choices * for evalFlag bits in tclInt.h!! */ - #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 @@ -934,7 +1015,6 @@ typedef struct Tcl_DString { * Special freeProc values that may be passed to Tcl_SetResult (see * the man page for details): */ - #define TCL_VOLATILE ((Tcl_FreeProc *) 1) #define TCL_STATIC ((Tcl_FreeProc *) 0) #define TCL_DYNAMIC ((Tcl_FreeProc *) 3) @@ -942,7 +1022,6 @@ typedef struct Tcl_DString { /* * Flag values passed to variable-related procedures. */ - #define TCL_GLOBAL_ONLY 1 #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 @@ -979,28 +1058,28 @@ typedef struct Tcl_DString { * flag) */ #ifndef TCL_NO_DEPRECATED -#define TCL_PARSE_PART1 0x400 +# define TCL_PARSE_PART1 0x400 #endif /* * Types for linked variables: */ - #define TCL_LINK_INT 1 #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 #define TCL_LINK_STRING 4 +#define TCL_LINK_WIDE_INT 5 #define TCL_LINK_READ_ONLY 0x80 + /* * Forward declarations of Tcl_HashTable and related types. */ - typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; - + typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, VOID *keyPtr)); typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr, @@ -1017,7 +1096,7 @@ typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr)); * member has been removed and the space used to store the hash value. */ #ifndef TCL_HASH_KEY_STORE_HASH -#define TCL_HASH_KEY_STORE_HASH 1 +# define TCL_HASH_KEY_STORE_HASH 1 #endif /* @@ -1072,7 +1151,7 @@ struct Tcl_HashEntry { * N bits as the index into the table. */ #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1 - + /* * Structure definition for the methods associated with a hash table * key type. @@ -1086,7 +1165,7 @@ struct Tcl_HashKeyType { */ int flags; /* Flags, see above for details. */ - + /* Calculates a hash value for the key. If this is NULL then the pointer * itself is used as a hash value. */ @@ -1115,7 +1194,7 @@ struct Tcl_HashKeyType { */ Tcl_FreeHashEntryProc *freeEntryProc; }; - + /* * Structure definition for a hash table. Must be in tcl.h so clients * can allocate space for these structures, but clients should never @@ -1232,21 +1311,19 @@ typedef struct Tcl_HashSearch { (*((tablePtr)->findProc))(tablePtr, key) # define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, key, newPtr) -#endif - -#if !TCL_PRESERVE_BINARY_COMPATABILITY +#else /* !TCL_PRESERVE_BINARY_COMPATABILITY */ /* * Macro to use new extended version of Tcl_InitHashTable. */ -#define Tcl_InitHashTable(tablePtr, keyType) \ +# define Tcl_InitHashTable(tablePtr, keyType) \ Tcl_InitHashTableEx(tablePtr, keyType, NULL) -#endif +#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */ + /* * Flag values to pass to Tcl_DoOneEvent to disable searches * for some kinds of events: */ - #define TCL_DONT_WAIT (1<<1) #define TCL_WINDOW_EVENTS (1<<2) #define TCL_FILE_EVENTS (1<<3) @@ -1263,7 +1340,6 @@ typedef struct Tcl_HashSearch { * a Tcl_Event header followed by additional information specific to that * event. */ - struct Tcl_Event { Tcl_EventProc *proc; /* Procedure to call to service this event. */ struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */ @@ -1272,7 +1348,6 @@ struct Tcl_Event { /* * Positions to pass to Tcl_QueueEvent: */ - typedef enum { TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK } Tcl_QueuePosition; @@ -1281,17 +1356,16 @@ typedef enum { * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ - #define TCL_SERVICE_NONE 0 #define TCL_SERVICE_ALL 1 + /* * The following structure keeps is used to hold a time value, either as * an absolute time (the number of seconds from the epoch) or as an * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT. * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT. */ - typedef struct Tcl_Time { long sec; /* Seconds. */ long usec; /* Microseconds. */ @@ -1300,11 +1374,11 @@ typedef struct Tcl_Time { typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr)); typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); + /* * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler * to indicate what sorts of events are of interest: */ - #define TCL_READABLE (1<<1) #define TCL_WRITABLE (1<<2) #define TCL_EXCEPTION (1<<3) @@ -1314,7 +1388,6 @@ typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, * are also used in Tcl_GetStdChannel. */ - #define TCL_STDIN (1<<1) #define TCL_STDOUT (1<<2) #define TCL_STDERR (1<<3) @@ -1324,7 +1397,6 @@ typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel * should be closed. */ - #define TCL_CLOSE_READ (1<<1) #define TCL_CLOSE_WRITE (1<<2) @@ -1332,20 +1404,18 @@ typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); * Value to use as the closeProc for a channel that supports the * close2Proc interface. */ - #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ - #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) + /* * Typedefs for the various operations in a channel type: */ - typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( ClientData instanceData, int mode)); typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, @@ -1356,8 +1426,8 @@ typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCodePtr)); typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, CONST84 char *buf, int toWrite, int *errorCodePtr)); -typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, - long offset, int mode, int *errorCodePtr)); +typedef Tcl_WideInt (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_WideInt offset, int mode, int *errorCodePtr)); typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, CONST char *value)); @@ -1374,12 +1444,12 @@ typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_(( typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( ClientData instanceData, int interestMask)); + /* * The following declarations either map ckalloc and ckfree to * malloc and free, or they map them to procedures with all sorts * of debugging hooks defined in tclCkalloc.c. */ - #ifdef TCL_MEM_DEBUG # define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) @@ -1395,7 +1465,6 @@ typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( * is using the same memory allocator both inside and outside of the * Tcl library. */ - # define ckalloc(x) Tcl_Alloc(x) # define ckfree(x) Tcl_Free(x) # define ckrealloc(x,y) Tcl_Realloc(x,y) @@ -1417,7 +1486,6 @@ typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( * It is recommend that the Tcl_Channel* functions are used to access * elements of this structure, instead of direct accessing. */ - typedef struct Tcl_ChannelType { char *typeName; /* The name of the channel type in Tcl * commands. This storage is owned by @@ -1464,7 +1532,6 @@ typedef struct Tcl_ChannelType { * set the channel into blocking or nonblocking mode. They are passed * as arguments to the blockModeProc procedure in the above structure. */ - #define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ #define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking * mode. */ @@ -1472,13 +1539,13 @@ typedef struct Tcl_ChannelType { /* * Enum for different types of file paths. */ - typedef enum Tcl_PathType { TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, TCL_PATH_VOLUME_RELATIVE } Tcl_PathType; + /* * The following structure is used to pass glob type data amongst * the various glob routines and Tcl_FSMatchInDirectory. @@ -1511,11 +1578,11 @@ typedef struct Tcl_GlobTypeData { #define TCL_GLOB_PERM_W (1<<3) #define TCL_GLOB_PERM_X (1<<4) + /* * Typedefs for the various filesystem operations: */ - -typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); +typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -1526,7 +1593,7 @@ typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - struct stat *buf)); + Tcl_StatBuf *buf)); typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, @@ -1586,7 +1653,6 @@ typedef struct Tcl_FSVersion_ *Tcl_FSVersion; /* * Filesystem version tag. This was introduced in 8.4. */ - #define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1) /* @@ -1774,11 +1840,11 @@ typedef struct Tcl_Filesystem { */ } Tcl_Filesystem; + /* * The following structure represents the Notifier functions that * you can override with the Tcl_SetNotifier call. */ - typedef struct Tcl_NotifierProcs { Tcl_SetTimerProc *setTimerProc; Tcl_WaitForEventProc *waitForEventProc; @@ -1786,11 +1852,11 @@ typedef struct Tcl_NotifierProcs { Tcl_DeleteFileHandlerProc *deleteFileHandlerProc; } Tcl_NotifierProcs; + /* * The following structure represents a user-defined encoding. It collects * together all the functions that are used by the specific encoding. */ - typedef struct Tcl_EncodingType { CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". * This name is the unique key for this @@ -1844,16 +1910,14 @@ typedef struct Tcl_EncodingType { * in the destination buffer and then continue * to sonvert the source. */ - #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 #define TCL_ENCODING_STOPONERROR 0x04 + /* - *---------------------------------------------------------------- - * The following data structures and declarations are for the new - * Tcl parser. This stuff should all move to tcl.h eventually. - *---------------------------------------------------------------- + * The following data structures and declarations are for the new Tcl + * parser. */ /* @@ -1861,7 +1925,6 @@ typedef struct Tcl_EncodingType { * variable reference, one of the following structures is created to * describe the token. */ - typedef struct Tcl_Token { int type; /* Type of token, such as TCL_TOKEN_WORD; * see below for valid types. */ @@ -1947,7 +2010,6 @@ typedef struct Tcl_Token { * operator's operands. NumComponents is * always 0. */ - #define TCL_TOKEN_WORD 1 #define TCL_TOKEN_SIMPLE_WORD 2 #define TCL_TOKEN_TEXT 4 @@ -1962,7 +2024,6 @@ typedef struct Tcl_Token { * will be stored in the error field of the Tcl_Parse structure * defined below. */ - #define TCL_PARSE_SUCCESS 0 #define TCL_PARSE_QUOTE_EXTRA 1 #define TCL_PARSE_BRACE_EXTRA 2 @@ -1978,7 +2039,6 @@ typedef struct Tcl_Token { * A structure of the following type is filled in by Tcl_ParseCommand. * It describes a single command parsed from an input string. */ - #define NUM_STATIC_TOKENS 20 typedef struct Tcl_Parse { @@ -2068,41 +2128,40 @@ typedef struct Tcl_Parse { * encoding. This error is reported only if * TCL_ENCODING_STOPONERROR was specified. */ - #define TCL_CONVERT_MULTIBYTE -1 #define TCL_CONVERT_SYNTAX -2 #define TCL_CONVERT_UNKNOWN -3 #define TCL_CONVERT_NOSPACE -4 + /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. */ - #define TCL_UTF_MAX 3 /* * This represents a Unicode character. Any changes to this should * also be reflected in regcustom.h. */ - typedef unsigned short Tcl_UniChar; + /* * Deprecated Tcl procedures: */ - #ifndef TCL_NO_DEPRECATED -#define Tcl_EvalObj(interp,objPtr) Tcl_EvalObjEx((interp),(objPtr),0) -#define Tcl_GlobalEvalObj(interp,objPtr) \ +# define Tcl_EvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),0) +# define Tcl_GlobalEvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) #endif + /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibilty. */ - #define Tcl_Ckalloc Tcl_Alloc #define Tcl_Ckfree Tcl_Free #define Tcl_Ckrealloc Tcl_Realloc @@ -2111,6 +2170,7 @@ typedef unsigned short Tcl_UniChar; #define panic Tcl_Panic #define panicVA Tcl_PanicVA + /* * The following constant is used to test for older versions of Tcl * in the stubs tables. @@ -2183,7 +2243,6 @@ EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, * This function is not *implemented* by the tcl library, so the storage * class is neither DLLEXPORT nor DLLIMPORT */ - #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS @@ -2197,9 +2256,8 @@ EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); /* * end block for C++ */ - #ifdef __cplusplus } #endif - + #endif /* _TCL */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d9765a0..814b4a5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.46 2002/02/10 20:36:34 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.47 2002/02/15 14:28:48 dkf Exp $ */ #include "tclInt.h" @@ -541,6 +541,9 @@ Tcl_CreateInterp() ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", + Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); + /* * Set up other variables such as tcl_version and tcl_library */ diff --git a/generic/tclBinary.c b/generic/tclBinary.c index f2d9327..c8ff568 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -10,12 +10,12 @@ * 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.11 2002/01/17 04:37:33 dgp Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.12 2002/02/15 14:28:48 dkf Exp $ */ -#include <math.h> #include "tclInt.h" #include "tclPort.h" +#include <math.h> /* * The following constants are used by GetFormatSpec to indicate various @@ -665,6 +665,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) size = 4; goto doNumbers; } + case 'w': + case 'W': { + size = 8; + goto doNumbers; + } case 'f': { size = sizeof(float); goto doNumbers; @@ -945,6 +950,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'S': case 'i': case 'I': + case 'w': + case 'W': case 'd': case 'f': { int listc, i; @@ -1222,6 +1229,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) size = 4; goto scanNumber; } + case 'w': + case 'W': { + size = 8; + goto scanNumber; + } case 'f': { size = sizeof(float); goto scanNumber; @@ -1455,8 +1467,11 @@ FormatNumber(interp, type, src, cursorPtr) { long value; double dvalue; + Tcl_WideInt wvalue; - if ((type == 'd') || (type == 'f')) { + switch (type) { + case 'd': + case 'f': /* * For floating point types, we need to copy the data using * memcpy to avoid alignment issues. @@ -1485,7 +1500,38 @@ FormatNumber(interp, type, src, cursorPtr) memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float)); *cursorPtr += sizeof(float); } - } else { + 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; } @@ -1508,8 +1554,8 @@ FormatNumber(interp, type, src, cursorPtr) *(*cursorPtr)++ = (unsigned char) (value >> 8); *(*cursorPtr)++ = (unsigned char) value; } + return TCL_OK; } - return TCL_OK; } /* @@ -1542,6 +1588,7 @@ ScanNumber(buffer, type, numberCachePtrPtr) * different numbers have been scanned. */ { long value; + Tcl_WideInt wvalue; /* * We cannot rely on the compiler to properly sign extend integer values @@ -1630,7 +1677,26 @@ ScanNumber(buffer, type, numberCachePtrPtr) return objPtr; } } - + case 'w': + value = (long) (buffer[4] + | (buffer[5] << 8) + | (buffer[6] << 16) + | (buffer[7] << 24)); + wvalue = ((Tcl_WideInt) value) << 32 | (buffer[0] + | (buffer[1] << 8) + | (buffer[2] << 16) + | (buffer[3] << 24)); + return Tcl_NewWideIntObj(wvalue); + case 'W': + value = (long) (buffer[3] + | (buffer[2] << 8) + | (buffer[1] << 16) + | (buffer[0] << 24)); + wvalue = ((Tcl_WideInt) value) << 32 | (buffer[7] + | (buffer[6] << 8) + | (buffer[5] << 16) + | (buffer[4] << 24)); + return Tcl_NewWideIntObj(wvalue); case 'f': { float fvalue; memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float)); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6771374..d6c3ba7 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.20 2002/01/26 01:10:08 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.21 2002/02/15 14:28:48 dkf Exp $ */ #include "tclInt.h" @@ -26,10 +26,10 @@ static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int mode)); static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_FSStatProc *statProc, - struct stat *statPtr)); + Tcl_StatBuf *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, struct stat *statPtr)); + char *varName, Tcl_StatBuf *statPtr)); /* *---------------------------------------------------------------------- @@ -93,9 +93,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { register int i; - int body, result; + int body, result, caseObjc; char *string, *arg; - int caseObjc; Tcl_Obj *CONST *caseObjv; Tcl_Obj *armPtr; @@ -725,6 +724,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) * Create a new object holding the concatenated argument strings. */ + /*** QUESTION: Do we need to copy the slow way? ***/ bytes = Tcl_GetStringFromObj(objv[1], &length); objPtr = Tcl_NewStringObj(bytes, length); Tcl_IncrRefCount(objPtr); @@ -824,7 +824,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) switch ((enum options) index) { case FILE_ATIME: { - struct stat buf; + Tcl_StatBuf buf; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { @@ -918,7 +918,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } case FILE_ISDIRECTORY: { int value; - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; @@ -932,7 +932,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } case FILE_ISFILE: { int value; - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; @@ -957,7 +957,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } case FILE_LSTAT: { char *varName; - struct stat buf; + Tcl_StatBuf buf; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "name varName"); @@ -970,7 +970,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return StoreStatData(interp, varName, &buf); } case FILE_MTIME: { - struct stat buf; + Tcl_StatBuf buf; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { @@ -1045,7 +1045,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } case FILE_OWNED: { int value; - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; @@ -1165,7 +1165,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_OK; } case FILE_SIZE: { - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; @@ -1173,7 +1173,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_size); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), buf.st_size); return TCL_OK; } case FILE_SPLIT: { @@ -1185,7 +1185,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } case FILE_STAT: { char *varName; - struct stat buf; + Tcl_StatBuf buf; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); @@ -1254,7 +1254,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_OK; } case FILE_TYPE: { - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; @@ -1351,7 +1351,7 @@ GetStatBuf(interp, objPtr, statProc, statPtr) Tcl_Obj *objPtr; /* Path name to examine. */ Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on * desired behavior. */ - struct stat *statPtr; /* Filled with info about file obtained by + Tcl_StatBuf *statPtr; /* Filled with info about file obtained by * calling (*statProc)(). */ { int status; @@ -1397,66 +1397,50 @@ StoreStatData(interp, varName, statPtr) Tcl_Interp *interp; /* Interpreter for error reports. */ char *varName; /* Name of associative array variable * in which to store stat results. */ - struct stat *statPtr; /* Pointer to buffer containing + Tcl_StatBuf *statPtr; /* Pointer to buffer containing * stat data to store in varName. */ { - char string[TCL_INTEGER_SPACE]; + Tcl_Obj *var = Tcl_NewStringObj(varName, -1); + Tcl_Obj *field = Tcl_NewObj(); + Tcl_Obj *value; + register unsigned short mode; - TclFormatInt(string, (long) statPtr->st_dev); - if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_ino); - if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (unsigned short) statPtr->st_mode); - if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_nlink); - if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_uid); - if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_gid); - if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%lu", (unsigned long) statPtr->st_size); - if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_atime); - if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_mtime); - if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_ctime); - if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - if (Tcl_SetVar2(interp, varName, "type", - GetTypeFromMode((unsigned short) statPtr->st_mode), - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } + /* + * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! + */ +#define STORE_ARY(fieldName, object) \ + Tcl_SetStringObj(field, (fieldName), -1); \ + value = (object); \ + if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \ + Tcl_DecrRefCount(var); \ + Tcl_DecrRefCount(field); \ + Tcl_DecrRefCount(value); \ + return TCL_ERROR; \ + } + + Tcl_IncrRefCount(var); + Tcl_IncrRefCount(field); + STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); + /* + * Watch out porters; the inode is meant to be an *unsigned* value, + * so the cast might fail when there isn't a real arithmentic 'long + * long' type... + */ + STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); + STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); + STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); + STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); + STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); +#ifdef HAVE_ST_BLOCKS + STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); +#endif + STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); + STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); + STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); + mode = (unsigned short) statPtr->st_mode; + STORE_ARY("mode", Tcl_NewIntObj(mode)); + STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); +#undef STORE_ARY return TCL_OK; } @@ -1635,17 +1619,17 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_Obj **argObjv = argObjStorage; #define STATIC_LIST_SIZE 4 - int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */ - int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */ - Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */ - int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */ - Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */ - - int *index = indexArray; - int *varcList = varcListArray; - Tcl_Obj ***varvList = varvListArray; - int *argcList = argcListArray; - Tcl_Obj ***argvList = argvListArray; + int indexArray[STATIC_LIST_SIZE]; + int varcListArray[STATIC_LIST_SIZE]; + Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; + int argcListArray[STATIC_LIST_SIZE]; + Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; + + int *index = indexArray; /* Array of value list indices */ + int *varcList = varcListArray; /* # loop variables per list */ + Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */ + int *argcList = argcListArray; /* Array of value list sizes */ + Tcl_Obj ***argvList = argvListArray; /* Array of value lists */ if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1844,9 +1828,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) { char *format; /* Used to read characters from the format * string. */ - int formatLen; /* The length of the format string */ + int formatLen; /* The length of the format string */ char *endPtr; /* Points to the last char in format array */ - char newFormat[40]; /* A new format specifier is generated here. */ + char newFormat[43]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ int precision; /* Field precision from field specifier, or 0 @@ -1860,6 +1844,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * it's a one-word value. */ double doubleValue; /* Used to hold value to pass to sprintf if * it's a double value. */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if + * it's a 'long long' value. */ +#endif /* TCL_WIDE_INT_IS_LONG */ int whichValue; /* Indicates which of intValue, ptrValue, * or doubleValue has the value to pass to * sprintf, according to the following @@ -1869,6 +1857,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) # define PTR_VALUE 2 # define DOUBLE_VALUE 3 # define STRING_VALUE 4 +# define WIDE_VALUE 5 # define MAX_FLOAT_SIZE 320 Tcl_Obj *resultPtr; /* Where result is stored finally. */ @@ -1897,6 +1886,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * been set for the current field. */ int gotZero; /* Non-zero indicates that a zero flag has * been seen in the current field. */ +#ifndef TCL_WIDE_INT_IS_LONG + int useWide; /* Value to be printed is Tcl_WideInt. */ +#endif /* TCL_WIDE_INT_IS_LONG */ /* * This procedure is a bit nasty. The goal is to use sprintf to @@ -1926,6 +1918,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) width = precision = noPercent = useShort = 0; gotZero = gotMinus = gotPrecision = 0; +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 0; +#endif /* TCL_WIDE_INT_IS_LONG */ whichValue = PTR_VALUE; /* @@ -2069,6 +2064,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } } if (*format == 'l') { +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 1; + strcpy(newPtr, TCL_LL_MODIFIER); + newPtr += TCL_LL_MODIFIER_SIZE; +#endif /* TCL_WIDE_INT_IS_LONG */ format++; } else if (*format == 'h') { useShort = 1; @@ -2090,7 +2090,18 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'u': case 'x': case 'X': - if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */ +#ifndef TCL_WIDE_INT_IS_LONG + if (useWide) { + if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &wideValue) != TCL_OK) { + goto fmtError; + } + whichValue = WIDE_VALUE; + size = 40 + precision; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } @@ -2187,6 +2198,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */ break; } +#ifndef TCL_WIDE_INT_IS_LONG + case WIDE_VALUE: { + sprintf(dst, newFormat, wideValue); + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ case INT_VALUE: { if (useShort) { sprintf(dst, newFormat, (short) intValue); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4a922fe..f7cdf29 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.40 2002/01/26 01:10:08 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.41 2002/02/15 14:28:48 dkf Exp $ */ #include "tclInt.h" @@ -323,10 +323,36 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) if (objc == 2) { incrAmount = 1; } else { +#ifdef TCL_WIDE_INT_IS_LONG if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } +#else + /* + * Need to be a bit cautious to ensure that [expr]-like rules + * are enforced for interpretation of wide integers, despite + * the fact that the underlying API itself is a 'long' only one. + */ + if (objv[2]->typePtr == &tclIntType) { + incrAmount = objv[2]->internalRep.longValue; + } else if (objv[2]->typePtr == &tclWideIntType) { + incrAmount = Tcl_WideAsLong(objv[2]->internalRep.wideValue); + } else { + Tcl_WideInt wide; + + if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + return TCL_ERROR; + } + incrAmount = Tcl_WideAsLong(wide); + if ((wide <= Tcl_LongAsWide(LONG_MAX)) + && (wide >= Tcl_LongAsWide(LONG_MIN))) { + objv[2]->typePtr = &tclIntType; + objv[2]->internalRep.longValue = incrAmount; + } + } +#endif } /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 204f1ae..af2e214 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.59 2002/02/08 02:52:54 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.60 2002/02/15 14:28:48 dkf Exp $ */ #include "tclInt.h" @@ -1572,7 +1572,11 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) */ if (TclLooksLikeInt(string1, length1)) { errno = 0; - strtoul(string1, &stop, 0); +#ifdef TCL_WIDE_INT_IS_LONG + strtoul(string1, &stop, 0); /* INTL: Tcl source. */ +#else + strtoull(string1, &stop, 0); /* INTL: Tcl source. */ +#endif if (stop == end) { if (errno == ERANGE) { result = 0; @@ -1626,7 +1630,11 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) */ result = 0; errno = 0; +#ifdef TCL_WIDE_INT_IS_LONG strtoul(string1, &stop, 0); /* INTL: Tcl source. */ +#else + strtoull(string1, &stop, 0); /* INTL: Tcl source. */ +#endif if (errno == ERANGE) { /* * if (errno == ERANGE), then it was an over/underflow diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1a44da8..e0bf175 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.24 2002/01/25 20:40:55 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.25 2002/02/15 14:28:48 dkf Exp $ */ #ifndef _TCLCOMPILATION @@ -513,6 +513,7 @@ typedef struct ByteCode { #define INST_LIST_INDEX 80 #define INST_LIST_LENGTH 81 +/* Opcodes 82 to 87 */ #define INST_APPEND_SCALAR1 82 #define INST_APPEND_SCALAR4 83 #define INST_APPEND_ARRAY1 84 @@ -520,6 +521,7 @@ typedef struct ByteCode { #define INST_APPEND_ARRAY_STK 86 #define INST_APPEND_STK 87 +/* Opcodes 88 to 93 */ #define INST_LAPPEND_SCALAR1 88 #define INST_LAPPEND_SCALAR4 89 #define INST_LAPPEND_ARRAY1 90 @@ -611,8 +613,9 @@ extern InstructionDesc instructionTable[]; #define BUILTIN_FUNC_RAND 22 #define BUILTIN_FUNC_ROUND 23 #define BUILTIN_FUNC_SRAND 24 +#define BUILTIN_FUNC_WIDE 25 -#define LAST_BUILTIN_FUNC 24 +#define LAST_BUILTIN_FUNC 25 /* * Table describing the built-in math functions. Entries in this table are diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 563805d..316da70 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.82 2002/02/10 20:36:34 kennykb Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.83 2002/02/15 14:28:48 dkf Exp $ */ #ifndef _TCLDECLS @@ -174,7 +174,7 @@ EXTERN int Tcl_ListObjIndex _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj ** objPtrPtr)); /* 47 */ EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * listPtr, int * intPtr)); + Tcl_Obj * listPtr, int * lengthPtr)); /* 48 */ EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int first, int count, @@ -717,8 +717,8 @@ EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * str, EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 220 */ -EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, int offset, - int mode)); +EXTERN int Tcl_SeekOld _ANSI_ARGS_((Tcl_Channel chan, + int offset, int mode)); /* 221 */ EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void)); /* 222 */ @@ -796,7 +796,7 @@ EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp, EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 246 */ -EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan)); /* 247 */ EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, @@ -1415,7 +1415,7 @@ EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_(( Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 446 */ -EXTERN Tcl_Obj* Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, +EXTERN Tcl_Obj * Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr)); /* 447 */ EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, @@ -1425,7 +1425,7 @@ EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 449 */ EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj * pathPtr, - struct stat * buf)); + Tcl_StatBuf * buf)); /* 450 */ EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); @@ -1442,7 +1442,7 @@ EXTERN CONST char ** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 454 */ EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj * pathPtr, - struct stat * buf)); + Tcl_StatBuf * buf)); /* 455 */ EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); @@ -1533,6 +1533,26 @@ EXTERN int Tcl_GetCommandInfoFromToken _ANSI_ARGS_(( EXTERN int Tcl_SetCommandInfoFromToken _ANSI_ARGS_(( Tcl_Command token, CONST Tcl_CmdInfo* infoPtr)); +/* 486 */ +EXTERN Tcl_Obj * Tcl_DbNewWideIntObj _ANSI_ARGS_(( + Tcl_WideInt wideValue, CONST char * file, + int line)); +/* 487 */ +EXTERN int Tcl_GetWideIntFromObj _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * objPtr, + Tcl_WideInt * widePtr)); +/* 488 */ +EXTERN Tcl_Obj * Tcl_NewWideIntObj _ANSI_ARGS_((Tcl_WideInt wideValue)); +/* 489 */ +EXTERN void Tcl_SetWideIntObj _ANSI_ARGS_((Tcl_Obj * objPtr, + Tcl_WideInt wideValue)); +/* 490 */ +EXTERN Tcl_StatBuf * Tcl_AllocStatBuf _ANSI_ARGS_((void)); +/* 491 */ +EXTERN Tcl_WideInt Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, + Tcl_WideInt offset, int mode)); +/* 492 */ +EXTERN Tcl_WideInt Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1607,7 +1627,7 @@ typedef struct TclStubs { int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr)); /* 44 */ int (*tcl_ListObjGetElements) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * objcPtr, Tcl_Obj *** objvPtr)); /* 45 */ int (*tcl_ListObjIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj ** objPtrPtr)); /* 46 */ - int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * intPtr)); /* 47 */ + int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * lengthPtr)); /* 47 */ int (*tcl_ListObjReplace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[])); /* 48 */ Tcl_Obj * (*tcl_NewBooleanObj) _ANSI_ARGS_((int boolValue)); /* 49 */ Tcl_Obj * (*tcl_NewByteArrayObj) _ANSI_ARGS_((CONST unsigned char* bytes, int length)); /* 50 */ @@ -1812,7 +1832,7 @@ typedef struct TclStubs { void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */ int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */ int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */ - int (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */ + int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */ int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */ int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */ void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */ @@ -1838,7 +1858,7 @@ typedef struct TclStubs { void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */ void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */ int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */ - int (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */ + int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */ int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */ int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */ char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 249 */ @@ -2038,15 +2058,15 @@ typedef struct TclStubs { int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */ int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */ int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */ - Tcl_Obj* (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr)); /* 446 */ + Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr)); /* 446 */ int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */ int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */ - int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 449 */ + int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */ int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */ int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */ int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */ CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */ - int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 454 */ + int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 454 */ int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 455 */ Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * modeString, int permissions)); /* 456 */ Tcl_Obj* (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 457 */ @@ -2078,6 +2098,13 @@ typedef struct TclStubs { Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp* interp, int level, int flags, Tcl_CmdObjTraceProc* objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc* delProc)); /* 483 */ int (*tcl_GetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, Tcl_CmdInfo* infoPtr)); /* 484 */ int (*tcl_SetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, CONST Tcl_CmdInfo* infoPtr)); /* 485 */ + Tcl_Obj * (*tcl_DbNewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue, CONST char * file, int line)); /* 486 */ + int (*tcl_GetWideIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_WideInt * widePtr)); /* 487 */ + Tcl_Obj * (*tcl_NewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue)); /* 488 */ + void (*tcl_SetWideIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_WideInt wideValue)); /* 489 */ + Tcl_StatBuf * (*tcl_AllocStatBuf) _ANSI_ARGS_((void)); /* 490 */ + Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */ + Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */ } TclStubs; #ifdef __cplusplus @@ -3001,9 +3028,9 @@ extern TclStubs *tclStubsPtr; #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ #endif -#ifndef Tcl_Seek -#define Tcl_Seek \ - (tclStubsPtr->tcl_Seek) /* 220 */ +#ifndef Tcl_SeekOld +#define Tcl_SeekOld \ + (tclStubsPtr->tcl_SeekOld) /* 220 */ #endif #ifndef Tcl_ServiceAll #define Tcl_ServiceAll \ @@ -3105,9 +3132,9 @@ extern TclStubs *tclStubsPtr; #define Tcl_StringMatch \ (tclStubsPtr->tcl_StringMatch) /* 245 */ #endif -#ifndef Tcl_Tell -#define Tcl_Tell \ - (tclStubsPtr->tcl_Tell) /* 246 */ +#ifndef Tcl_TellOld +#define Tcl_TellOld \ + (tclStubsPtr->tcl_TellOld) /* 246 */ #endif #ifndef Tcl_TraceVar #define Tcl_TraceVar \ @@ -4062,6 +4089,34 @@ extern TclStubs *tclStubsPtr; #define Tcl_SetCommandInfoFromToken \ (tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */ #endif +#ifndef Tcl_DbNewWideIntObj +#define Tcl_DbNewWideIntObj \ + (tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */ +#endif +#ifndef Tcl_GetWideIntFromObj +#define Tcl_GetWideIntFromObj \ + (tclStubsPtr->tcl_GetWideIntFromObj) /* 487 */ +#endif +#ifndef Tcl_NewWideIntObj +#define Tcl_NewWideIntObj \ + (tclStubsPtr->tcl_NewWideIntObj) /* 488 */ +#endif +#ifndef Tcl_SetWideIntObj +#define Tcl_SetWideIntObj \ + (tclStubsPtr->tcl_SetWideIntObj) /* 489 */ +#endif +#ifndef Tcl_AllocStatBuf +#define Tcl_AllocStatBuf \ + (tclStubsPtr->tcl_AllocStatBuf) /* 490 */ +#endif +#ifndef Tcl_Seek +#define Tcl_Seek \ + (tclStubsPtr->tcl_Seek) /* 491 */ +#endif +#ifndef Tcl_Tell +#define Tcl_Tell \ + (tclStubsPtr->tcl_Tell) /* 492 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fbbaa53..546f000 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.46 2002/01/29 02:21:47 hobbs Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.47 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -210,13 +210,102 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; fprintf(stdout, "\n"); \ } #define O2S(objPtr) \ - (objPtr ? Tcl_GetString(objPtr) : "") + (objPtr ? TclGetString(objPtr) : "") #else #define TRACE(a) #define TRACE_WITH_OBJ(a, objPtr) #define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ + +/* + * Most of the code to support working with wide values is factored + * out here because it greatly reduces the number of conditionals + * through the rest of the file. Note that this needs to be + * conditional because we do not want to alter Tcl's behaviour on + * native-64bit platforms... + */ + +#ifndef TCL_WIDE_INT_IS_LONG +#define W0 Tcl_LongAsWide(0) + +/* + * Macro to read a string containing either a wide or an int and + * decide which it is while decoding it at the same time. This + * enforces the policy that integer constants between LONG_MIN and + * LONG_MAX (inclusive) are represented by normal longs, and integer + * constants outside that range are represented by wide ints. + * + * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never + * generates an error message. + */ +#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ + (objPtr)->typePtr = &tclIntType; \ + (objPtr)->internalRep.longValue = (longVar) \ + = Tcl_WideAsLong(wideVar); \ + } +#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ + &(wideVar)); \ + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ + (objPtr)->typePtr = &tclIntType; \ + (objPtr)->internalRep.longValue = (longVar) \ + = Tcl_WideAsLong(wideVar); \ + } +#define IS_INTEGER_TYPE(typePtr) \ + ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType) +/* + * Extract a double value from a general numeric object. + */ +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ + if ((typePtr) == &tclIntType) { \ + (doubleVar) = (double) (objPtr)->internalRep.longValue; \ + } else if ((typePtr) == &tclWideIntType) { \ + (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\ + } else { \ + (doubleVar) = (objPtr)->internalRep.doubleValue; \ + } +/* + * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from + * an obj. + */ +#define FORCE_LONG(objPtr, longVar, wideVar) \ + if ((objPtr)->typePtr == &tclWideIntType) { \ + (longVar) = Tcl_WideAsLong(wideVar); \ + } +/* + * For tracing that uses wide values. + */ +#define LLTRACE(a) TRACE(a) +#define LLTRACE_WITH_OBJ(a,b) TRACE_WITH_OBJ(a,b) +#define LLD "%" TCL_LL_MODIFIER "d" +#else /* TCL_WIDE_INT_IS_LONG */ +/* + * Versions of the above that do not use wide values. + */ +#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetLongFromObj(interp, (objPtr), &(longVar)); +#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetLongFromObj((Tcl_Interp *) NULL, (objPtr), \ + &(longVar)); +#define IS_INTEGER_TYPE(typePtr) ((typePtr) == &tclIntType) +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ + if ((typePtr) == &tclIntType) { \ + (doubleVar) = (double) (objPtr)->internalRep.longValue; \ + } else { \ + (doubleVar) = (objPtr)->internalRep.doubleValue; \ + } +#define FORCE_LONG(objPtr, longVar, wideVar) +#define LLTRACE(a) +#define LLTRACE_WITH_OBJ(a,b) +#endif /* TCL_WIDE_INT_IS_LONG */ +#define IS_NUMERIC_TYPE(typePtr) \ + (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) + /* * Declarations for local procedures to this file: */ @@ -241,6 +330,10 @@ static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); +#ifndef TCL_WIDE_INT_IS_LONG +static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +#endif #ifdef TCL_COMPILE_STATS static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); @@ -307,6 +400,11 @@ BuiltinFunc builtinFuncTable[] = { {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, {"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, +#ifdef TCL_WIDE_INT_IS_LONG + {"wide", 1, {TCL_EITHER}, ExprIntFunc, 0}, +#else + {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0}, +#endif /* TCL_WIDE_INT_IS_LONG */ {0}, }; @@ -700,7 +798,7 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) Tcl_SetObjResult(interp, saveObjPtr); } - Tcl_DecrRefCount(saveObjPtr); + TclDecrRefCount(saveObjPtr); return result; } @@ -995,7 +1093,10 @@ TclExecuteByteCode(interp, codePtr) Tcl_Obj *valuePtr, *value2Ptr, *objPtr, *elemPtr; char *bytes; int length; - long i; + long i = 0; /* Init. avoids compiler warning. */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt w; +#endif /* * This procedure uses a stack to hold information about catch commands. @@ -1157,7 +1258,7 @@ TclExecuteByteCode(interp, codePtr) *p = '\0'; } else { for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - Tcl_DecrRefCount(stackPtr[i]); + TclDecrRefCount(stackPtr[i]); } } stackTop -= opnd; @@ -1193,7 +1294,7 @@ TclExecuteByteCode(interp, codePtr) #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { if (traceInstructions) { - strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20); + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { fprintf(stdout, "%d: (%u) invoking ", @@ -1399,7 +1500,7 @@ TclExecuteByteCode(interp, codePtr) if (rangePtr == NULL) { TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n", O2S(objPtr), StringForResultCode(result))); - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); goto abnormalReturn; /* no catch exists to check */ } switch (rangePtr->type) { @@ -1409,7 +1510,7 @@ TclExecuteByteCode(interp, codePtr) } else if (rangePtr->continueOffset == -1) { TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n", O2S(objPtr), StringForResultCode(result))); - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); goto checkForCatch; } else { newPcOffset = rangePtr->continueOffset; @@ -1422,18 +1523,18 @@ TclExecuteByteCode(interp, codePtr) case CATCH_EXCEPTION_RANGE: TRACE(("\"%.30s\" => %s ", O2S(objPtr), StringForResultCode(result))); - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); } - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); pc = (codePtr->codeStart + newPcOffset); continue; /* restart outer instruction loop at pc */ } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); goto checkForCatch; } @@ -1446,7 +1547,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); goto checkForCatch; } stackPtr[++stackTop] = valuePtr; /* already has right refct */ @@ -1493,7 +1594,7 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr == NULL) { TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); result = TCL_ERROR; goto checkForCatch; } @@ -1521,7 +1622,7 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr == NULL) { TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } @@ -1542,8 +1643,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", O2S(objPtr), O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } @@ -1572,7 +1673,7 @@ TclExecuteByteCode(interp, codePtr) if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1594,8 +1695,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1626,8 +1727,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1650,9 +1751,9 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1687,7 +1788,7 @@ TclExecuteByteCode(interp, codePtr) if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1722,8 +1823,8 @@ TclExecuteByteCode(interp, codePtr) O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); } - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1761,8 +1862,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ", opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1816,7 +1917,7 @@ TclExecuteByteCode(interp, codePtr) if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1855,7 +1956,7 @@ TclExecuteByteCode(interp, codePtr) TCL_TRACE_READS); CACHE_STACK_INFO(); if (valuePtr == NULL) { - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); createdNewObj = 1; } else if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); @@ -1870,15 +1971,17 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(elemPtr); } else { TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ", O2S(objPtr), O2S(value2Ptr)), Tcl_GetObjResult(interp)); } - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(value2Ptr); - if (createdNewObj) Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(value2Ptr); + if (createdNewObj) { + TclDecrRefCount(valuePtr); + } result = TCL_ERROR; goto checkForCatch; } @@ -1892,15 +1995,17 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(elemPtr); } else { TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ", O2S(objPtr), O2S(value2Ptr)), Tcl_GetObjResult(interp)); } - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(value2Ptr); - if (createdNewObj) Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(value2Ptr); + if (createdNewObj) { + TclDecrRefCount(valuePtr); + } result = TCL_ERROR; goto checkForCatch; } @@ -1940,8 +2045,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ", opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1958,24 +2063,30 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); - valuePtr = POP_OBJECT(); - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + i = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } + FORCE_LONG(valuePtr, i, w); } - i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); value2Ptr = TclIncrIndexedScalar(interp, opnd, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1988,18 +2099,24 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_STK: valuePtr = POP_OBJECT(); objPtr = POP_OBJECT(); /* scalar name */ - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + i = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ", O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } + FORCE_LONG(valuePtr, i, w); } - i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, TCL_LEAVE_ERR_MSG); @@ -2007,34 +2124,40 @@ TclExecuteByteCode(interp, codePtr) if (value2Ptr == NULL) { TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ", O2S(objPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i), value2Ptr); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(valuePtr); ADJUST_PC(1); case INST_INCR_ARRAY1: opnd = TclGetUInt1AtPtr(pc+1); valuePtr = POP_OBJECT(); elemPtr = POP_OBJECT(); - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + i = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } + FORCE_LONG(valuePtr, i, w); } - i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, elemPtr, i); @@ -2043,35 +2166,41 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); ADJUST_PC(2); case INST_INCR_ARRAY_STK: valuePtr = POP_OBJECT(); elemPtr = POP_OBJECT(); objPtr = POP_OBJECT(); /* array name */ - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + i = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } + FORCE_LONG(valuePtr, i, w); } - i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, TCL_LEAVE_ERR_MSG); @@ -2080,18 +2209,18 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", O2S(objPtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", O2S(objPtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); ADJUST_PC(1); case INST_INCR_SCALAR1_IMM: @@ -2122,7 +2251,7 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ", O2S(objPtr), i), Tcl_GetObjResult(interp)); result = TCL_ERROR; - Tcl_DecrRefCount(objPtr); + TclDecrRefCount(objPtr); goto checkForCatch; } PUSH_OBJECT(value2Ptr); @@ -2143,14 +2272,14 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(elemPtr); ADJUST_PC(3); case INST_INCR_ARRAY_STK_IMM: @@ -2165,18 +2294,22 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", O2S(objPtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", O2S(objPtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); + TclDecrRefCount(objPtr); + TclDecrRefCount(elemPtr); ADJUST_PC(2); + /* + * END INCR INSTRUCTIONS + */ + case INST_JUMP1: #ifdef TCL_COMPILE_DEBUG opnd = TclGetInt1AtPtr(pc+1); @@ -2212,12 +2345,16 @@ TclExecuteByteCode(interp, codePtr) b = (valuePtr->internalRep.longValue != 0); } else if (valuePtr->typePtr == &tclDoubleType) { b = (valuePtr->internalRep.doubleValue != 0.0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + b = (valuePtr->internalRep.wideValue != W0); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); if (result != TCL_OK) { TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } } @@ -2252,12 +2389,16 @@ TclExecuteByteCode(interp, codePtr) b = (valuePtr->internalRep.longValue != 0); } else if (valuePtr->typePtr == &tclDoubleType) { b = (valuePtr->internalRep.doubleValue != 0.0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + b = (valuePtr->internalRep.wideValue != W0); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); if (result != TCL_OK) { TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } } @@ -2294,14 +2435,27 @@ TclExecuteByteCode(interp, codePtr) if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { i1 = (valuePtr->internalRep.longValue != 0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t1Ptr == &tclWideIntType) { + i1 = (valuePtr->internalRep.wideValue != W0); +#endif /* TCL_WIDE_INT_IS_LONG */ } else if (t1Ptr == &tclDoubleType) { i1 = (valuePtr->internalRep.doubleValue != 0.0); } else { s = Tcl_GetStringFromObj(valuePtr, &length); if (TclLooksLikeInt(s, length)) { +#ifdef TCL_WIDE_INT_IS_LONG result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); i1 = (i != 0); +#else /* !TCL_WIDE_INT_IS_LONG */ + GET_WIDE_OR_INT(result, valuePtr, i, w); + if (valuePtr->typePtr == &tclIntType) { + i1 = (i != 0); + } else { + i1 = (w != W0); + } +#endif /* TCL_WIDE_INT_IS_LONG */ } else { result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, valuePtr, &i1); @@ -2312,22 +2466,35 @@ TclExecuteByteCode(interp, codePtr) O2S(valuePtr), (t1Ptr? t1Ptr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto checkForCatch; } } if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { i2 = (value2Ptr->internalRep.longValue != 0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t2Ptr == &tclWideIntType) { + i2 = (value2Ptr->internalRep.wideValue != W0); +#endif /* TCL_WIDE_INT_IS_LONG */ } else if (t2Ptr == &tclDoubleType) { i2 = (value2Ptr->internalRep.doubleValue != 0.0); } else { s = Tcl_GetStringFromObj(value2Ptr, &length); if (TclLooksLikeInt(s, length)) { +#ifdef TCL_WIDE_INT_IS_LONG result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); i2 = (i != 0); +#else /* !TCL_WIDE_INT_IS_LONG */ + GET_WIDE_OR_INT(result, value2Ptr, i, w); + if (value2Ptr->typePtr == &tclIntType) { + i2 = (i != 0); + } else { + i2 = (w != W0); + } +#endif /* TCL_WIDE_INT_IS_LONG */ } else { result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); @@ -2337,8 +2504,8 @@ TclExecuteByteCode(interp, codePtr) O2S(value2Ptr), (t2Ptr? t2Ptr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto checkForCatch; } } @@ -2383,42 +2550,38 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(1); case INST_LIST_INDEX: - { - - /*** lindex with objc == 3 ***/ + /*** lindex with objc == 3 ***/ - /* Pop the two operands */ - - value2Ptr = POP_OBJECT(); - valuePtr = POP_OBJECT(); - - /* Extract the desired list element */ - - objPtr = TclLindexList( interp, valuePtr, value2Ptr ); - if ( objPtr == NULL ) { - TRACE_WITH_OBJ( ( "%.30s %.30s => ERROR: ", - O2S( valuePtr ), - O2S( value2Ptr ) ), - Tcl_GetObjResult( interp ) ); - TclDecrRefCount( value2Ptr ); - TclDecrRefCount( valuePtr ); - result = TCL_ERROR; - goto checkForCatch; - } - - /* Stash the list element on the stack */ + /* + * Pop the two operands + */ + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); - PUSH_OBJECT( objPtr ); - TRACE(( "%.20s %.20s => %s\n", - O2S( valuePtr ), - O2S( value2Ptr ), - O2S( objPtr ) ) ); - TclDecrRefCount( valuePtr ); - TclDecrRefCount( value2Ptr ); - TclDecrRefCount( objPtr ); + /* + * Extract the desired list element + */ + objPtr = TclLindexList(interp, valuePtr, value2Ptr); + if (objPtr == NULL) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", + O2S(valuePtr), O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + TclDecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; } - ADJUST_PC( 1 ); + /* + * Stash the list element on the stack + */ + PUSH_OBJECT(objPtr); + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objPtr))); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + TclDecrRefCount(objPtr); + ADJUST_PC(1); case INST_LIST_INDEX_MULTI: { @@ -2427,7 +2590,7 @@ TclExecuteByteCode(interp, codePtr) * * Determine the count of index args. */ - + int numIdx; opnd = TclGetUInt4AtPtr(pc+1); @@ -2436,154 +2599,141 @@ TclExecuteByteCode(interp, codePtr) /* * Do the 'lindex' operation. */ + objPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx], + numIdx, stackPtr + stackTop - numIdx + 1); - objPtr = TclLindexFlat( interp, - stackPtr[ stackTop - numIdx ], - numIdx, - stackPtr + stackTop - numIdx + 1 ); /* * Clean up ref counts */ - - for ( i = 0 ; i <= numIdx ; i++ ) { - Tcl_DecrRefCount( stackPtr[ stackTop -- ] ); + for (i=0 ; i<=numIdx ; i++) { + /* + * Watch out for multiple references in macros! + */ + valuePtr = stackPtr[stackTop--]; + TclDecrRefCount(valuePtr); } /* * Check for errors */ - - if ( objPtr == NULL ) { - TRACE_WITH_OBJ( ( "%d => ERROR: ", opnd ), - Tcl_GetObjResult( interp ) ); + if (objPtr == NULL) { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), + Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } - + /* * Set result */ - - PUSH_OBJECT( objPtr ); - TRACE(( "%d => %s\n", opnd, O2S( objPtr ) )); - Tcl_DecrRefCount( objPtr ); - + PUSH_OBJECT(objPtr); + TRACE(("%d => %s\n", opnd, O2S(objPtr))); + TclDecrRefCount(objPtr); } - ADJUST_PC( 5 ); + ADJUST_PC(5); case INST_LSET_FLAT: { /* - * Lset with 3, 5, or more args. Get the number of index args. + * Lset with 3, 5, or more args. Get the number + * of index args. */ - int numIdx; opnd = TclGetUInt4AtPtr( pc + 1 ); numIdx = opnd - 2; - + /* * Get the old value of variable, and remove the stack ref. * This is safe because the variable still references the * object; the ref count will never go zero here. */ - value2Ptr = POP_OBJECT(); - Tcl_DecrRefCount( value2Ptr ); + TclDecrRefCount(value2Ptr); /* * Get the new element value. */ - valuePtr = POP_OBJECT(); /* * Compute the new variable value */ - - objPtr = TclLsetFlat( interp, value2Ptr, numIdx, - stackPtr + stackTop - numIdx + 1, - valuePtr ); - Tcl_DecrRefCount( valuePtr ); + objPtr = TclLsetFlat(interp, value2Ptr, numIdx, + stackPtr + stackTop - numIdx + 1, valuePtr); + TclDecrRefCount(valuePtr); /* * Clean up ref counts */ - - for ( i = 0 ; i < numIdx ; i++ ) { - Tcl_DecrRefCount( stackPtr[ stackTop -- ] ); + for (i=0 ; i<numIdx ; i++) { + /* + * Watch out for multiple references in macros! + */ + valuePtr = stackPtr[stackTop--]; + TclDecrRefCount(valuePtr); } /* * Check for errors */ - - if ( objPtr == NULL ) { - TRACE_WITH_OBJ( ( "%d => ERROR: ", opnd ), - Tcl_GetObjResult( interp ) ); + if (objPtr == NULL) { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), + Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } - + /* * Set result */ - - PUSH_OBJECT( objPtr ); - TRACE(( "%d => %s\n", opnd, O2S( objPtr ) )); - Tcl_DecrRefCount( objPtr ); - + PUSH_OBJECT(objPtr); + TRACE(("%d => %s\n", opnd, O2S(objPtr))); + TclDecrRefCount(objPtr); } - ADJUST_PC( 5 ); + ADJUST_PC(5); case INST_LSET_LIST: - { - /* - * 'lset' with 4 args. - * - * Get the old value of variable, and remove the stack ref. - * This is safe because the variable still references the - * object; the ref count will never go zero here. - */ - - objPtr = POP_OBJECT(); - Tcl_DecrRefCount( objPtr ); - - /* - * Get the new element value, and the index list - */ - - valuePtr = POP_OBJECT(); - value2Ptr = POP_OBJECT(); - - /* - * Compute the new variable value - */ - - objPtr = TclLsetList( interp, objPtr, value2Ptr, valuePtr ); - Tcl_DecrRefCount( valuePtr ); - Tcl_DecrRefCount( value2Ptr ); + /* + * 'lset' with 4 args. + * + * Get the old value of variable, and remove the stack ref. + * This is safe because the variable still references the + * object; the ref count will never go zero here. + */ + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); - /* - * Check for errors - */ + /* + * Get the new element value, and the index list + */ + valuePtr = POP_OBJECT(); + value2Ptr = POP_OBJECT(); - if ( objPtr == NULL ) { - TRACE_WITH_OBJ( ( "\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult( interp ) ); - result = TCL_ERROR; - goto checkForCatch; - } - - /* - * Set result - */ + /* + * Compute the new variable value + */ + objPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); - PUSH_OBJECT( objPtr ); - TRACE(( "=> %s\n", O2S( objPtr ) )); - Tcl_DecrRefCount( objPtr ); + /* + * Check for errors + */ + if (objPtr == NULL) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } - ADJUST_PC( 1 ); + + /* + * Set result + */ + PUSH_OBJECT(objPtr); + TRACE(("=> %s\n", O2S(objPtr))); + TclDecrRefCount(objPtr); + ADJUST_PC(1); case INST_STR_EQ: case INST_STR_NEQ: @@ -2752,8 +2902,8 @@ TclExecuteByteCode(interp, codePtr) result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index); if (result != TCL_OK) { - Tcl_DecrRefCount(value2Ptr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); goto checkForCatch; } @@ -2776,7 +2926,7 @@ TclExecuteByteCode(interp, codePtr) objPtr = Tcl_NewStringObj(buf, length); } } else { - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); } PUSH_OBJECT(objPtr); @@ -2804,8 +2954,8 @@ TclExecuteByteCode(interp, codePtr) match = Tcl_UniCharCaseMatch(Tcl_GetUnicode(valuePtr), Tcl_GetUnicode(value2Ptr), nocase); } else { - match = Tcl_StringCaseMatch(Tcl_GetString(valuePtr), - Tcl_GetString(value2Ptr), nocase); + match = Tcl_StringCaseMatch(TclGetString(valuePtr), + TclGetString(value2Ptr), nocase); } /* @@ -2841,12 +2991,12 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ObjType *t1Ptr, *t2Ptr; - char *s1 = NULL; /* Init. avoids compiler warning. */ - char *s2 = NULL; /* Init. avoids compiler warning. */ - long i2 = 0; /* Init. avoids compiler warning. */ - double d1 = 0.0; /* Init. avoids compiler warning. */ - double d2 = 0.0; /* Init. avoids compiler warning. */ - long iResult = 0; /* Init. avoids compiler warning. */ + char *s1 = NULL; /* Init. avoids compiler warning. */ + char *s2 = NULL; /* Init. avoids compiler warning. */ + long i2 = 0; /* Init. avoids compiler warning. */ + double d1 = 0.0; /* Init. avoids compiler warning. */ + double d2 = 0.0; /* Init. avoids compiler warning. */ + long iResult = 0; /* Init. avoids compiler warning. */ value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); @@ -2858,26 +3008,24 @@ TclExecuteByteCode(interp, codePtr) * neither type is NULL. A NULL type means the arg is * essentially an empty object ("", {} or [list]). */ - if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL)) - || (valuePtr->bytes && (valuePtr->length == 0))) - || (((t2Ptr == NULL) && (value2Ptr->bytes == NULL)) - || (value2Ptr->bytes && (value2Ptr->length == 0))))) { - if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { + if (!( (!t1Ptr && !valuePtr->bytes) + || (valuePtr->bytes && !valuePtr->length) + || (!t2Ptr && !value2Ptr->bytes) + || (value2Ptr->bytes && !value2Ptr->length))) { + if (!IS_NUMERIC_TYPE(t1Ptr)) { s1 = Tcl_GetStringFromObj(valuePtr, &length); if (TclLooksLikeInt(s1, length)) { - (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); + GET_WIDE_OR_INT(iResult, valuePtr, i, w); } else { (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1); } t1Ptr = valuePtr->typePtr; } - if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { + if (!IS_NUMERIC_TYPE(t2Ptr)) { s2 = Tcl_GetStringFromObj(value2Ptr, &length); if (TclLooksLikeInt(s2, length)) { - (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, - value2Ptr, &i2); + GET_WIDE_OR_INT(iResult, value2Ptr, i2, w); } else { (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d2); @@ -2885,15 +3033,14 @@ TclExecuteByteCode(interp, codePtr) t2Ptr = value2Ptr->typePtr; } } - if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) - || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { + if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) { /* * One operand is not numeric. Compare as strings. * NOTE: strcmp is not correct for \x00 < \x01. */ int cmpValue; - s1 = Tcl_GetString(valuePtr); - s2 = Tcl_GetString(value2Ptr); + s1 = TclGetString(valuePtr); + s2 = TclGetString(value2Ptr); cmpValue = strcmp(s1, s2); switch (*pc) { case INST_EQ: @@ -2922,13 +3069,9 @@ TclExecuteByteCode(interp, codePtr) */ if (t1Ptr == &tclDoubleType) { d1 = valuePtr->internalRep.doubleValue; - if (t2Ptr == &tclIntType) { - d2 = value2Ptr->internalRep.longValue; - } else { - d2 = value2Ptr->internalRep.doubleValue; - } - } else { /* t1Ptr is int, t2Ptr is double */ - d1 = valuePtr->internalRep.longValue; + GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr); + } else { /* t1Ptr is integer, t2Ptr is double */ + GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr); d2 = value2Ptr->internalRep.doubleValue; } switch (*pc) { @@ -2951,6 +3094,44 @@ TclExecuteByteCode(interp, codePtr) iResult = d1 >= d2; break; } +#ifndef TCL_WIDE_INT_IS_LONG + } else if ((t1Ptr == &tclWideIntType) + || (t2Ptr == &tclWideIntType)) { + Tcl_WideInt w2; + /* + * Compare as wide ints (neither are doubles) + */ + if (t1Ptr == &tclIntType) { + w = Tcl_LongAsWide(valuePtr->internalRep.longValue); + w2 = value2Ptr->internalRep.wideValue; + } else if (t2Ptr == &tclIntType) { + w = valuePtr->internalRep.wideValue; + w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue); + } else { + w = valuePtr->internalRep.wideValue; + w2 = value2Ptr->internalRep.wideValue; + } + switch (*pc) { + case INST_EQ: + iResult = w == w2; + break; + case INST_NEQ: + iResult = w != w2; + break; + case INST_LT: + iResult = w < w2; + break; + case INST_GT: + iResult = w > w2; + break; + case INST_LE: + iResult = w <= w2; + break; + case INST_GE: + iResult = w >= w2; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ } else { /* * Compare as ints. @@ -2983,21 +3164,19 @@ TclExecuteByteCode(interp, codePtr) * Reuse the valuePtr object already on stack if possible. */ + TRACE(("%.20s %.20s => %ld\n", + O2S(valuePtr), O2S(value2Ptr), iResult)); if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%.20s %.20s => %ld\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%.20s %.20s => %ld\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } TclDecrRefCount(value2Ptr); } ADJUST_PC(1); - + case INST_MOD: case INST_LSHIFT: case INST_RSHIFT: @@ -3009,40 +3188,50 @@ TclExecuteByteCode(interp, codePtr) * Only integers are allowed. We compute value op value2. */ - long i2, rem, negative; + long i2 = 0, rem, negative; long iResult = 0; /* Init. avoids compiler warning. */ - +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt w2, wResult = W0; + int doWide = 0; +#endif /* TCL_WIDE_INT_IS_LONG */ + value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ } else { /* try to convert to int */ - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto checkForCatch; } } if (value2Ptr->typePtr == &tclIntType) { i2 = value2Ptr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (value2Ptr->typePtr == &tclWideIntType) { + w2 = value2Ptr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ } else { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - value2Ptr, &i2); + REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto checkForCatch; } } @@ -3055,13 +3244,65 @@ TclExecuteByteCode(interp, codePtr) * remainder always has the same sign as the divisor and * a smaller absolute value. */ +#ifdef TCL_WIDE_INT_IS_LONG if (i2 == 0) { TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + goto divideByZero; + } +#else /* !TCL_WIDE_INT_IS_LONG */ + if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { + if (valuePtr->typePtr == &tclIntType) { + LLTRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); + } else { + LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); + } + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto divideByZero; } + if (value2Ptr->typePtr == &tclIntType && i2 == 0) { + if (valuePtr->typePtr == &tclIntType) { + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); + } else { + LLTRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); + } + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + goto divideByZero; + } +#endif /* TCL_WIDE_INT_IS_LONG */ negative = 0; +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + Tcl_WideInt wRemainder; + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + if (w2 < 0) { + w2 = -w2; + w = -w; + negative = 1; + } + wRemainder = w % w2; + if (wRemainder < 0) { + wRemainder += w2; + } + if (negative) { + wRemainder = -wRemainder; + } + wResult = wRemainder; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ if (i2 < 0) { i2 = -i2; i = -i; @@ -3077,6 +3318,20 @@ TclExecuteByteCode(interp, codePtr) iResult = rem; break; case INST_LSHIFT: +#ifndef TCL_WIDE_INT_IS_LONG + /* + * Shifts are never usefully 64-bits wide! + */ + FORCE_LONG(value2Ptr, i2, w2); + if (valuePtr->typePtr == &tclWideIntType) { +#ifdef TCL_COMPILE_DEBUG + w2 = Tcl_LongAsWide(i2); +#endif /* TCL_COMPILE_DEBUG */ + wResult = w << i2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ iResult = i << i2; break; case INST_RSHIFT: @@ -3085,6 +3340,24 @@ TclExecuteByteCode(interp, codePtr) * right shifts propagate the sign bit even on machines * where ">>" won't do it by default. */ +#ifndef TCL_WIDE_INT_IS_LONG + /* + * Shifts are never usefully 64-bits wide! + */ + FORCE_LONG(value2Ptr, i2, w2); + if (valuePtr->typePtr == &tclWideIntType) { +#ifdef TCL_COMPILE_DEBUG + w2 = Tcl_LongAsWide(i2); +#endif /* TCL_COMPILE_DEBUG */ + if (w < 0) { + wResult = ~((~w) >> i2); + } else { + wResult = w >> i2; + } + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ if (i < 0) { iResult = ~((~i) >> i2); } else { @@ -3092,12 +3365,60 @@ TclExecuteByteCode(interp, codePtr) } break; case INST_BITOR: +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w | w2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ iResult = i | i2; break; case INST_BITXOR: +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w ^ w2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ iResult = i ^ i2; break; case INST_BITAND: +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w & w2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ iResult = i & i2; break; } @@ -3107,18 +3428,36 @@ TclExecuteByteCode(interp, codePtr) */ if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); +#ifndef TCL_WIDE_INT_IS_LONG + if (doWide) { + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + } else { +#endif /* TCL_WIDE_INT_IS_LONG */ + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); +#ifndef TCL_WIDE_INT_IS_LONG + } +#endif /* TCL_WIDE_INT_IS_LONG */ TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - Tcl_SetLongObj(valuePtr, iResult); +#ifndef TCL_WIDE_INT_IS_LONG + if (doWide) { + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + Tcl_SetWideIntObj(valuePtr, wResult); + } else { +#endif /* TCL_WIDE_INT_IS_LONG */ + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + Tcl_SetLongObj(valuePtr, iResult); +#ifndef TCL_WIDE_INT_IS_LONG + } +#endif /* TCL_WIDE_INT_IS_LONG */ ++stackTop; /* valuePtr now on stk top has right r.c. */ } TclDecrRefCount(value2Ptr); } ADJUST_PC(1); - + case INST_ADD: case INST_SUB: case INST_MULT: @@ -3130,19 +3469,28 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ObjType *t1Ptr, *t2Ptr; - long i2, quot, rem; + long i2 = 0, quot, rem; /* Init. avoids compiler warning. */ double d1, d2; - long iResult = 0; /* Init. avoids compiler warning. */ - double dResult = 0.0; /* Init. avoids compiler warning. */ - int doDouble = 0; /* 1 if doing floating arithmetic */ - + long iResult = 0; /* Init. avoids compiler warning. */ + double dResult = 0.0; /* Init. avoids compiler warning. */ + int doDouble = 0; /* 1 if doing floating arithmetic */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt w2, wquot, wrem; + Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ + int doWide = 0; /* 1 if doing wide arithmetic. */ +#endif /* TCL_WIDE_INT_IS_LONG */ + value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); t1Ptr = valuePtr->typePtr; t2Ptr = value2Ptr->typePtr; if (t1Ptr == &tclIntType) { - i = valuePtr->internalRep.longValue; + i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t1Ptr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ } else if ((t1Ptr == &tclDoubleType) && (valuePtr->bytes == NULL)) { /* @@ -3155,8 +3503,7 @@ TclExecuteByteCode(interp, codePtr) } else { char *s = Tcl_GetStringFromObj(valuePtr, &length); if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); + GET_WIDE_OR_INT(result, valuePtr, i, w); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1); @@ -3167,15 +3514,19 @@ TclExecuteByteCode(interp, codePtr) (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto checkForCatch; } t1Ptr = valuePtr->typePtr; } - + if (t2Ptr == &tclIntType) { i2 = value2Ptr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t2Ptr == &tclWideIntType) { + w2 = value2Ptr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ } else if ((t2Ptr == &tclDoubleType) && (value2Ptr->bytes == NULL)) { /* @@ -3188,8 +3539,7 @@ TclExecuteByteCode(interp, codePtr) } else { char *s = Tcl_GetStringFromObj(value2Ptr, &length); if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - value2Ptr, &i2); + GET_WIDE_OR_INT(result, value2Ptr, i2, w2); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d2); @@ -3200,8 +3550,8 @@ TclExecuteByteCode(interp, codePtr) (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto checkForCatch; } t2Ptr = value2Ptr->typePtr; @@ -3216,6 +3566,12 @@ TclExecuteByteCode(interp, codePtr) d1 = i; /* promote value 1 to double */ } else if (t2Ptr == &tclIntType) { d2 = i2; /* promote value 2 to double */ +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t1Ptr == &tclWideIntType) { + d1 = Tcl_WideAsDouble(w); + } else if (t2Ptr == &tclWideIntType) { + d2 = Tcl_WideAsDouble(w2); +#endif /* TCL_WIDE_INT_IS_LONG */ } switch (*pc) { case INST_ADD: @@ -3230,8 +3586,8 @@ TclExecuteByteCode(interp, codePtr) case INST_DIV: if (d2 == 0.0) { TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto divideByZero; } dResult = d1 / d2; @@ -3247,10 +3603,58 @@ TclExecuteByteCode(interp, codePtr) O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto checkForCatch; } +#ifndef TCL_WIDE_INT_IS_LONG + } else if ((t1Ptr == &tclWideIntType) || + (t2Ptr == &tclWideIntType)) { + /* + * Do wide integer arithmetic. + */ + doWide = 1; + if (t1Ptr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (t2Ptr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + switch (*pc) { + case INST_ADD: + wResult = w + w2; + break; + case INST_SUB: + wResult = w - w2; + break; + case INST_MULT: + wResult = w * w2; + break; + case INST_DIV: + /* + * This code is tricky: C doesn't guarantee much + * about the quotient or remainder, but Tcl does. + * The remainder always has the same sign as the + * divisor and a smaller absolute value. + */ + if (w2 == W0) { + LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); + goto divideByZero; + } + if (w2 < 0) { + w2 = -w2; + w = -w; + } + wquot = w / w2; + wrem = w % w2; + if (wrem < W0) { + wquot -= 1; + } + wResult = wquot; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ } else { /* * Do integer arithmetic. @@ -3274,8 +3678,8 @@ TclExecuteByteCode(interp, codePtr) */ if (i2 == 0) { TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); goto divideByZero; } if (i2 < 0) { @@ -3300,6 +3704,11 @@ TclExecuteByteCode(interp, codePtr) if (doDouble) { PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (doWide) { + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { PUSH_OBJECT(Tcl_NewLongObj(iResult)); TRACE(("%ld %ld => %ld\n", i, i2, iResult)); @@ -3309,6 +3718,11 @@ TclExecuteByteCode(interp, codePtr) if (doDouble) { /* NB: stack top is off by 1 */ TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); Tcl_SetDoubleObj(valuePtr, dResult); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (doWide) { + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + Tcl_SetWideIntObj(valuePtr, wResult); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { TRACE(("%ld %ld => %ld\n", i, i2, iResult)); Tcl_SetLongObj(valuePtr, iResult); @@ -3318,7 +3732,7 @@ TclExecuteByteCode(interp, codePtr) TclDecrRefCount(value2Ptr); } ADJUST_PC(1); - + case INST_UPLUS: { /* @@ -3330,12 +3744,11 @@ TclExecuteByteCode(interp, codePtr) valuePtr = stackPtr[stackTop]; tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) || (valuePtr->bytes != NULL))) { char *s = Tcl_GetStringFromObj(valuePtr, &length); if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); + GET_WIDE_OR_INT(result, valuePtr, i, w); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -3362,12 +3775,17 @@ TclExecuteByteCode(interp, codePtr) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; objPtr = Tcl_NewLongObj(i); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + objPtr = Tcl_NewWideIntObj(w); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; objPtr = Tcl_NewDoubleObj(d); } Tcl_IncrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); valuePtr = objPtr; stackPtr[stackTop] = valuePtr; } else { @@ -3395,7 +3813,7 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) || (valuePtr->bytes != NULL))) { if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { @@ -3403,8 +3821,7 @@ TclExecuteByteCode(interp, codePtr) } else { char *s = Tcl_GetStringFromObj(valuePtr, &length); if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); + GET_WIDE_OR_INT(result, valuePtr, i, w); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -3418,7 +3835,7 @@ TclExecuteByteCode(interp, codePtr) TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", s, (tPtr? tPtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } } @@ -3434,6 +3851,16 @@ TclExecuteByteCode(interp, codePtr) objPtr = Tcl_NewLongObj( (*pc == INST_UMINUS)? -i : !i); TRACE_WITH_OBJ(("%ld => ", i), objPtr); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + if (*pc == INST_UMINUS) { + objPtr = Tcl_NewWideIntObj(-w); + } else { + objPtr = Tcl_NewLongObj(w == W0); + } + LLTRACE_WITH_OBJ((LLD" => ", w), objPtr); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (*pc == INST_UMINUS) { @@ -3458,6 +3885,16 @@ TclExecuteByteCode(interp, codePtr) Tcl_SetLongObj(valuePtr, (*pc == INST_UMINUS)? -i : !i); TRACE_WITH_OBJ(("%ld => ", i), valuePtr); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + if (*pc == INST_UMINUS) { + Tcl_SetWideIntObj(valuePtr, -w); + } else { + Tcl_SetLongObj(valuePtr, w == W0); + } + LLTRACE_WITH_OBJ((LLD" => ", w), valuePtr); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (*pc == INST_UMINUS) { @@ -3475,7 +3912,7 @@ TclExecuteByteCode(interp, codePtr) } } ADJUST_PC(1); - + case INST_BITNOT: { /* @@ -3489,34 +3926,53 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); tPtr = valuePtr->typePtr; - if (tPtr != &tclIntType) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); + if (!IS_INTEGER_TYPE(tPtr)) { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { /* try to convert to double */ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (tPtr? tPtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); goto checkForCatch; } } - i = valuePtr->internalRep.longValue; - if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewLongObj(~i)); - TRACE(("0x%lx => (%lu)\n", i, ~i)); - TclDecrRefCount(valuePtr); +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewWideIntObj(~w)); + LLTRACE(("0x%llx => (%llu)\n", w, ~w)); + TclDecrRefCount(valuePtr); + } else { + /* + * valuePtr is unshared. Modify it directly. + */ + Tcl_SetWideIntObj(valuePtr, ~w); + ++stackTop; /*valuePtr now on stk top has right r.c.*/ + LLTRACE(("0x%llx => (%llu)\n", w, ~w)); + } } else { - /* - * valuePtr is unshared. Modify it directly. - */ - Tcl_SetLongObj(valuePtr, ~i); - ++stackTop; /* valuePtr now on stk top has right r.c. */ - TRACE(("0x%lx => (%lu)\n", i, ~i)); +#endif /* TCL_WIDE_INT_IS_LONG */ + i = valuePtr->internalRep.longValue; + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(~i)); + TRACE(("0x%lx => (%lu)\n", i, ~i)); + TclDecrRefCount(valuePtr); + } else { + /* + * valuePtr is unshared. Modify it directly. + */ + Tcl_SetLongObj(valuePtr, ~i); + ++stackTop; /*valuePtr now on stk top has right r.c.*/ + TRACE(("0x%lx => (%lu)\n", i, ~i)); + } +#ifndef TCL_WIDE_INT_IS_LONG } +#endif /* TCL_WIDE_INT_IS_LONG */ } ADJUST_PC(1); - + case INST_CALL_BUILTIN_FUNC1: opnd = TclGetUInt1AtPtr(pc+1); { @@ -3589,7 +4045,7 @@ TclExecuteByteCode(interp, codePtr) valuePtr = stackPtr[stackTop]; tPtr = valuePtr->typePtr; converted = 0; - if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) || (valuePtr->bytes != NULL))) { if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { @@ -3598,15 +4054,14 @@ TclExecuteByteCode(interp, codePtr) } else { s = Tcl_GetStringFromObj(valuePtr, &length); if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); + GET_WIDE_OR_INT(result, valuePtr, i, w); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); } if (result == TCL_OK) { converted = 1; - } + } result = TCL_OK; /* reset the result variable */ } tPtr = valuePtr->typePtr; @@ -3623,7 +4078,7 @@ TclExecuteByteCode(interp, codePtr) * floating point error. */ - if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) { + if (IS_NUMERIC_TYPE(tPtr)) { shared = 0; if (Tcl_IsShared(valuePtr)) { shared = 1; @@ -3635,6 +4090,11 @@ TclExecuteByteCode(interp, codePtr) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; objPtr = Tcl_NewLongObj(i); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + objPtr = Tcl_NewWideIntObj(w); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; objPtr = Tcl_NewDoubleObj(d); @@ -3844,7 +4304,7 @@ TclExecuteByteCode(interp, codePtr) int setEmptyStr = 0; if (valIndex >= listLen) { setEmptyStr = 1; - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); } else { valuePtr = listRepPtr->elements[valIndex]; } @@ -3859,7 +4319,7 @@ TclExecuteByteCode(interp, codePtr) opnd, varIndex), Tcl_GetObjResult(interp)); if (setEmptyStr) { - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); } result = TCL_ERROR; goto checkForCatch; @@ -3985,7 +4445,7 @@ TclExecuteByteCode(interp, codePtr) abnormalReturn: while (stackTop > initStackTop) { valuePtr = POP_OBJECT(); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); } if (stackTop < initStackTop) { fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n", @@ -4185,7 +4645,7 @@ IllegalExprOperandType(interp, pc, opndPtr) * improve the error message. */ - char *s = Tcl_GetString(opndPtr); + char *s = TclGetString(opndPtr); double d; if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { @@ -4193,7 +4653,7 @@ IllegalExprOperandType(interp, pc, opndPtr) * Make sure that what appears to be a double * (ie 08) isn't really a bad octal */ - if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) { + if (TclCheckBadOctal(NULL, TclGetString(opndPtr))) { msg = "invalid octal number"; } else { msg = "floating-point value"; @@ -4439,7 +4899,8 @@ GetOpcodeName(pc) * TCL_OK if it was int or double, TCL_ERROR otherwise * * Side effects: - * objPtr is ensured to be either tclIntType of tclDoubleType. + * objPtr is ensured to be of tclIntType, tclWideIntType or + * tclDoubleType. * *---------------------------------------------------------------------- */ @@ -4450,16 +4911,20 @@ VerifyExprObjType(interp, objPtr) * function. */ Tcl_Obj *objPtr; /* Points to the object to type check. */ { - if ((objPtr->typePtr == &tclIntType) || - (objPtr->typePtr == &tclDoubleType)) { + if (IS_NUMERIC_TYPE(objPtr->typePtr)) { return TCL_OK; } else { int length, result = TCL_OK; char *s = Tcl_GetStringFromObj(objPtr, &length); if (TclLooksLikeInt(s, length)) { +#ifdef TCL_WIDE_INT_IS_LONG long i; result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i); +#else /* !TCL_WIDE_INT_IS_LONG */ + Tcl_WideInt w; + result = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, objPtr, &w); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { double d; result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); @@ -4536,12 +5001,8 @@ ExprUnaryFunc(interp, eePtr, clientData) result = TCL_ERROR; goto done; } - - if (valuePtr->typePtr == &tclIntType) { - d = (double) valuePtr->internalRep.longValue; - } else { - d = valuePtr->internalRep.doubleValue; - } + + GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); errno = 0; dResult = (*func)(d); @@ -4562,7 +5023,7 @@ ExprUnaryFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -4607,17 +5068,8 @@ ExprBinaryFunc(interp, eePtr, clientData) goto done; } - if (valuePtr->typePtr == &tclIntType) { - d1 = (double) valuePtr->internalRep.longValue; - } else { - d1 = valuePtr->internalRep.doubleValue; - } - - if (value2Ptr->typePtr == &tclIntType) { - d2 = (double) value2Ptr->internalRep.longValue; - } else { - d2 = value2Ptr->internalRep.doubleValue; - } + GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr); + GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr); errno = 0; dResult = (*func)(d1, d2); @@ -4638,8 +5090,8 @@ ExprBinaryFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); DECACHE_STACK_INFO(); return result; } @@ -4697,6 +5149,25 @@ ExprAbsFunc(interp, eePtr, clientData) iResult = i; } PUSH_OBJECT(Tcl_NewLongObj(iResult)); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wResult, w = valuePtr->internalRep.wideValue; + if (w < W0) { + wResult = -w; + if (wResult < 0) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + wResult = w; + } + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { @@ -4717,7 +5188,7 @@ ExprAbsFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -4754,11 +5225,7 @@ ExprDoubleFunc(interp, eePtr, clientData) goto done; } - if (valuePtr->typePtr == &tclIntType) { - dResult = (double) valuePtr->internalRep.longValue; - } else { - dResult = valuePtr->internalRep.doubleValue; - } + GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); /* * Push a Tcl object with the result. @@ -4771,7 +5238,7 @@ ExprDoubleFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -4811,6 +5278,10 @@ ExprIntFunc(interp, eePtr, clientData) if (valuePtr->typePtr == &tclIntType) { iResult = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + iResult = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { @@ -4848,11 +5319,92 @@ ExprIntFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } +#ifndef TCL_WIDE_INT_IS_LONG +static int +ExprWideFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_WideInt wResult; + double d; + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + if (valuePtr->typePtr == &tclWideIntType) { + wResult = valuePtr->internalRep.wideValue; + } else if (valuePtr->typePtr == &tclIntType) { + wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue); + } else { + d = valuePtr->internalRep.doubleValue; + if (d < 0.0) { + if (d < Tcl_WideAsDouble(LLONG_MIN)) { + tooLarge: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + if (d > Tcl_WideAsDouble(LLONG_MAX)) { + goto tooLarge; + } + } + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto done; + } + wResult = Tcl_DoubleAsWide(d); + } + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + TclDecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} +#endif /* TCL_WIDE_INT_IS_LONG */ + static int ExprRandFunc(interp, eePtr, clientData) Tcl_Interp *interp; /* The interpreter in which to execute the @@ -4876,7 +5428,7 @@ ExprRandFunc(interp, eePtr, clientData) * to insure different seeds in different threads (bug #416643) */ - iPtr->randSeed = TclpGetClicks() + ((long) Tcl_GetCurrentThread() << 12); + iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. @@ -4989,6 +5541,11 @@ ExprRoundFunc(interp, eePtr, clientData) if (valuePtr->typePtr == &tclIntType) { iResult = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + PUSH_OBJECT(Tcl_NewWideIntObj(valuePtr->internalRep.wideValue)); + goto done; +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { @@ -5029,7 +5586,7 @@ ExprRoundFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -5069,6 +5626,10 @@ ExprSrandFunc(interp, eePtr, clientData) if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + i = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { /* * At this point, the only other possible type is double @@ -5078,7 +5639,7 @@ ExprSrandFunc(interp, eePtr, clientData) "can't use floating-point value as argument to srand", (char *) NULL); badValue: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return TCL_ERROR; } @@ -5101,7 +5662,7 @@ ExprSrandFunc(interp, eePtr, clientData) * function will always succeed. */ - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); ExprRandFunc(interp, eePtr, clientData); @@ -5166,7 +5727,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) * Look up the MathFunc record for the function. */ - funcName = Tcl_GetString(objv[0]); + funcName = TclGetString(objv[0]); hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -5206,15 +5767,39 @@ ExprCallMathFunc(interp, eePtr, objc, objv) if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { args[k].type = TCL_DOUBLE; args[k].doubleValue = i; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_LongAsWide(i); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { args[k].type = TCL_INT; args[k].intValue = i; } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt w = valuePtr->internalRep.wideValue; + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].wideValue = Tcl_WideAsDouble(w); + } else if (mathFuncPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].wideValue = Tcl_WideAsLong(w); + } else { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = w; + } +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (mathFuncPtr->argTypes[k] == TCL_INT) { args[k].type = TCL_INT; args[k].intValue = (long) d; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_DoubleAsWide(d); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { args[k].type = TCL_DOUBLE; args[k].doubleValue = d; @@ -5241,7 +5826,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) i = (stackTop - (objc-1)); while (i <= stackTop) { valuePtr = stackPtr[i]; - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); i++; } stackTop -= objc; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index db9c6ad..61d4df2 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.15 2002/01/17 04:37:33 dgp Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.16 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -111,7 +111,7 @@ FileCopyRename(interp, objc, objv, copyFlag) * rename them. */ { int i, result, force; - struct stat statBuf; + Tcl_StatBuf statBuf; Tcl_Obj *target; i = FileForceOption(interp, objc - 2, objv + 2, &force); @@ -229,7 +229,7 @@ TclFileMakeDirsCmd(interp, objc, objv) int result, i, j, pobjc; Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; - struct stat statBuf; + Tcl_StatBuf statBuf; errfile = NULL; @@ -250,9 +250,9 @@ TclFileMakeDirsCmd(interp, objc, objv) target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); /* - * Call Tcl_Stat() so that if target is a symlink that points - * to a directory we will create subdirectories in that - * directory. + * Call Tcl_FSStat() so that if target is a symlink that + * points to a directory we will create subdirectories in + * that directory. */ if (Tcl_FSStat(target, &statBuf) == 0) { @@ -333,7 +333,7 @@ TclFileDeleteCmd(interp, objc, objv) result = TCL_OK; for ( ; i < objc; i++) { - struct stat statBuf; + Tcl_StatBuf statBuf; errfile = objv[i]; if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -448,7 +448,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) { int result; Tcl_Obj *errfile, *errorBuffer; - struct stat sourceStatBuf, targetStatBuf; + Tcl_StatBuf sourceStatBuf, targetStatBuf; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a0e808d..0b698f1 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.30 2002/02/08 02:52:54 dgp Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.31 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -2467,7 +2467,7 @@ TclDoGlob(interp, separators, headPtr, tail, types) */ Tcl_Obj *nameObj; - struct stat buf; + Tcl_StatBuf buf; /* Used to deal with one special case pertinent to MacOS */ int macSpecialCase = 0; @@ -2597,3 +2597,27 @@ TclFileDirname(interp, pathPtr) Tcl_DecrRefCount(splitPtr); return splitResultPtr; } + +/* + *--------------------------------------------------------------------------- + * + * Tcl_AllocStatBuf + * + * This procedure allocates a Tcl_StatBuf on the heap. It exists + * so that extensions may be used unchanged on systems where + * largefile support is optional. + * + * Results: + * A pointer to a Tcl_StatBuf which may be deallocated by being + * passed to ckfree(). + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_StatBuf * +Tcl_AllocStatBuf() { + return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); +} diff --git a/generic/tclIO.c b/generic/tclIO.c index ed5598c..df8a8c2 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.51 2002/01/26 01:10:08 dgp Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.52 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -92,8 +92,7 @@ static int CopyAndTranslateBuffer _ANSI_ARGS_(( ChannelState *statePtr, char *result, int space)); static int CopyBuffer _ANSI_ARGS_(( - Channel *chanPtr, char *result, - int space)); + Channel *chanPtr, char *result, int space)); static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask)); static void CopyEventProc _ANSI_ARGS_((ClientData clientData, int mask)); @@ -130,8 +129,8 @@ static int ReadBytes _ANSI_ARGS_((ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft, int *offsetPtr)); static int ReadChars _ANSI_ARGS_((ChannelState *statePtr, - Tcl_Obj *objPtr, int charsLeft, int *offsetPtr, - int *factorPtr)); + Tcl_Obj *objPtr, int charsLeft, + int *offsetPtr, int *factorPtr)); static void RecycleBuffer _ANSI_ARGS_((ChannelState *statePtr, ChannelBuffer *bufPtr, int mustDiscard)); static int StackSetBlockMode _ANSI_ARGS_((Channel *chanPtr, @@ -140,11 +139,11 @@ static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int mode)); static void StopCopy _ANSI_ARGS_((CopyState *csPtr)); static int TranslateInputEOL _ANSI_ARGS_((ChannelState *statePtr, - char *dst, CONST char *src, int *dstLenPtr, - int *srcLenPtr)); + char *dst, CONST char *src, + int *dstLenPtr, int *srcLenPtr)); static int TranslateOutputEOL _ANSI_ARGS_((ChannelState *statePtr, - char *dst, CONST char *src, int *dstLenPtr, - int *srcLenPtr)); + char *dst, CONST char *src, + int *dstLenPtr, int *srcLenPtr)); static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); @@ -2954,7 +2953,7 @@ WriteBytes(chanPtr, src, srcLen) ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; char *dst; - int dstLen, dstMax, sawLF, savedLF, total, toWrite; + int dstMax, sawLF, savedLF, total, dstLen, toWrite; total = 0; sawLF = 0; @@ -3042,8 +3041,8 @@ WriteChars(chanPtr, src, srcLen) ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; char *dst, *stage; - int saved, savedLF, sawLF, total, toWrite, flags; - int dstWrote, dstLen, stageLen, stageMax, stageRead; + int saved, savedLF, sawLF, total, flags, dstLen, stageMax, dstWrote; + int stageLen, toWrite, stageRead; Tcl_Encoding encoding; char safe[BUFFER_PADDING]; @@ -3444,11 +3443,10 @@ Tcl_GetsObj(chan, objPtr) Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal; + int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; - int oldLength, oldFlags, oldRemoved; /* * This operation should occur at the top of a channel stack. @@ -3686,8 +3684,9 @@ Tcl_GetsObj(chan, objPtr) statePtr->inputEncodingState = gs.state; Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, gs.rawRead, statePtr->inputEncodingFlags, - &statePtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX, - &gs.rawRead, NULL, &gs.charsWrote); + &statePtr->inputEncodingState, dst, + eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL, + &gs.charsWrote); bufPtr->nextRemoved += gs.rawRead; /* @@ -4131,7 +4130,7 @@ Tcl_Read(chan, dst, bytesToRead) int Tcl_ReadRaw(chan, bufPtr, bytesToRead) Tcl_Channel chan; /* The channel from which to read. */ - char *bufPtr; /* Where to store input read. */ + char *bufPtr; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; @@ -4464,7 +4463,7 @@ ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) * output, filled with how many bytes are now * being used. */ { - int toRead, srcLen, srcRead, dstWrote, offset, length; + int toRead, srcLen, offset, length, srcRead, dstWrote; ChannelBuffer *bufPtr; char *src, *dst; @@ -4572,8 +4571,8 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) * UTF-8. On output, contains another guess * based on the data seen so far. */ { - int toRead, factor, offset, spaceLeft, length; - int srcLen, srcRead, dstNeeded, dstRead, dstWrote, numChars; + int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded; + int srcRead, dstWrote, numChars, dstRead; ChannelBuffer *bufPtr; char *src, *dst; Tcl_EncodingState oldState; @@ -4586,7 +4585,7 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; toRead = charsToRead; - if ((unsigned) toRead > (unsigned) srcLen) { + if ((unsigned)toRead > (unsigned)srcLen) { toRead = srcLen; } @@ -5291,17 +5290,17 @@ GetInput(chanPtr) *---------------------------------------------------------------------- */ -int +Tcl_WideInt Tcl_Seek(chan, offset, mode) Tcl_Channel chan; /* The channel on which to seek. */ - int offset; /* Offset to seek to. */ + Tcl_WideInt offset; /* Offset to seek to. */ int mode; /* Relative to which location to seek? */ { Channel *chanPtr = (Channel *) chan; /* The real IO channel. */ ChannelState *statePtr = chanPtr->state; /* state info for channel */ int inputBuffered, outputBuffered; int result; /* Of device driver operations. */ - int curPos; /* Position on the device. */ + Tcl_WideInt curPos; /* Position on the device. */ int wasAsync; /* Was the channel nonblocking before the * seek operation? If so, must restore to * nonblocking mode after the seek. */ @@ -5410,7 +5409,7 @@ Tcl_Seek(chan, offset, mode) */ curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, - (long) offset, mode, &result); + offset, mode, &result); if (curPos == -1) { Tcl_SetErrno(result); } @@ -5453,7 +5452,7 @@ Tcl_Seek(chan, offset, mode) *---------------------------------------------------------------------- */ -int +Tcl_WideInt Tcl_Tell(chan) Tcl_Channel chan; /* The channel to return pos for. */ { @@ -5461,7 +5460,7 @@ Tcl_Tell(chan) ChannelState *statePtr = chanPtr->state; /* state info for channel */ int inputBuffered, outputBuffered; int result; /* Of calling device driver. */ - int curPos; /* Position on device. */ + Tcl_WideInt curPos; /* Position on device. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { return -1; @@ -5513,7 +5512,7 @@ Tcl_Tell(chan) */ curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, - (long) 0, SEEK_CUR, &result); + Tcl_LongAsWide(0), SEEK_CUR, &result); if (curPos == -1) { Tcl_SetErrno(result); return -1; @@ -5527,6 +5526,46 @@ Tcl_Tell(chan) /* *--------------------------------------------------------------------------- * + * Tcl_SeekOld, Tcl_TellOld -- + * + * Backward-compatability versions of the seek/tell interface that + * do not support 64-bit offsets. + * + * Results: + * As for Tcl_Seek and Tcl_Tell respectively. + * + * Side effects: + * As for Tcl_Seek and Tcl_Tell respectively. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_SeekOld(chan, offset, mode) + Tcl_Channel chan; /* The channel on which to seek. */ + int offset; /* Offset to seek to. */ + int mode; /* Relative to which location to seek? */ +{ + Tcl_WideInt wOffset, wResult; + + wOffset = Tcl_LongAsWide((long)offset); + wResult = Tcl_Seek(chan, wOffset, mode); + return (int)Tcl_WideAsLong(wResult); +} + +int +Tcl_TellOld(chan) + Tcl_Channel chan; /* The channel to return pos for. */ +{ + Tcl_WideInt wResult; + + wResult = Tcl_Tell(chan); + return (int)Tcl_WideAsLong(wResult); +} + +/* + *--------------------------------------------------------------------------- + * * CheckChannelErrors -- * * See if the channel is in an ready state and can perform the @@ -7378,14 +7417,10 @@ CopyData(csPtr, mask) int mask; /* Current channel event flags. */ { Tcl_Interp *interp; - Tcl_Obj *cmdPtr, *errObj = NULL; + Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; - int result = TCL_OK; - int size; - int total; - int sizeb; - Tcl_Obj* bufObj = NULL; + int result = TCL_OK, size, total, sizeb; char* buffer; int inBinary, outBinary, sameEncoding; /* Encoding control */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 54d0d5c..bb2b567 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.14 2002/02/14 19:24:15 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.15 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -416,8 +416,9 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ - int offset, mode; /* Where to seek? */ - int result; /* Of calling Tcl_Seek. */ + Tcl_WideInt offset; /* Where to seek? */ + int mode; /* How to seek? */ + Tcl_WideInt result; /* Of calling Tcl_Seek. */ char *chanName; int optionIndex; static CONST char *originOptions[] = { @@ -434,7 +435,7 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &offset) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { return TCL_ERROR; } mode = SEEK_SET; @@ -447,7 +448,7 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) } result = Tcl_Seek(chan, offset, mode); - if (result == -1) { + if (result == Tcl_LongAsWide(-1)) { Tcl_AppendResult(interp, "error during seek on \"", chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; @@ -497,7 +498,7 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); return TCL_OK; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 4071217..c48ce18 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * CVS: $Id: tclIOGT.c,v 1.4 2002/01/15 17:55:30 dgp Exp $ + * CVS: $Id: tclIOGT.c,v 1.5 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -33,8 +33,8 @@ static int TransformInputProc _ANSI_ARGS_ (( static int TransformOutputProc _ANSI_ARGS_ (( ClientData instanceData, CONST char *buf, int toWrite, int* errorCodePtr)); -static int TransformSeekProc _ANSI_ARGS_ (( - ClientData instanceData, long offset, +static Tcl_WideInt TransformSeekProc _ANSI_ARGS_ (( + ClientData instanceData, Tcl_WideInt offset, int mode, int* errorCodePtr)); static int TransformSetOptionProc _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, @@ -156,8 +156,8 @@ static Tcl_ChannelType transformChannelType = { struct ResultBuffer { unsigned char* buf; /* Reference to the buffer area */ - int allocated; /* Allocated size of the buffer area */ - int used; /* Number of bytes in the buffer, <= allocated */ + int allocated; /* Allocated size of the buffer area */ + int used; /* Number of bytes in the buffer, <= allocated */ }; /* @@ -357,11 +357,11 @@ TclChannelTransform(interp, chan, cmdObjPtr) static int ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) - TransformChannelData* dataPtr; /* Transformation with the callback */ + TransformChannelData* dataPtr; /* Transformation with the callback */ Tcl_Interp* interp; /* Current interpreter, possibly NULL */ unsigned char* op; /* Operation invoking the callback */ unsigned char* buf; /* Buffer to give to the script. */ - int bufLen; /* Ands its length */ + int bufLen; /* Ands its length */ int transmit; /* Flag, determines whether the result * of the callback is sent to the * underlying channel or not. */ @@ -377,16 +377,14 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) * arguments. Feather's curried commands would come in handy here. */ - Tcl_Obj* resObj; /* See below, switch (transmit) */ - int resLen; - unsigned char* resBuf; + Tcl_Obj* resObj; /* See below, switch (transmit) */ + int resLen; + unsigned char* resBuf; Tcl_SavedResult ciSave; - int res = TCL_OK; Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command); Tcl_Obj* temp; - if (preserve) { Tcl_SaveResult (dataPtr->interp, &ciSave); } @@ -641,7 +639,7 @@ static int TransformInputProc (instanceData, buf, toRead, errorCodePtr) ClientData instanceData; char* buf; - int toRead; + int toRead; int* errorCodePtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; @@ -764,8 +762,7 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) */ res = ExecuteCallback (dataPtr, NO_INTERP, A_READ, - UCHARP (buf), read, TRANSMIT_IBUF, - P_PRESERVE); + UCHARP (buf), read, TRANSMIT_IBUF, P_PRESERVE); if (res != TCL_OK) { *errorCodePtr = EINVAL; @@ -846,12 +843,12 @@ TransformOutputProc (instanceData, buf, toWrite, errorCodePtr) *------------------------------------------------------* */ -static int +static Tcl_WideInt TransformSeekProc (instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ - long offset; /* Size of movement. */ - int mode; /* How to move */ - int* errorCodePtr; /* Location of error flag. */ + ClientData instanceData; /* The channel to manipulate */ + Tcl_WideInt offset; /* Size of movement. */ + int mode; /* How to move */ + int* errorCodePtr; /* Location of error flag. */ { int result; TransformChannelData* dataPtr = (TransformChannelData*) instanceData; @@ -1274,7 +1271,7 @@ static int ResultCopy (r, buf, toRead) ResultBuffer* r; /* The buffer to read from */ unsigned char* buf; /* The buffer to copy into */ - int toRead; /* Number of requested bytes */ + int toRead; /* Number of requested bytes */ { if (r->used == 0) { /* Nothing to copy in the case of an empty buffer. @@ -1337,7 +1334,7 @@ static void ResultAdd (r, buf, toWrite) ResultBuffer* r; /* The buffer to extend */ unsigned char* buf; /* The buffer to read from */ - int toWrite; /* The number of bytes in 'buf' */ + int toWrite; /* The number of bytes in 'buf' */ { if ((r->used + toWrite) > r->allocated) { /* Extension of the internal buffer is required. diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index f972b2c..bdea467 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.34 2002/02/08 02:52:54 dgp Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.35 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -80,15 +80,63 @@ extern CONST TclFileAttrProcs tclpFileAttrProcs[]; /* Obsolete */ int -Tcl_Stat(path, buf) +Tcl_Stat(path, oldStyleBuf) CONST char *path; /* Path of file to stat (in current CP). */ - struct stat *buf; /* Filled with results of stat call. */ + struct stat *oldStyleBuf; /* Filled with results of stat call. */ { int ret; + Tcl_StatBuf buf; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); - ret = Tcl_FSStat(pathPtr,buf); + ret = Tcl_FSStat(pathPtr, &buf); Tcl_DecrRefCount(pathPtr); + if (ret != -1) { +#ifndef TCL_WIDE_INT_IS_LONG +# define OUT_OF_RANGE(x) \ + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) +# define OUT_OF_URANGE(x) \ + (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) + + /* + * Perform the result-buffer overflow check manually. + * + * Note that ino_t/ino64_t is unsigned... + */ + + if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) + || OUT_OF_RANGE(buf.st_blocks)) { + errno = EOVERFLOW; + return -1; + } + +# undef OUT_OF_RANGE +# undef OUT_OF_URANGE +#endif /* !TCL_WIDE_INT_IS_LONG */ + + /* + * Copy across all supported fields, with possible type + * coercions on those fields that change between the normal + * and lf64 versions of the stat structure (on Solaris at + * least.) This is slow when the structure sizes coincide, + * but that's what you get for using an obsolete interface. + */ + + oldStyleBuf->st_mode = buf.st_mode; + oldStyleBuf->st_ino = (ino_t) buf.st_ino; + oldStyleBuf->st_dev = buf.st_dev; + oldStyleBuf->st_rdev = buf.st_rdev; + oldStyleBuf->st_nlink = buf.st_nlink; + oldStyleBuf->st_uid = buf.st_uid; + oldStyleBuf->st_gid = buf.st_gid; + oldStyleBuf->st_size = (off_t) buf.st_size; + oldStyleBuf->st_atime = buf.st_atime; + oldStyleBuf->st_mtime = buf.st_mtime; + oldStyleBuf->st_ctime = buf.st_ctime; + oldStyleBuf->st_blksize = buf.st_blksize; + oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; + } return ret; } @@ -1150,7 +1198,7 @@ Tcl_FSEvalFile(interp, pathPtr) * will be performed on this name. */ { int result, length; - struct stat statBuf; + Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; char *string; @@ -1334,11 +1382,12 @@ Tcl_PosixError(interp) int Tcl_FSStat(pathPtr, buf) Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ - struct stat *buf; /* Filled with results of stat call. */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS StatProc *statProcPtr; + struct stat oldStyleStatBuffer; int retVal = -1; char *path; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); @@ -1356,11 +1405,28 @@ Tcl_FSStat(pathPtr, buf) Tcl_MutexLock(&obsoleteFsHookMutex); statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { - retVal = (*statProcPtr->proc)(path, buf); + retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); statProcPtr = statProcPtr->nextPtr; } Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != -1) { + /* + * Note that EOVERFLOW is not a problem here, and these + * assignments should all be widening (if not identity.) + */ + buf->st_mode = oldStyleStatBuffer.st_mode; + buf->st_ino = (Tcl_WideUInt) Tcl_LongAsWide(oldStyleStatBuffer.st_ino); + buf->st_dev = oldStyleStatBuffer.st_dev; + buf->st_rdev = oldStyleStatBuffer.st_rdev; + buf->st_nlink = oldStyleStatBuffer.st_nlink; + buf->st_uid = oldStyleStatBuffer.st_uid; + buf->st_gid = oldStyleStatBuffer.st_gid; + buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); + buf->st_atime = oldStyleStatBuffer.st_atime; + buf->st_mtime = oldStyleStatBuffer.st_mtime; + buf->st_ctime = oldStyleStatBuffer.st_ctime; + buf->st_blksize = oldStyleStatBuffer.st_blksize; + buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ @@ -1398,7 +1464,7 @@ Tcl_FSStat(pathPtr, buf) int Tcl_FSLstat(pathPtr, buf) Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ - struct stat *buf; /* Filled with results of stat call. */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -2165,7 +2231,7 @@ Tcl_FSChdir(pathPtr) retVal = (*proc)(pathPtr); } else { /* Fallback on stat-based implementation */ - struct stat buf; + Tcl_StatBuf buf; /* If the file can be stat'ed and is a directory and * is readable, then we can chdir. */ if ((Tcl_FSStat(pathPtr, &buf) == 0) @@ -3057,7 +3123,7 @@ TclCrossFilesystemCopy(interp, source, target) /* This is very strange, we checked this above */ Tcl_Close(interp, out); } else { - struct stat sourceStatBuf; + Tcl_StatBuf sourceStatBuf; struct utimbuf tval; /* * Copy it synchronously. We might wish to add an diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index c9baf3c..4b5dfe4 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -10,10 +10,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.12 2002/01/17 04:37:33 dgp Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.13 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" +#include "tclPort.h" /* * Prototypes for procedures defined later in this file: @@ -21,6 +22,10 @@ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); +static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *dupPtr)); +static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * The structure below defines the index Tcl object type by means of @@ -29,21 +34,44 @@ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ObjType tclIndexType = { "index", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + FreeIndex, /* freeIntRepProc */ + DupIndex, /* dupIntRepProc */ + UpdateStringOfIndex, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; /* - * DKF - Just noting that the data format used in objects with the - * above type is that the ptr1 field will contain a pointer to the - * table that the last lookup was performed in, and the ptr2 field - * will contain the sizeof(char) offset of the string within that - * table. Note that we assume that each table is only ever called - * with a single offset, but this is a pretty safe assumption in - * practise... + * The definition of the internal representation of the "index" + * object; The internalRep.otherValuePtr field of an object of "index" + * type will be a pointer to one of these structures. + * + * Keep this structure declaration in sync with tclTestObj.c + */ + +typedef struct { + VOID *tablePtr; /* Pointer to the table of strings */ + int offset; /* Offset between table entries */ + int index; /* Selected index into table. */ +} IndexRep; + +/* + * The following macros greatly simplify moving through a table... + * + * SunPro CC prohibits address arithmetic on (void *) values, so + * use (char *) on that platform/build-environment instead. */ +#ifdef __sparc +# define STRING_AT(table, offset, index) \ + (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index))))) +#else +# define STRING_AT(table, offset, index) \ + (*((CONST char * CONST *)(((VOID *)(table)) + (ptrdiff_t)((offset) * (index))))) +#endif +#define NEXT_ENTRY(table, offset) \ + (&(STRING_AT(table, offset, 1))) +#define EXPAND_OF(indexRep) \ + STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) + /* *---------------------------------------------------------------------- @@ -91,11 +119,17 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) * is cached). */ - if ((objPtr->typePtr == &tclIndexType) - && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { - *indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2) - / sizeof(char *); - return TCL_OK; + if (objPtr->typePtr == &tclIndexType) { + IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + /* + * Here's hoping we don't get hit by unfortunate packing + * constraints on odd platforms like a Cray PVP... + */ + if (indexRep->tablePtr == (VOID *)tablePtr && + indexRep->offset == sizeof(char *)) { + *indexPtr = indexRep->index; + return TCL_OK; + } } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); @@ -150,15 +184,18 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, CONST char *p2; CONST char * CONST *entryPtr; Tcl_Obj *resultPtr; + IndexRep *indexRep; /* * See if there is a valid cached result from a previous lookup. */ - if ((objPtr->typePtr == &tclIndexType) - && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { - *indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2) / offset; - return TCL_OK; + if (objPtr->typePtr == &tclIndexType) { + indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { + *indexPtr = indexRep->index; + return TCL_OK; + } } /* @@ -178,15 +215,21 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, goto error; } + /* + * Scan the table looking for one of: + * - An exact match (always preferred) + * - A single abbreviation (allowed depending on flags) + * - Several abbreviations (never allowed, but overridden by exact match) + */ for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; - entryPtr = (CONST char **) ((char *)entryPtr + offset), i++) { + entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { - if (*p1 == 0) { + if (*p1 == '\0') { index = i; goto done; } } - if (*p1 == 0) { + if (*p1 == '\0') { /* * The value is an abbreviation for this entry. Continue * checking other entries to make sure it's unique. If we @@ -199,36 +242,51 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, index = i; } } + /* + * Check if we were instructed to disallow abbreviations. + */ if ((flags & TCL_EXACT) || (numAbbrev != 1)) { goto error; } done: - if ((objPtr->typePtr != NULL) - && (objPtr->typePtr->freeIntRepProc != NULL)) { - objPtr->typePtr->freeIntRepProc(objPtr); - } - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr; /* - * Make sure to account for offsets != sizeof(char *). [Bug 5153] + * Cache the found representation. Note that we want to avoid + * allocating a new internal-rep if at all possible since that is + * potentially a slow operation. */ - objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) (index * offset); - objPtr->typePtr = &tclIndexType; + if (objPtr->typePtr == &tclIndexType) { + indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + } else { + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + objPtr->internalRep.otherValuePtr = (VOID *) indexRep; + objPtr->typePtr = &tclIndexType; + } + indexRep->tablePtr = tablePtr; + indexRep->offset = offset; + indexRep->index = index; + *indexPtr = index; return TCL_OK; error: if (interp != NULL) { + /* + * Produce a fancy error message. + */ int count; resultPtr = Tcl_GetObjResult(interp); Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, "\": must be ", *tablePtr, (char *) NULL); - for (entryPtr = (CONST char **)((char *)tablePtr + offset), count = 0; + for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; *entryPtr != NULL; - entryPtr = (CONST char **)((char *)entryPtr + offset), - count++) { - if ((*((char **) ((char *) entryPtr + offset))) == NULL) { + entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { + if (*NEXT_ENTRY(entryPtr, offset) == NULL) { Tcl_AppendStringsToObj(resultPtr, (count > 0) ? ", or " : " or ", *entryPtr, (char *) NULL); @@ -275,6 +333,94 @@ SetIndexFromAny(interp, objPtr) /* *---------------------------------------------------------------------- * + * UpdateStringOfIndex -- + * + * This procedure is called to convert a Tcl object from index + * internal form to its string form. No abbreviation is ever + * generated. + * + * Results: + * None. + * + * Side effects: + * The string representation of the object is updated. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfIndex(objPtr) + Tcl_Obj *objPtr; +{ + IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + register char *buf; + register unsigned len; + register CONST char *indexStr = EXPAND_OF(indexRep); + + len = strlen(indexStr); + buf = (char *) ckalloc(len + 1); + memcpy(buf, indexStr, len+1); + objPtr->bytes = buf; + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * DupIndex -- + * + * This procedure is called to copy the internal rep of an index + * Tcl object from to another object. + * + * Results: + * None. + * + * Side effects: + * The internal representation of the target object is updated + * and the type is set. + * + *---------------------------------------------------------------------- + */ + +static void +DupIndex(srcPtr, dupPtr) + Tcl_Obj *srcPtr, *dupPtr; +{ + IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr; + IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + + memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); + dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep; + dupPtr->typePtr = &tclIndexType; +} + +/* + *---------------------------------------------------------------------- + * + * FreeIndex -- + * + * This procedure is called to delete the internal rep of an index + * Tcl object. + * + * Results: + * None. + * + * Side effects: + * The internal representation of the target object is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +FreeIndex(objPtr) + Tcl_Obj *objPtr; +{ + ckfree((char *) objPtr->internalRep.otherValuePtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_WrongNumArgs -- * * This procedure generates a "wrong # args" error message in an @@ -309,8 +455,8 @@ Tcl_WrongNumArgs(interp, objc, objv, message) * message may be NULL. */ { Tcl_Obj *objPtr; - char **tablePtr; - int i, offset; + int i; + register IndexRep *indexRep; objPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); @@ -322,11 +468,8 @@ Tcl_WrongNumArgs(interp, objc, objv, message) */ if (objv[i]->typePtr == &tclIndexType) { - tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1); - offset = ((int) objv[i]->internalRep.twoPtrValue.ptr2); - Tcl_AppendStringsToObj(objPtr, - *((char **)(((char *)tablePtr)+offset)), - (char *) NULL); + indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); } else { Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), (char *) NULL); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 67bd6f7..912c596 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.45 2002/01/27 11:09:30 das Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.46 2002/02/15 14:28:49 dkf Exp $ library tcl @@ -43,7 +43,7 @@ declare 3 generic { # int TclChdir(Tcl_Interp *interp, char *dirName) # } declare 5 {unix win} { - int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \ + int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) } declare 6 generic { @@ -53,20 +53,20 @@ declare 7 generic { int TclCopyAndCollapse(int count, CONST char *src, char *dst) } declare 8 generic { - int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \ + int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } # TclCreatePipeline unofficially exported for use by BLT. declare 9 {unix win} { - int TclCreatePipeline(Tcl_Interp *interp, int argc, CONST char **argv, \ - Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, \ + int TclCreatePipeline(Tcl_Interp *interp, int argc, CONST char **argv, + Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr) } declare 10 generic { int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, - CONST char *procName, + CONST char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr) } declare 11 generic { @@ -76,7 +76,7 @@ declare 12 generic { void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr) } declare 13 generic { - int TclDoGlob(Tcl_Interp *interp, char *separators, \ + int TclDoGlob(Tcl_Interp *interp, char *separators, Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) } declare 14 generic { @@ -106,8 +106,8 @@ declare 16 generic { # int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) #} declare 22 generic { - int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \ - int listLength, CONST char **elementPtr, CONST char **nextPtr, \ + int TclFindElement(Tcl_Interp *interp, CONST char *listStr, + int listLength, CONST char **elementPtr, CONST char **nextPtr, int *sizePtr, int *bracePtr) } declare 23 generic { @@ -124,14 +124,14 @@ declare 25 generic { # char * TclGetCwd(Tcl_Interp *interp) # } declare 27 generic { - int TclGetDate(char *p, unsigned long now, long zone, \ + int TclGetDate(char *p, unsigned long now, long zone, unsigned long *timePtr) } declare 28 generic { Tcl_Channel TclpGetDefaultStdChannel(int type) } declare 29 generic { - Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \ + Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, int localIndex, Tcl_Obj *elemPtr, int flags) } # Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: @@ -142,18 +142,18 @@ declare 31 generic { char * TclGetExtension(char *name) } declare 32 generic { - int TclGetFrame(Tcl_Interp *interp, CONST char *str, \ + int TclGetFrame(Tcl_Interp *interp, CONST char *str, CallFrame **framePtrPtr) } declare 33 generic { TclCmdProcType TclGetInterpProc(void) } declare 34 generic { - int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr) } declare 35 generic { - Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \ + Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, int flags) } declare 36 generic { @@ -163,9 +163,9 @@ declare 37 generic { int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName) } declare 38 generic { - int TclGetNamespaceForQualName(Tcl_Interp *interp, CONST char *qualName, \ - Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, \ - Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, \ + int TclGetNamespaceForQualName(Tcl_Interp *interp, CONST char *qualName, + Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, + Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, CONST char **simpleNamePtr) } declare 39 generic { @@ -193,19 +193,19 @@ declare 46 generic { int TclInExit(void) } declare 47 generic { - Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, \ + Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, int localIndex, Tcl_Obj *elemPtr, long incrAmount) } declare 48 generic { - Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, \ + Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, long incrAmount) } declare 49 generic { - Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ + Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) } declare 50 generic { - void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, \ + void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr) } declare 51 generic { @@ -215,11 +215,11 @@ declare 52 generic { int TclInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) } declare 53 generic { - int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, \ + int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) } declare 54 generic { - int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, \ + int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 55 generic { @@ -227,8 +227,8 @@ declare 55 generic { } # Replaced with TclpLoadFile in 8.1: # declare 56 generic { -# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ -# char *sym2, Tcl_PackageInitProc **proc1Ptr, \ +# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, +# char *sym2, Tcl_PackageInitProc **proc1Ptr, # Tcl_PackageInitProc **proc2Ptr) # } # Signature changed to take a length in 8.1: @@ -236,13 +236,13 @@ declare 55 generic { # int TclLooksLikeInt(char *p) # } declare 58 generic { - Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \ - int flags, char *msg, int createPart1, int createPart2, \ + Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, + int flags, char *msg, int createPart1, int createPart2, Var **arrayPtrPtr) } # Replaced by Tcl_FSMatchInDirectory in 8.4 #declare 59 generic { -# int TclpMatchFiles(Tcl_Interp *interp, char *separators, \ +# int TclpMatchFiles(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail) #} declare 60 generic { @@ -255,15 +255,15 @@ declare 62 generic { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } declare 63 generic { - int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, \ + int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 64 generic { - int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ + int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) } declare 65 generic { - int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, \ + int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) } declare 66 generic { @@ -283,7 +283,7 @@ declare 69 generic { # int TclpCopyFile(CONST char *source, CONST char *dest) #} #declare 71 generic { -# int TclpCopyDirectory(CONST char *source, CONST char *dest, \ +# int TclpCopyDirectory(CONST char *source, CONST char *dest, # Tcl_DString *errorPtr) #} #declare 72 generic { @@ -316,14 +316,14 @@ declare 78 generic { #} # Replaced by Tcl_FSOpenFileChannel in 8.4: #declare 80 generic { -# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, \ +# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, # char *modeString, int permissions) #} declare 81 generic { char * TclpRealloc(char *ptr, unsigned int size) } #declare 82 generic { -# int TclpRemoveDirectory(CONST char *path, int recursive, \ +# int TclpRemoveDirectory(CONST char *path, int recursive, # Tcl_DString *errorPtr) #} #declare 83 generic { @@ -331,26 +331,26 @@ declare 81 generic { #} # Removed in 8.1: # declare 84 generic { -# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \ +# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, # ParseValue *pvPtr) # } # declare 85 generic { -# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \ +# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, # char **termPtr, ParseValue *pvPtr) # } # declare 86 generic { -# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \ +# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 generic { # void TclPlatformInit(Tcl_Interp *interp) # } declare 88 generic { - char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \ + char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags) } declare 89 generic { - int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \ + int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd) } # Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): @@ -361,20 +361,20 @@ declare 91 generic { void TclProcCleanupProc(Proc *procPtr) } declare 92 generic { - int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, \ - Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, \ + int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, + Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, CONST char *procName) } declare 93 generic { void TclProcDeleteProc(ClientData clientData) } declare 94 generic { - int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, \ + int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) } # Replaced by Tcl_FSStat in 8.4: #declare 95 generic { -# int TclpStat(CONST char *path, struct stat *buf) +# int TclpStat(CONST char *path, Tcl_StatBuf *buf) #} declare 96 generic { int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName) @@ -386,11 +386,11 @@ declare 98 generic { int TclServiceIdle(void) } declare 99 generic { - Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \ - int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags) + Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags) } declare 100 generic { - Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \ + Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, Tcl_Obj *objPtr, int flags) } declare 101 {unix win} { @@ -400,7 +400,7 @@ declare 102 generic { void TclSetupEnv(Tcl_Interp *interp) } declare 103 generic { - int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \ + int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, int *portPtr) } declare 104 {unix win} { @@ -408,7 +408,7 @@ declare 104 {unix win} { } # Replaced by Tcl_FSStat in 8.4: #declare 105 generic { -# int TclStat(CONST char *path, struct stat *buf) +# int TclStat(CONST char *path, Tcl_StatBuf *buf) #} declare 106 generic { int TclStatDeleteProc(TclStatProc_ *proc) @@ -431,54 +431,54 @@ declare 109 generic { # defined here instead of in tcl.decls since they are not stable yet. declare 111 generic { - void Tcl_AddInterpResolvers(Tcl_Interp *interp, CONST char *name, \ - Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ + void Tcl_AddInterpResolvers(Tcl_Interp *interp, CONST char *name, + Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 generic { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ + int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 generic { - Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name, \ + Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 generic { void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 generic { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ + int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern, int resetListFirst) } declare 116 generic { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name, \ + Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 generic { - Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name, \ + Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 generic { - int Tcl_GetInterpResolvers(Tcl_Interp *interp, CONST char *name, \ + int Tcl_GetInterpResolvers(Tcl_Interp *interp, CONST char *name, Tcl_ResolverInfo *resInfo) } declare 119 generic { - int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ + int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo) } declare 120 generic { - Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, char *name, \ + Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 121 generic { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ + int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern) } declare 122 generic { Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 generic { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, \ + void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 generic { @@ -488,26 +488,26 @@ declare 125 generic { Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp) } declare 126 generic { - void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, \ + void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 generic { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ + int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern, int allowOverwrite) } declare 128 generic { void Tcl_PopCallFrame(Tcl_Interp* interp) } declare 129 generic { - int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, \ + int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame) } declare 130 generic { int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, CONST char *name) } declare 131 generic { - void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ - Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ + void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, + Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 generic { @@ -517,7 +517,7 @@ declare 133 generic { struct tm * TclpGetDate(TclpTime_t time, int useGMT) } declare 134 generic { - size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \ + size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, CONST struct tm *t) } declare 135 generic { @@ -533,8 +533,8 @@ declare 138 generic { CONST char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) } #declare 139 generic { -# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ -# char *sym2, Tcl_PackageInitProc **proc1Ptr, \ +# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, +# char *sym2, Tcl_PackageInitProc **proc1Ptr, # Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) #} declare 140 generic { @@ -545,15 +545,15 @@ declare 141 generic { CONST char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 generic { - int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData) } declare 143 generic { - int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, \ + int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) } declare 144 generic { - void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, \ + void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, int index) } declare 145 generic { @@ -582,7 +582,7 @@ declare 150 generic { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 generic { - void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, \ + void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, int *endPtr) } @@ -599,12 +599,12 @@ declare 153 generic { # Tcl_Interp *interp, int argc, char **argv) #} #declare 155 generic { -# int TclTestChannelEventCmd(ClientData clientData, \ +# int TclTestChannelEventCmd(ClientData clientData, # Tcl_Interp *interp, int argc, char **argv) #} declare 156 generic { - void TclRegError (Tcl_Interp *interp, CONST char *msg, \ + void TclRegError (Tcl_Interp *interp, CONST char *msg, int status) } declare 157 generic { @@ -617,13 +617,13 @@ declare 159 generic { CONST char *TclGetStartupScriptFileName(void) } #declare 160 generic { -# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \ +# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types) #} # new in 8.3.2/8.4a2 declare 161 generic { - int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, \ + int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr) } declare 162 generic { @@ -654,10 +654,8 @@ declare 165 generic { # New function due to TIP #33 declare 166 generic { - int TclListObjSetElement( Tcl_Interp* interp, - Tcl_Obj* listPtr, - int index, - Tcl_Obj* valuePtr ) + int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, + int index, Tcl_Obj *valuePtr) } # VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) @@ -701,7 +699,7 @@ declare 5 mac { int FSpSetDefaultDir(FSSpecPtr theSpec) } declare 6 mac { - OSErr FSpFindFolder(short vRefNum, OSType folderType, \ + OSErr FSpFindFolder(short vRefNum, OSType folderType, Boolean createFolder, FSSpec *spec) } declare 7 mac { @@ -713,15 +711,15 @@ declare 7 mac { # however. The first set are from the MoreFiles package. declare 8 mac { - pascal OSErr FSpGetDirectoryIDTcl(CONST FSSpec *spec, long *theDirID, \ + pascal OSErr FSpGetDirectoryIDTcl(CONST FSSpec *spec, long *theDirID, Boolean *isDirectory) } declare 9 mac { - pascal short FSpOpenResFileCompatTcl(CONST FSSpec *spec, \ + pascal short FSpOpenResFileCompatTcl(CONST FSSpec *spec, SignedByte permission) } declare 10 mac { - pascal void FSpCreateResFileCompatTcl(CONST FSSpec *spec, OSType creator, \ + pascal void FSpCreateResFileCompatTcl(CONST FSSpec *spec, OSType creator, OSType fileType, ScriptCode scriptTag) } @@ -732,7 +730,7 @@ declare 11 mac { int FSpLocationFromPath(int length, CONST char *path, FSSpecPtr theSpec) } declare 12 mac { - OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length, \ + OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length, Handle *fullPath) } @@ -760,7 +758,7 @@ declare 19 mac { int TclMacTimerExpired(void *timerToken) } declare 20 mac { - int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, \ + int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, int insert) } declare 21 mac { @@ -793,11 +791,11 @@ declare 1 win { void TclWinConvertWSAError(DWORD errCode) } declare 2 win { - struct servent * TclWinGetServByName(CONST char *nm, \ + struct servent * TclWinGetServByName(CONST char *nm, CONST char *proto) } declare 3 win { - int TclWinGetSockOpt(SOCKET s, int level, int optname, \ + int TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval, int FAR *optlen) } declare 4 win { @@ -811,7 +809,7 @@ declare 6 win { u_short TclWinNToHS(u_short ns) } declare 7 win { - int TclWinSetSockOpt(SOCKET s, int level, int optname, \ + int TclWinSetSockOpt(SOCKET s, int level, int optname, CONST char FAR * optval, int optlen) } declare 8 win { @@ -834,15 +832,15 @@ declare 12 win { int TclpCloseFile(TclFile file) } declare 13 win { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 14 win { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 15 win { - int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv, \ - TclFile inputFile, TclFile outputFile, TclFile errorFile, \ + int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv, + TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } # Signature changed in 8.1: @@ -902,21 +900,20 @@ declare 1 unix { int TclpCloseFile(TclFile file) } declare 2 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 3 unix { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv, \ - TclFile inputFile, TclFile outputFile, TclFile errorFile, \ + int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv, + TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } # Signature changed in 8.1: # declare 5 unix { -# TclFile TclpCreateTempFile(char *contents, -# Tcl_DString *namePtr) +# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) # } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) diff --git a/generic/tclInt.h b/generic/tclInt.h index dcb573c..209991d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.79 2002/02/10 20:36:34 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.80 2002/02/15 14:28:49 dkf Exp $ */ #ifndef _TCLINT @@ -28,12 +28,12 @@ * needed by stdlib.h in some configurations. */ -#include <stdio.h> - #ifndef _TCL #include "tcl.h" #endif +#include <stdio.h> + #include <ctype.h> #ifdef NO_LIMITS_H # include "../compat/limits.h" @@ -1190,7 +1190,7 @@ typedef struct Interp { /* * Information related to procedures and variables. See tclProc.c - * and tclvar.c for usage. + * and tclVar.c for usage. */ int numLevels; /* Keeps track of how many nested calls to @@ -1595,6 +1595,9 @@ extern Tcl_ObjType tclStringType; extern Tcl_ObjType tclArraySearchType; extern Tcl_ObjType tclIndexType; extern Tcl_ObjType tclNsNameType; +#ifndef TCL_WIDE_INT_IS_LONG +extern Tcl_ObjType tclWideIntType; +#endif /* * Variables denoting the hash key types defined in the core. @@ -1790,7 +1793,7 @@ EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename, int mode)); EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, - struct stat *buf)); + Tcl_StatBuf *buf)); EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void)); @@ -1859,7 +1862,7 @@ EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr)); EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj*pathPtr)); -EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); +EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *modeString, int permissions)); @@ -1867,8 +1870,7 @@ EXTERN void TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *, format)); EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, Tcl_DString *linkPtr)); -EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, - unsigned int size)); +EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, unsigned int size)); EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file)); EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 0b39602..3c7359c 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.37 2002/01/25 22:01:31 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.38 2002/02/15 14:28:49 dkf Exp $ */ #ifndef _TCLINTDECLS @@ -494,9 +494,9 @@ EXTERN void TclExpandCodeArray _ANSI_ARGS_((void * envPtr)); /* 165 */ EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); /* 166 */ -EXTERN int TclListObjSetElement _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* listPtr, int index, - Tcl_Obj* valuePtr)); +EXTERN int TclListObjSetElement _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * listPtr, + int index, Tcl_Obj * valuePtr)); /* 167 */ EXTERN void TclSetStartupScriptPath _ANSI_ARGS_(( Tcl_Obj * pathPtr)); @@ -705,7 +705,7 @@ typedef struct TclIntStubs { void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */ void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */ void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */ - int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* listPtr, int index, Tcl_Obj* valuePtr)); /* 166 */ + int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */ void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */ Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */ } TclIntStubs; diff --git a/generic/tclInterp.c b/generic/tclInterp.c index da3ab66..b7d07cb 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -9,12 +9,12 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.10 2002/01/17 04:37:33 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.11 2002/02/15 14:28:49 dkf Exp $ */ -#include <stdio.h> #include "tclInt.h" #include "tclPort.h" +#include <stdio.h> /* * Counter for how many aliases were created (global) diff --git a/generic/tclLink.c b/generic/tclLink.c index 3066557..8d7a3fe 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.4 2002/01/25 20:40:55 dgp Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.5 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -26,7 +26,7 @@ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ - char *varName; /* Name of variable (must be global). This + Tcl_Obj *varName; /* Name of variable (must be global). This * is needed during trace callbacks, since * the actual variable may be aliased at * that time via upvar. */ @@ -35,6 +35,7 @@ typedef struct Link { union { int i; double d; + Tcl_WideInt w; } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below @@ -61,8 +62,7 @@ typedef struct Link { static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); -static char * StringValue _ANSI_ARGS_((Link *linkPtr, - char *buffer)); +static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr)); /* *---------------------------------------------------------------------- @@ -96,13 +96,12 @@ Tcl_LinkVar(interp, varName, addr, type) * OR'ed in. */ { Link *linkPtr; - char buffer[TCL_DOUBLE_SPACE]; int code; linkPtr = (Link *) ckalloc(sizeof(Link)); linkPtr->interp = interp; - linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); - strcpy(linkPtr->varName, varName); + linkPtr->varName = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; if (type & TCL_LINK_READ_ONLY) { @@ -110,9 +109,9 @@ Tcl_LinkVar(interp, varName, addr, type) } else { linkPtr->flags = 0; } - if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), + if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); return TCL_ERROR; } @@ -120,7 +119,7 @@ Tcl_LinkVar(interp, varName, addr, type) |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); if (code != TCL_OK) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } return code; @@ -159,7 +158,7 @@ Tcl_UnlinkVar(interp, varName) Tcl_UntraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } @@ -188,7 +187,6 @@ Tcl_UpdateLinkedVar(interp, varName) char *varName; /* Name of global variable that is linked. */ { Link *linkPtr; - char buffer[TCL_DOUBLE_SPACE]; int savedFlag; linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, @@ -198,7 +196,7 @@ Tcl_UpdateLinkedVar(interp, varName) } savedFlag = linkPtr->flags & LINK_BEING_UPDATED; linkPtr->flags |= LINK_BEING_UPDATED; - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } @@ -233,11 +231,10 @@ LinkTraceProc(clientData, interp, name1, name2, flags) int flags; /* Miscellaneous additional information. */ { Link *linkPtr = (Link *) clientData; - int changed; - char buffer[TCL_DOUBLE_SPACE]; + int changed, valueLength; CONST char *value; char **pp, *result; - Tcl_Obj *objPtr; + Tcl_Obj *objPtr, *valueObj; /* * If the variable is being unset, then just re-create it (with a @@ -246,14 +243,14 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if (flags & TCL_INTERP_DESTROYED) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY - |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, (ClientData) linkPtr); + Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES + |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); } return NULL; } @@ -276,21 +273,24 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_READS) { switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; - break; - case TCL_LINK_DOUBLE: - changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; - break; - case TCL_LINK_STRING: - changed = 1; - break; - default: - return "internal error: bad linked variable type"; + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; + break; + case TCL_LINK_WIDE_INT: + changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w; + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return "internal error: bad linked variable type"; } if (changed) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); } return NULL; @@ -306,12 +306,12 @@ LinkTraceProc(clientData, interp, name1, name2, flags) */ if (linkPtr->flags & LINK_READ_ONLY) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "linked variable is read-only"; } - value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); - if (value == NULL) { + valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); + if (valueObj == NULL) { /* * This shouldn't ever happen. */ @@ -324,48 +324,67 @@ LinkTraceProc(clientData, interp, name1, name2, flags) result = NULL; switch (linkPtr->type) { - case TCL_LINK_INT: - if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have integer value"; - goto end; - } - *(int *)(linkPtr->addr) = linkPtr->lastValue.i; - break; - case TCL_LINK_DOUBLE: - if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have real value"; - goto end; - } - *(double *)(linkPtr->addr) = linkPtr->lastValue.d; - break; - case TCL_LINK_BOOLEAN: - if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have boolean value"; - goto end; - } - *(int *)(linkPtr->addr) = linkPtr->lastValue.i; - break; - case TCL_LINK_STRING: - pp = (char **)(linkPtr->addr); - if (*pp != NULL) { - ckfree(*pp); - } - *pp = (char *) ckalloc((unsigned) (strlen(value) + 1)); - strcpy(*pp, value); - break; - default: - result = "internal error: bad linked variable type"; + case TCL_LINK_INT: + if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have integer value"; + goto end; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + + case TCL_LINK_WIDE_INT: + if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have integer value"; + goto end; + } + *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w; + break; + + case TCL_LINK_DOUBLE: + if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have real value"; + goto end; + } + *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + break; + + case TCL_LINK_BOOLEAN: + if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have boolean value"; + goto end; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + + case TCL_LINK_STRING: + value = Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; + pp = (char **)(linkPtr->addr); + if (*pp != NULL) { + ckfree(*pp); + } + *pp = (char *) ckalloc((unsigned) valueLength); + memcpy(*pp, value, (unsigned) valueLength); + break; + + default: + return "internal error: bad linked variable type"; } end: Tcl_DecrRefCount(objPtr); @@ -375,13 +394,13 @@ LinkTraceProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * StringValue -- + * ObjValue -- * - * Converts the value of a C variable to a string for use in a + * Converts the value of a C variable to a Tcl_Obj* for use in a * Tcl variable to which it is linked. * * Results: - * The return value is a pointer to a string that represents + * The return value is a pointer to a Tcl_Obj that represents * the value of the C variable given by linkPtr. * * Side effects: @@ -390,42 +409,37 @@ LinkTraceProc(clientData, interp, name1, name2, flags) *---------------------------------------------------------------------- */ -static char * -StringValue(linkPtr, buffer) +static Tcl_Obj * +ObjValue(linkPtr) Link *linkPtr; /* Structure describing linked variable. */ - char *buffer; /* Small buffer to use for converting - * values. Must have TCL_DOUBLE_SPACE - * bytes or more. */ { char *p; switch (linkPtr->type) { - case TCL_LINK_INT: - linkPtr->lastValue.i = *(int *)(linkPtr->addr); - TclFormatInt(buffer, linkPtr->lastValue.i); - return buffer; - case TCL_LINK_DOUBLE: - linkPtr->lastValue.d = *(double *)(linkPtr->addr); - Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer); - return buffer; - case TCL_LINK_BOOLEAN: - linkPtr->lastValue.i = *(int *)(linkPtr->addr); - if (linkPtr->lastValue.i != 0) { - return "1"; - } - return "0"; - case TCL_LINK_STRING: - p = *(char **)(linkPtr->addr); - if (p == NULL) { - return "NULL"; - } - return p; - } + case TCL_LINK_INT: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + return Tcl_NewIntObj(linkPtr->lastValue.i); + case TCL_LINK_WIDE_INT: + linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr); + return Tcl_NewWideIntObj(linkPtr->lastValue.w); + case TCL_LINK_DOUBLE: + linkPtr->lastValue.d = *(double *)(linkPtr->addr); + return Tcl_NewDoubleObj(linkPtr->lastValue.d); + case TCL_LINK_BOOLEAN: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + case TCL_LINK_STRING: + p = *(char **)(linkPtr->addr); + if (p == NULL) { + return Tcl_NewStringObj("NULL", 4); + } + return Tcl_NewStringObj(p, -1); /* * This code only gets executed if the link type is unknown * (shouldn't ever happen). */ - - return "??"; + default: + return Tcl_NewStringObj("??", 2); + } } diff --git a/generic/tclObj.c b/generic/tclObj.c index c895237..c5f7f12 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.28 2002/01/25 21:36:09 dgp Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.29 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -63,6 +63,11 @@ static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#ifndef TCL_WIDE_INT_IS_LONG +static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#endif /* * Prototypes for the array hash key methods. @@ -121,6 +126,16 @@ Tcl_ObjType tclIntType = { SetIntFromAny /* setFromAnyProc */ }; +#ifndef TCL_WIDE_INT_IS_LONG +Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ +}; +#endif + /* * The structure below defines the Tcl obj hash key type. */ @@ -218,6 +233,9 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_RegisterObjType(&tclWideIntType); +#endif Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclByteCodeType); @@ -826,11 +844,11 @@ Tcl_GetString(objPtr) char * Tcl_GetStringFromObj(objPtr, lengthPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ - register int *lengthPtr; /* If non-NULL, the location where the - * string rep's byte array length should be - * stored. If NULL, no length is stored. */ + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should + * be returned. */ + register int *lengthPtr; /* If non-NULL, the location where the string + * rep's byte array length should * be stored. + * If NULL, no length is stored. */ { if (objPtr->bytes == NULL) { if (objPtr->typePtr->updateStringProc == NULL) { @@ -1092,7 +1110,6 @@ SetBooleanFromAny(interp, objPtr) char lowerCase[10]; int newBool, length; register int i; - double dbl; /* * Get the string representation. Make it up-to-date if necessary. @@ -1148,6 +1165,24 @@ SetBooleanFromAny(interp, objPtr) goto badBoolean; } } else { + double dbl; +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt wide = strtoll(string, &end, 0); + if (end != string) { + /* + * Make sure the string has no garbage after the end of + * the wide int. + */ + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end == (string+length)) { + newBool = (wide != Tcl_LongAsWide(0)); + goto goodBoolean; + } + } +#endif /* * Still might be a string containing the characters representing an * int or double that wasn't handled above. This would be a string @@ -1182,6 +1217,7 @@ SetBooleanFromAny(interp, objPtr) * Tcl_GetStringFromObj, to use that old internalRep. */ + goodBoolean: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); } @@ -2060,6 +2096,380 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) /* *---------------------------------------------------------------------- * + * SetWideIntFromAny -- + * + * Attempt to generate an integer internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard object Tcl result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If no error occurs, an int is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static int +SetWideIntFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + int length; + register char *p; + Tcl_WideInt newWide; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an int. We use an implementation here + * that doesn't report errors in interp if interp is NULL. Note: use + * strtoull instead of strtoll for integer conversions to allow full-size + * unsigned numbers, but don't depend on strtoull to handle sign + * characters; it won't in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ + /* Empty loop body. */ + } + if (*p == '-') { + p++; + newWide = -((Tcl_WideInt)strtoull(p, &end, 0)); + } else if (*p == '+') { + p++; + newWide = strtoull(p, &end, 0); + } else { + newWide = strtoull(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected integer but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + TclCheckBadOctal(interp, string); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the int. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ + end++; + } + if (end != (string+length)) { + goto badInteger; + } + + /* + * The conversion to int succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = newWide; + objPtr->typePtr = &tclWideIntType; + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfWideInt -- + * + * Update the string representation for a wide integer object. + * Note: This procedure does not free 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 wideInt-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static void +UpdateStringOfWideInt(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE+2]; + register unsigned len; + register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); + len = strlen(buffer); + objPtr->bytes = ckalloc((unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewWideIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling + * the debugging procedure Tcl_DbNewWideIntObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewWideIntObj result in a call to one of the two + * Tcl_NewWideIntObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewWideIntObj + +Tcl_Obj * +Tcl_NewWideIntObj(wideValue) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ +{ + return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewWideIntObj(wideValue) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + return Tcl_NewLongObj(wideValue); +#else + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif /* TCL_WIDE_INT_IS_LONG */ +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewWideIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewWideIntObj to create new wide integer end up calling + * the debugging procedure Tcl_DbNewWideIntObj instead. We + * provide two implementations of Tcl_DbNewWideIntObj so that + * whether the Tcl core is compiled to do memory debugging of the + * core is independent of whether a client requests debugging for + * itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, + * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file + * name and line number from its caller. This simplifies + * debugging since then the checkmem command will report the + * caller's file name and line number when reporting objects that + * haven't been freed. + * + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, + * this procedure just returns the result of calling Tcl_NewWideIntObj. + * + * Results: + * The newly created wide integer object is returned. This object + * will have an invalid string representation. The returned object has + * ref count 0. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewWideIntObj(wideValue, file, line) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ + 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. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + return Tcl_DbNewLongObj(wideValue, file, line); +#else + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewWideIntObj(wideValue, file, line) + register Tcl_WideInt wideValue; /* Long integer used to initialize + * the new object. */ + 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_NewWideIntObj(wideValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetWideIntObj -- + * + * Modify an object to be a wide integer object and to have the + * specified wide integer value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetWideIntObj(objPtr, wideValue) + register Tcl_Obj *objPtr; /* Object w. internal rep to init. */ + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the object's value. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_SetLongObj(objPtr, wideValue); +#else + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetWideIntObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + Tcl_InvalidateStringRep(objPtr); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetWideIntFromObj -- + * + * Attempt to return a wide integer from the Tcl object "objPtr". If + * the object is not already a wide int object, an attempt will be made + * to convert it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int object, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* Object from which to get a wide int. */ + register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + /* + * Next line is type-safe because we only do this when long = Tcl_WideInt + */ + return Tcl_GetLongFromObj(interp, objPtr, wideIntPtr); +#else + register int result; + + if (objPtr->typePtr == &tclWideIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } + result = SetWideIntFromAny(interp, objPtr); + if (result == TCL_OK) { + *wideIntPtr = objPtr->internalRep.wideValue; + } + return result; +#endif +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index defdecf..f7d0428 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParseExpr.c,v 1.11 2001/12/06 10:59:17 dkf Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.12 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -1579,7 +1579,11 @@ GetLexeme(infoPtr) startsWithDigit = isdigit(UCHAR(c)); /* INTL: digit */ if (startsWithDigit && TclLooksLikeInt(src, -1)) { errno = 0; +#ifdef TCL_WIDE_INT_IS_LONG (void) strtoul(src, &termPtr, 0); +#else + (void) strtoull(src, &termPtr, 0); +#endif if (errno == ERANGE) { if (interp != NULL) { char *s = "integer value too large to represent"; diff --git a/generic/tclPipe.c b/generic/tclPipe.c index dcfabdf..5365047 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPipe.c,v 1.5 2002/01/25 20:40:55 dgp Exp $ + * RCS: @(#) $Id: tclPipe.c,v 1.6 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -372,7 +372,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) int count; Tcl_Obj *objPtr; - Tcl_Seek(errorChan, 0L, SEEK_SET); + Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); objPtr = Tcl_NewObj(); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { diff --git a/generic/tclPort.h b/generic/tclPort.h index 70281a2..930ae1d 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPort.h,v 1.5 1999/05/25 01:00:27 stanton Exp $ + * RCS: @(#) $Id: tclPort.h,v 1.6 2002/02/15 14:28:49 dkf Exp $ */ #ifndef _TCLPORT @@ -22,10 +22,22 @@ # include "../win/tclWinPort.h" #else # if defined(MAC_TCL) -# include "tclMacPort.h" -# else -# include "../unix/tclUnixPort.h" -# endif +# include "tclMacPort.h" +# else +# include "../unix/tclUnixPort.h" +# endif #endif +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(LLONG_MIN) +# ifdef LLONG_BIT +# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1))) +# else +/* Assume we're on a system with a 64-bit 'long long' type */ +# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63)) +# endif +/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */ +# define LLONG_MAX (~LLONG_MIN) +#endif + + #endif /* _TCLPORT */ diff --git a/generic/tclScan.c b/generic/tclScan.c index d631116..9eb60e7 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -8,10 +8,14 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.10 2002/02/08 09:33:24 hobbs Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.11 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" +/* + * For strtoll() and strtoull() declarations on some platforms... + */ +#include "tclPort.h" /* * Flag values used by Tcl_ScanObjCmd. @@ -29,6 +33,7 @@ #define SCAN_PTOK 0x100 /* Decimal point is allowed. */ #define SCAN_EXPOK 0x200 /* An exponent is allowed. */ +#define SCAN_LONGER 0x400 /* Asked for a wide value. */ /* * The following structure contains the information associated with @@ -270,6 +275,7 @@ ValidateFormat(interp, format, numVars, totalSubs) int staticAssign[STATIC_LIST_SIZE]; int *nassign = staticAssign; int objIndex, xpgSize, nspace = STATIC_LIST_SIZE; + char buf[TCL_UTF_MAX+1]; /* * Initialize an array that records the number of times a variable @@ -359,10 +365,16 @@ ValidateFormat(interp, format, numVars, totalSubs) } /* - * Ignore size specifier. + * Handle any size specifier. */ - if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + switch (ch) { + case 'l': + case 'L': +#ifndef TCL_WIDE_INT_IS_LONG + flags |= SCAN_LONGER; +#endif + case 'h': format += Tcl_UtfToUniChar(format, &ch); } @@ -375,24 +387,45 @@ ValidateFormat(interp, format, numVars, totalSubs) */ switch (ch) { + case 'c': + if (flags & SCAN_WIDTH) { + Tcl_SetResult(interp, + "field width may not be specified in %c conversion", + TCL_STATIC); + goto error; + } + /* + * Fall through! + */ case 'n': + case 's': + if (flags & SCAN_LONGER) { + invalidLonger: + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "'l' modifier may not be specified in %", buf, + " conversion", NULL); + goto error; + } + /* + * Fall through! + */ case 'd': + case 'e': + case 'f': + case 'g': case 'i': case 'o': - case 'x': case 'u': - case 'f': - case 'e': - case 'g': - case 's': - break; - case 'c': - if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); - goto error; - } - break; + case 'x': + break; + /* + * Bracket terms need special checking + */ case '[': + if (flags & SCAN_LONGER) { + goto invalidLonger; + } if (*format == '\0') { goto badSet; } @@ -547,6 +580,10 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) int underflow = 0; size_t width; long (*fn)() = NULL; +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt (*lfn)() = NULL; + Tcl_WideInt wideValue; +#endif Tcl_UniChar ch, sch; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; @@ -661,10 +698,16 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) } /* - * Ignore size specifier. + * Handle any size specifier. */ - if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + switch (ch) { + case 'l': + case 'L': +#ifndef TCL_WIDE_INT_IS_LONG + flags |= SCAN_LONGER; +#endif + case 'h': format += Tcl_UtfToUniChar(format, &ch); } @@ -686,27 +729,42 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) op = 'i'; base = 10; fn = (long (*)())strtol; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoll; +#endif break; case 'i': op = 'i'; base = 0; fn = (long (*)())strtol; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoll; +#endif break; case 'o': op = 'i'; base = 8; fn = (long (*)())strtoul; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoull; +#endif break; case 'x': op = 'i'; base = 16; fn = (long (*)())strtoul; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoull; +#endif break; case 'u': op = 'i'; base = 10; flags |= SCAN_UNSIGNED; fn = (long (*)())strtoul; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoull; +#endif break; case 'f': @@ -962,17 +1020,33 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) if (!(flags & SCAN_SUPPRESS)) { *end = '\0'; - value = (long) (*fn)(buf, NULL, base); - if ((flags & SCAN_UNSIGNED) && (value < 0)) { - sprintf(buf, "%lu", value); /* INTL: ISO digit */ - objPtr = Tcl_NewStringObj(buf, -1); +#ifndef TCL_WIDE_INT_IS_LONG + if (flags & SCAN_LONGER) { + wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { + /* INTL: ISO digit */ + sprintf(buf, "%" TCL_LL_MODIFIER "u", + (Tcl_WideUInt)wideValue); + objPtr = Tcl_NewStringObj(buf, -1); + } else { + objPtr = Tcl_NewWideIntObj(wideValue); + } } else { - if ((unsigned long) value > UINT_MAX) { - objPtr = Tcl_NewLongObj(value); +#endif /* !TCL_WIDE_INT_IS_LONG */ + value = (long) (*fn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (value < 0)) { + sprintf(buf, "%lu", value); /* INTL: ISO digit */ + objPtr = Tcl_NewStringObj(buf, -1); } else { - objPtr = Tcl_NewIntObj(value); + if ((unsigned long) value > UINT_MAX) { + objPtr = Tcl_NewLongObj(value); + } else { + objPtr = Tcl_NewIntObj(value); + } } +#ifndef TCL_WIDE_INT_IS_LONG } +#endif Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } @@ -987,6 +1061,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) if ((width == 0) || (width > sizeof(buf) - 1)) { width = sizeof(buf) - 1; } + flags &= ~SCAN_LONGER; flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; for (end = buf; width > 0; width--) { switch (*string) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7285dac..0ece7d5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.67 2002/02/10 20:36:34 kennykb Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.68 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -622,7 +622,7 @@ TclStubs tclStubs = { Tcl_ResetResult, /* 217 */ Tcl_ScanElement, /* 218 */ Tcl_ScanCountedElement, /* 219 */ - Tcl_Seek, /* 220 */ + Tcl_SeekOld, /* 220 */ Tcl_ServiceAll, /* 221 */ Tcl_ServiceEvent, /* 222 */ Tcl_SetAssocData, /* 223 */ @@ -648,7 +648,7 @@ TclStubs tclStubs = { Tcl_SplitPath, /* 243 */ Tcl_StaticPackage, /* 244 */ Tcl_StringMatch, /* 245 */ - Tcl_Tell, /* 246 */ + Tcl_TellOld, /* 246 */ Tcl_TraceVar, /* 247 */ Tcl_TraceVar2, /* 248 */ Tcl_TranslateFileName, /* 249 */ @@ -888,6 +888,13 @@ TclStubs tclStubs = { Tcl_CreateObjTrace, /* 483 */ Tcl_GetCommandInfoFromToken, /* 484 */ Tcl_SetCommandInfoFromToken, /* 485 */ + Tcl_DbNewWideIntObj, /* 486 */ + Tcl_GetWideIntFromObj, /* 487 */ + Tcl_NewWideIntObj, /* 488 */ + Tcl_SetWideIntObj, /* 489 */ + Tcl_AllocStatBuf, /* 490 */ + Tcl_Seek, /* 491 */ + Tcl_Tell, /* 492 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index a8635bd..7da18fd 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.43 2002/02/10 20:36:34 kennykb Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.44 2002/02/15 14:28:49 dkf Exp $ */ #define TCL_TEST @@ -341,7 +341,7 @@ static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg static Tcl_Obj *TestReportGetNativePath(Tcl_Obj* pathObjPtr); static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path, - struct stat *buf)); + Tcl_StatBuf *buf)); static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path, int mode)); static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ (( @@ -353,7 +353,7 @@ static int TestReportMatchInDirectory _ANSI_ARGS_ (( Tcl_GlobTypeData *types)); static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName)); static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path, - struct stat *buf)); + Tcl_StatBuf *buf)); static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src, Tcl_Obj *dst)); static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path)); @@ -2122,22 +2122,31 @@ TestlinkCmd(dummy, interp, argc, argv) static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; + static Tcl_WideInt wideVar = Tcl_LongAsWide(79); static char *stringVar = NULL; static int created = 0; - char buffer[TCL_DOUBLE_SPACE]; + char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; + Tcl_Obj *tmp; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg arg?\"", (char *) NULL); + " option ?arg arg arg arg arg?\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { + if (argc != 7) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + " intRO realRO boolRO stringRO wideRO\"", (char *) NULL); + return TCL_ERROR; + } if (created) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); + Tcl_UnlinkVar(interp, "wide"); } created = 1; if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { @@ -2172,11 +2181,20 @@ TestlinkCmd(dummy, interp, argc, argv) TCL_LINK_STRING | flag) != TCL_OK) { return TCL_ERROR; } + if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, + TCL_LINK_WIDE_INT | flag) != TCL_OK) { + return TCL_ERROR; + } } else if (strcmp(argv[1], "delete") == 0) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); + Tcl_UnlinkVar(interp, "wide"); created = 0; } else if (strcmp(argv[1], "get") == 0) { TclFormatInt(buffer, intVar); @@ -2186,11 +2204,18 @@ TestlinkCmd(dummy, interp, argc, argv) TclFormatInt(buffer, boolVar); Tcl_AppendElement(interp, buffer); Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + /* + * Wide ints only have an object-based interface. + */ + tmp = Tcl_NewWideIntObj(wideVar); + Tcl_AppendElement(interp, Tcl_GetString(tmp)); + Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { - if (argc != 6) { + if (argc != 7) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], - "intValue realValue boolValue stringValue\"", (char *) NULL); + argv[0], " ", argv[1], + " intValue realValue boolValue stringValue wideValue\"", + (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -2219,11 +2244,20 @@ TestlinkCmd(dummy, interp, argc, argv) strcpy(stringVar, argv[5]); } } + if (argv[6][0] != 0) { + tmp = Tcl_NewStringObj(argv[6], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + } } else if (strcmp(argv[1], "update") == 0) { - if (argc != 6) { + if (argc != 7) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], - "intValue realValue boolValue stringValue\"", (char *) NULL); + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue wideValue\"", + (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -2256,6 +2290,15 @@ TestlinkCmd(dummy, interp, argc, argv) } Tcl_UpdateLinkedVar(interp, "string"); } + if (argv[6][0] != 0) { + tmp = Tcl_NewStringObj(argv[6], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + Tcl_UpdateLinkedVar(interp, "wide"); + } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be create, delete, get, set, or update", @@ -2404,8 +2447,16 @@ TestMathFunc2(clientData, interp, args, resultPtr) resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = ((d0 > d1)? d0 : d1); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = Tcl_LongAsWide(i0); + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); +#endif } else { - Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else if (args[0].type == TCL_DOUBLE) { @@ -2421,12 +2472,44 @@ TestMathFunc2(clientData, interp, args, resultPtr) resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = ((d0 > d1)? d0 : d1); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (args[1].type == TCL_WIDE_INT) { + double d1 = Tcl_WideAsDouble(args[1].wideValue); + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); +#endif } else { - Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (args[0].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = args[0].wideValue; + + if (args[1].type == TCL_INT) { + Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = Tcl_WideAsDouble(w0); + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } +#endif } else { - Tcl_SetResult(interp, "T2: wrong type for arg 1", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); result = TCL_ERROR; } return result; @@ -4240,10 +4323,62 @@ static int PretendTclpStat(path, buf) { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); +#ifdef TCL_WIDE_INT_IS_LONG Tcl_IncrRefCount(pathPtr); ret = TclpObjStat(pathPtr, buf); Tcl_DecrRefCount(pathPtr); return ret; +#else /* TCL_WIDE_INT_IS_LONG */ + Tcl_StatBuf realBuf; + Tcl_IncrRefCount(pathPtr); + ret = TclpObjStat(pathPtr, &realBuf); + Tcl_DecrRefCount(pathPtr); + if (ret != -1) { +# define OUT_OF_RANGE(x) \ + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) +# define OUT_OF_URANGE(x) \ + (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) + + /* + * Perform the result-buffer overflow check manually. + * + * Note that ino_t/ino64_t is unsigned... + */ + + if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size) + || OUT_OF_RANGE(realBuf.st_blocks)) { + errno = EOVERFLOW; + return -1; + } + +# undef OUT_OF_RANGE +# undef OUT_OF_URANGE + + /* + * Copy across all supported fields, with possible type + * coercions on those fields that change between the normal + * and lf64 versions of the stat structure (on Solaris at + * least.) This is slow when the structure sizes coincide, + * but that's what you get for mixing interfaces... + */ + + buf->st_mode = realBuf.st_mode; + buf->st_ino = (ino_t) realBuf.st_ino; + buf->st_dev = realBuf.st_dev; + buf->st_rdev = realBuf.st_rdev; + buf->st_nlink = realBuf.st_nlink; + buf->st_uid = realBuf.st_uid; + buf->st_gid = realBuf.st_gid; + buf->st_size = (off_t) realBuf.st_size; + buf->st_atime = realBuf.st_atime; + buf->st_mtime = realBuf.st_mtime; + buf->st_ctime = realBuf.st_ctime; + buf->st_blksize = realBuf.st_blksize; + buf->st_blocks = (blkcnt_t) realBuf.st_blocks; + } + return ret; +#endif /* TCL_WIDE_INT_IS_LONG */ } /* Be careful in the compares in these tests, since the Macintosh puts a @@ -4867,7 +5002,7 @@ TestChannelCmd(clientData, interp, argc, argv) TclFormatInt(buf, IOQueued); Tcl_AppendElement(interp, buf); - TclFormatInt(buf, Tcl_Tell((Tcl_Channel) chanPtr)); + TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr)); Tcl_AppendElement(interp, buf); TclFormatInt(buf, statePtr->refCount); @@ -5576,7 +5711,7 @@ TestReport(cmd, path, arg2) static int TestReportStat(path, buf) Tcl_Obj *path; /* Path of file to stat (in current CP). */ - struct stat *buf; /* Filled with results of stat call. */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ { TestReport("stat",path, NULL); return Tcl_FSStat(TestReportGetNativePath(path),buf); @@ -5584,7 +5719,7 @@ TestReportStat(path, buf) static int TestReportLstat(path, buf) Tcl_Obj *path; /* Path of file to stat (in current CP). */ - struct stat *buf; /* Filled with results of stat call. */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ { TestReport("lstat",path, NULL); return Tcl_FSLstat(TestReportGetNativePath(path),buf); diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index ca9b088..5d36cc0 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestObj.c,v 1.9 2002/01/17 04:37:33 dgp Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.10 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -406,6 +406,15 @@ TestindexobjCmd(clientData, interp, objc, objv) int allowAbbrev, index, index2, setError, i, result; CONST char **argv; static CONST char *tablePtr[] = {"a", "b", "check", (char *) NULL}; + /* + * Keep this structure declaration in sync with tclIndexObj.c + */ + struct IndexRep { + VOID *tablePtr; /* Pointer to the table of strings */ + int offset; /* Offset between table entries */ + int index; /* Selected index into table. */ + }; + struct IndexRep *indexRep; if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "check") == 0)) { @@ -415,13 +424,14 @@ TestindexobjCmd(clientData, interp, objc, objv) * returned on subsequent lookups. */ - Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, - "token", 0, &index); if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { return TCL_ERROR; } - objv[1]->internalRep.twoPtrValue.ptr2 = - (VOID *) (index2 * sizeof(char *)); + + Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, + "token", 0, &index); + indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr; + indexRep->index = index2; result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, "token", 0, &index); if (result == TCL_OK) { @@ -455,9 +465,12 @@ TestindexobjCmd(clientData, interp, objc, objv) * the index object, clear out the object's cached state. */ - if ((objv[3]->typePtr == Tcl_GetObjType("index")) - && (objv[3]->internalRep.twoPtrValue.ptr1 == (VOID *) argv)) { - objv[3]->typePtr = NULL; + if (objv[3]->typePtr == &tclIndexType) { + indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr; + if (indexRep->tablePtr == (VOID *) argv) { + objv[3]->typePtr->freeIntRepProc(objv[3]); + objv[3]->typePtr = NULL; + } } result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], diff --git a/generic/tclVar.c b/generic/tclVar.c index a827dea..b850878 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.47 2002/01/25 21:36:09 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.48 2002/02/15 14:28:49 dkf Exp $ */ #include "tclInt.h" @@ -2025,12 +2025,10 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ long i; - int result; varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); if (varValuePtr == NULL) { @@ -2051,24 +2049,46 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) varValuePtr = Tcl_DuplicateObj(varValuePtr); createdNewObj = 1; } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { +#ifdef TCL_WIDE_INT_IS_LONG + if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { if (createdNewObj) { Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } Tcl_SetLongObj(varValuePtr, (i + incrAmount)); +#else + if (varValuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wide = varValuePtr->internalRep.wideValue; + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } else if (varValuePtr->typePtr == &tclIntType) { + i = varValuePtr->internalRep.longValue; + Tcl_SetIntObj(varValuePtr, i + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + Tcl_WideInt wide; + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + if (wide <= Tcl_LongAsWide(LONG_MAX) + && wide >= Tcl_LongAsWide(LONG_MIN)) { + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + } else { + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } + } +#endif /* * Store the variable's new value and run any write traces. */ - resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; + return Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); } /* @@ -2105,12 +2125,10 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) long incrAmount; /* Amount to be added to variable. */ { register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ long i; - int result; varValuePtr = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { @@ -2132,25 +2150,47 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) createdNewObj = 1; varValuePtr = Tcl_DuplicateObj(varValuePtr); } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { +#ifdef TCL_WIDE_INT_IS_LONG + if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { if (createdNewObj) { Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } Tcl_SetLongObj(varValuePtr, (i + incrAmount)); +#else + if (varValuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wide = varValuePtr->internalRep.wideValue; + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } else if (varValuePtr->typePtr == &tclIntType) { + i = varValuePtr->internalRep.longValue; + Tcl_SetIntObj(varValuePtr, i + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + Tcl_WideInt wide; + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + if (wide <= Tcl_LongAsWide(LONG_MAX) + && wide >= Tcl_LongAsWide(LONG_MIN)) { + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + } else { + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } + } +#endif /* * Store the variable's new value and run any write traces. */ - resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, + return TclSetIndexedScalar(interp, localIndex, varValuePtr, TCL_LEAVE_ERR_MSG); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; } /* @@ -2191,12 +2231,10 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) long incrAmount; /* Amount to be added to variable. */ { register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ long i; - int result; varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, TCL_LEAVE_ERR_MSG); @@ -2219,25 +2257,47 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) createdNewObj = 1; varValuePtr = Tcl_DuplicateObj(varValuePtr); } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { +#ifdef TCL_WIDE_INT_IS_LONG + if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { if (createdNewObj) { Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } Tcl_SetLongObj(varValuePtr, (i + incrAmount)); - +#else + if (varValuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wide = varValuePtr->internalRep.wideValue; + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } else if (varValuePtr->typePtr == &tclIntType) { + i = varValuePtr->internalRep.longValue; + Tcl_SetIntObj(varValuePtr, i + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + Tcl_WideInt wide; + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + if (wide <= Tcl_LongAsWide(LONG_MAX) + && wide >= Tcl_LongAsWide(LONG_MIN)) { + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + } else { + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } + } +#endif + /* * Store the variable's new value and run any write traces. */ - resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, + return TclSetElementOfIndexedArray(interp, localIndex, elemPtr, varValuePtr, TCL_LEAVE_ERR_MSG); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; } /* |