Last-Modified: Fri, 04 Oct 2024 15:25:42 GMT
Expires: Mon, 02 Oct 2034 15:25:42 GMT
tcl.git - Tcl is a high-level, general-purpose, interpreted, dynamic programming language. It was designed with the goal of being very simple but powerful.
/* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API at the * script level. Contributed by Andreas Kupries. * * Copyright (c) 2000 Ajuba Solutions * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */#include"tclInt.h"#include"tclIO.h"/* * Forward declarations of internal procedures. First the driver procedures of * the transformation. */static intTransformBlockModeProc(ClientData instanceData,int mode);static intTransformCloseProc(ClientData instanceData,
Tcl_Interp *interp);static intTransformInputProc(ClientData instanceData,char*buf,int toRead,int*errorCodePtr);static intTransformOutputProc(ClientData instanceData,const char*buf,int toWrite,int*errorCodePtr);static intTransformSeekProc(ClientData instanceData,long offset,int mode,int*errorCodePtr);static intTransformSetOptionProc(ClientData instanceData,
Tcl_Interp *interp,const char*optionName,const char*value);static intTransformGetOptionProc(ClientData instanceData,
Tcl_Interp *interp,const char*optionName,
Tcl_DString *dsPtr);static voidTransformWatchProc(ClientData instanceData,int mask);static intTransformGetFileHandleProc(ClientData instanceData,int direction, ClientData *handlePtr);static intTransformNotifyProc(ClientData instanceData,int mask);static Tcl_WideInt TransformWideSeekProc(ClientData instanceData,
Tcl_WideInt offset,int mode,int*errorCodePtr);/* * Forward declarations of internal procedures. Secondly the procedures for * handling and generating fileeevents. */static voidTransformChannelHandlerTimer(ClientData clientData);/* * Forward declarations of internal procedures. Third, helper procedures * encapsulating essential tasks. */typedefstruct TransformChannelData TransformChannelData;static intExecuteCallback(TransformChannelData *ctrl,
Tcl_Interp *interp,unsigned char*op,unsigned char*buf,int bufLen,int transmit,int preserve);/* * Action codes to give to 'ExecuteCallback' (argument 'transmit'), telling * the procedure what to do with the result of the script it calls. */#define TRANSMIT_DONT 0/* No transfer to do. */#define TRANSMIT_DOWN 1/* Transfer to the underlying channel. */#define TRANSMIT_SELF 2/* Transfer into our channel. */#define TRANSMIT_IBUF 3/* Transfer to internal input buffer. */#define TRANSMIT_NUM 4/* Transfer number to 'maxRead'. *//* * Codes for 'preserve' of 'ExecuteCallback'. */#define P_PRESERVE 1#define P_NO_PRESERVE 0/* * Strings for the action codes delivered to the script implementing a * transformation. Argument 'op' of 'ExecuteCallback'. */#define A_CREATE_WRITE (UCHARP("create/write"))#define A_DELETE_WRITE (UCHARP("delete/write"))#define A_FLUSH_WRITE (UCHARP("flush/write"))#define A_WRITE (UCHARP("write"))#define A_CREATE_READ (UCHARP("create/read"))#define A_DELETE_READ (UCHARP("delete/read"))#define A_FLUSH_READ (UCHARP("flush/read"))#define A_READ (UCHARP("read"))#define A_QUERY_MAXREAD (UCHARP("query/maxRead"))#define A_CLEAR_READ (UCHARP("clear/read"))/* * Management of a simple buffer. */typedefstruct ResultBuffer ResultBuffer;staticinlinevoidResultClear(ResultBuffer *r);staticinlinevoidResultInit(ResultBuffer *r);staticinlineintResultEmpty(ResultBuffer *r);staticinlineintResultCopy(ResultBuffer *r,unsigned char*buf,size_t toRead);staticinlinevoidResultAdd(ResultBuffer *r,unsigned char*buf,size_t toWrite);/* * This structure describes the channel type structure for Tcl-based * transformations. */static const Tcl_ChannelType transformChannelType = {"transform",/* Type name. */
TCL_CHANNEL_VERSION_5,/* v5 channel */
TransformCloseProc,/* Close proc. */
TransformInputProc,/* Input proc. */
TransformOutputProc,/* Output proc. */
TransformSeekProc,/* Seek proc. */
TransformSetOptionProc,/* Set option proc. */
TransformGetOptionProc,/* Get option proc. */
TransformWatchProc,/* Initialize notifier. */
TransformGetFileHandleProc,/* Get OS handles out of channel. */
NULL,/* close2proc */
TransformBlockModeProc,/* Set blocking/nonblocking mode.*/
NULL,/* Flush proc. */
TransformNotifyProc,/* Handling of events bubbling up. */
TransformWideSeekProc,/* Wide seek proc. */
NULL,/* Thread action. */
NULL /* Truncate. */};/* * Possible values for 'flags' field in control structure, see below. */#define CHANNEL_ASYNC (1<<0)/* Non-blocking mode. *//* * Definition of the structure containing the information about the internal * input buffer. */struct ResultBuffer {unsigned char*buf;/* Reference to the buffer area. */size_t allocated;/* Allocated size of the buffer area. */size_t used;/* Number of bytes in the buffer, no more than * number allocated. */};/* * Additional bytes to allocate during buffer expansion. */#define INCREMENT 512/* * Number of milliseconds to wait before firing an event to flush out * information waiting in buffers (fileevent support). */#define FLUSH_DELAY 5/* * Convenience macro to make some casts easier to use. */#define UCHARP(x) ((unsigned char *) (x))/* * Definition of a structure used by all transformations generated here to * maintain their local state. */struct TransformChannelData {/* * General section. Data to integrate the transformation into the channel * system. */
Tcl_Channel self;/* Our own Channel handle. */int readIsFlushed;/* Flag to note whether in.flushProc was * called or not. */int eofPending;/* Flag: EOF seen down, not raised up */int flags;/* Currently CHANNEL_ASYNC or zero. */int watchMask;/* Current watch/event/interest mask. */int mode;/* Mode of parent channel, OR'ed combination * of TCL_READABLE, TCL_WRITABLE. */
Tcl_TimerToken timer;/* Timer for automatic flushing of information * sitting in an internal buffer. Required for * full fileevent support. *//* * Transformation specific data. */int maxRead;/* Maximum allowed number of bytes to read, as * given to us by the Tcl script implementing * the transformation. */
Tcl_Interp *interp;/* Reference to the interpreter which created * the transformation. Used to execute the * code below. */
Tcl_Obj *command;/* Tcl code to execute for a buffer */
ResultBuffer result;/* Internal buffer used to store the result of * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */int refCount;};static voidPreserveData(
TransformChannelData *dataPtr){
dataPtr->refCount++;}static voidReleaseData(
TransformChannelData *dataPtr){if(--dataPtr->refCount) {return;}ResultClear(&dataPtr->result);Tcl_DecrRefCount(dataPtr->command);ckfree(dataPtr);}/* *---------------------------------------------------------------------- * * TclChannelTransform -- * * Implements the Tcl "testchannel transform" debugging command. This is * part of the testing environment. This sets up a tcl script (cmdObjPtr) * to be used as a transform on the channel. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- *//* ARGSUSED */intTclChannelTransform(
Tcl_Interp *interp,/* Interpreter for result. */
Tcl_Channel chan,/* Channel to transform. */
Tcl_Obj *cmdObjPtr)/* Script to use for transform. */{
Channel *chanPtr;/* The actual channel. */
ChannelState *statePtr;/* State info for channel. */int mode;/* Read/write mode of the channel. */int objc;
TransformChannelData *dataPtr;
Tcl_DString ds;if(chan == NULL) {return TCL_ERROR;}if(TCL_OK !=Tcl_ListObjLength(interp, cmdObjPtr, &objc)) {Tcl_SetObjResult(interp,Tcl_NewStringObj("-command value is not a list", -1));return TCL_ERROR;}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));/* * Now initialize the transformation state and stack it upon the specified * channel. One of the necessary things to do is to retrieve the blocking * regime of the underlying channel and to use the same for us too. */
dataPtr =ckalloc(sizeof(TransformChannelData));
dataPtr->refCount =1;Tcl_DStringInit(&ds);Tcl_GetChannelOption(interp, chan,"-blocking", &ds);
dataPtr->readIsFlushed =0;
dataPtr->eofPending =0;
dataPtr->flags =0;if(ds.string[0] =='0') {
dataPtr->flags |= CHANNEL_ASYNC;}Tcl_DStringFree(&ds);
dataPtr->watchMask =0;
dataPtr->mode = mode;
dataPtr->timer = NULL;
dataPtr->maxRead =4096;/* Initial value not relevant. */
dataPtr->interp = interp;
dataPtr->command = cmdObjPtr;Tcl_IncrRefCount(dataPtr->command);ResultInit(&dataPtr->result);
dataPtr->self =Tcl_StackChannel(interp, &transformChannelType, dataPtr,
mode, chan);if(dataPtr->self == NULL) {Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp),"\nfailed to stack channel\"%s\"",Tcl_GetChannelName(chan));ReleaseData(dataPtr);return TCL_ERROR;}Tcl_Preserve(dataPtr->self);/* * At last initialize the transformation at the script level. */PreserveData(dataPtr);if((dataPtr->mode & TCL_WRITABLE) &&ExecuteCallback(dataPtr, NULL,
A_CREATE_WRITE, NULL,0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){Tcl_UnstackChannel(interp, chan);ReleaseData(dataPtr);return TCL_ERROR;}if((dataPtr->mode & TCL_READABLE) &&ExecuteCallback(dataPtr, NULL,
A_CREATE_READ, NULL,0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK) {ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL,0, TRANSMIT_DONT,
P_NO_PRESERVE);Tcl_UnstackChannel(interp, chan);ReleaseData(dataPtr);return TCL_ERROR;}ReleaseData(dataPtr);return TCL_OK;}/* *---------------------------------------------------------------------- * * ExecuteCallback -- * * Executes the defined callback for buffer and operation. * * Side effects: * As of the executed tcl script. * * Result: * A standard TCL error code. In case of an error a message is left in * the result area of the specified interpreter. * *---------------------------------------------------------------------- */static intExecuteCallback(
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,/* And its length. */int transmit,/* Flag, determines whether the result of the * callback is sent to the underlying channel * or not. */int preserve)/* Flag. If true the procedure will preserve * the result state of all accessed * interpreters. */{
Tcl_Obj *resObj;/* See below, switch (transmit). */int resLen;unsigned char*resBuf;
Tcl_InterpState state = NULL;int res = TCL_OK;
Tcl_Obj *command =TclListObjCopy(NULL, dataPtr->command);
Tcl_Interp *eval = dataPtr->interp;Tcl_Preserve(eval);/* * Step 1, create the complete command to execute. Do this by appending * operation and buffer to operate upon to a copy of the callback * definition. We *cannot* create a list containing 3 objects and then use * 'Tcl_EvalObjv', because the command may contain additional prefixed * arguments. Feather's curried commands would come in handy here. */if(preserve == P_PRESERVE) {
state =Tcl_SaveInterpState(eval, res);}Tcl_IncrRefCount(command);Tcl_ListObjAppendElement(NULL, command,Tcl_NewStringObj((char*) op, -1));/* * Use a byte-array to prevent the misinterpretation of binary data coming * through as UTF while at the tcl level. */Tcl_ListObjAppendElement(NULL, command,Tcl_NewByteArrayObj(buf, bufLen));/* * Step 2, execute the command at the global level of the interpreter used * to create the transformation. Destroy the command afterward. If an * error occured and the current interpreter is defined and not equal to * the interpreter for the callback, then copy the error message into * current interpreter. Don't copy if in preservation mode. */
res =Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);Tcl_DecrRefCount(command);
command = NULL;if((res != TCL_OK) && (interp != NULL) && (eval != interp)&& (preserve == P_NO_PRESERVE)) {Tcl_SetObjResult(interp,Tcl_GetObjResult(eval));Tcl_Release(eval);return res;}/* * Step 3, transmit a possible conversion result to the underlying * channel, or ourselves. */switch(transmit) {case TRANSMIT_DONT:/* nothing to do */break;case TRANSMIT_DOWN:if(dataPtr->self == NULL) {break;}
resObj =Tcl_GetObjResult(eval);
resBuf =Tcl_GetByteArrayFromObj(resObj, &resLen);Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char*) resBuf,
resLen);break;case TRANSMIT_SELF:if(dataPtr->self == NULL) {break;}
resObj =Tcl_GetObjResult(eval);
resBuf =Tcl_GetByteArrayFromObj(resObj, &resLen);Tcl_WriteRaw(dataPtr->self, (char*) resBuf, resLen);break;case TRANSMIT_IBUF:
resObj =Tcl_GetObjResult(eval);
resBuf =Tcl_GetByteArrayFromObj(resObj, &resLen);ResultAdd(&dataPtr->result, resBuf, resLen);break;case TRANSMIT_NUM:/* * Interpret result as integer number. */
resObj =Tcl_GetObjResult(eval);TclGetIntFromObj(eval, resObj, &dataPtr->maxRead);break;}Tcl_ResetResult(eval);if(preserve == P_PRESERVE) {(void)Tcl_RestoreInterpState(eval, state);}Tcl_Release(eval);return res;}/* *---------------------------------------------------------------------- * * TransformBlockModeProc -- * * Trap handler. Called by the generic IO system during option processing * to change the blocking mode of the channel. * * Side effects: * Forwards the request to the underlying channel. * * Result: * 0 if successful, errno when failed. * *---------------------------------------------------------------------- */static intTransformBlockModeProc(
ClientData instanceData,/* State of transformation. */int mode)/* New blocking mode. */{
TransformChannelData *dataPtr = instanceData;if(mode == TCL_MODE_NONBLOCKING) {
dataPtr->flags |= CHANNEL_ASYNC;}else{
dataPtr->flags &= ~CHANNEL_ASYNC;}return0;}/* *---------------------------------------------------------------------- * * TransformCloseProc -- * * Trap handler. Called by the generic IO system during destruction of * the transformation channel. * * Side effects: * Releases the memory allocated in 'Tcl_TransformObjCmd'. * * Result: * None. * *---------------------------------------------------------------------- */static intTransformCloseProc(
ClientData instanceData,
Tcl_Interp *interp){
TransformChannelData *dataPtr = instanceData;/* * Important: In this procedure 'dataPtr->self' already points to the * underlying channel. * * There is no need to cancel an existing channel handler, this is already * done. Either by 'Tcl_UnstackChannel' or by the general cleanup in * 'Tcl_Close'. * * But we have to cancel an active timer to prevent it from firing on the * removed channel. */if(dataPtr->timer != NULL) {Tcl_DeleteTimerHandler(dataPtr->timer);
dataPtr->timer = NULL;}/* * Now flush data waiting in internal buffers to output and input. The * input must be done despite the fact that there is no real receiver for * it anymore. But the scripts might have sideeffects other parts of the * system rely on (f.e. signaling the close to interested parties). */PreserveData(dataPtr);if(dataPtr->mode & TCL_WRITABLE) {ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL,0,
TRANSMIT_DOWN, P_PRESERVE);}if((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
dataPtr->readIsFlushed =1;ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL,0, TRANSMIT_IBUF,
P_PRESERVE);}if(dataPtr->mode & TCL_WRITABLE) {ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL,0,
TRANSMIT_DONT, P_PRESERVE);}if(dataPtr->mode & TCL_READABLE) {ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL,0,
TRANSMIT_DONT, P_PRESERVE);}ReleaseData(dataPtr);/* * General cleanup. */Tcl_Release(dataPtr->self);
dataPtr->self = NULL;ReleaseData(dataPtr);return TCL_OK;}/* *---------------------------------------------------------------------- * * TransformInputProc -- * * Called by the generic IO system to convert read data. * * Side effects: * As defined by the conversion. * * Result: * A transformed buffer. * *---------------------------------------------------------------------- */static intTransformInputProc(
ClientData instanceData,char*buf,int toRead,int*errorCodePtr){
TransformChannelData *dataPtr = instanceData;int gotBytes, read, copied;
Tcl_Channel downChan;/* * Should assert(dataPtr->mode & TCL_READABLE); */if(toRead ==0|| dataPtr->self == NULL) {/* * Catch a no-op. TODO: Is this a panic()? */return0;}
gotBytes =0;
downChan =Tcl_GetStackedChannel(dataPtr->self);PreserveData(dataPtr);while(toRead >0) {/* * Loop until the request is satisfied (or no data is available from * below, possibly EOF). */
copied =ResultCopy(&dataPtr->result,UCHARP(buf), toRead);
toRead -= copied;
buf += copied;
gotBytes += copied;if(toRead ==0) {/* * The request was completely satisfied from our buffers. We can * break out of the loop and return to the caller. */break;}/* * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming * 'buf'! as target to store the intermediary information read from * the underlying channel. * * Ask the tcl level how much data it allows us to read from the * underlying channel. This feature allows the transform to signal EOF * upstream although there is none downstream. Useful to control an * unbounded 'fcopy', either through counting bytes, or by pattern * matching. */ExecuteCallback(dataPtr, NULL, A_QUERY_MAXREAD, NULL,0,
TRANSMIT_NUM /* -> maxRead */, P_PRESERVE);if(dataPtr->maxRead >=0) {if(dataPtr->maxRead < toRead) {
toRead = dataPtr->maxRead;}}/* else: 'maxRead < 0' == Accept the current value of toRead. */if(toRead <=0) {break;}if(dataPtr->eofPending) {/* * Already saw EOF from downChan; don't ask again. * NOTE: Could move this up to avoid the last maxRead * execution. Believe this would still be correct behavior, * but the test suite tests the whole command callback * sequence, so leave it unchanged for now. */break;}/* * Get bytes from the underlying channel. */
read =Tcl_ReadRaw(downChan, buf, toRead);if(read <0) {if(Tcl_InputBlocked(downChan) && (gotBytes >0)) {/* * Zero bytes available from downChan because blocked. * But nonzero bytes already copied, so total is a * valid blocked short read. Return to caller. */break;}/* * Either downChan is not blocked (there's a real error). * or it is and there are no bytes copied yet. In either * case we want to pass the "error" along to the caller, * either to report an error, or to signal to the caller * that zero bytes are available because blocked. */*errorCodePtr =Tcl_GetErrno();
gotBytes = -1;break;}else if(read ==0) {/* * Zero returned from Tcl_ReadRaw() always indicates EOF * on the down channel. */
dataPtr->eofPending =1;
dataPtr->readIsFlushed =1;ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL,0,
TRANSMIT_IBUF, P_PRESERVE);if(ResultEmpty(&dataPtr->result)) {/* * We had nothing to flush. */break;}continue;/* at: while (toRead > 0) */}/* read == 0 *//* * Transform the read chunk and add the result to our read buffer * (dataPtr->result). */if(ExecuteCallback(dataPtr, NULL, A_READ,UCHARP(buf), read,
TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) {*errorCodePtr = EINVAL;
gotBytes = -1;break;}}/* while toRead > 0 */if(gotBytes ==0) {
dataPtr->eofPending =0;}ReleaseData(dataPtr);return gotBytes;}/* *---------------------------------------------------------------------- * * TransformOutputProc -- * * Called by the generic IO system to convert data waiting to be written. * * Side effects: * As defined by the transformation. * * Result: * A transformed buffer. * *---------------------------------------------------------------------- */static intTransformOutputProc(
ClientData instanceData,const char*buf,int toWrite,int*errorCodePtr){
TransformChannelData *dataPtr = instanceData;/* * Should assert(dataPtr->mode & TCL_WRITABLE); */if(toWrite ==0) {/* * Catch a no-op. */return0;}PreserveData(dataPtr);if(ExecuteCallback(dataPtr, NULL, A_WRITE,UCHARP(buf), toWrite,
TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) {*errorCodePtr = EINVAL;
toWrite = -1;}ReleaseData(dataPtr);return toWrite;}/* *---------------------------------------------------------------------- * * TransformSeekProc -- * * This procedure is called by the generic IO level to move the access * point in a channel. * * Side effects: * Moves the location at which the channel will be accessed in future * operations. Flushes all transformation buffers, then forwards it to * the underlying channel. * * Result: * -1 if failed, the new position if successful. An output argument * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */static intTransformSeekProc(
ClientData instanceData,/* The channel to manipulate. */long offset,/* Size of movement. */int mode,/* How to move. */int*errorCodePtr)/* Location of error flag. */{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel parent =Tcl_GetStackedChannel(dataPtr->self);const Tcl_ChannelType *parentType =Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc =Tcl_ChannelSeekProc(parentType);if((offset ==0) && (mode == SEEK_CUR)) {/* * This is no seek but a request to tell the caller the current * location. Simply pass the request down. */returnparentSeekProc(Tcl_GetChannelInstanceData(parent), offset,
mode, errorCodePtr);}/* * It is a real request to change the position. Flush all data waiting for * output and discard everything in the input buffers. Then pass the * request down, unchanged. */PreserveData(dataPtr);if(dataPtr->mode & TCL_WRITABLE) {ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL,0, TRANSMIT_DOWN,
P_NO_PRESERVE);}if(dataPtr->mode & TCL_READABLE) {ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL,0, TRANSMIT_DONT,
P_NO_PRESERVE);ResultClear(&dataPtr->result);
dataPtr->readIsFlushed =0;
dataPtr->eofPending =0;}ReleaseData(dataPtr);returnparentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);}/* *---------------------------------------------------------------------- * * TransformWideSeekProc -- * * This procedure is called by the generic IO level to move the access * point in a channel, with a (potentially) 64-bit offset. * * Side effects: * Moves the location at which the channel will be accessed in future * operations. Flushes all transformation buffers, then forwards it to * the underlying channel. * * Result: * -1 if failed, the new position if successful. An output argument * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */static Tcl_WideInt
TransformWideSeekProc(
ClientData instanceData,/* The channel to manipulate. */
Tcl_WideInt offset,/* Size of movement. */int mode,/* How to move. */int*errorCodePtr)/* Location of error flag. */{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel parent =Tcl_GetStackedChannel(dataPtr->self);const Tcl_ChannelType *parentType =Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc =Tcl_ChannelSeekProc(parentType);
Tcl_DriverWideSeekProc *parentWideSeekProc =Tcl_ChannelWideSeekProc(parentType);
ClientData parentData =Tcl_GetChannelInstanceData(parent);if((offset ==Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) {/* * This is no seek but a request to tell the caller the current * location. Simply pass the request down. */if(parentWideSeekProc != NULL) {returnparentWideSeekProc(parentData, offset, mode, errorCodePtr);}returnTcl_LongAsWide(parentSeekProc(parentData,0, mode,
errorCodePtr));}/* * It is a real request to change the position. Flush all data waiting for * output and discard everything in the input buffers. Then pass the * request down, unchanged. */PreserveData(dataPtr);if(dataPtr->mode & TCL_WRITABLE) {ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL,0, TRANSMIT_DOWN,
P_NO_PRESERVE);}if(dataPtr->mode & TCL_READABLE) {ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL,0, TRANSMIT_DONT,
P_NO_PRESERVE);ResultClear(&dataPtr->result);
dataPtr->readIsFlushed =0;
dataPtr->eofPending =0;}ReleaseData(dataPtr);/* * If we have a wide seek capability, we should stick with that. */if(parentWideSeekProc != NULL) {returnparentWideSeekProc(parentData, offset, mode, errorCodePtr);}/* * We're transferring to narrow seeks at this point; this is a bit complex * because we have to check whether the seek is possible first (i.e. * whether we are losing information in truncating the bits of the * offset). Luckily, there's a defined error for what happens when trying * to go out of the representable range. */if(offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {*errorCodePtr = EOVERFLOW;returnTcl_LongAsWide(-1);}returnTcl_LongAsWide(parentSeekProc(parentData,Tcl_WideAsLong(offset),
mode, errorCodePtr));}/* *---------------------------------------------------------------------- * * TransformSetOptionProc -- * * Called by generic layer to handle the reconfiguration of channel * specific options. As this channel type does not have such, it simply * passes all requests downstream. * * Side effects: * As defined by the channel downstream. * * Result: * A standard TCL error code. * *---------------------------------------------------------------------- */static intTransformSetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,const char*optionName,const char*value){
TransformChannelData *dataPtr = instanceData;
Tcl_Channel downChan =Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverSetOptionProc *setOptionProc;
setOptionProc =Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));if(setOptionProc == NULL) {return TCL_ERROR;}returnsetOptionProc(Tcl_GetChannelInstanceData(downChan), interp,
optionName, value);}/* *---------------------------------------------------------------------- * * TransformGetOptionProc -- * * Called by generic layer to handle requests for the values of channel * specific options. As this channel type does not have such, it simply * passes all requests downstream. * * Side effects: * As defined by the channel downstream. * * Result: * A standard TCL error code. * *---------------------------------------------------------------------- */static intTransformGetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,const char*optionName,
Tcl_DString *dsPtr){
TransformChannelData *dataPtr = instanceData;
Tcl_Channel downChan =Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverGetOptionProc *getOptionProc;
getOptionProc =Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));if(getOptionProc != NULL) {returngetOptionProc(Tcl_GetChannelInstanceData(downChan), interp,
optionName, dsPtr);}else if(optionName == NULL) {/* * Request is query for all options, this is ok. */return TCL_OK;}/* * Request for a specific option has to fail, since we don't have any. */return TCL_ERROR;}/* *---------------------------------------------------------------------- * * TransformWatchProc -- * * Initialize the notifier to watch for events from this channel. * * Side effects: * Sets up the notifier so that a future event on the channel will be * seen by Tcl. * * Result: * None. * *---------------------------------------------------------------------- *//* ARGSUSED */static voidTransformWatchProc(
ClientData instanceData,/* Channel to watch. */int mask)/* Events of interest. */{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel downChan;/* * The caller expressed interest in events occuring for this channel. We * are forwarding the call to the underlying channel now. */
dataPtr->watchMask = mask;/* * No channel handlers any more. We will be notified automatically about * events on the channel below via a call to our 'TransformNotifyProc'. * But we have to pass the interest down now. We are allowed to add * additional 'interest' to the mask if we want to. But this * transformation has no such interest. It just passes the request down, * unchanged. */if(dataPtr->self == NULL) {return;}
downChan =Tcl_GetStackedChannel(dataPtr->self);Tcl_GetChannelType(downChan)->watchProc(Tcl_GetChannelInstanceData(downChan), mask);/* * Management of the internal timer. */if((dataPtr->timer != NULL) &&(!(mask & TCL_READABLE) ||ResultEmpty(&dataPtr->result))) {/* * A pending timer exists, but either is there no (more) interest in * the events it generates or nothing is available for reading, so * remove it. */Tcl_DeleteTimerHandler(dataPtr->timer);
dataPtr->timer = NULL;}if((dataPtr->timer == NULL) && (mask & TCL_READABLE)&& !ResultEmpty(&dataPtr->result)) {/* * There is no pending timer, but there is interest in readable events * and we actually have data waiting, so generate a timer to flush * that. */
dataPtr->timer =Tcl_CreateTimerHandler(FLUSH_DELAY,
TransformChannelHandlerTimer, dataPtr);}}/* *---------------------------------------------------------------------- * * TransformGetFileHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS specific file handle * from inside this channel. * * Side effects: * None. * * Result: * The appropriate Tcl_File or NULL if not present. * *---------------------------------------------------------------------- */static intTransformGetFileHandleProc(
ClientData instanceData,/* Channel to query. */int direction,/* Direction of interest. */
ClientData *handlePtr)/* Place to store the handle into. */{
TransformChannelData *dataPtr = instanceData;/* * Return the handle belonging to parent channel. IOW, pass the request * down and the result up. */returnTcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self),
direction, handlePtr);}/* *---------------------------------------------------------------------- * * TransformNotifyProc -- * * Handler called by Tcl to inform us of activity on the underlying * channel. * * Side effects: * May process the incoming event by itself. * * Result: * None. * *---------------------------------------------------------------------- */static intTransformNotifyProc(
ClientData clientData,/* The state of the notified * transformation. */int mask)/* The mask of occuring events. */{
TransformChannelData *dataPtr = clientData;/* * An event occured in the underlying channel. This transformation doesn't * process such events thus returns the incoming mask unchanged. */if(dataPtr->timer != NULL) {/* * Delete an existing timer. It was not fired, yet we are here, so the * channel below generated such an event and we don't have to. The * renewal of the interest after the execution of channel handlers * will eventually cause us to recreate the timer (in * TransformWatchProc). */Tcl_DeleteTimerHandler(dataPtr->timer);
dataPtr->timer = NULL;}return mask;}/* *---------------------------------------------------------------------- * * TransformChannelHandlerTimer -- * * Called by the notifier (-> timer) to flush out information waiting in * the input buffer. * * Side effects: * As of 'Tcl_NotifyChannel'. * * Result: * None. * *---------------------------------------------------------------------- */static voidTransformChannelHandlerTimer(
ClientData clientData)/* Transformation to query. */{
TransformChannelData *dataPtr = clientData;
dataPtr->timer = NULL;if(!(dataPtr->watchMask&TCL_READABLE) ||ResultEmpty(&dataPtr->result)) {/* * The timer fired, but either is there no (more) interest in the * events it generates or nothing is available for reading, so ignore * it and don't recreate it. */return;}Tcl_NotifyChannel(dataPtr->self, TCL_READABLE);}/* *---------------------------------------------------------------------- * * ResultClear -- * * Deallocates any memory allocated by 'ResultAdd'. * * Side effects: * See above. * * Result: * None. * *---------------------------------------------------------------------- */staticinlinevoidResultClear(
ResultBuffer *r)/* Reference to the buffer to clear out. */{
r->used =0;if(r->allocated) {ckfree(r->buf);
r->buf = NULL;
r->allocated =0;}}/* *---------------------------------------------------------------------- * * ResultInit -- * * Initializes the specified buffer structure. The structure will contain * valid information for an emtpy buffer. * * Side effects: * See above. * * Result: * None. * *---------------------------------------------------------------------- */staticinlinevoidResultInit(
ResultBuffer *r)/* Reference to the structure to * initialize. */{
r->used =0;
r->allocated =0;
r->buf = NULL;}/* *---------------------------------------------------------------------- * * ResultEmpty -- * * Returns whether the number of bytes stored in the buffer is zero. * * Side effects: * None. * * Result: * A boolean. * *---------------------------------------------------------------------- */staticinlineintResultEmpty(
ResultBuffer *r)/* The structure to query. */{return r->used ==0;}/* *---------------------------------------------------------------------- * * ResultCopy -- * * Copies the requested number of bytes from the buffer into the * specified array and removes them from the buffer afterward. Copies * less if there is not enough data in the buffer. * * Side effects: * See above. * * Result: * The number of actually copied bytes, possibly less than 'toRead'. * *---------------------------------------------------------------------- */staticinlineintResultCopy(
ResultBuffer *r,/* The buffer to read from. */unsigned char*buf,/* The buffer to copy into. */size_t toRead)/* Number of requested bytes. */{if(r->used ==0) {/* * Nothing to copy in the case of an empty buffer. */return0;}else if(r->used == toRead) {/* * We have just enough. Copy everything to the caller. */memcpy(buf, r->buf, toRead);
r->used =0;}else if(r->used > toRead) {/* * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. */memcpy(buf, r->buf, toRead);memmove(r->buf, r->buf + toRead, r->used - toRead);
r->used -= toRead;}else{/* * There is not enough in the buffer to satisfy the caller, so take * everything. */memcpy(buf, r->buf, r->used);
toRead = r->used;
r->used =0;}return toRead;}/* *---------------------------------------------------------------------- * * ResultAdd -- * * Adds the bytes in the specified array to the buffer, by appending it. * * Side effects: * See above. * * Result: * None. * *---------------------------------------------------------------------- */staticinlinevoidResultAdd(
ResultBuffer *r,/* The buffer to extend. */unsigned char*buf,/* The buffer to read from. */size_t toWrite)/* The number of bytes in 'buf'. */{if(r->used + toWrite > r->allocated) {/* * Extension of the internal buffer is required. */if(r->allocated ==0) {
r->allocated = toWrite + INCREMENT;
r->buf =ckalloc(r->allocated);}else{
r->allocated += toWrite + INCREMENT;
r->buf =ckrealloc(r->buf, r->allocated);}}/* * Now we may copy the data. */memcpy(r->buf + r->used, buf, toWrite);
r->used += toWrite;}/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */
/* * tclExecute.c -- * * This file contains procedures that execute byte-compiled Tcl commands. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002-2005 by Miguel Sofer. * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * 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.369.2.21 2011/01/19 08:14:17 ferrieux Exp $ */#include"tclInt.h"#include"tclCompile.h"#include"tommath.h"#include <math.h>#include <float.h>/* * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision * and range, but VAX, IBM, and Cray do not; are there any other floating * point units that we might care about? */#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)#define IEEE_FLOATING_POINT#endif/* * A mask (should be 2**n-1) that is used to work out when the bytecode engine * should call Tcl_AsyncReady() to see whether there is a signal that needs * handling. */#ifndef ASYNC_CHECK_COUNT_MASK# define ASYNC_CHECK_COUNT_MASK 63#endif/* !ASYNC_CHECK_COUNT_MASK *//* * Boolean flag indicating whether the Tcl bytecode interpreter has been * initialized. */static int execInitialized =0;TCL_DECLARE_MUTEX(execMutex)#ifdef TCL_COMPILE_DEBUG/* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: * 0: no execution tracing * 1: trace invocations of Tcl procs only * 2: trace invocations of all (not compiled away) commands * 3: display each instruction executed * This variable is linked to the Tcl variable "tcl_traceExec". */int tclTraceExec =0;#endif/* * Mapping from expression instruction opcodes to strings; used for error * messages. Note that these entries must match the order and number of the * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is * disjoint for backward-compatability reasons. */static const char*operatorStrings[] = {"||","&&","|","^","&","==","!=","<",">","<=",">=","<<",">>","+","-","*","/","%","+","-","~","!","BUILTIN FUNCTION","FUNCTION","","","","","","","","","eq","ne"};/* * Mapping from Tcl result codes to strings; used for error and debugging * messages. */#ifdef TCL_COMPILE_DEBUGstatic const char*resultStrings[] = {"TCL_OK","TCL_ERROR","TCL_RETURN","TCL_BREAK","TCL_CONTINUE"};#endif/* * These are used by evalstats to monitor object usage in Tcl. */#ifdef TCL_COMPILE_STATSlong tclObjsAlloced =0;long tclObjsFreed =0;long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = {0,0,0,0,0};#endif/* TCL_COMPILE_STATS *//* * Support pre-8.5 bytecodes unless specifically requested otherwise. */#ifndef TCL_SUPPORT_84_BYTECODE#define TCL_SUPPORT_84_BYTECODE 1#endif#if TCL_SUPPORT_84_BYTECODE/* * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. */typedefstruct{char*name;/* Name of function. */int numArgs;/* Number of arguments for function. */} BuiltinFunc;/* * Table describing the built-in math functions. Entries in this table are * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's * operand byte. */static BuiltinFunc tclBuiltinFuncTable[] = {{"acos",1},{"asin",1},{"atan",1},{"atan2",2},{"ceil",1},{"cos",1},{"cosh",1},{"exp",1},{"floor",1},{"fmod",2},{"hypot",2},{"log",1},{"log10",1},{"pow",2},{"sin",1},{"sinh",1},{"sqrt",1},{"tan",1},{"tanh",1},{"abs",1},{"double",1},{"int",1},{"rand",0},{"round",1},{"srand",1},{"wide",1},{0},};#define LAST_BUILTIN_FUNC 25#endif/* * These variable-access macros have to coincide with those in tclVar.c */#define VarHashGetValue(hPtr) \ ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))staticinline Var *VarHashCreateVar(
TclVarHashTable *tablePtr,
Tcl_Obj *key,int*newPtr){
Tcl_HashEntry *hPtr =Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,(char*) key, newPtr);if(!hPtr) {return NULL;}returnVarHashGetValue(hPtr);}#define VarHashFindVar(tablePtr, key) \ VarHashCreateVar((tablePtr), (key), NULL)/* * The new macro for ending an instruction; note that a reasonable C-optimiser * will resolve all branches at compile time. (result) is always a constant; * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved * at runtime for variable (nCleanup). * * ARGUMENTS: * pcAdjustment: how much to increment pc * nCleanup: how many objects to remove from the stack * resultHandling: 0 indicates no object should be pushed on the stack; * otherwise, push objResultPtr. If (result < 0), objResultPtr already * has the correct reference count. */#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ if (nCleanup == 0) {\ if (resultHandling != 0) {\ if ((resultHandling) > 0) {\ PUSH_OBJECT(objResultPtr);\ } else {\ *(++tosPtr) = objResultPtr;\ }\ } \ pc += (pcAdjustment);\ goto cleanup0;\ } else if (resultHandling != 0) {\ if ((resultHandling) > 0) {\ Tcl_IncrRefCount(objResultPtr);\ }\ pc += (pcAdjustment);\ switch (nCleanup) {\ case 1: goto cleanup1_pushObjResultPtr;\ case 2: goto cleanup2_pushObjResultPtr;\ default: Tcl_Panic("bad usage of macro NEXT_INST_F");\ }\ } else {\ pc += (pcAdjustment);\ switch (nCleanup) {\ case 1: goto cleanup1;\ case 2: goto cleanup2;\ default: Tcl_Panic("bad usage of macro NEXT_INST_F");\ }\ }#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ pc += (pcAdjustment);\ cleanup = (nCleanup);\ if (resultHandling) {\ if ((resultHandling) > 0) {\ Tcl_IncrRefCount(objResultPtr);\ }\ goto cleanupV_pushObjResultPtr;\ } else {\ goto cleanupV;\ }/* * Macros used to cache often-referenced Tcl evaluation stack information * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() * pair must surround any call inside TclExecuteByteCode (and a few other * procedures that use this scheme) that could result in a recursive call * to TclExecuteByteCode. */#define CACHE_STACK_INFO() \ checkInterp = 1#define DECACHE_STACK_INFO() \ esPtr->tosPtr = tosPtr/* * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT * increments the object's ref count since it makes the stack have another * reference pointing to the object. However, POP_OBJECT does not decrement * the ref count. This is because the stack may hold the only reference to the * object, so the object would be destroyed if its ref count were decremented * before the caller had a chance to, e.g., store it in a variable. It is the * caller's responsibility to decrement the ref count when it is finished with * an object. * * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT * macro. The actual parameter might be an expression with side effects, and * this ensures that it will be executed only once. */#define PUSH_OBJECT(objPtr) \ Tcl_IncrRefCount(*(++tosPtr) = (objPtr))#define POP_OBJECT() *(tosPtr--)#define OBJ_AT_TOS *tosPtr#define OBJ_UNDER_TOS *(tosPtr-1)#define OBJ_AT_DEPTH(n) *(tosPtr-(n))#define CURR_DEPTH (tosPtr - initTosPtr)/* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is * only used in TRACE* calls to get a string from an object. */#ifdef TCL_COMPILE_DEBUG# define TRACE(a) \ if (traceInstructions) { \ fprintf(stdout,"%2d: %2d (%u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (unsigned)(pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ }# define TRACE_APPEND(a) \ if (traceInstructions) { \ printf a; \ }# define TRACE_WITH_OBJ(a, objPtr) \ if (traceInstructions) { \ fprintf(stdout,"%2d: %2d (%u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (unsigned)(pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ TclPrintObject(stdout, objPtr, 30); \ fprintf(stdout,"\n"); \ }# define O2S(objPtr) \ (objPtr ? TclGetString(objPtr) :"")#else/* !TCL_COMPILE_DEBUG */# define TRACE(a)# define TRACE_APPEND(a)# define TRACE_WITH_OBJ(a, objPtr)# define O2S(objPtr)#endif/* TCL_COMPILE_DEBUG *//* * DTrace instruction probe macros. */#define TCL_DTRACE_INST_NEXT() \ if (TCL_DTRACE_INST_DONE_ENABLED()) {\ if (curInstName) {\ TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ }\ curInstName = tclInstructionTable[*pc].name;\ if (TCL_DTRACE_INST_START_ENABLED()) {\ TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, tosPtr);\ }\ } else if (TCL_DTRACE_INST_START_ENABLED()) {\ TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, (int) CURR_DEPTH,\ tosPtr);\ }#define TCL_DTRACE_INST_LAST() \ if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\ TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ }/* * Macro used in this file to save a function call for common uses of * TclGetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * ClientData *ptrPtr, int *tPtr); */#ifdef NO_WIDE_TYPE#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.longValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))#else#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.longValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclWideIntType) \ ? (*(tPtr) = TCL_NUMBER_WIDE, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))#endif/* * Macro used in this file to save a function call for common uses of * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * int *boolPtr); */#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ ((((objPtr)->typePtr == &tclIntType) \ || ((objPtr)->typePtr == &tclBooleanType)) \ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))/* * Macro used in this file to save a function call for common uses of * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * Tcl_WideInt *wideIntPtr); */#ifdef NO_WIDE_TYPE#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))#else#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclWideIntType) \ ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ ((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))#endif/* * Macro used to make the check for type overflow more mnemonic. This works by * comparing sign bits; the rest of the word is irrelevant. The ANSI C * "prototype" (where inttype_t is any integer type) is: * * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum); * * Check first the condition most likely to fail in usual code (at least for * usage in [incr]: do the first summand and the sum have != signs? */#define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0))/* * Custom object type only used in this file; values of its type should never * be seen by user scripts. */static Tcl_ObjType dictIteratorType = {"dictIterator",
NULL, NULL, NULL, NULL
};/* * Auxiliary tables used to compute powers of small integers */#if (LONG_MAX == 0x7fffffff)/* * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit * signed integer */static const long MaxBase32[] = {46340,1290,215,73,35,21,14};static const size_t MaxBase32Size =sizeof(MaxBase32)/sizeof(long);/* * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of * powers of i+3; Exp32Value[i] gives the corresponding powers. */static const unsigned short Exp32Index[] = {0,11,18,23,26,29,31,32,33};static const size_t Exp32IndexSize =sizeof(Exp32Index)/sizeof(unsigned short);static const long Exp32Value[] = {19683,59049,177147,531441,1594323,4782969,14348907,43046721,129140163,387420489,1162261467,262144,1048576,4194304,16777216,67108864,268435456,1073741824,1953125,9765625,48828125,244140625,1220703125,10077696,60466176,362797056,40353607,282475249,1977326743,134217728,1073741824,387420489,1000000000};static const size_t Exp32ValueSize =sizeof(Exp32Value)/sizeof(long);#endif/* LONG_MAX == 0x7fffffff -- 32 bit machine */#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)/* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. */static const Tcl_WideInt MaxBase64[] = {(Tcl_WideInt)46340*65536+62259,/* 3037000499 == isqrt(2**63-1) */(Tcl_WideInt)2097151, (Tcl_WideInt)55108, (Tcl_WideInt)6208,(Tcl_WideInt)1448, (Tcl_WideInt)511, (Tcl_WideInt)234, (Tcl_WideInt)127,(Tcl_WideInt)78, (Tcl_WideInt)52, (Tcl_WideInt)38, (Tcl_WideInt)28,(Tcl_WideInt)22, (Tcl_WideInt)18, (Tcl_WideInt)15};static const size_t MaxBase64Size =sizeof(MaxBase64)/sizeof(Tcl_WideInt);/* *Table giving 3, 4, ..., 13 raised to powers greater than 16 when the * results fit in a 64-bit signed integer. */static const unsigned short Exp64Index[] = {0,23,38,49,57,63,67,70,72,74,75,76};static const size_t Exp64IndexSize =sizeof(Exp64Index)/sizeof(unsigned short);static const Tcl_WideInt Exp64Value[] = {(Tcl_WideInt)243*243*243*3*3,(Tcl_WideInt)243*243*243*3*3*3,(Tcl_WideInt)243*243*243*3*3*3*3,(Tcl_WideInt)243*243*243*243,(Tcl_WideInt)243*243*243*243*3,(Tcl_WideInt)243*243*243*243*3*3,(Tcl_WideInt)243*243*243*243*3*3*3,(Tcl_WideInt)243*243*243*243*3*3*3*3,(Tcl_WideInt)243*243*243*243*243,(Tcl_WideInt)243*243*243*243*243*3,(Tcl_WideInt)243*243*243*243*243*3*3,(Tcl_WideInt)243*243*243*243*243*3*3*3,(Tcl_WideInt)243*243*243*243*243*3*3*3*3,(Tcl_WideInt)243*243*243*243*243*243,(Tcl_WideInt)243*243*243*243*243*243*3,(Tcl_WideInt)243*243*243*243*243*243*3*3,(Tcl_WideInt)243*243*243*243*243*243*3*3*3,(Tcl_WideInt)243*243*243*243*243*243*3*3*3*3,(Tcl_WideInt)243*243*243*243*243*243*243,(Tcl_WideInt)243*243*243*243*243*243*243*3,(Tcl_WideInt)243*243*243*243*243*243*243*3*3,(Tcl_WideInt)243*243*243*243*243*243*243*3*3*3,(Tcl_WideInt)243*243*243*243*243*243*243*3*3*3*3,(Tcl_WideInt)1024*1024*1024*4*4,(Tcl_WideInt)1024*1024*1024*4*4*4,(Tcl_WideInt)1024*1024*1024*4*4*4*4,(Tcl_WideInt)1024*1024*1024*1024,(Tcl_WideInt)1024*1024*1024*1024*4,(Tcl_WideInt)1024*1024*1024*1024*4*4,(Tcl_WideInt)1024*1024*1024*1024*4*4*4,(Tcl_WideInt)1024*1024*1024*1024*4*4*4*4,(Tcl_WideInt)1024*1024*1024*1024*1024,(Tcl_WideInt)1024*1024*1024*1024*1024*4,(Tcl_WideInt)1024*1024*1024*1024*1024*4*4,(Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4,(Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4*4,(Tcl_WideInt)1024*1024*1024*1024*1024*1024,(Tcl_WideInt)1024*1024*1024*1024*1024*1024*4,(Tcl_WideInt)3125*3125*3125*5*5,(Tcl_WideInt)3125*3125*3125*5*5*5,(Tcl_WideInt)3125*3125*3125*5*5*5*5,(Tcl_WideInt)3125*3125*3125*3125,(Tcl_WideInt)3125*3125*3125*3125*5,(Tcl_WideInt)3125*3125*3125*3125*5*5,(Tcl_WideInt)3125*3125*3125*3125*5*5*5,(Tcl_WideInt)3125*3125*3125*3125*5*5*5*5,(Tcl_WideInt)3125*3125*3125*3125*3125,(Tcl_WideInt)3125*3125*3125*3125*3125*5,(Tcl_WideInt)3125*3125*3125*3125*3125*5*5,(Tcl_WideInt)7776*7776*7776*6*6,(Tcl_WideInt)7776*7776*7776*6*6*6,(Tcl_WideInt)7776*7776*7776*6*6*6*6,(Tcl_WideInt)7776*7776*7776*7776,(Tcl_WideInt)7776*7776*7776*7776*6,(Tcl_WideInt)7776*7776*7776*7776*6*6,(Tcl_WideInt)7776*7776*7776*7776*6*6*6,(Tcl_WideInt)7776*7776*7776*7776*6*6*6*6,(Tcl_WideInt)16807*16807*16807*7*7,(Tcl_WideInt)16807*16807*16807*7*7*7,(Tcl_WideInt)16807*16807*16807*7*7*7*7,(Tcl_WideInt)16807*16807*16807*16807,(Tcl_WideInt)16807*16807*16807*16807*7,(Tcl_WideInt)16807*16807*16807*16807*7*7,(Tcl_WideInt)32768*32768*32768*8*8,(Tcl_WideInt)32768*32768*32768*8*8*8,(Tcl_WideInt)32768*32768*32768*8*8*8*8,(Tcl_WideInt)32768*32768*32768*32768,(Tcl_WideInt)59049*59049*59049*9*9,(Tcl_WideInt)59049*59049*59049*9*9*9,(Tcl_WideInt)59049*59049*59049*9*9*9*9,(Tcl_WideInt)100000*100000*100000*10*10,(Tcl_WideInt)100000*100000*100000*10*10*10,(Tcl_WideInt)161051*161051*161051*11*11,(Tcl_WideInt)161051*161051*161051*11*11*11,(Tcl_WideInt)248832*248832*248832*12*12,(Tcl_WideInt)371293*371293*371293*13*13};static const size_t Exp64ValueSize =sizeof(Exp64Value)/sizeof(Tcl_WideInt);#endif/* * Declarations for local procedures to this file: */#ifdef TCL_COMPILE_STATSstatic intEvalStatsCmd(ClientData clientData,
Tcl_Interp *interp,int objc,
Tcl_Obj *const objv[]);#endif/* TCL_COMPILE_STATS */#ifdef TCL_COMPILE_DEBUGstatic char*GetOpcodeName(unsigned char*pc);static voidPrintByteCodeInfo(ByteCode *codePtr);static const char*StringForResultCode(int result);static voidValidatePcAndStackTop(ByteCode *codePtr,unsigned char*pc,int stackTop,int stackLowerBound,int checkStack);#endif/* TCL_COMPILE_DEBUG */static voidDeleteExecStack(ExecStack *esPtr);static voidDupExprCodeInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);static voidFreeExprCodeInternalRep(Tcl_Obj *objPtr);static ExceptionRange *GetExceptRangeForPc(unsigned char*pc,int catchOnly,
ByteCode *codePtr);static const char*GetSrcInfoForPc(unsigned char*pc, ByteCode *codePtr,int*lengthPtr);static Tcl_Obj **GrowEvaluationStack(ExecEnv *eePtr,int growth,int move);static voidIllegalExprOperandType(Tcl_Interp *interp,unsigned char*pc, Tcl_Obj *opndPtr);static voidInitByteCodeExecution(Tcl_Interp *interp);/* Useful elsewhere, make available in tclInt.h or stubs? */static Tcl_Obj **StackAllocWords(Tcl_Interp *interp,int numWords);static Tcl_Obj **StackReallocWords(Tcl_Interp *interp,int numWords);/* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */static Tcl_ObjType exprCodeType = {"exprcode",
FreeExprCodeInternalRep,/* freeIntRepProc */
DupExprCodeInternalRep,/* dupIntRepProc */
NULL,/* updateStringProc */
NULL /* setFromAnyProc */};/* *---------------------------------------------------------------------- * * InitByteCodeExecution -- * * This procedure is called once to initialize the Tcl bytecode * interpreter. * * Results: * None. * * Side effects: * This procedure initializes the array of instruction names. If * compiling with the TCL_COMPILE_STATS flag, it initializes the array * that counts the executions of each instruction and it creates the * "evalstats" command. It also establishes the link between the Tcl * "tcl_traceExec" and C "tclTraceExec" variables. * *---------------------------------------------------------------------- */static voidInitByteCodeExecution(
Tcl_Interp *interp)/* Interpreter for which the Tcl variable * "tcl_traceExec" is linked to control * instruction tracing. */{#ifdef TCL_COMPILE_DEBUGif(Tcl_LinkVar(interp,"tcl_traceExec", (char*) &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");}#endif#ifdef TCL_COMPILE_STATSTcl_CreateObjCommand(interp,"evalstats", EvalStatsCmd, NULL, NULL);#endif/* TCL_COMPILE_STATS */}/* *---------------------------------------------------------------------- * * TclCreateExecEnv -- * * This procedure creates a new execution environment for Tcl bytecode * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is * typically created once for each Tcl interpreter (Interp structure) and * recursively passed to TclExecuteByteCode to execute ByteCode sequences * for nested commands. * * Results: * A newly allocated ExecEnv is returned. This points to an empty * evaluation stack of the standard initial size. * * Side effects: * The bytecode interpreter is also initialized here, as this procedure * will be called before any call to TclExecuteByteCode. * *---------------------------------------------------------------------- */#define TCL_STACK_INITIAL_SIZE 2000
ExecEnv *TclCreateExecEnv(
Tcl_Interp *interp)/* Interpreter for which the execution * environment is being created. */{
ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv));
ExecStack *esPtr = (ExecStack *)ckalloc(sizeof(ExecStack)+ (size_t) (TCL_STACK_INITIAL_SIZE-1) *sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;TclNewBooleanObj(eePtr->constants[0],0);Tcl_IncrRefCount(eePtr->constants[0]);TclNewBooleanObj(eePtr->constants[1],1);Tcl_IncrRefCount(eePtr->constants[1]);
esPtr->prevPtr = NULL;
esPtr->nextPtr = NULL;
esPtr->markerPtr = NULL;
esPtr->endPtr = &esPtr->stackWords[TCL_STACK_INITIAL_SIZE-1];
esPtr->tosPtr = &esPtr->stackWords[-1];Tcl_MutexLock(&execMutex);if(!execInitialized) {TclInitAuxDataTypeTable();InitByteCodeExecution(interp);
execInitialized =1;}Tcl_MutexUnlock(&execMutex);return eePtr;}#undef TCL_STACK_INITIAL_SIZE/* *---------------------------------------------------------------------- * * TclDeleteExecEnv -- * * Frees the storage for an ExecEnv. * * Results: * None. * * Side effects: * Storage for an ExecEnv and its contained storage (e.g. the evaluation * stack) is freed. * *---------------------------------------------------------------------- */static voidDeleteExecStack(
ExecStack *esPtr){if(esPtr->markerPtr) {Tcl_Panic("freeing an execStack which is still in use");}if(esPtr->prevPtr) {
esPtr->prevPtr->nextPtr = esPtr->nextPtr;}if(esPtr->nextPtr) {
esPtr->nextPtr->prevPtr = esPtr->prevPtr;}ckfree((char*) esPtr);}voidTclDeleteExecEnv(
ExecEnv *eePtr)/* Execution environment to free. */{
ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;/* * Delete all stacks in this exec env. */while(esPtr->nextPtr) {
esPtr = esPtr->nextPtr;}while(esPtr) {
tmpPtr = esPtr;
esPtr = tmpPtr->prevPtr;DeleteExecStack(tmpPtr);}TclDecrRefCount(eePtr->constants[0]);TclDecrRefCount(eePtr->constants[1]);ckfree((char*) eePtr);}/* *---------------------------------------------------------------------- * * TclFinalizeExecution -- * * Finalizes the execution environment setup so that it can be later * reinitialized. * * Results: * None. * * Side effects: * After this call, the next time TclCreateExecEnv will be called it will * call InitByteCodeExecution. * *---------------------------------------------------------------------- */voidTclFinalizeExecution(void){Tcl_MutexLock(&execMutex);
execInitialized =0;Tcl_MutexUnlock(&execMutex);TclFinalizeAuxDataTypeTable();}/* * Auxiliary code to insure that GrowEvaluationStack always returns correctly * aligned memory. * * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a * multiple of the wordsize 'sizeof(Tcl_Obj *)'. */#define WALLOCALIGN \ (TCL_ALLOCALIGN/sizeof(Tcl_Obj *))/* * OFFSET computes how many words have to be skipped until the next aligned * word. Note that we are only interested in the low order bits of ptr, so * that any possible information loss in PTR2INT is of no consequence. */staticinlineintOFFSET(void*ptr){int mask = TCL_ALLOCALIGN-1;int base =PTR2INT(ptr) & mask;return(TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *);}/* * Given a marker, compute where the following aligned memory starts. */#define MEMSTART(markerPtr) \ ((markerPtr) + OFFSET(markerPtr))/* *---------------------------------------------------------------------- * * GrowEvaluationStack -- * * This procedure grows a Tcl evaluation stack stored in an ExecEnv, * copying over the words since the last mark if so requested. A mark is * set at the beginning of the new area when no copying is requested. * * Results: * Returns a pointer to the first usable word in the (possibly) grown * stack. * * Side effects: * The size of the evaluation stack may be grown, a marker is set * *---------------------------------------------------------------------- */static Tcl_Obj **GrowEvaluationStack(
ExecEnv *eePtr,/* Points to the ExecEnv with an evaluation * stack to enlarge. */int growth,/* How much larger than the current used * size. */int move)/* 1 if move words since last marker. */{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;int newBytes, newElems, currElems;int needed = growth - (esPtr->endPtr - esPtr->tosPtr);
Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;int moveWords =0;if(move) {if(!markerPtr) {Tcl_Panic("STACK: Reallocating with no previous alloc");}if(needed <=0) {returnMEMSTART(markerPtr);}}else{
Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr +1;int offset =OFFSET(tmpMarkerPtr);if(needed + offset <0) {/* * Put a marker pointing to the previous marker in this stack, and * store it in esPtr as the current marker. Return a pointer to * the start of aligned memory. */
esPtr->markerPtr = tmpMarkerPtr;
memStart = tmpMarkerPtr + offset;
esPtr->tosPtr = memStart -1;*esPtr->markerPtr = (Tcl_Obj *) markerPtr;return memStart;}}/* * Reset move to hold the number of words to be moved to new stack (if * any) and growth to hold the complete stack requirements: add one for * the marker, (WALLOCALIGN-1) for the maximal possible offset. */if(move) {
moveWords = esPtr->tosPtr -MEMSTART(markerPtr) +1;}
needed = growth + moveWords + WALLOCALIGN;/* * Check if there is enough room in the next stack (if there is one, it * should be both empty and the last one!) */if(esPtr->nextPtr) {
oldPtr = esPtr;
esPtr = oldPtr->nextPtr;
currElems = esPtr->endPtr - &esPtr->stackWords[-1];if(esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) {Tcl_Panic("STACK: Stack after current is in use");}if(esPtr->nextPtr) {Tcl_Panic("STACK: Stack after current is not last");}if(needed <= currElems) {goto newStackReady;}DeleteExecStack(esPtr);
esPtr = oldPtr;}else{
currElems = esPtr->endPtr - &esPtr->stackWords[-1];}/* * We need to allocate a new stack! It needs to store 'growth' words, * including the elements to be copied over and the new marker. */
newElems =2*currElems;while(needed > newElems) {
newElems *=2;}
newBytes =sizeof(ExecStack) + (newElems-1) *sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = (ExecStack *)ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
esPtr->nextPtr = NULL;
esPtr->endPtr = &esPtr->stackWords[newElems-1];
newStackReady:
eePtr->execStackPtr = esPtr;/* * Store a NULL marker at the beginning of the stack, to indicate that * this is the first marker in this stack and that rewinding to here * should actually be a return to the previous stack. */
esPtr->stackWords[0] = NULL;
esPtr->markerPtr = &esPtr->stackWords[0];
memStart =MEMSTART(esPtr->markerPtr);
esPtr->tosPtr = memStart -1;if(move) {memcpy(memStart,MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *));
esPtr->tosPtr += moveWords;
oldPtr->markerPtr = (Tcl_Obj **) *markerPtr;
oldPtr->tosPtr = markerPtr-1;}/* * Free the old stack if it is now unused. */if(!oldPtr->markerPtr) {DeleteExecStack(oldPtr);}return memStart;}/* *-------------------------------------------------------------- * * TclStackAlloc, TclStackRealloc, TclStackFree -- * * Allocate memory from the execution stack; it has to be returned later * with a call to TclStackFree. * * Results: * A pointer to the first byte allocated, or panics if the allocation did * not succeed. * * Side effects: * The execution stack may be grown. * *-------------------------------------------------------------- */static Tcl_Obj **StackAllocWords(
Tcl_Interp *interp,int numWords){/* * Note that GrowEvaluationStack sets a marker in the stack. This marker * is read when rewinding, e.g., by TclStackFree. */
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
Tcl_Obj **resPtr =GrowEvaluationStack(eePtr, numWords,0);
eePtr->execStackPtr->tosPtr += numWords;return resPtr;}static Tcl_Obj **StackReallocWords(
Tcl_Interp *interp,int numWords){
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
Tcl_Obj **resPtr =GrowEvaluationStack(eePtr, numWords,1);
eePtr->execStackPtr->tosPtr += numWords;return resPtr;}voidTclStackFree(
Tcl_Interp *interp,void*freePtr){
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr;if(iPtr == NULL || iPtr->execEnvPtr == NULL) {Tcl_Free((char*) freePtr);return;}/* * Rewind the stack to the previous marker position. The current marker, * as set in the last call to GrowEvaluationStack, contains a pointer to * the previous marker. */
eePtr = iPtr->execEnvPtr;
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;if(MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) {Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?");}
esPtr->tosPtr = markerPtr-1;
esPtr->markerPtr = (Tcl_Obj **) *markerPtr;if(*markerPtr) {return;}/* * Return to previous stack. */
esPtr->tosPtr = &esPtr->stackWords[-1];if(esPtr->prevPtr) {
eePtr->execStackPtr = esPtr->prevPtr;}if(esPtr->nextPtr) {if(!esPtr->prevPtr) {
eePtr->execStackPtr = esPtr->nextPtr;}DeleteExecStack(esPtr);}}void*TclStackAlloc(
Tcl_Interp *interp,int numBytes){
Interp *iPtr = (Interp *) interp;int numWords = (numBytes + (sizeof(Tcl_Obj *) -1))/sizeof(Tcl_Obj *);if(iPtr == NULL || iPtr->execEnvPtr == NULL) {return(void*)Tcl_Alloc(numBytes);}return(void*)StackAllocWords(interp, numWords);}void*TclStackRealloc(
Tcl_Interp *interp,void*ptr,int numBytes){
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr;int numWords;if(iPtr == NULL || iPtr->execEnvPtr == NULL) {return(void*)Tcl_Realloc((char*) ptr, numBytes);}
eePtr = iPtr->execEnvPtr;
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;if(MEMSTART(markerPtr) != (Tcl_Obj **)ptr) {Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?");}
numWords = (numBytes + (sizeof(Tcl_Obj *) -1))/sizeof(Tcl_Obj *);return(void*)StackReallocWords(interp, numWords);}/* *-------------------------------------------------------------- * * Tcl_ExprObj -- * * Evaluate an expression in a Tcl_Obj. * * Results: * A standard Tcl object result. If the result is other than TCL_OK, then * the interpreter's result contains an error message. If the result is * TCL_OK, then a pointer to the expression's result value object is * stored in resultPtrPtr. In that case, the object's ref count is * incremented to reflect the reference returned to the caller; the * caller is then responsible for the resulting object and must, for * example, decrement the ref count when it is finished with the object. * * Side effects: * Any side effects caused by subcommands in the expression, if any. The * interpreter result is not modified unless there is an error. * *-------------------------------------------------------------- */intTcl_ExprObj(
Tcl_Interp *interp,/* Context in which to evaluate the * expression. */register Tcl_Obj *objPtr,/* Points to Tcl object containing expression * to evaluate. */
Tcl_Obj **resultPtrPtr)/* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv;/* Compilation environment structure allocated * in frame. */register ByteCode *codePtr = NULL;/* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */int result;/* * Execute the expression after first saving the interpreter's result. */
Tcl_Obj *saveObjPtr =Tcl_GetObjResult(interp);Tcl_IncrRefCount(saveObjPtr);/* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */if(objPtr->typePtr == &exprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;if(((Interp *) *codePtr->interpHandle != iPtr)|| (codePtr->compileEpoch != iPtr->compileEpoch)|| (codePtr->nsPtr != namespacePtr)|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
objPtr->typePtr->freeIntRepProc(objPtr);
objPtr->typePtr = (Tcl_ObjType *) NULL;}}if(objPtr->typePtr != &exprCodeType) {/* * TIP #280: No invoker (yet) - Expression compilation. */int length;const char*string =TclGetStringFromObj(objPtr, &length);TclInitCompileEnv(interp, &compEnv, string, length, NULL,0);TclCompileExpr(interp, string, length, &compEnv,0);/* * Successful compilation. If the expression yielded no instructions, * push an zero object as the expression's result. */if(compEnv.codeNext == compEnv.codeStart) {TclEmitPush(TclRegisterNewLiteral(&compEnv,"0",1),&compEnv);}/* * Add a "done" instruction as the last instruction and change the * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */TclEmitOpcode(INST_DONE, &compEnv);TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &exprCodeType;TclFreeCompileEnv(&compEnv);
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;#ifdef TCL_COMPILE_DEBUGif(tclTraceCompile ==2) {TclPrintByteCodeObj(interp, objPtr);fflush(stdout);}#endif/* TCL_COMPILE_DEBUG */}Tcl_ResetResult(interp);/* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */
codePtr->refCount++;
result =TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;if(codePtr->refCount <=0) {TclCleanupByteCode(codePtr);}/* * If the expression evaluated successfully, store a pointer to its value * object in resultPtrPtr then restore the old interpreter result. We * increment the object's ref count to reflect the reference that we are * returning to the caller. We also decrement the ref count of the * interpreter's result object after calling Tcl_SetResult since we next * store into that field directly. */if(result == TCL_OK) {*resultPtrPtr = iPtr->objResultPtr;Tcl_IncrRefCount(iPtr->objResultPtr);Tcl_SetObjResult(interp, saveObjPtr);}TclDecrRefCount(saveObjPtr);return result;}/* *---------------------------------------------------------------------- * * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression * bytecode. We do not copy the bytecode intrep. Instead, we * return without setting copyPtr->typePtr, so the copy is a plain * string copy of the expression value, and if it is to be used * as a compiled expression, it will just need a recompile. * * This makes sense, because with Tcl's copy-on-write practices, * the usual (only?) time Tcl_DuplicateObj() will be called is * when the copy is about to be modified, which would invalidate * any copied bytecode anyway. The only reason it might make sense * to copy the bytecode is if we had some modifying routines that * operated directly on the intrep, like we do for lists and dicts. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */static voidDupExprCodeInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr){return;}/* *---------------------------------------------------------------------- * * FreeExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression * bytecode. Frees the storage allocated to hold the internal rep, * unless ref counts indicate bytecode execution is still in progress. * * Results: * None. * * Side effects: * May free allocated memory. Leaves objPtr untyped. *---------------------------------------------------------------------- */static voidFreeExprCodeInternalRep(
Tcl_Obj *objPtr){
ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
codePtr->refCount--;if(codePtr->refCount <=0) {TclCleanupByteCode(codePtr);}
objPtr->typePtr = NULL;
objPtr->internalRep.otherValuePtr = NULL;}/* *---------------------------------------------------------------------- * * TclCompEvalObj -- * * This procedure evaluates the script contained in a Tcl_Obj by first * compiling it and then passing it to TclExecuteByteCode. * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and interp->objResultPtr refers to a Tcl object that either * contains the result of executing the code or an error message. * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */intTclCompEvalObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,const CmdFrame *invoker,int word){register Interp *iPtr = (Interp *) interp;register ByteCode *codePtr;/* Tcl Internal type of bytecode. */int result;
Namespace *namespacePtr;/* * Check that the interpreter is ready to execute scripts. Note that we * manage the interp's runlevel here: it is a small white lie (maybe), but * saves a ++/-- pair at each invocation. Amazingly enough, the impact on * performance is noticeable. */
iPtr->numLevels++;if(TclInterpReady(interp) == TCL_ERROR) {
result = TCL_ERROR;goto done;}
namespacePtr = iPtr->varFramePtr->nsPtr;/* * If the object is not already of tclByteCodeType, compile it (and reset * the compilation flags in the interpreter; this should be done after any * compilation). Otherwise, check that it is "fresh" enough. */if(objPtr->typePtr == &tclByteCodeType) {/* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the * compiled code wrong). The object needs to be recompiled if it was * compiled in/for a different interpreter, or for a different * namespace, or for the same namespace but with different name * resolution rules. Precompiled objects, however, are immutable and * therefore they are not recompiled, even if the epoch has changed. * * To be pedantically correct, we should also check that the * originating procPtr is the same as the current context procPtr * (assuming one exists at all - none for global level). This code is * #def'ed out because [info body] was changed to never return a * bytecode type object, which should obviate us from the extra checks * here. */
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;if(((Interp *) *codePtr->interpHandle != iPtr)|| (codePtr->compileEpoch != iPtr->compileEpoch)|| (codePtr->nsPtr != namespacePtr)|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {if(codePtr->flags & TCL_BYTECODE_PRECOMPILED) {if((Interp *) *codePtr->interpHandle != iPtr) {Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");}
codePtr->compileEpoch = iPtr->compileEpoch;}else{/* * This byteCode is invalid: free it and recompile. */
objPtr->typePtr->freeIntRepProc(objPtr);goto recompileObj;}}/* * #280. * Literal sharing fix. This part of the fix is not required by 8.4 * because it eval-directs any literals, so just saving the argument * locations per command in bytecode is enough, embedded 'eval' * commands, etc. get the correct information. * * It had be backported for 8.5 because we can force the separate * compiling of a literal (in a proc body) by putting it into a control * command with dynamic pieces, and then such literal may be shared * and require their line-information to be reset, as for 8.6, as * described below. * * In 8.6 all the embedded script are compiled, and the resulting * bytecode stored in the literal. Now the shared literal has bytecode * with location data for _one_ particular location this literal is * found at. If we get executed from a different location the bytecode * has to be recompiled to get the correct locations. Not doing this * will execute the saved bytecode with data for a different location, * causing 'info frame' to point to the wrong place in the sources. * * Future optimizations ... * (1) Save the location data (ExtCmdLoc) keyed by start line. In that * case we recompile once per location of the literal, but not * continously, because the moment we have all locations we do not * need to recompile any longer. * * (2) Alternative: Do not recompile, tell the execution engine the * offset between saved starting line and actual one. Then modify * the users to adjust the locations they have by this offset. * * (3) Alternative 2: Do not fully recompile, adjust just the location * information. */{
Tcl_HashEntry *hePtr =Tcl_FindHashEntry(iPtr->lineBCPtr, (char*) codePtr);if(hePtr) {
ExtCmdLoc *eclPtr =Tcl_GetHashValue(hePtr);int redo =0;if(invoker) {
CmdFrame *ctxPtr =TclStackAlloc(interp,sizeof(CmdFrame));*ctxPtr = *invoker;if(invoker->type == TCL_LOCATION_BC) {/* * Note: Type BC => ctx.data.eval.path is not used. * ctx.data.tebc.codePtr used instead */TclGetSrcInfoForPc(ctxPtr);if(ctxPtr->type == TCL_LOCATION_SOURCE) {/* * The reference made by 'TclGetSrcInfoForPc' is * dead. */Tcl_DecrRefCount(ctxPtr->data.eval.path);
ctxPtr->data.eval.path = NULL;}}if(word < ctxPtr->nline) {/* * Note: We do not care if the line[word] is -1. This * is a difference and requires a recompile (location * changed from absolute to relative, literal is used * fixed and through variable) * * Example: * test info-32.0 using literal of info-24.8 * (dict with ... vs set body ...). */
redo = ((eclPtr->type == TCL_LOCATION_SOURCE)&& (eclPtr->start != ctxPtr->line[word]))|| ((eclPtr->type == TCL_LOCATION_BC)&& (ctxPtr->type == TCL_LOCATION_SOURCE));}TclStackFree(interp, ctxPtr);}if(redo) {goto recompileObj;}}}/* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */
runCompiledObj:
codePtr->refCount++;
result =TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;if(codePtr->refCount <=0) {TclCleanupByteCode(codePtr);}goto done;}
recompileObj:
iPtr->errorLine =1;/* * TIP #280. Remember the invoker for a moment in the interpreter * structures so that the byte code compiler can pick it up when * initializing the compilation environment, i.e. the extended location * information. */
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
tclByteCodeType.setFromAnyProc(interp, objPtr);
iPtr->invokeCmdFramePtr = NULL;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;goto runCompiledObj;
done:
iPtr->numLevels--;return result;}/* *---------------------------------------------------------------------- * * TclIncrObj -- * * Increment an integeral value in a Tcl_Obj by an integeral value held * in another Tcl_Obj. Caller is responsible for making sure we can * update the first object. * * Results: * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On * error, an error message is left in the interpreter (if it is not NULL, * of course). * * Side effects: * valuePtr gets the new incrmented value. * *---------------------------------------------------------------------- */intTclIncrObj(
Tcl_Interp *interp,
Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr){
ClientData ptr1, ptr2;int type1, type2;
mp_int value, incr;if(Tcl_IsShared(valuePtr)) {Tcl_Panic("%s called with shared object","TclIncrObj");}if(GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {/* * Produce error message (reparse?!) */returnTclGetIntFromObj(interp, valuePtr, &type1);}if(GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) {/* * Produce error message (reparse?!) */TclGetIntFromObj(interp, incrPtr, &type1);Tcl_AddErrorInfo(interp,"\n(reading increment)");return TCL_ERROR;}if((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {long augend = *((const long*) ptr1);long addend = *((const long*) ptr2);long sum = augend + addend;/* * Overflow when (augend and sum have different sign) and (augend and * addend have the same sign). This is encapsulated in the Overflowing * macro. */if(!Overflowing(augend, addend, sum)) {TclSetLongObj(valuePtr, sum);return TCL_OK;}#ifndef NO_WIDE_TYPE{
Tcl_WideInt w1 = (Tcl_WideInt) augend;
Tcl_WideInt w2 = (Tcl_WideInt) addend;/* * We know the sum value is outside the long range, so we use the * macro form that doesn't range test again. */TclSetWideIntObj(valuePtr, w1 + w2);return TCL_OK;}#endif}if((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {/* * Produce error message (reparse?!) */returnTclGetIntFromObj(interp, valuePtr, &type1);}if((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {/* * Produce error message (reparse?!) */TclGetIntFromObj(interp, incrPtr, &type1);Tcl_AddErrorInfo(interp,"\n(reading increment)");return TCL_ERROR;}#ifndef NO_WIDE_TYPEif((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
Tcl_WideInt w1, w2, sum;TclGetWideIntFromObj(NULL, valuePtr, &w1);TclGetWideIntFromObj(NULL, incrPtr, &w2);
sum = w1 + w2;/* * Check for overflow. */if(!Overflowing(w1, w2, sum)) {Tcl_SetWideIntObj(valuePtr, sum);return TCL_OK;}}#endifTcl_TakeBignumFromObj(interp, valuePtr, &value);Tcl_GetBignumFromObj(interp, incrPtr, &incr);mp_add(&value, &incr, &value);mp_clear(&incr);Tcl_SetBignumObj(valuePtr, &value);return TCL_OK;}/* *---------------------------------------------------------------------- * * TclExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It * returns when a "done" instruction is executed or an error occurs. * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and interp->objResultPtr refers to a Tcl object that either * contains the result of executing the code or an error message. * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */intTclExecuteByteCode(
Tcl_Interp *interp,/* Token for command interpreter. */
ByteCode *codePtr)/* The bytecode sequence to interpret. */{/* * Compiler cast directive - not a real variable. * Interp *iPtr = (Interp *) interp; */#define iPtr ((Interp *) interp)/* * Check just the read-traced/write-traced bit of a variable. */#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)/* * Constants: variables that do not change during the execution, used * sporadically. */
ExecStack *esPtr;
Tcl_Obj **initTosPtr;/* Stack top at start of execution. */ptrdiff_t*initCatchTop;/* Catch stack top at start of execution. */
Var *compiledLocals;
Namespace *namespacePtr;
CmdFrame *bcFramePtr;/* TIP #280: Structure for tracking lines. */
Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];/* * Globals: variables that store state, must remain valid at all times. */ptrdiff_t*catchTop;register Tcl_Obj **tosPtr;/* Cached pointer to top of evaluation * stack. */registerunsigned char*pc = codePtr->codeStart;/* The current program counter. */int instructionCount =0;/* Counter that is used to work out when to * call Tcl_AsyncReady() */
Tcl_Obj *expandNestList = NULL;int checkInterp =0;/* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() *//* * Transfer variables - needed only between opcodes, but not while * executing an instruction. */registerint cleanup;
Tcl_Obj *objResultPtr;/* * Result variable - needed only when going to checkForcatch or other * error handlers; also used as local in some opcodes. */int result = TCL_OK;/* Return code returned after execution. *//* * Locals - variables that are used within opcodes or bounded sections of * the file (jumps between opcodes within a family). * NOTE: These are now defined locally where needed. */#ifdef TCL_COMPILE_DEBUGint traceInstructions = (tclTraceExec ==3);char cmdNameBuf[21];#endifchar*curInstName = NULL;/* * The execution uses a unified stack: first the catch stack, immediately * above it a CmdFrame, then the execution stack. * * Make sure the catch stack is large enough to hold the maximum number of * catch commands that could ever be executing at the same time (this will * be no more than the exception range array's depth). Make sure the * execution stack is large enough to execute this ByteCode. */
catchTop = initCatchTop = (ptrdiff_t*) (GrowEvaluationStack(iPtr->execEnvPtr,(sizeof(CmdFrame) +sizeof(Tcl_Obj *) -1)/sizeof(Tcl_Obj *) +
codePtr->maxExceptDepth + codePtr->maxStackDepth,0) -1);
bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth +1);
tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr +1)) -1;
esPtr = iPtr->execEnvPtr->execStackPtr;/* * TIP #280: Initialize the frame. Do not push it yet. */
bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1:1);
bcFramePtr->framePtr = iPtr->framePtr;
bcFramePtr->nextPtr = iPtr->cmdFramePtr;
bcFramePtr->nline =0;
bcFramePtr->line = NULL;
bcFramePtr->data.tebc.codePtr = codePtr;
bcFramePtr->data.tebc.pc = NULL;
bcFramePtr->cmd.str.cmd = NULL;
bcFramePtr->cmd.str.len =0;#ifdef TCL_COMPILE_DEBUGif(tclTraceExec >=2) {PrintByteCodeInfo(codePtr);fprintf(stdout," Starting stack top=%d\n", (int) CURR_DEPTH);fflush(stdout);}#endif#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;#endif
namespacePtr = iPtr->varFramePtr->nsPtr;
compiledLocals = iPtr->varFramePtr->compiledLocals;/* * Loop executing instructions until a "done" instruction, a TCL_RETURN, * or some error. */goto cleanup0;/* * Targets for standard instruction endings; unrolled for speed in the * most frequent cases (instructions that consume up to two stack * elements). * * This used to be a "for(;;)" loop, with each instruction doing its own * cleanup. */{
Tcl_Obj *valuePtr;
cleanupV_pushObjResultPtr:switch(cleanup) {case0:*(++tosPtr) = (objResultPtr);goto cleanup0;default:
cleanup -=2;while(cleanup--) {
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);}case2:
cleanup2_pushObjResultPtr:
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);case1:
cleanup1_pushObjResultPtr:
valuePtr = OBJ_AT_TOS;TclDecrRefCount(valuePtr);}
OBJ_AT_TOS = objResultPtr;goto cleanup0;
cleanupV:switch(cleanup) {default:
cleanup -=2;while(cleanup--) {
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);}case2:
cleanup2:
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);case1:
cleanup1:
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);case0:/* * We really want to do nothing now, but this is needed for some * compilers (SunPro CC). */break;}}
cleanup0:#ifdef TCL_COMPILE_DEBUG/* * Skip the stack depth check if an expansion is in progress. */ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH,0,/*checkStack*/ expandNestList == NULL);if(traceInstructions) {fprintf(stdout,"%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);TclPrintInstruction(codePtr, pc);fflush(stdout);}#endif/* TCL_COMPILE_DEBUG */#ifdef TCL_COMPILE_STATS
iPtr->stats.instructionCount[*pc]++;#endif/* * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */if((instructionCount++ & ASYNC_CHECK_COUNT_MASK) ==0) {/* * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1). */if(TclAsyncReady(iPtr)) {int localResult;DECACHE_STACK_INFO();
localResult =Tcl_AsyncInvoke(interp, result);CACHE_STACK_INFO();if(localResult == TCL_ERROR) {
result = localResult;goto checkForCatch;}}if(TclLimitReady(iPtr->limit)) {int localResult;DECACHE_STACK_INFO();
localResult =Tcl_LimitCheck(interp);CACHE_STACK_INFO();if(localResult == TCL_ERROR) {
result = localResult;goto checkForCatch;}}}TCL_DTRACE_INST_NEXT();/* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf] * Resolving them before the switch reduces the cost of branch * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!) * reduces total obj size. */if(*pc == INST_LOAD_SCALAR1) {goto instLoadScalar1;}else if(*pc == INST_PUSH1) {goto instPush1Peephole;}switch(*pc) {case INST_SYNTAX:case INST_RETURN_IMM: {int code =TclGetInt4AtPtr(pc+1);int level =TclGetUInt4AtPtr(pc+5);/* * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr. */TRACE(("%u %u => ", code, level));
result =TclProcessReturn(interp, code, level, OBJ_AT_TOS);if(result == TCL_OK) {TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",O2S(objResultPtr)));NEXT_INST_F(9,1,0);}else{Tcl_SetObjResult(interp, OBJ_UNDER_TOS);if(*pc == INST_SYNTAX) {
iPtr->flags &= ~ERR_ALREADY_LOGGED;}
cleanup =2;goto processExceptionReturn;}}case INST_RETURN_STK:TRACE(("=> "));
objResultPtr =POP_OBJECT();
result =Tcl_SetReturnOptions(interp, OBJ_AT_TOS);Tcl_DecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = objResultPtr;if(result == TCL_OK) {TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",O2S(objResultPtr)));NEXT_INST_F(1,0,0);}else{Tcl_SetObjResult(interp, objResultPtr);
cleanup =1;goto processExceptionReturn;}case INST_DONE:if(tosPtr > initTosPtr) {/* * Set the interpreter's object result to point to the topmost * object from the stack, and check for a possible [catch]. The * stackTop's level and refCount will be handled by "processCatch" * or "abnormalReturn". */Tcl_SetObjResult(interp, OBJ_AT_TOS);#ifdef TCL_COMPILE_DEBUGTRACE_WITH_OBJ(("=> return code=%d, result=", result),
iPtr->objResultPtr);if(traceInstructions) {fprintf(stdout,"\n");}#endifgoto checkForCatch;}else{(void)POP_OBJECT();goto abnormalReturn;}case INST_PUSH1:
instPush1Peephole:PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);TRACE_WITH_OBJ(("%u => ",TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
pc +=2;#if !TCL_COMPILE_DEBUG/* * Runtime peephole optimisation: check if we are pushing again. */if(*pc == INST_PUSH1) {TCL_DTRACE_INST_NEXT();goto instPush1Peephole;}#endifNEXT_INST_F(0,0,0);case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];TRACE_WITH_OBJ(("%u => ",TclGetUInt4AtPtr(pc+1)), objResultPtr);NEXT_INST_F(5,0,1);case INST_POP: {
Tcl_Obj *valuePtr;TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);/* * Runtime peephole optimisation: an INST_POP is scheduled at the end * of most commands. If the next instruction is an INST_START_CMD, * fall through to it. */
pc++;#if !TCL_COMPILE_DEBUGif(*pc == INST_START_CMD) {TCL_DTRACE_INST_NEXT();goto instStartCmdPeephole;}#endifNEXT_INST_F(0,0,0);}case INST_START_CMD:#if !TCL_COMPILE_DEBUG
instStartCmdPeephole:#endif/* * Remark that if the interpreter is marked for deletion its * compileEpoch is modified, so that the epoch check also verifies * that the interp is not deleted. If no outside call has been made * since the last check, it is safe to omit the check. */
iPtr->cmdCount +=TclGetUInt4AtPtr(pc+5);if(!checkInterp) {
instStartCmdOK:NEXT_INST_F(9,0,0);}else if(((codePtr->compileEpoch == iPtr->compileEpoch)&& (codePtr->nsEpoch == namespacePtr->resolverEpoch))|| (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
checkInterp =0;goto instStartCmdOK;}else{const char*bytes;int length, opnd;
Tcl_Obj *newObjResultPtr;
bytes =GetSrcInfoForPc(pc, codePtr, &length);DECACHE_STACK_INFO();
result =Tcl_EvalEx(interp, bytes, length,0);CACHE_STACK_INFO();if(result != TCL_OK) {
cleanup =0;if(result == TCL_ERROR) {/* * Tcl_EvalEx already did the task of logging * the error to the stack trace for us, so set * a flag to prevent the TEBC exception handling * machinery from trying to do it again. * Tcl Bug 2037338. See test execute-8.4. */
iPtr->flags |= ERR_ALREADY_LOGGED;}goto processExceptionReturn;}
opnd =TclGetUInt4AtPtr(pc+1);
objResultPtr =Tcl_GetObjResult(interp);TclNewObj(newObjResultPtr);Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;NEXT_INST_V(opnd,0, -1);}case INST_DUP:
objResultPtr = OBJ_AT_TOS;TRACE_WITH_OBJ(("=> "), objResultPtr);NEXT_INST_F(1,0,1);case INST_OVER: {int opnd;
opnd =TclGetUInt4AtPtr(pc+1);
objResultPtr =OBJ_AT_DEPTH(opnd);TRACE_WITH_OBJ(("=> "), objResultPtr);NEXT_INST_F(5,0,1);}case INST_REVERSE: {int opnd;
Tcl_Obj **a, **b;
opnd =TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;while(a<b) {
Tcl_Obj *temp = *a;*a = *b;*b = temp;
a++; b--;}NEXT_INST_F(5,0,0);}case INST_CONCAT1: {int opnd, length, appendLen =0;char*bytes, *p;
Tcl_Obj **currPtr;
opnd =TclGetUInt1AtPtr(pc+1);/* * Compute the length to be appended. */for(currPtr=&OBJ_AT_DEPTH(opnd-2);
appendLen >=0&& currPtr<=&OBJ_AT_TOS; currPtr++) {
bytes =TclGetStringFromObj(*currPtr, &length);if(bytes != NULL) {
appendLen += length;}}if(appendLen <0) {/* TODO: convert panic to error ? */Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);}/* * If nothing is to be appended, just return the first object by * dropping all the others from the stack; this saves both the * computation and copy of the string rep of the first object, * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. */if(appendLen ==0) {TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);NEXT_INST_V(2, (opnd-1),0);}/* * If the first object is shared, we need a new obj for the result; * otherwise, we can reuse the first object. In any case, make sure it * has enough room to accomodate all the concatenated bytes. Note that * if it is unshared its bytes are copied by ckrealloc, so that we set * the loop parameters to avoid copying them again: p points to the * end of the already copied bytes, currPtr to the second object. */
objResultPtr =OBJ_AT_DEPTH(opnd-1);
bytes =TclGetStringFromObj(objResultPtr, &length);if(length + appendLen <0) {/* TODO: convert panic to error ? */Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);}#if !TCL_COMPILE_DEBUGif(bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {TclFreeIntRep(objResultPtr);
objResultPtr->typePtr = NULL;
objResultPtr->bytes =ckrealloc(bytes, (length + appendLen +1));
objResultPtr->length = length + appendLen;
p =TclGetString(objResultPtr) + length;
currPtr = &OBJ_AT_DEPTH(opnd -2);}else{#endif
p = (char*)ckalloc((unsigned) (length + appendLen +1));TclNewObj(objResultPtr);
objResultPtr->bytes = p;
objResultPtr->length = length + appendLen;
currPtr = &OBJ_AT_DEPTH(opnd -1);#if !TCL_COMPILE_DEBUG}#endif/* * Append the remaining characters. */for(; currPtr <= &OBJ_AT_TOS; currPtr++) {
bytes =TclGetStringFromObj(*currPtr, &length);if(bytes != NULL) {memcpy(p, bytes, (size_t) length);
p += length;}}*p ='\0';TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);NEXT_INST_V(2, opnd,1);}case INST_EXPAND_START: {/* * Push an element to the expandNestList. This records the current * stack depth - i.e., the point in the stack where the expanded * command starts. * * Use a Tcl_Obj as linked list element; slight mem waste, but faster * allocation than ckalloc. This also abuses the Tcl_Obj structure, as * we do not define a special tclObjType for it. It is not dangerous * as the obj is never passed anywhere, so that all manipulations are * performed here and in INST_INVOKE_EXPANDED (in case of an expansion * error, also in INST_EXPAND_STKTOP). */
Tcl_Obj *objPtr;TclNewObj(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) CURR_DEPTH;
objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList;
expandNestList = objPtr;NEXT_INST_F(1,0,0);}case INST_EXPAND_STKTOP: {int objc, length, i;
Tcl_Obj **objv, *valuePtr;ptrdiff_t moved;/* * Make sure that the element at stackTop is a list; if not, just * leave with an error. Note that the element from the expand list * will be removed at checkForCatch. */
valuePtr = OBJ_AT_TOS;if(TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){TRACE_WITH_OBJ(("%.30s => ERROR: ",O2S(valuePtr)),Tcl_GetObjResult(interp));
result = TCL_ERROR;goto checkForCatch;}(void)POP_OBJECT();/* * Make sure there is enough room in the stack to expand this list * *and* process the rest of the command (at least up to the next * argument expansion or command end). The operand is the current * stack depth, as seen by the compiler. */
length = objc + (codePtr->maxStackDepth -TclGetInt4AtPtr(pc+1));DECACHE_STACK_INFO();
moved = (GrowEvaluationStack(iPtr->execEnvPtr, length,1) -1)- (Tcl_Obj **) initCatchTop;if(moved) {/* * Change the global data to point to the new stack. */
initCatchTop += moved;
catchTop += moved;
initTosPtr += moved;
tosPtr += moved;
esPtr = iPtr->execEnvPtr->execStackPtr;}/* * Expand the list at stacktop onto the stack; free the list. Knowing * that it has a freeIntRepProc we use Tcl_DecrRefCount(). */for(i =0; i < objc; i++) {PUSH_OBJECT(objv[i]);}Tcl_DecrRefCount(valuePtr);NEXT_INST_F(5,0,0);}{/* * INVOCATION BLOCK */int objc, pcAdjustment;case INST_INVOKE_EXPANDED:{
Tcl_Obj *objPtr = expandNestList;
expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
objc = CURR_DEPTH
- (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1;TclDecrRefCount(objPtr);}if(objc) {
pcAdjustment =1;goto doInvocation;}else{/* * Nothing was expanded, return {}. */TclNewObj(objResultPtr);NEXT_INST_F(1,0,1);}case INST_INVOKE_STK4:
objc =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;goto doInvocation;case INST_INVOKE_STK1:
objc =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
doInvocation:{
Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1);#ifdef TCL_COMPILE_DEBUGif(tclTraceExec >=2) {int i;if(traceInstructions) {strncpy(cmdNameBuf,TclGetString(objv[0]),20);TRACE(("%u => call ", objc));}else{fprintf(stdout,"%d: (%u) invoking ", iPtr->numLevels,(unsigned)(pc - codePtr->codeStart));}for(i =0; i < objc; i++) {TclPrintObject(stdout, objv[i],15);fprintf(stdout," ");}fprintf(stdout,"\n");fflush(stdout);}#endif/*TCL_COMPILE_DEBUG*//* * Reset the instructionCount variable, since we're about to check * for async stuff anyway while processing TclEvalObjvInternal. */
instructionCount =1;/* * Finally, let TclEvalObjvInternal handle the command. * * TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */
bcFramePtr->data.tebc.pc = (char*) pc;
iPtr->cmdFramePtr = bcFramePtr;if(iPtr->flags & INTERP_DEBUG_FRAME) {TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, pc - codePtr->codeStart);}DECACHE_STACK_INFO();
result =TclEvalObjvInternal(interp, objc, objv,/* call from TEBC */(char*) -1, -1,0);CACHE_STACK_INFO();if(iPtr->flags & INTERP_DEBUG_FRAME) {TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc,
codePtr, pc - codePtr->codeStart);}
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;if(result == TCL_OK) {
Tcl_Obj *objPtr;#ifndef TCL_COMPILE_DEBUGif(*(pc+pcAdjustment) == INST_POP) {NEXT_INST_V((pcAdjustment+1), objc,0);}#endif/* * Push the call's object result and continue execution with * the next instruction. */TRACE_WITH_OBJ(("%u => ... after\"%.20s\": TCL_OK, result=",
objc, cmdNameBuf),Tcl_GetObjResult(interp));
objResultPtr =Tcl_GetObjResult(interp);/* * Reset the interp's result to avoid possible duplications of * large objects [Bug 781585]. We do not call Tcl_ResetResult * to avoid any side effects caused by the resetting of * errorInfo and errorCode [Bug 804681], which are not needed * here. We chose instead to manipulate the interp's object * result directly. * * Note that the result object is now in objResultPtr, it * keeps the refCount it had in its role of * iPtr->objResultPtr. */TclNewObj(objPtr);Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;NEXT_INST_V(pcAdjustment, objc, -1);}else{
cleanup = objc;goto processExceptionReturn;}}#if TCL_SUPPORT_84_BYTECODEcase INST_CALL_BUILTIN_FUNC1: {/* * Call one of the built-in pre-8.5 Tcl math functions. This * translates to INST_INVOKE_STK1 with the first argument of * ::tcl::mathfunc::$objv[0]. We need to insert the named math * function into the stack. */int opnd, numArgs;
Tcl_Obj *objPtr;
opnd =TclGetUInt1AtPtr(pc+1);if((opnd <0) || (opnd > LAST_BUILTIN_FUNC)) {TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);}
objPtr =Tcl_NewStringObj("::tcl::mathfunc::",17);Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1);/* * Only 0, 1 or 2 args. */
numArgs = tclBuiltinFuncTable[opnd].numArgs;if(numArgs ==0) {PUSH_OBJECT(objPtr);}else if(numArgs ==1) {
Tcl_Obj *tmpPtr1 =POP_OBJECT();PUSH_OBJECT(objPtr);PUSH_OBJECT(tmpPtr1);Tcl_DecrRefCount(tmpPtr1);}else{
Tcl_Obj *tmpPtr1, *tmpPtr2;
tmpPtr2 =POP_OBJECT();
tmpPtr1 =POP_OBJECT();PUSH_OBJECT(objPtr);PUSH_OBJECT(tmpPtr1);PUSH_OBJECT(tmpPtr2);Tcl_DecrRefCount(tmpPtr1);Tcl_DecrRefCount(tmpPtr2);}
objc = numArgs +1;
pcAdjustment =2;goto doInvocation;}case INST_CALL_FUNC1: {/* * Call a non-builtin Tcl math function previously registered by a * call to Tcl_CreateMathFunc pre-8.5. This is essentially * INST_INVOKE_STK1 converting the first arg to * ::tcl::mathfunc::$objv[0]. */
Tcl_Obj *tmpPtr, *objPtr;/* * Number of arguments. The function name is the 0-th argument. */
objc =TclGetUInt1AtPtr(pc+1);
objPtr =OBJ_AT_DEPTH(objc-1);
tmpPtr =Tcl_NewStringObj("::tcl::mathfunc::",17);Tcl_AppendObjToObj(tmpPtr, objPtr);Tcl_DecrRefCount(objPtr);/* * Variation of PUSH_OBJECT. */OBJ_AT_DEPTH(objc-1) = tmpPtr;Tcl_IncrRefCount(tmpPtr);
pcAdjustment =2;goto doInvocation;}#else/* * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support * remains for existing bytecode precompiled files. */case INST_CALL_BUILTIN_FUNC1:Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");case INST_CALL_FUNC1:Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found");#endif}case INST_EVAL_STK: {/* * Note to maintainers: it is important that INST_EVAL_STK pop its * argument from the stack before jumping to checkForCatch! DO NOT * OPTIMISE! */
Tcl_Obj *objPtr = OBJ_AT_TOS;DECACHE_STACK_INFO();/* * TIP #280: The invoking context is left NULL for a dynamically * constructed command. We cannot match its lines to the outer * context. */
result =TclCompEvalObj(interp, objPtr, NULL,0);CACHE_STACK_INFO();if(result == TCL_OK) {/* * Normal return; push the eval's object result. */
objResultPtr =Tcl_GetObjResult(interp);TRACE_WITH_OBJ(("\"%.30s\"=> ",O2S(objPtr)),Tcl_GetObjResult(interp));/* * Reset the interp's result to avoid possible duplications of * large objects [Bug 781585]. We do not call Tcl_ResetResult to * avoid any side effects caused by the resetting of errorInfo and * errorCode [Bug 804681], which are not needed here. We chose * instead to manipulate the interp's object result directly. * * Note that the result object is now in objResultPtr, it keeps * the refCount it had in its role of iPtr->objResultPtr. */TclNewObj(objPtr);Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;NEXT_INST_F(1,1, -1);}else{
cleanup =1;goto processExceptionReturn;}}case INST_EXPR_STK: {
Tcl_Obj *objPtr, *valuePtr;
objPtr = OBJ_AT_TOS;DECACHE_STACK_INFO();/*Tcl_ResetResult(interp);*/
result =Tcl_ExprObj(interp, objPtr, &valuePtr);CACHE_STACK_INFO();if(result == TCL_OK) {
objResultPtr = valuePtr;TRACE_WITH_OBJ(("\"%.30s\"=> ",O2S(objPtr)), valuePtr);NEXT_INST_F(1,1, -1);/* Already has right refct. */}else{TRACE_WITH_OBJ(("\"%.30s\"=> ERROR: ",O2S(objPtr)),Tcl_GetObjResult(interp));goto checkForCatch;}}/* * --------------------------------------------------------- * Start of INST_LOAD instructions. * * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to some * common execution code. */{int opnd, pcAdjustment;
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
Tcl_Obj *objPtr;case INST_LOAD_SCALAR1:
instLoadScalar1:
opnd =TclGetUInt1AtPtr(pc+1);
varPtr = &(compiledLocals[opnd]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}TRACE(("%u => ", opnd));if(TclIsVarDirectReadable(varPtr)) {/* * No errors, no traces: just get the value. */
objResultPtr = varPtr->value.objPtr;TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_F(2,0,1);}
pcAdjustment =2;
cleanup =0;
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;goto doCallPtrGetVar;case INST_LOAD_SCALAR4:
opnd =TclGetUInt4AtPtr(pc+1);
varPtr = &(compiledLocals[opnd]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}TRACE(("%u => ", opnd));if(TclIsVarDirectReadable(varPtr)) {/* * No errors, no traces: just get the value. */
objResultPtr = varPtr->value.objPtr;TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_F(5,0,1);}
pcAdjustment =5;
cleanup =0;
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;goto doCallPtrGetVar;case INST_LOAD_ARRAY4:
opnd =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;goto doLoadArray;case INST_LOAD_ARRAY1:
opnd =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
doLoadArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
arrayPtr = &(compiledLocals[opnd]);while(TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;}TRACE(("%u\"%.30s\"=> ", opnd,O2S(part2Ptr)));if(TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
varPtr =VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);if(varPtr &&TclIsVarDirectReadable(varPtr)) {/* * No errors, no traces: just get the value. */
objResultPtr = varPtr->value.objPtr;TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_F(pcAdjustment,1,1);}}
varPtr =TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG,"read",0,1, arrayPtr, opnd);if(varPtr == NULL) {TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}
cleanup =1;goto doCallPtrGetVar;case INST_LOAD_ARRAY_STK:
cleanup =2;
part2Ptr = OBJ_AT_TOS;/* element name */
objPtr = OBJ_UNDER_TOS;/* array name */TRACE(("\"%.30s(%.30s)\"=> ",O2S(objPtr),O2S(part2Ptr)));goto doLoadStk;case INST_LOAD_STK:case INST_LOAD_SCALAR_STK:
cleanup =1;
part2Ptr = NULL;
objPtr = OBJ_AT_TOS;/* variable name */TRACE(("\"%.30s\"=> ",O2S(objPtr)));
doLoadStk:
part1Ptr = objPtr;
varPtr =TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG,"read",/*createPart1*/0,/*createPart2*/1,&arrayPtr);if(varPtr) {if(TclIsVarDirectReadable2(varPtr, arrayPtr)) {/* * No errors, no traces: just get the value. */
objResultPtr = varPtr->value.objPtr;TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_V(1, cleanup,1);}
pcAdjustment =1;
opnd = -1;goto doCallPtrGetVar;}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}
doCallPtrGetVar:/* * There are either errors or the variable is traced: call * TclPtrGetVar to process fully. */DECACHE_STACK_INFO();
objResultPtr =TclPtrGetVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);CACHE_STACK_INFO();if(objResultPtr) {TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_V(pcAdjustment, cleanup,1);}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}}/* * End of INST_LOAD instructions. * --------------------------------------------------------- *//* * --------------------------------------------------------- * Start of INST_STORE and related instructions. * * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to somme * common execution code. */{int opnd, pcAdjustment, storeFlags;
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
Tcl_Obj *objPtr, *valuePtr;case INST_STORE_ARRAY4:
opnd =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;goto doStoreArrayDirect;case INST_STORE_ARRAY1:
opnd =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
doStoreArrayDirect:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
arrayPtr = &(compiledLocals[opnd]);TRACE(("%u\"%.30s\"<-\"%.30s\"=> ", opnd,O2S(part2Ptr),O2S(valuePtr)));while(TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;}if(TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) {
varPtr =VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);if(varPtr &&TclIsVarDirectWritable(varPtr)) {
tosPtr--;Tcl_DecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = valuePtr;goto doStoreVarDirect;}}
cleanup =2;
storeFlags = TCL_LEAVE_ERR_MSG;
part1Ptr = NULL;goto doStoreArrayDirectFailed;case INST_STORE_SCALAR4:
opnd =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;goto doStoreScalarDirect;case INST_STORE_SCALAR1:
opnd =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
doStoreScalarDirect:
valuePtr = OBJ_AT_TOS;
varPtr = &(compiledLocals[opnd]);TRACE(("%u <-\"%.30s\"=> ", opnd,O2S(valuePtr)));while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}if(TclIsVarDirectWritable(varPtr)) {
doStoreVarDirect:/* * No traces, no errors, plain 'set': we can safely inline. The * value *will* be set to what's requested, so that the stack top * remains pointing to the same Tcl_Obj. */
valuePtr = varPtr->value.objPtr;if(valuePtr != NULL) {TclDecrRefCount(valuePtr);}
objResultPtr = OBJ_AT_TOS;
varPtr->value.objPtr = objResultPtr;#ifndef TCL_COMPILE_DEBUGif(*(pc+pcAdjustment) == INST_POP) {
tosPtr--;NEXT_INST_F((pcAdjustment+1),0,0);}#elseTRACE_APPEND(("%.30s\n",O2S(objResultPtr)));#endifTcl_IncrRefCount(objResultPtr);NEXT_INST_F(pcAdjustment,0,0);}
storeFlags = TCL_LEAVE_ERR_MSG;
part1Ptr = NULL;goto doStoreScalar;case INST_LAPPEND_STK:
valuePtr = OBJ_AT_TOS;/* value to append */
part2Ptr = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);goto doStoreStk;case INST_LAPPEND_ARRAY_STK:
valuePtr = OBJ_AT_TOS;/* value to append */
part2Ptr = OBJ_UNDER_TOS;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);goto doStoreStk;case INST_APPEND_STK:
valuePtr = OBJ_AT_TOS;/* value to append */
part2Ptr = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);goto doStoreStk;case INST_APPEND_ARRAY_STK:
valuePtr = OBJ_AT_TOS;/* value to append */
part2Ptr = OBJ_UNDER_TOS;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);goto doStoreStk;case INST_STORE_ARRAY_STK:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
storeFlags = TCL_LEAVE_ERR_MSG;goto doStoreStk;case INST_STORE_STK:case INST_STORE_SCALAR_STK:
valuePtr = OBJ_AT_TOS;
part2Ptr = NULL;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreStk:
objPtr =OBJ_AT_DEPTH(1+ (part2Ptr != NULL));/* variable name */
part1Ptr = objPtr;#ifdef TCL_COMPILE_DEBUGif(part2Ptr == NULL) {TRACE(("\"%.30s\"<-\"%.30s\"=>",O2S(part1Ptr),O2S(valuePtr)));}else{TRACE(("\"%.30s(%.30s)\"<-\"%.30s\"=> ",O2S(part1Ptr),O2S(part2Ptr),O2S(valuePtr)));}#endif
varPtr =TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG,"set",/*createPart1*/1,/*createPart2*/1, &arrayPtr);if(varPtr) {
cleanup = ((part2Ptr == NULL)? 2:3);
pcAdjustment =1;
opnd = -1;goto doCallPtrSetVar;}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}case INST_LAPPEND_ARRAY4:
opnd =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);goto doStoreArray;case INST_LAPPEND_ARRAY1:
opnd =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);goto doStoreArray;case INST_APPEND_ARRAY4:
opnd =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);goto doStoreArray;case INST_APPEND_ARRAY1:
opnd =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);goto doStoreArray;
doStoreArray:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
arrayPtr = &(compiledLocals[opnd]);TRACE(("%u\"%.30s\"<-\"%.30s\"=> ", opnd,O2S(part2Ptr),O2S(valuePtr)));while(TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;}
cleanup =2;
part1Ptr = NULL;
doStoreArrayDirectFailed:
varPtr =TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG,"set",1,1, arrayPtr, opnd);if(varPtr) {goto doCallPtrSetVar;}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}case INST_LAPPEND_SCALAR4:
opnd =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);goto doStoreScalar;case INST_LAPPEND_SCALAR1:
opnd =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);goto doStoreScalar;case INST_APPEND_SCALAR4:
opnd =TclGetUInt4AtPtr(pc+1);
pcAdjustment =5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);goto doStoreScalar;case INST_APPEND_SCALAR1:
opnd =TclGetUInt1AtPtr(pc+1);
pcAdjustment =2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);goto doStoreScalar;
doStoreScalar:
valuePtr = OBJ_AT_TOS;
varPtr = &(compiledLocals[opnd]);TRACE(("%u <-\"%.30s\"=> ", opnd,O2S(valuePtr)));while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}
cleanup =1;
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
doCallPtrSetVar:DECACHE_STACK_INFO();
objResultPtr =TclPtrSetVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);CACHE_STACK_INFO();if(objResultPtr) {#ifndef TCL_COMPILE_DEBUGif(*(pc+pcAdjustment) == INST_POP) {NEXT_INST_V((pcAdjustment+1), cleanup,0);}#endifTRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_V(pcAdjustment, cleanup,1);}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}}/* * End of INST_STORE and related instructions. * --------------------------------------------------------- *//* * --------------------------------------------------------- * Start of INST_INCR instructions. * * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to somme * common execution code. *//*TODO: Consider more untangling here; merge with LOAD and STORE ? */{
Tcl_Obj *objPtr, *incrPtr;int opnd, pcAdjustment;#ifndef NO_WIDE_TYPE
Tcl_WideInt w;#endiflong i;
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;case INST_INCR_SCALAR1:case INST_INCR_ARRAY1:case INST_INCR_ARRAY_STK:case INST_INCR_SCALAR_STK:case INST_INCR_STK:
opnd =TclGetUInt1AtPtr(pc+1);
incrPtr =POP_OBJECT();switch(*pc) {case INST_INCR_SCALAR1:
pcAdjustment =2;goto doIncrScalar;case INST_INCR_ARRAY1:
pcAdjustment =2;goto doIncrArray;default:
pcAdjustment =1;goto doIncrStk;}case INST_INCR_ARRAY_STK_IMM:case INST_INCR_SCALAR_STK_IMM:case INST_INCR_STK_IMM:
i =TclGetInt1AtPtr(pc+1);
incrPtr =Tcl_NewIntObj(i);Tcl_IncrRefCount(incrPtr);
pcAdjustment =2;
doIncrStk:if((*pc == INST_INCR_ARRAY_STK_IMM)|| (*pc == INST_INCR_ARRAY_STK)) {
part2Ptr = OBJ_AT_TOS;
objPtr = OBJ_UNDER_TOS;TRACE(("\"%.30s(%.30s)\"(by %ld) => ",O2S(objPtr),O2S(part2Ptr), i));}else{
part2Ptr = NULL;
objPtr = OBJ_AT_TOS;TRACE(("\"%.30s\"(by %ld) => ",O2S(objPtr), i));}
part1Ptr = objPtr;
opnd = -1;
varPtr =TclObjLookupVarEx(interp, objPtr, part2Ptr,
TCL_LEAVE_ERR_MSG,"read",1,1, &arrayPtr);if(varPtr) {
cleanup = ((part2Ptr == NULL)? 1:2);goto doIncrVar;}else{Tcl_AddObjErrorInfo(interp,"\n(reading value of variable to increment)", -1);TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;Tcl_DecrRefCount(incrPtr);goto checkForCatch;}case INST_INCR_ARRAY1_IMM:
opnd =TclGetUInt1AtPtr(pc+1);
i =TclGetInt1AtPtr(pc+2);
incrPtr =Tcl_NewIntObj(i);Tcl_IncrRefCount(incrPtr);
pcAdjustment =3;
doIncrArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
arrayPtr = &(compiledLocals[opnd]);
cleanup =1;while(TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;}TRACE(("%u\"%.30s\"(by %ld) => ", opnd,O2S(part2Ptr), i));
varPtr =TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG,"read",1,1, arrayPtr, opnd);if(varPtr) {goto doIncrVar;}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;Tcl_DecrRefCount(incrPtr);goto checkForCatch;}case INST_INCR_SCALAR1_IMM:
opnd =TclGetUInt1AtPtr(pc+1);
i =TclGetInt1AtPtr(pc+2);
pcAdjustment =3;
cleanup =0;
varPtr = &(compiledLocals[opnd]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}if(TclIsVarDirectModifyable(varPtr)) {
ClientData ptr;int type;
objPtr = varPtr->value.objPtr;if(GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {if(type == TCL_NUMBER_LONG) {long augend = *((const long*)ptr);long sum = augend + i;/* * Overflow when (augend and sum have different sign) and * (augend and i have the same sign). This is encapsulated * in the Overflowing macro. */if(!Overflowing(augend, i, sum)) {TRACE(("%u %ld => ", opnd, i));if(Tcl_IsShared(objPtr)) {
objPtr->refCount--;/* We know it's shared. */TclNewLongObj(objResultPtr, sum);Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;}else{
objResultPtr = objPtr;TclSetLongObj(objPtr, sum);}goto doneIncr;}#ifndef NO_WIDE_TYPE{
w = (Tcl_WideInt)augend;TRACE(("%u %ld => ", opnd, i));if(Tcl_IsShared(objPtr)) {
objPtr->refCount--;/* We know it's shared. */
objResultPtr =Tcl_NewWideIntObj(w+i);Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;}else{
objResultPtr = objPtr;/* * We know the sum value is outside the long * range; use macro form that doesn't range test * again. */TclSetWideIntObj(objPtr, w+i);}goto doneIncr;}#endif}/* end if (type == TCL_NUMBER_LONG) */#ifndef NO_WIDE_TYPEif(type == TCL_NUMBER_WIDE) {
Tcl_WideInt sum;
w = *((const Tcl_WideInt *)ptr);
sum = w + i;/* * Check for overflow. */if(!Overflowing(w, i, sum)) {TRACE(("%u %ld => ", opnd, i));if(Tcl_IsShared(objPtr)) {
objPtr->refCount--;/* We know it's shared. */
objResultPtr =Tcl_NewWideIntObj(sum);Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;}else{
objResultPtr = objPtr;/* * We *do not* know the sum value is outside the * long range (wide + long can yield long); use * the function call that checks range. */Tcl_SetWideIntObj(objPtr, sum);}goto doneIncr;}}#endif}if(Tcl_IsShared(objPtr)) {
objPtr->refCount--;/* We know it's shared */
objResultPtr =Tcl_DuplicateObj(objPtr);Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;}else{
objResultPtr = objPtr;}TclNewLongObj(incrPtr, i);
result =TclIncrObj(interp, objResultPtr, incrPtr);Tcl_DecrRefCount(incrPtr);if(result == TCL_OK) {goto doneIncr;}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));goto checkForCatch;}}/* * All other cases, flow through to generic handling. */TclNewLongObj(incrPtr, i);Tcl_IncrRefCount(incrPtr);
doIncrScalar:
varPtr = &(compiledLocals[opnd]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup =0;TRACE(("%u %ld => ", opnd, i));
doIncrVar:if(TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
objPtr = varPtr->value.objPtr;if(Tcl_IsShared(objPtr)) {
objPtr->refCount--;/* We know it's shared */
objResultPtr =Tcl_DuplicateObj(objPtr);Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;}else{
objResultPtr = objPtr;}
result =TclIncrObj(interp, objResultPtr, incrPtr);Tcl_DecrRefCount(incrPtr);if(result == TCL_OK) {goto doneIncr;}else{TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));goto checkForCatch;}}else{DECACHE_STACK_INFO();
objResultPtr =TclPtrIncrObjVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd);CACHE_STACK_INFO();Tcl_DecrRefCount(incrPtr);if(objResultPtr == NULL) {TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}}
doneIncr:TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));#ifndef TCL_COMPILE_DEBUGif(*(pc+pcAdjustment) == INST_POP) {NEXT_INST_V((pcAdjustment+1), cleanup,0);}#endifNEXT_INST_V(pcAdjustment, cleanup,1);}/* * End of INST_INCR instructions. * --------------------------------------------------------- *//* * --------------------------------------------------------- * Start of INST_EXIST instructions. */{
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;case INST_EXIST_SCALAR: {int opnd =TclGetUInt4AtPtr(pc+1);
varPtr = &(compiledLocals[opnd]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}TRACE(("%u => ", opnd));if(ReadTraced(varPtr)) {DECACHE_STACK_INFO();TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL,
TCL_TRACE_READS,0, opnd);CACHE_STACK_INFO();if(TclIsVarUndefined(varPtr)) {TclCleanupVar(varPtr, NULL);
varPtr = NULL;}}/* * Tricky! Arrays always exist. */
objResultPtr = constants[!varPtr ||TclIsVarUndefined(varPtr) ? 0:1];TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_F(5,0,1);}case INST_EXIST_ARRAY: {int opnd =TclGetUInt4AtPtr(pc+1);
part2Ptr = OBJ_AT_TOS;
arrayPtr = &(compiledLocals[opnd]);while(TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;}TRACE(("%u\"%.30s\"=> ", opnd,O2S(part2Ptr)));if(TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
varPtr =VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);if(!varPtr || !ReadTraced(varPtr)) {goto doneExistArray;}}
varPtr =TclLookupArrayElement(interp, NULL, part2Ptr,0,"access",0,1, arrayPtr, opnd);if(varPtr) {if(ReadTraced(varPtr) || (arrayPtr &&ReadTraced(arrayPtr))) {DECACHE_STACK_INFO();TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr,
TCL_TRACE_READS,0, opnd);CACHE_STACK_INFO();}if(TclIsVarUndefined(varPtr)) {TclCleanupVar(varPtr, arrayPtr);
varPtr = NULL;}}
doneExistArray:
objResultPtr = constants[!varPtr ||TclIsVarUndefined(varPtr) ? 0:1];TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_F(5,1,1);}case INST_EXIST_ARRAY_STK:
cleanup =2;
part2Ptr = OBJ_AT_TOS;/* element name */
part1Ptr = OBJ_UNDER_TOS;/* array name */TRACE(("\"%.30s(%.30s)\"=> ",O2S(part1Ptr),O2S(part2Ptr)));goto doExistStk;case INST_EXIST_STK:
cleanup =1;
part2Ptr = NULL;
part1Ptr = OBJ_AT_TOS;/* variable name */TRACE(("\"%.30s\"=> ",O2S(part1Ptr)));
doExistStk:
varPtr =TclObjLookupVarEx(interp, part1Ptr, part2Ptr,0,"access",/*createPart1*/0,/*createPart2*/1, &arrayPtr);if(varPtr) {if(ReadTraced(varPtr) || (arrayPtr &&ReadTraced(arrayPtr))) {DECACHE_STACK_INFO();TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr,
TCL_TRACE_READS,0, -1);CACHE_STACK_INFO();}if(TclIsVarUndefined(varPtr)) {TclCleanupVar(varPtr, arrayPtr);
varPtr = NULL;}}
objResultPtr = constants[!varPtr ||TclIsVarUndefined(varPtr) ? 0:1];TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_V(1, cleanup,1);}/* * End of INST_EXIST instructions. * --------------------------------------------------------- */case INST_UPVAR: {int opnd;
Var *varPtr, *otherPtr;TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);{
CallFrame *framePtr, *savedFramePtr;
result =TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr);if(result != -1) {/* * Locate the other variable. */
savedFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = framePtr;
otherPtr =TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,(TCL_LEAVE_ERR_MSG),"access",/*createPart1*/1,/*createPart2*/1, &varPtr);
iPtr->varFramePtr = savedFramePtr;if(otherPtr) {
result = TCL_OK;goto doLinkVars;}}
result = TCL_ERROR;goto checkForCatch;}case INST_VARIABLE:TRACE(("variable "));
otherPtr =TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG),"access",/*createPart1*/1,/*createPart2*/1, &varPtr);if(otherPtr) {/* * Do the [variable] magic. */TclSetVarNamespaceVar(otherPtr);
result = TCL_OK;goto doLinkVars;}
result = TCL_ERROR;goto checkForCatch;case INST_NSUPVAR:TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);{
Tcl_Namespace *nsPtr, *savedNsPtr;
result =TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr);if(result == TCL_OK) {/* * Locate the other variable. */
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
otherPtr =TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG),"access",/*createPart1*/1,/*createPart2*/1, &varPtr);
iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;if(otherPtr) {goto doLinkVars;}}
result = TCL_ERROR;goto checkForCatch;}
doLinkVars:/* * If we are here, the local variable has already been created: do the * little work of TclPtrMakeUpvar that remains to be done right here * if there are no errors; otherwise, let it handle the case. */
opnd =TclGetInt4AtPtr(pc+1);;
varPtr = &(compiledLocals[opnd]);if((varPtr != otherPtr) && !TclIsVarTraced(varPtr)&& (TclIsVarUndefined(varPtr) ||TclIsVarLink(varPtr))) {if(!TclIsVarUndefined(varPtr)) {/* * Then it is a defined link. */
Var *linkPtr = varPtr->value.linkPtr;if(linkPtr == otherPtr) {goto doLinkVarsDone;}if(TclIsVarInHash(linkPtr)) {VarHashRefCount(linkPtr)--;if(TclIsVarUndefined(linkPtr)) {TclCleanupVar(linkPtr, NULL);}}}TclSetVarLink(varPtr);
varPtr->value.linkPtr = otherPtr;if(TclIsVarInHash(otherPtr)) {VarHashRefCount(otherPtr)++;}}else{
result =TclPtrObjMakeUpvar(interp, otherPtr, NULL,0, opnd);if(result != TCL_OK) {goto checkForCatch;}}/* * Do not pop the namespace or frame index, it may be needed for other * variables - and [variable] did not push it at all. */
doLinkVarsDone:NEXT_INST_F(5,1,0);}case INST_JUMP1: {int opnd =TclGetInt1AtPtr(pc+1);TRACE(("%d => new pc %u\n", opnd,(unsigned)(pc + opnd - codePtr->codeStart)));NEXT_INST_F(opnd,0,0);}case INST_JUMP4: {int opnd =TclGetInt4AtPtr(pc+1);TRACE(("%d => new pc %u\n", opnd,(unsigned)(pc + opnd - codePtr->codeStart)));NEXT_INST_F(opnd,0,0);}{int jmpOffset[2], b;
Tcl_Obj *valuePtr;/* TODO: consider rewrite so we don't compute the offset we're not * going to take. */case INST_JUMP_FALSE4:
jmpOffset[0] =TclGetInt4AtPtr(pc+1);/* FALSE offset */
jmpOffset[1] =5;/* TRUE offset*/goto doCondJump;case INST_JUMP_TRUE4:
jmpOffset[0] =5;
jmpOffset[1] =TclGetInt4AtPtr(pc+1);goto doCondJump;case INST_JUMP_FALSE1:
jmpOffset[0] =TclGetInt1AtPtr(pc+1);
jmpOffset[1] =2;goto doCondJump;case INST_JUMP_TRUE1:
jmpOffset[0] =2;
jmpOffset[1] =TclGetInt1AtPtr(pc+1);
doCondJump:
valuePtr = OBJ_AT_TOS;/* TODO - check claim that taking address of b harms performance *//* TODO - consider optimization search for constants */
result =TclGetBooleanFromObj(interp, valuePtr, &b);if(result != TCL_OK) {TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))
? 0:1]),Tcl_GetObjResult(interp));goto checkForCatch;}#ifdef TCL_COMPILE_DEBUGif(b) {if((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1],O2S(valuePtr),(unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));}else{TRACE(("%d => %.20s true\n", jmpOffset[0],O2S(valuePtr)));}}else{if((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {TRACE(("%d => %.20s false\n", jmpOffset[0],O2S(valuePtr)));}else{TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0],O2S(valuePtr),(unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));}}#endifNEXT_INST_F(jmpOffset[b],1,0);}case INST_JUMP_TABLE: {
Tcl_HashEntry *hPtr;
JumptableInfo *jtPtr;int opnd;/* * Jump to location looked up in a hashtable; fall through to next * instr if lookup fails. */
opnd =TclGetInt4AtPtr(pc+1);
jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData;TRACE(("%d => %.20s ", opnd,O2S(OBJ_AT_TOS)));
hPtr =Tcl_FindHashEntry(&jtPtr->hashTable,TclGetString(OBJ_AT_TOS));if(hPtr != NULL) {int jumpOffset =PTR2INT(Tcl_GetHashValue(hPtr));TRACE_APPEND(("found in table, new pc %u\n",(unsigned)(pc - codePtr->codeStart + jumpOffset)));NEXT_INST_F(jumpOffset,1,0);}else{TRACE_APPEND(("not found in table\n"));NEXT_INST_F(5,1,0);}}/* * These two instructions are now redundant: the complete logic of the LOR * and LAND is now handled by the expression compiler. */case INST_LOR:case INST_LAND: {/* * Operands must be boolean or numeric. No int->double conversions are * performed. */int i1, i2, iResult;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
result =TclGetBooleanFromObj(NULL, valuePtr, &i1);if(result != TCL_OK) {TRACE(("\"%.20s\"=> ILLEGAL TYPE %s\n",O2S(valuePtr),(valuePtr->typePtr? valuePtr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}
result =TclGetBooleanFromObj(NULL, value2Ptr, &i2);if(result != TCL_OK) {TRACE(("\"%.20s\"=> ILLEGAL TYPE %s\n",O2S(value2Ptr),(value2Ptr->typePtr? value2Ptr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, value2Ptr);CACHE_STACK_INFO();goto checkForCatch;}if(*pc == INST_LOR) {
iResult = (i1 || i2);}else{
iResult = (i1 && i2);}
objResultPtr = constants[iResult];TRACE(("%.20s %.20s => %d\n",O2S(valuePtr),O2S(value2Ptr),iResult));NEXT_INST_F(1,2,1);}/* * --------------------------------------------------------- * Start of INST_LIST and related instructions. */case INST_LIST: {/* * Pop the opnd (objc) top stack elements into a new list obj and then * decrement their ref counts. */int opnd;
opnd =TclGetUInt4AtPtr(pc+1);
objResultPtr =Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);NEXT_INST_V(5, opnd,1);}case INST_LIST_LENGTH: {
Tcl_Obj *valuePtr;int length;
valuePtr = OBJ_AT_TOS;
result =TclListObjLength(interp, valuePtr, &length);if(result == TCL_OK) {TclNewIntObj(objResultPtr, length);TRACE(("%.20s => %d\n",O2S(valuePtr), length));NEXT_INST_F(1,1,1);}else{TRACE_WITH_OBJ(("%.30s => ERROR: ",O2S(valuePtr)),Tcl_GetObjResult(interp));goto checkForCatch;}}case INST_LIST_INDEX: {/*** lindex with objc == 3 ***//* Variables also for INST_LIST_INDEX_IMM */int listc, idx, opnd, pcAdjustment;
Tcl_Obj **listv;
Tcl_Obj *valuePtr, *value2Ptr;/* * Pop the two operands. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;/* * Extract the desired list element. */
result =TclListObjGetElements(interp, valuePtr, &listc, &listv);if((result == TCL_OK) && (value2Ptr->typePtr != &tclListType)&& (TclGetIntForIndexM(NULL , value2Ptr, listc-1,&idx) == TCL_OK)) {TclDecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment =1;goto lindexFastPath;}
objResultPtr =TclLindexList(interp, valuePtr, value2Ptr);if(objResultPtr) {/* * Stash the list element on the stack. */TRACE(("%.20s %.20s => %s\n",O2S(valuePtr),O2S(value2Ptr),O2S(objResultPtr)));NEXT_INST_F(1,2, -1);/* Already has the correct refCount */}else{TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",O2S(valuePtr),O2S(value2Ptr)),Tcl_GetObjResult(interp));
result = TCL_ERROR;goto checkForCatch;}case INST_LIST_INDEX_IMM:/*** lindex with objc==3 and index in bytecode stream ***/
pcAdjustment =5;/* * Pop the list and get the index. */
valuePtr = OBJ_AT_TOS;
opnd =TclGetInt4AtPtr(pc+1);/* * Get the contents of the list, making sure that it really is a list * in the process. */
result =TclListObjGetElements(interp, valuePtr, &listc, &listv);if(result == TCL_OK) {/* * Select the list item based on the index. Negative operand means * end-based indexing. */if(opnd < -1) {
idx = opnd+1+ listc;}else{
idx = opnd;}
lindexFastPath:if(idx >=0&& idx < listc) {
objResultPtr = listv[idx];}else{TclNewObj(objResultPtr);}TRACE_WITH_OBJ(("\"%.30s\"%d => ",O2S(valuePtr), opnd),
objResultPtr);NEXT_INST_F(pcAdjustment,1,1);}else{TRACE_WITH_OBJ(("\"%.30s\"%d => ERROR: ",O2S(valuePtr), opnd),Tcl_GetObjResult(interp));goto checkForCatch;}}case INST_LIST_INDEX_MULTI: {/* * 'lindex' with multiple index args: * * Determine the count of index args. */int numIdx, opnd;
opnd =TclGetUInt4AtPtr(pc+1);
numIdx = opnd-1;/* * Do the 'lindex' operation. */
objResultPtr =TclLindexFlat(interp,OBJ_AT_DEPTH(numIdx),
numIdx, &OBJ_AT_DEPTH(numIdx -1));/* * Check for errors. */if(objResultPtr) {/* * Set result. */TRACE(("%d => %s\n", opnd,O2S(objResultPtr)));NEXT_INST_V(5, opnd, -1);}else{TRACE_WITH_OBJ(("%d => ERROR: ", opnd),Tcl_GetObjResult(interp));
result = TCL_ERROR;goto checkForCatch;}}case INST_LSET_FLAT: {/* * Lset with 3, 5, or more args. Get the number of index args. */int numIdx,opnd;
Tcl_Obj *valuePtr, *value2Ptr;
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 - we can use the smaller macro * Tcl_DecrRefCount. */
value2Ptr =POP_OBJECT();Tcl_DecrRefCount(value2Ptr);/* This one should be done here *//* * Get the new element value. */
valuePtr = OBJ_AT_TOS;/* * Compute the new variable value. */
objResultPtr =TclLsetFlat(interp, value2Ptr, numIdx,&OBJ_AT_DEPTH(numIdx), valuePtr);/* * Check for errors. */if(objResultPtr) {/* * Set result. */TRACE(("%d => %s\n", opnd,O2S(objResultPtr)));NEXT_INST_V(5, (numIdx+1), -1);}else{TRACE_WITH_OBJ(("%d => ERROR: ", opnd),Tcl_GetObjResult(interp));
result = TCL_ERROR;goto checkForCatch;}}case INST_LSET_LIST: {/* * 'lset' with 4 args. */
Tcl_Obj *objPtr, *valuePtr, *value2Ptr;/* * 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 - we can use the smaller macro * Tcl_DecrRefCount. */
objPtr =POP_OBJECT();Tcl_DecrRefCount(objPtr);/* This one should be done here. *//* * Get the new element value, and the index list. */
valuePtr = OBJ_AT_TOS;
value2Ptr = OBJ_UNDER_TOS;/* * Compute the new variable value. */
objResultPtr =TclLsetList(interp, objPtr, value2Ptr, valuePtr);/* * Check for errors. */if(objResultPtr) {/* * Set result. */TRACE(("=> %s\n",O2S(objResultPtr)));NEXT_INST_F(1,2, -1);}else{TRACE_WITH_OBJ(("\"%.30s\"=> ERROR: ",O2S(value2Ptr)),Tcl_GetObjResult(interp));
result = TCL_ERROR;goto checkForCatch;}}case INST_LIST_RANGE_IMM: {/*** lrange with objc==4 and both indices in bytecode stream ***/int listc, fromIdx, toIdx;
Tcl_Obj **listv, *valuePtr;/* * Pop the list and get the indices. */
valuePtr = OBJ_AT_TOS;
fromIdx =TclGetInt4AtPtr(pc+1);
toIdx =TclGetInt4AtPtr(pc+5);/* * Get the contents of the list, making sure that it really is a list * in the process. */
result =TclListObjGetElements(interp, valuePtr, &listc, &listv);/* * Skip a lot of work if we're about to throw the result away (common * with uses of [lassign]). */if(result == TCL_OK) {#ifndef TCL_COMPILE_DEBUGif(*(pc+9) == INST_POP) {NEXT_INST_F(10,1,0);}#endif}else{TRACE_WITH_OBJ(("\"%.30s\"%d %d => ERROR: ",O2S(valuePtr),
fromIdx, toIdx),Tcl_GetObjResult(interp));goto checkForCatch;}/* * Adjust the indices for end-based handling. */if(fromIdx < -1) {
fromIdx +=1+listc;if(fromIdx < -1) {
fromIdx = -1;}}else if(fromIdx > listc) {
fromIdx = listc;}if(toIdx < -1) {
toIdx +=1+listc;if(toIdx < -1) {
toIdx = -1;}}else if(toIdx > listc) {
toIdx = listc;}/* * Check if we are referring to a valid, non-empty list range, and if * so, build the list of elements in that range. */if(fromIdx<=toIdx && fromIdx<listc && toIdx>=0) {if(fromIdx<0) {
fromIdx =0;}if(toIdx >= listc) {
toIdx = listc-1;}
objResultPtr =Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx);}else{TclNewObj(objResultPtr);}TRACE_WITH_OBJ(("\"%.30s\"%d %d => ",O2S(valuePtr),TclGetInt4AtPtr(pc+1),TclGetInt4AtPtr(pc+5)), objResultPtr);NEXT_INST_F(9,1,1);}case INST_LIST_IN:case INST_LIST_NOT_IN: {/* * Basic list containment operators. */int found, s1len, s2len, llen, i;
Tcl_Obj *valuePtr, *value2Ptr, *o;char*s1;const char*s2;
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;/* TODO: Consider more efficient tests than strcmp() */
s1 =TclGetStringFromObj(valuePtr, &s1len);
result =TclListObjLength(interp, value2Ptr, &llen);if(result != TCL_OK) {TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\"=> ERROR: ",O2S(valuePtr),O2S(value2Ptr)),Tcl_GetObjResult(interp));goto checkForCatch;}
found =0;if(llen >0) {/* * An empty list doesn't match anything. */
i =0;do{Tcl_ListObjIndex(NULL, value2Ptr, i, &o);if(o != NULL) {
s2 =TclGetStringFromObj(o, &s2len);}else{
s2 ="";}if(s1len == s2len) {
found = (strcmp(s1, s2) ==0);}
i++;}while(i < llen && found ==0);}if(*pc == INST_LIST_NOT_IN) {
found = !found;}TRACE(("%.20s %.20s => %d\n",O2S(valuePtr),O2S(value2Ptr), found));/* * Peep-hole optimisation: if you're about to jump, do jump from here. * We're saving the effort of pushing a boolean value only to pop it * for branching. */
pc++;#ifndef TCL_COMPILE_DEBUGswitch(*pc) {case INST_JUMP_FALSE1:NEXT_INST_F((found ? 2:TclGetInt1AtPtr(pc+1)),2,0);case INST_JUMP_TRUE1:NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) :2),2,0);case INST_JUMP_FALSE4:NEXT_INST_F((found ? 5:TclGetInt4AtPtr(pc+1)),2,0);case INST_JUMP_TRUE4:NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) :5),2,0);}#endif
objResultPtr = constants[found];NEXT_INST_F(0,2,1);}/* * End of INST_LIST and related instructions. * --------------------------------------------------------- */case INST_STR_EQ:case INST_STR_NEQ: {/* * String (in)equality check * TODO: Consider merging into INST_STR_CMP */int iResult;
Tcl_Obj *valuePtr, *value2Ptr;
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;if(valuePtr == value2Ptr) {/* * On the off-chance that the objects are the same, we don't * really have to think hard about equality. */
iResult = (*pc == INST_STR_EQ);}else{char*s1, *s2;int s1len, s2len;
s1 =TclGetStringFromObj(valuePtr, &s1len);
s2 =TclGetStringFromObj(value2Ptr, &s2len);if(s1len == s2len) {/* * We only need to check (in)equality when we have equal * length strings. */if(*pc == INST_STR_NEQ) {
iResult = (strcmp(s1, s2) !=0);}else{/* INST_STR_EQ */
iResult = (strcmp(s1, s2) ==0);}}else{
iResult = (*pc == INST_STR_NEQ);}}TRACE(("%.20s %.20s => %d\n",O2S(valuePtr),O2S(value2Ptr),iResult));/* * Peep-hole optimisation: if you're about to jump, do jump from here. */
pc++;#ifndef TCL_COMPILE_DEBUGswitch(*pc) {case INST_JUMP_FALSE1:NEXT_INST_F((iResult? 2:TclGetInt1AtPtr(pc+1)),2,0);case INST_JUMP_TRUE1:NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) :2),2,0);case INST_JUMP_FALSE4:NEXT_INST_F((iResult? 5:TclGetInt4AtPtr(pc+1)),2,0);case INST_JUMP_TRUE4:NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) :5),2,0);}#endif
objResultPtr = constants[iResult];NEXT_INST_F(0,2,1);}case INST_STR_CMP: {/* * String compare. */const char*s1, *s2;int s1len, s2len, iResult;
Tcl_Obj *valuePtr, *value2Ptr;
stringCompare:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;/* * The comparison function should compare up to the minimum byte * length only. */if(valuePtr == value2Ptr) {/* * In the pure equality case, set lengths too for the checks below * (or we could goto beyond it). */
iResult = s1len = s2len =0;}else if((valuePtr->typePtr == &tclByteArrayType)&& (value2Ptr->typePtr == &tclByteArrayType)) {
s1 = (char*)Tcl_GetByteArrayFromObj(valuePtr, &s1len);
s2 = (char*)Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
iResult =memcmp(s1, s2,(size_t) ((s1len < s2len) ? s1len : s2len));}else if(((valuePtr->typePtr == &tclStringType)&& (value2Ptr->typePtr == &tclStringType))) {/* * Do a unicode-specific comparison if both of the args are of * String type. If the char length == byte length, we can do a * memcmp. In benchmark testing this proved the most efficient * check between the unicode and string comparison operations. */
s1len =Tcl_GetCharLength(valuePtr);
s2len =Tcl_GetCharLength(value2Ptr);if((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
iResult =memcmp(valuePtr->bytes, value2Ptr->bytes,(unsigned) ((s1len < s2len) ? s1len : s2len));}else{
iResult =TclUniCharNcmp(Tcl_GetUnicode(valuePtr),Tcl_GetUnicode(value2Ptr),(unsigned) ((s1len < s2len) ? s1len : s2len));}}else{/* * We can't do a simple memcmp in order to handle the special Tcl * \xC0\x80 null encoding for utf-8. */
s1 =TclGetStringFromObj(valuePtr, &s1len);
s2 =TclGetStringFromObj(value2Ptr, &s2len);
iResult =TclpUtfNcmp2(s1, s2,(size_t) ((s1len < s2len) ? s1len : s2len));}/* * Make sure only -1,0,1 is returned * TODO: consider peephole opt. */if(iResult ==0) {
iResult = s1len - s2len;}if(*pc != INST_STR_CMP) {/* * Take care of the opcodes that goto'ed into here. */switch(*pc) {case INST_EQ:
iResult = (iResult ==0);break;case INST_NEQ:
iResult = (iResult !=0);break;case INST_LT:
iResult = (iResult <0);break;case INST_GT:
iResult = (iResult >0);break;case INST_LE:
iResult = (iResult <=0);break;case INST_GE:
iResult = (iResult >=0);break;}}if(iResult <0) {TclNewIntObj(objResultPtr, -1);TRACE(("%.20s %.20s => %d\n",O2S(valuePtr),O2S(value2Ptr), -1));}else{
objResultPtr = constants[(iResult>0)];TRACE(("%.20s %.20s => %d\n",O2S(valuePtr),O2S(value2Ptr),(iResult >0)));}NEXT_INST_F(1,2,1);}case INST_STR_LEN: {int length;
Tcl_Obj *valuePtr;
valuePtr = OBJ_AT_TOS;if(valuePtr->typePtr == &tclByteArrayType) {(void)Tcl_GetByteArrayFromObj(valuePtr, &length);}else{
length =Tcl_GetCharLength(valuePtr);}TclNewIntObj(objResultPtr, length);TRACE(("%.20s => %d\n",O2S(valuePtr), length));NEXT_INST_F(1,1,1);}case INST_STR_INDEX: {/* * String compare. */int index, length;char*bytes;
Tcl_Obj *valuePtr, *value2Ptr;
bytes = NULL;/* lint */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;/* * If we have a ByteArray object, avoid indexing in the Utf string * since the byte array contains one byte per character. Otherwise, * use the Unicode string rep to get the index'th char. */if(valuePtr->typePtr == &tclByteArrayType) {
bytes = (char*)Tcl_GetByteArrayFromObj(valuePtr, &length);}else{/* * Get Unicode char length to calulate what 'end' means. */
length =Tcl_GetCharLength(valuePtr);}
result =TclGetIntForIndexM(interp, value2Ptr, length -1, &index);if(result != TCL_OK) {goto checkForCatch;}if((index >=0) && (index < length)) {if(valuePtr->typePtr == &tclByteArrayType) {
objResultPtr =Tcl_NewByteArrayObj((unsigned char*)(&bytes[index]),1);}else if(valuePtr->bytes && length == valuePtr->length) {
objResultPtr =Tcl_NewStringObj((const char*)(&valuePtr->bytes[index]),1);}else{char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
ch =Tcl_GetUniChar(valuePtr, index);/* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, * 1) but creating the object as a string seems to be faster * in practical use. */
length =Tcl_UniCharToUtf(ch, buf);
objResultPtr =Tcl_NewStringObj(buf, length);}}else{TclNewObj(objResultPtr);}TRACE(("%.20s %.20s => %s\n",O2S(valuePtr),O2S(value2Ptr),O2S(objResultPtr)));NEXT_INST_F(1,2,1);}case INST_STR_MATCH: {int nocase, match;
Tcl_Obj *valuePtr, *value2Ptr;
nocase =TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS;/* String */
value2Ptr = OBJ_UNDER_TOS;/* Pattern *//* * Check that at least one of the objects is Unicode before promoting * both. */if((valuePtr->typePtr == &tclStringType)|| (value2Ptr->typePtr == &tclStringType)) {
Tcl_UniChar *ustring1, *ustring2;int length1, length2;
ustring1 =Tcl_GetUnicodeFromObj(valuePtr, &length1);
ustring2 =Tcl_GetUnicodeFromObj(value2Ptr, &length2);
match =TclUniCharMatch(ustring1, length1, ustring2, length2,
nocase);}else if((valuePtr->typePtr == &tclByteArrayType) && !nocase) {unsigned char*string1, *string2;int length1, length2;
string1 =Tcl_GetByteArrayFromObj(valuePtr, &length1);
string2 =Tcl_GetByteArrayFromObj(value2Ptr, &length2);
match =TclByteArrayMatch(string1, length1, string2, length2,0);}else{
match =Tcl_StringCaseMatch(TclGetString(valuePtr),TclGetString(value2Ptr), nocase);}/* * Reuse value2Ptr object already on stack if possible. Adjustment is * 2 due to the nocase byte * TODO: consider peephole opt. */TRACE(("%.20s %.20s => %d\n",O2S(valuePtr),O2S(value2Ptr), match));
objResultPtr = constants[match];NEXT_INST_F(2,2,1);}case INST_REGEXP: {int cflags, match;
Tcl_Obj *valuePtr, *value2Ptr;
Tcl_RegExp regExpr;
cflags =TclGetInt1AtPtr(pc+1);/* RE compile flages like NOCASE */
valuePtr = OBJ_AT_TOS;/* String */
value2Ptr = OBJ_UNDER_TOS;/* Pattern */
regExpr =Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);if(regExpr == NULL) {
match = -1;}else{
match =Tcl_RegExpExecObj(interp, regExpr, valuePtr,0,0,0);}/* * Adjustment is 2 due to the nocase byte */if(match <0) {
objResultPtr =Tcl_GetObjResult(interp);TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",O2S(valuePtr),O2S(value2Ptr)), objResultPtr);
result = TCL_ERROR;goto checkForCatch;}else{TRACE(("%.20s %.20s => %d\n",O2S(valuePtr),O2S(value2Ptr), match));
objResultPtr = constants[match];NEXT_INST_F(2,2,1);}}case INST_EQ:case INST_NEQ:case INST_LT:case INST_GT:case INST_LE:case INST_GE: {
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
ClientData ptr1, ptr2;int iResult =0, compare =0, type1, type2;double d1, d2, tmp;long l1, l2;
mp_int big1, big2;#ifndef NO_WIDE_TYPE
Tcl_WideInt w1, w2;#endifif(GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {/* * At least one non-numeric argument - compare as strings. */goto stringCompare;}if(type1 == TCL_NUMBER_NAN) {/* * NaN first arg: NaN != to everything, other compares are false. */
iResult = (*pc == INST_NEQ);goto foundResult;}if(valuePtr == value2Ptr) {
compare = MP_EQ;goto convertComparison;}if(GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {/* * At least one non-numeric argument - compare as strings. */goto stringCompare;}if(type2 == TCL_NUMBER_NAN) {/* * NaN 2nd arg: NaN != to everything, other compares are false. */
iResult = (*pc == INST_NEQ);goto foundResult;}switch(type1) {case TCL_NUMBER_LONG:
l1 = *((const long*)ptr1);switch(type2) {case TCL_NUMBER_LONG:
l2 = *((const long*)ptr2);
longCompare:
compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);break;#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
w1 = (Tcl_WideInt)l1;goto wideCompare;#endifcase TCL_NUMBER_DOUBLE:
d2 = *((const double*)ptr2);
d1 = (double) l1;/* * If the double has a fractional part, or if the long can be * converted to double without loss of precision, then compare * as doubles. */if(DBL_MANT_DIG > CHAR_BIT*sizeof(long)|| l1 == (long) d1
||modf(d2, &tmp) !=0.0) {goto doubleCompare;}/* * Otherwise, to make comparision based on full precision, * need to convert the double to a suitably sized integer. * * Need this to get comparsions like * expr 20000000000000003 < 20000000000000004.0 * right. Converting the first argument to double will yield * two double values that are equivalent within double * precision. Converting the double to an integer gets done * exactly, then integer comparison can tell the difference. */if(d2 < (double)LONG_MIN) {
compare = MP_GT;break;}if(d2 > (double)LONG_MAX) {
compare = MP_LT;break;}
l2 = (long) d2;goto longCompare;case TCL_NUMBER_BIG:Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);if(mp_cmp_d(&big2,0) == MP_LT) {
compare = MP_GT;}else{
compare = MP_LT;}mp_clear(&big2);}break;#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE:
w1 = *((const Tcl_WideInt *)ptr1);switch(type2) {case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
wideCompare:
compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);break;case TCL_NUMBER_LONG:
l2 = *((const long*)ptr2);
w2 = (Tcl_WideInt)l2;goto wideCompare;case TCL_NUMBER_DOUBLE:
d2 = *((const double*)ptr2);
d1 = (double) w1;if(DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)|| w1 == (Tcl_WideInt) d1
||modf(d2, &tmp) !=0.0) {goto doubleCompare;}if(d2 < (double)LLONG_MIN) {
compare = MP_GT;break;}if(d2 > (double)LLONG_MAX) {
compare = MP_LT;break;}
w2 = (Tcl_WideInt) d2;goto wideCompare;case TCL_NUMBER_BIG:Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);if(mp_cmp_d(&big2,0) == MP_LT) {
compare = MP_GT;}else{
compare = MP_LT;}mp_clear(&big2);}break;#endifcase TCL_NUMBER_DOUBLE:
d1 = *((const double*)ptr1);switch(type2) {case TCL_NUMBER_DOUBLE:
d2 = *((const double*)ptr2);
doubleCompare:
compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);break;case TCL_NUMBER_LONG:
l2 = *((const long*)ptr2);
d2 = (double) l2;if(DBL_MANT_DIG > CHAR_BIT*sizeof(long)|| l2 == (long) d2
||modf(d1, &tmp) !=0.0) {goto doubleCompare;}if(d1 < (double)LONG_MIN) {
compare = MP_LT;break;}if(d1 > (double)LONG_MAX) {
compare = MP_GT;break;}
l1 = (long) d1;goto longCompare;#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
d2 = (double) w2;if(DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)|| w2 == (Tcl_WideInt) d2
||modf(d1, &tmp) !=0.0) {goto doubleCompare;}if(d1 < (double)LLONG_MIN) {
compare = MP_LT;break;}if(d1 > (double)LLONG_MAX) {
compare = MP_GT;break;}
w1 = (Tcl_WideInt) d1;goto wideCompare;#endifcase TCL_NUMBER_BIG:if(TclIsInfinite(d1)) {
compare = (d1 >0.0) ? MP_GT : MP_LT;break;}Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);if((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {if(mp_cmp_d(&big2,0) == MP_LT) {
compare = MP_GT;}else{
compare = MP_LT;}mp_clear(&big2);break;}if(DBL_MANT_DIG > CHAR_BIT*sizeof(long)&&modf(d1, &tmp) !=0.0) {
d2 =TclBignumToDouble(&big2);mp_clear(&big2);goto doubleCompare;}Tcl_InitBignumFromDouble(NULL, d1, &big1);goto bigCompare;}break;case TCL_NUMBER_BIG:Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);switch(type2) {#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE:#endifcase TCL_NUMBER_LONG:
compare =mp_cmp_d(&big1,0);mp_clear(&big1);break;case TCL_NUMBER_DOUBLE:
d2 = *((const double*)ptr2);if(TclIsInfinite(d2)) {
compare = (d2 >0.0) ? MP_LT : MP_GT;mp_clear(&big1);break;}if((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
compare =mp_cmp_d(&big1,0);mp_clear(&big1);break;}if(DBL_MANT_DIG > CHAR_BIT*sizeof(long)&&modf(d2, &tmp) !=0.0) {
d1 =TclBignumToDouble(&big1);mp_clear(&big1);goto doubleCompare;}Tcl_InitBignumFromDouble(NULL, d2, &big2);goto bigCompare;case TCL_NUMBER_BIG:Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
bigCompare:
compare =mp_cmp(&big1, &big2);mp_clear(&big1);mp_clear(&big2);}}/* * Turn comparison outcome into appropriate result for opcode. */
convertComparison:switch(*pc) {case INST_EQ:
iResult = (compare == MP_EQ);break;case INST_NEQ:
iResult = (compare != MP_EQ);break;case INST_LT:
iResult = (compare == MP_LT);break;case INST_GT:
iResult = (compare == MP_GT);break;case INST_LE:
iResult = (compare != MP_GT);break;case INST_GE:
iResult = (compare != MP_LT);break;}/* * Peep-hole optimisation: if you're about to jump, do jump from here. */
foundResult:
pc++;#ifndef TCL_COMPILE_DEBUGswitch(*pc) {case INST_JUMP_FALSE1:NEXT_INST_F((iResult? 2:TclGetInt1AtPtr(pc+1)),2,0);case INST_JUMP_TRUE1:NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) :2),2,0);case INST_JUMP_FALSE4:NEXT_INST_F((iResult? 5:TclGetInt4AtPtr(pc+1)),2,0);case INST_JUMP_TRUE4:NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) :5),2,0);}#endif
objResultPtr = constants[iResult];NEXT_INST_F(0,2,1);}case INST_MOD:case INST_LSHIFT:case INST_RSHIFT: {
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
ClientData ptr1, ptr2;int invalid, shift, type1, type2;long l1 =0;
result =GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);if((result != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE)|| (type1 == TCL_NUMBER_NAN)) {
result = TCL_ERROR;TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",O2S(valuePtr),O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}
result =GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);if((result != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE)|| (type2 == TCL_NUMBER_NAN)) {
result = TCL_ERROR;TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",O2S(valuePtr),O2S(value2Ptr), (value2Ptr->typePtr?
value2Ptr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, value2Ptr);CACHE_STACK_INFO();goto checkForCatch;}if(*pc == INST_MOD) {/* TODO: Attempts to re-use unshared operands on stack */long l2 =0;/* silence gcc warning */if(type2 == TCL_NUMBER_LONG) {
l2 = *((const long*)ptr2);if(l2 ==0) {TRACE(("%s %s => DIVIDE BY ZERO\n",O2S(valuePtr),O2S(value2Ptr)));goto divideByZero;}if((l2 ==1) || (l2 == -1)) {/* * Div. by |1| always yields remainder of 0. */
objResultPtr = constants[0];TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}}if(type1 == TCL_NUMBER_LONG) {
l1 = *((const long*)ptr1);if(l1 ==0) {/* * 0 % (non-zero) always yields remainder of 0. */
objResultPtr = constants[0];TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}if(type2 == TCL_NUMBER_LONG) {/* * Both operands are long; do native calculation. */long lRemainder, lQuotient = l1 / l2;/* * Force Tcl's integer division rules. * TODO: examine for logic simplification */if((lQuotient <0|| (lQuotient ==0&&((l1 <0&& l2 >0) || (l1 >0&& l2 <0)))) &&(lQuotient * l2 != l1)) {
lQuotient -=1;}
lRemainder = l1 - l2*lQuotient;TclNewLongObj(objResultPtr, lRemainder);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}/* * First operand fits in long; second does not, so the second * has greater magnitude than first. No need to divide to * determine the remainder. */#ifndef NO_WIDE_TYPEif(type2 == TCL_NUMBER_WIDE) {
Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);if((l1 >0) ^ (w2 > (Tcl_WideInt)0)) {/* * Arguments are opposite sign; remainder is sum. */
objResultPtr =Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}/* * Arguments are same sign; remainder is first operand. */TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}#endif{
mp_int big2;Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);/* TODO: internals intrusion */if((l1 >0) ^ (big2.sign == MP_ZPOS)) {/* * Arguments are opposite sign; remainder is sum. */
mp_int big1;TclBNInitBignumFromLong(&big1, l1);mp_add(&big2, &big1, &big2);mp_clear(&big1);
objResultPtr =Tcl_NewBignumObj(&big2);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}/* * Arguments are same sign; remainder is first operand. */mp_clear(&big2);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}#ifndef NO_WIDE_TYPEif(type1 == TCL_NUMBER_WIDE) {
Tcl_WideInt w1 = *((const Tcl_WideInt *)ptr1);if(type2 != TCL_NUMBER_BIG) {
Tcl_WideInt w2, wQuotient, wRemainder;Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2);
wQuotient = w1 / w2;/* * Force Tcl's integer division rules. * TODO: examine for logic simplification */if(((wQuotient < (Tcl_WideInt)0)|| ((wQuotient == (Tcl_WideInt)0)&& ((w1 < (Tcl_WideInt)0&& w2 > (Tcl_WideInt)0)|| (w1 > (Tcl_WideInt)0&& w2 < (Tcl_WideInt)0))))&& (wQuotient * w2 != w1)) {
wQuotient -= (Tcl_WideInt)1;}
wRemainder = w1 - w2*wQuotient;
objResultPtr =Tcl_NewWideIntObj(wRemainder);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}{
mp_int big2;Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);/* TODO: internals intrusion */if((w1 > ((Tcl_WideInt)0)) ^ (big2.sign == MP_ZPOS)) {/* * Arguments are opposite sign; remainder is sum. */
mp_int big1;TclBNInitBignumFromWideInt(&big1, w1);mp_add(&big2, &big1, &big2);mp_clear(&big1);
objResultPtr =Tcl_NewBignumObj(&big2);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}/* * Arguments are same sign; remainder is first operand. */mp_clear(&big2);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}#endif{
mp_int big1, big2, bigResult, bigRemainder;Tcl_GetBignumFromObj(NULL, valuePtr, &big1);Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);mp_init(&bigResult);mp_init(&bigRemainder);mp_div(&big1, &big2, &bigResult, &bigRemainder);if(!mp_iszero(&bigRemainder)&& (bigRemainder.sign != big2.sign)) {/* * Convert to Tcl's integer division rules. */mp_sub_d(&bigResult,1, &bigResult);mp_add(&bigRemainder, &big2, &bigRemainder);}mp_copy(&bigRemainder, &bigResult);mp_clear(&bigRemainder);mp_clear(&big1);mp_clear(&big2);TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewBignumObj(&bigResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetBignumObj(valuePtr, &bigResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}/* * Reject negative shift argument. */switch(type2) {case TCL_NUMBER_LONG:
invalid = (*((const long*)ptr2) < (long)0);break;#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE:
invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);break;#endifcase TCL_NUMBER_BIG: {
mp_int big2;Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
invalid = (mp_cmp_d(&big2,0) == MP_LT);mp_clear(&big2);break;}default:/* Unused, here to silence compiler warning */
invalid =0;}if(invalid) {Tcl_SetObjResult(interp,Tcl_NewStringObj("negative shift argument", -1));
result = TCL_ERROR;goto checkForCatch;}/* * Zero shifted any number of bits is still zero. */if((type1==TCL_NUMBER_LONG) && (*((const long*)ptr1) == (long)0)) {TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));
objResultPtr = constants[0];TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}if(*pc == INST_LSHIFT) {/* * Large left shifts create integer overflow. * * BEWARE! Can't use Tcl_GetIntFromObj() here because that * converts values in the (unsigned) range to their signed int * counterparts, leading to incorrect results. */if((type2 != TCL_NUMBER_LONG)|| (*((const long*)ptr2) > (long) INT_MAX)) {/* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the * work, and it takes only an int argument, that's a good * place to draw the line. */Tcl_SetObjResult(interp,Tcl_NewStringObj("integer value too large to represent", -1));
result = TCL_ERROR;goto checkForCatch;}
shift = (int)(*((const long*)ptr2));/* * Handle shifts within the native long range. */TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if((type1 == TCL_NUMBER_LONG)&& (size_t) shift < CHAR_BIT*sizeof(long)&& ((l1 = *(const long*)ptr1) !=0)&& !((l1>0 ? l1 : ~l1)& -(1L<<(CHAR_BIT*sizeof(long) -1- shift)))) {TclNewLongObj(objResultPtr, (l1<<shift));TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}/* * Handle shifts within the native wide range. */TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if((type1 != TCL_NUMBER_BIG)&& ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
Tcl_WideInt w;TclGetWideIntFromObj(NULL, valuePtr, &w);if(!((w>0 ? w : ~w)& -(((Tcl_WideInt)1)<< (CHAR_BIT*sizeof(Tcl_WideInt) -1- shift)))) {
objResultPtr =Tcl_NewWideIntObj(w<<shift);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}}}else{/* * Quickly force large right shifts to 0 or -1. */TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if((type2 != TCL_NUMBER_LONG)|| (*(const long*)ptr2 > INT_MAX)) {/* * Again, technically, the value to be shifted could be an * mp_int so huge that a right shift by (INT_MAX+1) bits could * not take us to the result of 0 or -1, but since we're using * mp_div_2d to do the work, and it takes only an int * argument, we draw the line there. */int zero;switch(type1) {case TCL_NUMBER_LONG:
zero = (*(const long*)ptr1 >0L);break;#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE:
zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);break;#endifcase TCL_NUMBER_BIG: {
mp_int big1;Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
zero = (mp_cmp_d(&big1,0) == MP_GT);mp_clear(&big1);break;}default:/* Unused, here to silence compiler warning. */
zero =0;}if(zero) {
objResultPtr = constants[0];}else{TclNewIntObj(objResultPtr, -1);}TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}
shift = (int)(*(const long*)ptr2);/* * Handle shifts within the native long range. */if(type1 == TCL_NUMBER_LONG) {
l1 = *((const long*)ptr1);if((size_t)shift >= CHAR_BIT*sizeof(long)) {if(l1 >= (long)0) {
objResultPtr = constants[0];}else{TclNewIntObj(objResultPtr, -1);}}else{TclNewLongObj(objResultPtr, (l1 >> shift));}TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}#ifndef NO_WIDE_TYPE/* * Handle shifts within the native wide range. */if(type1 == TCL_NUMBER_WIDE) {
Tcl_WideInt w = *(const Tcl_WideInt *)ptr1;if((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {if(w >= (Tcl_WideInt)0) {
objResultPtr = constants[0];}else{TclNewIntObj(objResultPtr, -1);}}else{
objResultPtr =Tcl_NewWideIntObj(w >> shift);}TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}#endif}{
mp_int big, bigResult, bigRemainder;Tcl_TakeBignumFromObj(NULL, valuePtr, &big);mp_init(&bigResult);if(*pc == INST_LSHIFT) {mp_mul_2d(&big, shift, &bigResult);}else{mp_init(&bigRemainder);mp_div_2d(&big, shift, &bigResult, &bigRemainder);if(mp_cmp_d(&bigRemainder,0) == MP_LT) {/* * Convert to Tcl's integer division rules. */mp_sub_d(&bigResult,1, &bigResult);}mp_clear(&bigRemainder);}mp_clear(&big);if(!Tcl_IsShared(valuePtr)) {Tcl_SetBignumObj(valuePtr, &bigResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}
objResultPtr =Tcl_NewBignumObj(&bigResult);}TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}case INST_BITOR:case INST_BITXOR:case INST_BITAND: {
ClientData ptr1, ptr2;int type1, type2;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
result =GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);if((result != TCL_OK)|| (type1 == TCL_NUMBER_NAN)|| (type1 == TCL_NUMBER_DOUBLE)) {
result = TCL_ERROR;TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",O2S(valuePtr),O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}
result =GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);if((result != TCL_OK) || (type2 == TCL_NUMBER_NAN)|| (type2 == TCL_NUMBER_DOUBLE)) {
result = TCL_ERROR;TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",O2S(valuePtr),O2S(value2Ptr), (value2Ptr->typePtr?
value2Ptr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, value2Ptr);CACHE_STACK_INFO();goto checkForCatch;}if((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
mp_int big1, big2, bigResult, *First, *Second;int numPos;Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);/* * Count how many positive arguments we have. If only one of the * arguments is negative, store it in 'Second'. */if(mp_cmp_d(&big1,0) != MP_LT) {
numPos =1+ (mp_cmp_d(&big2,0) != MP_LT);
First = &big1;
Second = &big2;}else{
First = &big2;
Second = &big1;
numPos = (mp_cmp_d(First,0) != MP_LT);}mp_init(&bigResult);switch(*pc) {case INST_BITAND:switch(numPos) {case2:/* * Both arguments positive, base case. */mp_and(First, Second, &bigResult);break;case1:/* * First is positive; second negative: * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) */mp_neg(Second, Second);mp_sub_d(Second,1, Second);mp_xor(First, Second, &bigResult);mp_and(First, &bigResult, &bigResult);break;case0:/* * Both arguments negative: * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */mp_neg(First, First);mp_sub_d(First,1, First);mp_neg(Second, Second);mp_sub_d(Second,1, Second);mp_or(First, Second, &bigResult);mp_neg(&bigResult, &bigResult);mp_sub_d(&bigResult,1, &bigResult);break;}break;case INST_BITOR:switch(numPos) {case2:/* * Both arguments positive, base case. */mp_or(First, Second, &bigResult);break;case1:/* * First is positive; second negative: * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 */mp_neg(Second, Second);mp_sub_d(Second,1, Second);mp_xor(First, Second, &bigResult);mp_and(Second, &bigResult, &bigResult);mp_neg(&bigResult, &bigResult);mp_sub_d(&bigResult,1, &bigResult);break;case0:/* * Both arguments negative: * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */mp_neg(First, First);mp_sub_d(First,1, First);mp_neg(Second, Second);mp_sub_d(Second,1, Second);mp_and(First, Second, &bigResult);mp_neg(&bigResult, &bigResult);mp_sub_d(&bigResult,1, &bigResult);break;}break;case INST_BITXOR:switch(numPos) {case2:/* * Both arguments positive, base case. */mp_xor(First, Second, &bigResult);break;case1:/* * First is positive; second negative: * P^N = ~(P^~N) = -(P^(-N-1))-1 */mp_neg(Second, Second);mp_sub_d(Second,1, Second);mp_xor(First, Second, &bigResult);mp_neg(&bigResult, &bigResult);mp_sub_d(&bigResult,1, &bigResult);break;case0:/* * Both arguments negative: * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */mp_neg(First, First);mp_sub_d(First,1, First);mp_neg(Second, Second);mp_sub_d(Second,1, Second);mp_xor(First, Second, &bigResult);break;}break;}mp_clear(&big1);mp_clear(&big2);TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewBignumObj(&bigResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetBignumObj(valuePtr, &bigResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}#ifndef NO_WIDE_TYPEif((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
Tcl_WideInt wResult, w1, w2;TclGetWideIntFromObj(NULL, valuePtr, &w1);TclGetWideIntFromObj(NULL, value2Ptr, &w2);switch(*pc) {case INST_BITAND:
wResult = w1 & w2;break;case INST_BITOR:
wResult = w1 | w2;break;case INST_BITXOR:
wResult = w1 ^ w2;break;default:/* Unused, here to silence compiler warning. */
wResult =0;}TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewWideIntObj(wResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetWideIntObj(valuePtr, wResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}#endif{long lResult, l1 = *((const long*)ptr1);long l2 = *((const long*)ptr2);switch(*pc) {case INST_BITAND:
lResult = l1 & l2;break;case INST_BITOR:
lResult = l1 | l2;break;case INST_BITXOR:
lResult = l1 ^ l2;break;default:/* Unused, here to silence compiler warning. */
lResult =0;}TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {TclNewLongObj(objResultPtr, lResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}TclSetLongObj(valuePtr, lResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}case INST_EXPON:case INST_ADD:case INST_SUB:case INST_DIV:case INST_MULT: {
ClientData ptr1, ptr2;int type1, type2;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
result =GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);if((result != TCL_OK)#ifndef ACCEPT_NAN|| (type1 == TCL_NUMBER_NAN)#endif) {
result = TCL_ERROR;TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",O2S(value2Ptr),O2S(valuePtr),(valuePtr->typePtr? valuePtr->typePtr->name:"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}#ifdef ACCEPT_NANif(type1 == TCL_NUMBER_NAN) {/* * NaN first argument -> result is also NaN. */NEXT_INST_F(1,1,0);}#endif
result =GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);if((result != TCL_OK)#ifndef ACCEPT_NAN|| (type2 == TCL_NUMBER_NAN)#endif) {
result = TCL_ERROR;TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",O2S(value2Ptr),O2S(valuePtr),(value2Ptr->typePtr? value2Ptr->typePtr->name:"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, value2Ptr);CACHE_STACK_INFO();goto checkForCatch;}#ifdef ACCEPT_NANif(type2 == TCL_NUMBER_NAN) {/* * NaN second argument -> result is also NaN. */
objResultPtr = value2Ptr;NEXT_INST_F(1,2,1);}#endifif((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {/* * At least one of the values is floating-point, so perform * floating point calculations. */double d1, d2, dResult;Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);switch(*pc) {case INST_ADD:
dResult = d1 + d2;break;case INST_SUB:
dResult = d1 - d2;break;case INST_MULT:
dResult = d1 * d2;break;case INST_DIV:#ifndef IEEE_FLOATING_POINTif(d2 ==0.0) {TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));goto divideByZero;}#endif/* * We presume that we are running with zero-divide unmasked if * we're on an IEEE box. Otherwise, this statement might cause * demons to fly out our noses. */
dResult = d1 / d2;break;case INST_EXPON:if(d1==0.0&& d2<0.0) {TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));goto exponOfZero;}
dResult =pow(d1, d2);break;default:/* Unused, here to silence compiler warning. */
dResult =0;}#ifndef ACCEPT_NAN/* * Check now for IEEE floating-point error. */if(TclIsNaN(dResult)) {TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",O2S(valuePtr),O2S(value2Ptr)));DECACHE_STACK_INFO();TclExprFloatError(interp, dResult);CACHE_STACK_INFO();
result = TCL_ERROR;goto checkForCatch;}#endifTRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {TclNewDoubleObj(objResultPtr, dResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}TclSetDoubleObj(valuePtr, dResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}if((sizeof(long) >=2*sizeof(int)) && (*pc == INST_MULT)&& (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {long l1 = *((const long*)ptr1);long l2 = *((const long*)ptr2);if((l1 <= INT_MAX) && (l1 >= INT_MIN)&& (l2 <= INT_MAX) && (l2 >= INT_MIN)) {long lResult = l1 * l2;TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {TclNewLongObj(objResultPtr,lResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}TclSetLongObj(valuePtr, lResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}if((sizeof(Tcl_WideInt) >=2*sizeof(long)) && (*pc == INST_MULT)&& (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
Tcl_WideInt w1, w2, wResult;TclGetWideIntFromObj(NULL, valuePtr, &w1);TclGetWideIntFromObj(NULL, value2Ptr, &w2);
wResult = w1 * w2;TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewWideIntObj(wResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetWideIntObj(valuePtr, wResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}/* TODO: Attempts to re-use unshared operands on stack. */if(*pc == INST_EXPON) {long l1 =0, l2 =0;int oddExponent =0, negativeExponent =0;#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
Tcl_WideInt w1;#endifif(type2 == TCL_NUMBER_LONG) {
l2 = *((const long*) ptr2);if(l2 ==0) {/* * Anything to the zero power is 1. */
objResultPtr = constants[1];NEXT_INST_F(1,2,1);}else if(l2 ==1) {/* * Anything to the first power is itself */NEXT_INST_F(1,1,0);}}switch(type2) {case TCL_NUMBER_LONG: {
negativeExponent = (l2 <0);
oddExponent = (int) (l2 &1);break;}#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE: {
Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);
negativeExponent = (w2 <0);
oddExponent = (int) (w2 & (Tcl_WideInt)1);break;}#endifcase TCL_NUMBER_BIG: {
mp_int big2;Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
negativeExponent = (mp_cmp_d(&big2,0) == MP_LT);mp_mod_2d(&big2,1, &big2);
oddExponent = !mp_iszero(&big2);mp_clear(&big2);break;}}if(type1 == TCL_NUMBER_LONG) {
l1 = *((const long*)ptr1);}if(negativeExponent) {if(type1 == TCL_NUMBER_LONG) {switch(l1) {case0:/* * Zero to a negative power is div by zero error. */TRACE(("%s %s => EXPONENT OF ZERO\n",O2S(valuePtr),O2S(value2Ptr)));goto exponOfZero;case-1:if(oddExponent) {TclNewIntObj(objResultPtr, -1);}else{
objResultPtr = constants[1];}NEXT_INST_F(1,2,1);case1:/* * 1 to any power is 1. */
objResultPtr = constants[1];NEXT_INST_F(1,2,1);}}/* * Integers with magnitude greater than 1 raise to a negative * power yield the answer zero (see TIP 123). */
objResultPtr = constants[0];NEXT_INST_F(1,2,1);}if(type1 == TCL_NUMBER_LONG) {switch(l1) {case0:/* * Zero to a positive power is zero. */
objResultPtr = constants[0];NEXT_INST_F(1,2,1);case1:/* * 1 to any power is 1. */
objResultPtr = constants[1];NEXT_INST_F(1,2,1);case-1:if(oddExponent) {TclNewIntObj(objResultPtr, -1);}else{
objResultPtr = constants[1];}NEXT_INST_F(1,2,1);}}/* * We refuse to accept exponent arguments that exceed * one mp_digit which means the max exponent value is * 2**28-1 = 0x0fffffff = 268435455, which fits into * a signed 32 bit int which is within the range of the * long int type. This means any numeric Tcl_Obj value * not using TCL_NUMBER_LONG type must hold a value larger * than we accept. */if(type2 != TCL_NUMBER_LONG) {Tcl_SetObjResult(interp,Tcl_NewStringObj("exponent too large", -1));
result = TCL_ERROR;goto checkForCatch;}if(type1 == TCL_NUMBER_LONG) {if(l1 ==2) {/* * Reduce small powers of 2 to shifts. */if((unsigned long) l2 < CHAR_BIT *sizeof(long) -1) {TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));TclNewLongObj(objResultPtr, (1L<< l2));TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}#if !defined(TCL_WIDE_INT_IS_LONG)if((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) -1){TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));
objResultPtr =Tcl_NewWideIntObj(((Tcl_WideInt)1) << l2);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}#endifgoto overflow;}if(l1 == -2) {int signum = oddExponent ? -1:1;/* * Reduce small powers of 2 to shifts. */if((unsigned long) l2 < CHAR_BIT *sizeof(long) -1) {TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));TclNewLongObj(objResultPtr, signum * (1L<< l2));TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}#if !defined(TCL_WIDE_INT_IS_LONG)if((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) -1){TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));
objResultPtr =Tcl_NewWideIntObj(
signum * (((Tcl_WideInt)1) << l2));TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}#endifgoto overflow;}#if (LONG_MAX == 0x7fffffff)if(l2 -2< (long)MaxBase32Size
&& l1 <= MaxBase32[l2 -2]&& l1 >= -MaxBase32[l2 -2]) {/* * Small powers of 32-bit integers. */long lResult = l1 * l1;/* b**2 */switch(l2) {case2:break;case3:
lResult *= l1;/* b**3 */break;case4:
lResult *= lResult;/* b**4 */break;case5:
lResult *= lResult;/* b**4 */
lResult *= l1;/* b**5 */break;case6:
lResult *= l1;/* b**3 */
lResult *= lResult;/* b**6 */break;case7:
lResult *= l1;/* b**3 */
lResult *= lResult;/* b**6 */
lResult *= l1;/* b**7 */break;case8:
lResult *= lResult;/* b**4 */
lResult *= lResult;/* b**8 */break;}TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {TclNewLongObj(objResultPtr, lResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetLongObj(valuePtr, lResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}if(l1 -3>=0&& l1 -2< (long)Exp32IndexSize
&& l2 -2< (long)(Exp32ValueSize + MaxBase32Size)) {unsigned short base = Exp32Index[l1 -3]+ (unsigned short) (l2 -2- MaxBase32Size);if(base < Exp32Index[l1 -2]) {/* * 32-bit number raised to intermediate power, done by * table lookup. */TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {TclNewLongObj(objResultPtr, Exp32Value[base]);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetLongObj(valuePtr, Exp32Value[base]);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}if(-l1 -3>=0&& -l1 -2< (long)Exp32IndexSize
&& l2 -2< (long)(Exp32ValueSize + MaxBase32Size)) {unsigned short base = Exp32Index[-l1 -3]+ (unsigned short) (l2 -2- MaxBase32Size);if(base < Exp32Index[-l1 -2]) {long lResult = (oddExponent) ?
-Exp32Value[base] : Exp32Value[base];/* * 32-bit number raised to intermediate power, done by * table lookup. */TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {TclNewLongObj(objResultPtr, lResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetLongObj(valuePtr, lResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}#endif}#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)if(type1 == TCL_NUMBER_LONG) {
w1 = l1;#ifndef NO_WIDE_TYPE}else if(type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt*) ptr1);#endif}else{goto overflow;}if(l2 -2< (long)MaxBase64Size
&& w1 <= MaxBase64[l2 -2]&& w1 >= -MaxBase64[l2 -2]) {/* * Small powers of integers whose result is wide. */
Tcl_WideInt wResult = w1 * w1;/* b**2 */switch(l2) {case2:break;case3:
wResult *= l1;/* b**3 */break;case4:
wResult *= wResult;/* b**4 */break;case5:
wResult *= wResult;/* b**4 */
wResult *= w1;/* b**5 */break;case6:
wResult *= w1;/* b**3 */
wResult *= wResult;/* b**6 */break;case7:
wResult *= w1;/* b**3 */
wResult *= wResult;/* b**6 */
wResult *= w1;/* b**7 */break;case8:
wResult *= wResult;/* b**4 */
wResult *= wResult;/* b**8 */break;case9:
wResult *= wResult;/* b**4 */
wResult *= wResult;/* b**8 */
wResult *= w1;/* b**9 */break;case10:
wResult *= wResult;/* b**4 */
wResult *= w1;/* b**5 */
wResult *= wResult;/* b**10 */break;case11:
wResult *= wResult;/* b**4 */
wResult *= w1;/* b**5 */
wResult *= wResult;/* b**10 */
wResult *= w1;/* b**11 */break;case12:
wResult *= w1;/* b**3 */
wResult *= wResult;/* b**6 */
wResult *= wResult;/* b**12 */break;case13:
wResult *= w1;/* b**3 */
wResult *= wResult;/* b**6 */
wResult *= wResult;/* b**12 */
wResult *= w1;/* b**13 */break;case14:
wResult *= w1;/* b**3 */
wResult *= wResult;/* b**6 */
wResult *= w1;/* b**7 */
wResult *= wResult;/* b**14 */break;case15:
wResult *= w1;/* b**3 */
wResult *= wResult;/* b**6 */
wResult *= w1;/* b**7 */
wResult *= wResult;/* b**14 */
wResult *= w1;/* b**15 */break;case16:
wResult *= wResult;/* b**4 */
wResult *= wResult;/* b**8 */
wResult *= wResult;/* b**16 */break;}TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));
objResultPtr =Tcl_NewWideIntObj(wResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}/* * Handle cases of powers > 16 that still fit in a 64-bit word by * doing table lookup. */if(w1 -3>=0&& w1 -2< (long)Exp64IndexSize
&& l2 -2< (long)(Exp64ValueSize + MaxBase64Size)) {unsigned short base = Exp64Index[w1 -3]+ (unsigned short) (l2 -2- MaxBase64Size);if(base < Exp64Index[w1 -2]) {/* * 64-bit number raised to intermediate power, done by * table lookup. */TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewWideIntObj(Exp64Value[base]);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetWideIntObj(valuePtr, Exp64Value[base]);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}if(-w1 -3>=0&& -w1 -2< (long)Exp64IndexSize
&& l2 -2< (long)(Exp64ValueSize + MaxBase64Size)) {unsigned short base = Exp64Index[-w1 -3]+ (unsigned short) (l2 -2- MaxBase64Size);if(base < Exp64Index[-w1 -2]) {
Tcl_WideInt wResult = (oddExponent) ?
-Exp64Value[base] : Exp64Value[base];/* * 64-bit number raised to intermediate power, done by * table lookup. */TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewWideIntObj(wResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetWideIntObj(valuePtr, wResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}#endifgoto overflow;}if((*pc != INST_MULT)&& (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
Tcl_WideInt w1, w2, wResult;TclGetWideIntFromObj(NULL, valuePtr, &w1);TclGetWideIntFromObj(NULL, value2Ptr, &w2);switch(*pc) {case INST_ADD:
wResult = w1 + w2;#ifndef NO_WIDE_TYPEif((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))#endif{/* * Check for overflow. */if(Overflowing(w1, w2, wResult)) {goto overflow;}}break;case INST_SUB:
wResult = w1 - w2;#ifndef NO_WIDE_TYPEif((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))#endif{/* * Must check for overflow. The macro tests for overflows * in sums by looking at the sign bits. As we have a * subtraction here, we are adding -w2. As -w2 could in * turn overflow, we test with ~w2 instead: it has the * opposite sign bit to w2 so it does the job. Note that * the only "bad" case (w2==0) is irrelevant for this * macro, as in that case w1 and wResult have the same * sign and there is no overflow anyway. */if(Overflowing(w1, ~w2, wResult)) {goto overflow;}}break;case INST_DIV:if(w2 ==0) {TRACE(("%s %s => DIVIDE BY ZERO\n",O2S(valuePtr),O2S(value2Ptr)));goto divideByZero;}/* * Need a bignum to represent (LLONG_MIN / -1) */if((w1 == LLONG_MIN) && (w2 == -1)) {goto overflow;}
wResult = w1 / w2;/* * Force Tcl's integer division rules. * TODO: examine for logic simplification */if(((wResult <0) || ((wResult ==0) &&((w1 <0&& w2 >0) || (w1 >0&& w2 <0)))) &&((wResult * w2) != w1)) {
wResult -=1;}break;default:/* * Unused, here to silence compiler warning. */
wResult =0;}TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewWideIntObj(wResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetWideIntObj(valuePtr, wResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}
overflow:{
mp_int big1, big2, bigResult, bigRemainder;TRACE(("%s %s => ",O2S(valuePtr),O2S(value2Ptr)));Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);mp_init(&bigResult);switch(*pc) {case INST_ADD:mp_add(&big1, &big2, &bigResult);break;case INST_SUB:mp_sub(&big1, &big2, &bigResult);break;case INST_MULT:mp_mul(&big1, &big2, &bigResult);break;case INST_DIV:if(mp_iszero(&big2)) {TRACE(("%s %s => DIVIDE BY ZERO\n",O2S(valuePtr),O2S(value2Ptr)));mp_clear(&big1);mp_clear(&big2);mp_clear(&bigResult);goto divideByZero;}mp_init(&bigRemainder);mp_div(&big1, &big2, &bigResult, &bigRemainder);/* TODO: internals intrusion */if(!mp_iszero(&bigRemainder)&& (bigRemainder.sign != big2.sign)) {/* * Convert to Tcl's integer division rules. */mp_sub_d(&bigResult,1, &bigResult);mp_add(&bigRemainder, &big2, &bigRemainder);}mp_clear(&bigRemainder);break;case INST_EXPON:if(big2.used >1) {Tcl_SetObjResult(interp,Tcl_NewStringObj("exponent too large", -1));mp_clear(&big1);mp_clear(&big2);mp_clear(&bigResult);
result = TCL_ERROR;goto checkForCatch;}mp_expt_d(&big1, big2.dp[0], &bigResult);break;}mp_clear(&big1);mp_clear(&big2);if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewBignumObj(&bigResult);TRACE(("%s\n",O2S(objResultPtr)));NEXT_INST_F(1,2,1);}Tcl_SetBignumObj(valuePtr, &bigResult);TRACE(("%s\n",O2S(valuePtr)));NEXT_INST_F(1,1,0);}}case INST_LNOT: {int b;
Tcl_Obj *valuePtr = OBJ_AT_TOS;/* TODO - check claim that taking address of b harms performance *//* TODO - consider optimization search for constants */
result =TclGetBooleanFromObj(NULL, valuePtr, &b);if(result != TCL_OK) {TRACE(("\"%.20s\"=> ILLEGAL TYPE %s\n",O2S(valuePtr),(valuePtr->typePtr? valuePtr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}/* TODO: Consider peephole opt. */
objResultPtr = constants[!b];NEXT_INST_F(1,1,1);}case INST_BITNOT: {
mp_int big;
ClientData ptr;int type;
Tcl_Obj *valuePtr = OBJ_AT_TOS;
result =GetNumberFromObj(NULL, valuePtr, &ptr, &type);if((result != TCL_OK)|| (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {/* * ... ~$NonInteger => raise an error. */
result = TCL_ERROR;TRACE(("\"%.20s\"=> ILLEGAL TYPE %s\n",O2S(valuePtr),(valuePtr->typePtr? valuePtr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}if(type == TCL_NUMBER_LONG) {long l = *((const long*)ptr);if(Tcl_IsShared(valuePtr)) {TclNewLongObj(objResultPtr, ~l);NEXT_INST_F(1,1,1);}TclSetLongObj(valuePtr, ~l);NEXT_INST_F(1,0,0);}#ifndef NO_WIDE_TYPEif(type == TCL_NUMBER_WIDE) {
Tcl_WideInt w = *((const Tcl_WideInt *)ptr);if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewWideIntObj(~w);NEXT_INST_F(1,1,1);}Tcl_SetWideIntObj(valuePtr, ~w);NEXT_INST_F(1,0,0);}#endifTcl_TakeBignumFromObj(NULL, valuePtr, &big);/* ~a = - a - 1 */mp_neg(&big, &big);mp_sub_d(&big,1, &big);if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewBignumObj(&big);NEXT_INST_F(1,1,1);}Tcl_SetBignumObj(valuePtr, &big);NEXT_INST_F(1,0,0);}case INST_UMINUS: {
ClientData ptr;int type;
Tcl_Obj *valuePtr = OBJ_AT_TOS;
result =GetNumberFromObj(NULL, valuePtr, &ptr, &type);if((result != TCL_OK)#ifndef ACCEPT_NAN|| (type == TCL_NUMBER_NAN)#endif) {
result = TCL_ERROR;TRACE(("\"%.20s\"=> ILLEGAL TYPE %s\n",O2S(valuePtr),(valuePtr->typePtr? valuePtr->typePtr->name :"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}switch(type) {case TCL_NUMBER_DOUBLE: {double d;if(Tcl_IsShared(valuePtr)) {TclNewDoubleObj(objResultPtr, -(*((const double*)ptr)));NEXT_INST_F(1,1,1);}
d = *((const double*)ptr);TclSetDoubleObj(valuePtr, -d);NEXT_INST_F(1,0,0);}case TCL_NUMBER_LONG: {long l = *((const long*)ptr);if(l != LONG_MIN) {if(Tcl_IsShared(valuePtr)) {TclNewLongObj(objResultPtr, -l);NEXT_INST_F(1,1,1);}TclSetLongObj(valuePtr, -l);NEXT_INST_F(1,0,0);}/* FALLTHROUGH */}#ifndef NO_WIDE_TYPEcase TCL_NUMBER_WIDE: {
Tcl_WideInt w;if(type == TCL_NUMBER_LONG) {
w = (Tcl_WideInt)(*((const long*)ptr));}else{
w = *((const Tcl_WideInt *)ptr);}if(w != LLONG_MIN) {if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewWideIntObj(-w);NEXT_INST_F(1,1,1);}Tcl_SetWideIntObj(valuePtr, -w);NEXT_INST_F(1,0,0);}/* FALLTHROUGH */}#endifcase TCL_NUMBER_BIG: {
mp_int big;switch(type) {#ifdef NO_WIDE_TYPEcase TCL_NUMBER_LONG:TclBNInitBignumFromLong(&big, *(const long*) ptr);break;#elsecase TCL_NUMBER_WIDE:TclBNInitBignumFromWideInt(&big, *(const Tcl_WideInt *) ptr);break;#endifcase TCL_NUMBER_BIG:Tcl_TakeBignumFromObj(NULL, valuePtr, &big);}mp_neg(&big, &big);if(Tcl_IsShared(valuePtr)) {
objResultPtr =Tcl_NewBignumObj(&big);NEXT_INST_F(1,1,1);}Tcl_SetBignumObj(valuePtr, &big);NEXT_INST_F(1,0,0);}case TCL_NUMBER_NAN:/* -NaN => NaN */NEXT_INST_F(1,0,0);}}case INST_UPLUS:case INST_TRY_CVT_TO_NUMERIC: {/* * Try to convert the topmost stack object to numeric object. This is * done in order to support [expr]'s policy of interpreting operands * if at all possible as numbers first, then strings. */
ClientData ptr;int type;
Tcl_Obj *valuePtr = OBJ_AT_TOS;if(GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) {if(*pc == INST_UPLUS) {/* * ... +$NonNumeric => raise an error. */
result = TCL_ERROR;TRACE(("\"%.20s\"=> ILLEGAL TYPE %s\n",O2S(valuePtr),(valuePtr->typePtr? valuePtr->typePtr->name:"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();goto checkForCatch;}else{/* ... TryConvertToNumeric($NonNumeric) is acceptable */TRACE(("\"%.20s\"=> not numeric\n",O2S(valuePtr)));NEXT_INST_F(1,0,0);}}#ifndef ACCEPT_NANif(type == TCL_NUMBER_NAN) {
result = TCL_ERROR;if(*pc == INST_UPLUS) {/* * ... +$NonNumeric => raise an error. */TRACE(("\"%.20s\"=> ILLEGAL TYPE %s\n",O2S(valuePtr),(valuePtr->typePtr? valuePtr->typePtr->name:"null")));DECACHE_STACK_INFO();IllegalExprOperandType(interp, pc, valuePtr);CACHE_STACK_INFO();}else{/* * Numeric conversion of NaN -> error. */TRACE(("\"%.20s\"=> IEEE FLOATING PT ERROR\n",O2S(objResultPtr)));DECACHE_STACK_INFO();TclExprFloatError(interp, *((const double*)ptr));CACHE_STACK_INFO();}goto checkForCatch;}#endif/* * Ensure that the numeric value has a string rep the same as the * formatted version of its internal rep. This is used, e.g., to make * sure that "expr {0001}" yields "1", not "0001". We implement this * by _discarding_ the string rep since we know it will be * regenerated, if needed later, by formatting the internal rep's * value. */if(valuePtr->bytes == NULL) {TRACE(("\"%.20s\"=> numeric, same Tcl_Obj\n",O2S(valuePtr)));NEXT_INST_F(1,0,0);}if(Tcl_IsShared(valuePtr)) {/* * Here we do some surgery within the Tcl_Obj internals. We want * to copy the intrep, but not the string, so we temporarily hide * the string so we do not copy it. */char*savedString = valuePtr->bytes;
valuePtr->bytes = NULL;
objResultPtr =Tcl_DuplicateObj(valuePtr);
valuePtr->bytes = savedString;TRACE(("\"%.20s\"=> numeric, new Tcl_Obj\n",O2S(valuePtr)));NEXT_INST_F(1,1,1);}TclInvalidateStringRep(valuePtr);TRACE(("\"%.20s\"=> numeric, same Tcl_Obj\n",O2S(valuePtr)));NEXT_INST_F(1,0,0);}case INST_BREAK:/* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); */
result = TCL_BREAK;
cleanup =0;goto processExceptionReturn;case INST_CONTINUE:/* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); */
result = TCL_CONTINUE;
cleanup =0;goto processExceptionReturn;case INST_FOREACH_START4: {/* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. */int opnd, iterTmpIndex;
ForeachInfo *infoPtr;
Var *iterVarPtr;
Tcl_Obj *oldValuePtr;
opnd =TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
iterVarPtr = &(compiledLocals[iterTmpIndex]);
oldValuePtr = iterVarPtr->value.objPtr;if(oldValuePtr == NULL) {TclNewLongObj(iterVarPtr->value.objPtr, -1);Tcl_IncrRefCount(iterVarPtr->value.objPtr);}else{TclSetLongObj(oldValuePtr, -1);}TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));#ifndef TCL_COMPILE_DEBUG/* * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately * after INST_FOREACH_START4 - let us just fall through instead of * jumping back to the top. */
pc +=5;TCL_DTRACE_INST_NEXT();#elseNEXT_INST_F(5,0,0);#endif}case INST_FOREACH_STEP4: {/* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. */
ForeachInfo *infoPtr;
ForeachVarList *varListPtr;
Tcl_Obj *listPtr,*valuePtr, *value2Ptr, **elements;
Var *iterVarPtr, *listVarPtr, *varPtr;int opnd, numLists, iterNum, listTmpIndex, listLen, numVars;int varIndex, valIndex, continueLoop, j;long i;
opnd =TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;/* * Increment the temp holding the loop iteration number. */
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
valuePtr = iterVarPtr->value.objPtr;
iterNum = (valuePtr->internalRep.longValue +1);TclSetLongObj(valuePtr, iterNum);/* * Check whether all value lists are exhausted and we should stop the * loop. */
continueLoop =0;
listTmpIndex = infoPtr->firstValueTemp;for(i =0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
result =TclListObjLength(interp, listPtr, &listLen);if(result == TCL_OK) {if(listLen > (iterNum * numVars)) {
continueLoop =1;}
listTmpIndex++;}else{TRACE_WITH_OBJ(("%u => ERROR converting list %ld,\"%s\": ",
opnd, i,O2S(listPtr)),Tcl_GetObjResult(interp));goto checkForCatch;}}/* * If some var in some var list still has a remaining list element * iterate one more time. Assign to var the next element from its * value list. We already checked above that each list temp holds a * valid list object (by calling Tcl_ListObjLength), but cannot rely * on that check remaining valid: one list could have been shimmered * as a side effect of setting a traced variable. */if(continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;for(i =0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr =TclListObjCopy(NULL, listVarPtr->value.objPtr);TclListObjGetElements(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);for(j =0; j < numVars; j++) {if(valIndex >= listLen) {TclNewObj(valuePtr);}else{
valuePtr = elements[valIndex];}
varIndex = varListPtr->varIndexes[j];
varPtr = &(compiledLocals[varIndex]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}if(TclIsVarDirectWritable(varPtr)) {
value2Ptr = varPtr->value.objPtr;if(valuePtr != value2Ptr) {if(value2Ptr != NULL) {TclDecrRefCount(value2Ptr);}
varPtr->value.objPtr = valuePtr;Tcl_IncrRefCount(valuePtr);}}else{DECACHE_STACK_INFO();
value2Ptr =TclPtrSetVar(interp, varPtr, NULL, NULL,
NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex);CACHE_STACK_INFO();if(value2Ptr == NULL) {TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
opnd,varIndex),Tcl_GetObjResult(interp));
result = TCL_ERROR;TclDecrRefCount(listPtr);goto checkForCatch;}}
valIndex++;}TclDecrRefCount(listPtr);
listTmpIndex++;}}TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
iterNum, (continueLoop? "continue":"exit")));/* * Run-time peep-hole optimisation: the compiler ALWAYS follows * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that * instruction and jump direct from here. */
pc +=5;if(*pc == INST_JUMP_FALSE1) {NEXT_INST_F((continueLoop? 2:TclGetInt1AtPtr(pc+1)),0,0);}else{NEXT_INST_F((continueLoop? 5:TclGetInt4AtPtr(pc+1)),0,0);}}case INST_BEGIN_CATCH4:/* * Record start of the catch command with exception range index equal * to the operand. Push the current stack depth onto the special catch * stack. */*(++catchTop) = CURR_DEPTH;TRACE(("%u => catchTop=%d, stackTop=%d\n",TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop -1),(int) CURR_DEPTH));NEXT_INST_F(5,0,0);case INST_END_CATCH:
catchTop--;DECACHE_STACK_INFO();Tcl_ResetResult(interp);CACHE_STACK_INFO();
result = TCL_OK;TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop -1)));NEXT_INST_F(1,0,0);case INST_PUSH_RESULT:
objResultPtr =Tcl_GetObjResult(interp);TRACE_WITH_OBJ(("=> "), objResultPtr);/* * See the comments at INST_INVOKE_STK */{
Tcl_Obj *newObjResultPtr;TclNewObj(newObjResultPtr);Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;}NEXT_INST_F(1,0, -1);case INST_PUSH_RETURN_CODE:TclNewIntObj(objResultPtr, result);TRACE(("=> %u\n", result));NEXT_INST_F(1,0,1);case INST_PUSH_RETURN_OPTIONS:
objResultPtr =Tcl_GetReturnOptions(interp, result);TRACE_WITH_OBJ(("=> "), objResultPtr);NEXT_INST_F(1,0,1);/* TODO: normalize "valPtr" to "valuePtr" */{int opnd, opnd2, allocateDict;
Tcl_Obj *dictPtr, *valPtr;
Var *varPtr;case INST_DICT_GET:
opnd =TclGetUInt4AtPtr(pc+1);TRACE(("%u => ", opnd));
dictPtr =OBJ_AT_DEPTH(opnd);if(opnd >1) {
dictPtr =TclTraceDictPath(interp, dictPtr, opnd-1,&OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);if(dictPtr == NULL) {TRACE_WITH_OBJ(("%u => ERROR tracing dictionary path into\"%s\": ",
opnd,O2S(OBJ_AT_DEPTH(opnd))),Tcl_GetObjResult(interp));
result = TCL_ERROR;goto checkForCatch;}}
result =Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr);if((result == TCL_OK) && objResultPtr) {TRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_V(5, opnd+1,1);}if(result != TCL_OK) {TRACE_WITH_OBJ(("%u => ERROR reading leaf dictionary key\"%s\": ",
opnd,O2S(dictPtr)),Tcl_GetObjResult(interp));}else{DECACHE_STACK_INFO();Tcl_ResetResult(interp);Tcl_AppendResult(interp,"key\"",TclGetString(OBJ_AT_TOS),"\"not known in dictionary", NULL);CACHE_STACK_INFO();TRACE_WITH_OBJ(("%u => ERROR ", opnd),Tcl_GetObjResult(interp));
result = TCL_ERROR;}goto checkForCatch;case INST_DICT_SET:case INST_DICT_UNSET:case INST_DICT_INCR_IMM:
opnd =TclGetUInt4AtPtr(pc+1);
opnd2 =TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd2]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}TRACE(("%u %u => ", opnd, opnd2));if(TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;}else{DECACHE_STACK_INFO();
dictPtr =TclPtrGetVar(interp, varPtr, NULL,NULL,NULL,0, opnd2);CACHE_STACK_INFO();}if(dictPtr == NULL) {TclNewObj(dictPtr);
allocateDict =1;}else{
allocateDict =Tcl_IsShared(dictPtr);if(allocateDict) {
dictPtr =Tcl_DuplicateObj(dictPtr);}}switch(*pc) {case INST_DICT_SET:
cleanup = opnd +1;
result =Tcl_DictObjPutKeyList(interp, dictPtr, opnd,&OBJ_AT_DEPTH(opnd), OBJ_AT_TOS);break;case INST_DICT_INCR_IMM:
cleanup =1;
opnd =TclGetInt4AtPtr(pc+1);
result =Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valPtr);if(result != TCL_OK) {break;}if(valPtr == NULL) {Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));}else{
Tcl_Obj *incrPtr =Tcl_NewIntObj(opnd);Tcl_IncrRefCount(incrPtr);if(Tcl_IsShared(valPtr)) {
valPtr =Tcl_DuplicateObj(valPtr);Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valPtr);}
result =TclIncrObj(interp, valPtr, incrPtr);if(result == TCL_OK) {Tcl_InvalidateStringRep(dictPtr);}TclDecrRefCount(incrPtr);}break;case INST_DICT_UNSET:
cleanup = opnd;
result =Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd,&OBJ_AT_DEPTH(opnd-1));break;default:
cleanup =0;/* stop compiler warning */Tcl_Panic("Should not happen!");}if(result != TCL_OK) {if(allocateDict) {TclDecrRefCount(dictPtr);}TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",
opnd, opnd2),Tcl_GetObjResult(interp));goto checkForCatch;}if(TclIsVarDirectWritable(varPtr)) {if(allocateDict) {
Tcl_Obj *oldValuePtr = varPtr->value.objPtr;Tcl_IncrRefCount(dictPtr);if(oldValuePtr != NULL) {TclDecrRefCount(oldValuePtr);}
varPtr->value.objPtr = dictPtr;}
objResultPtr = dictPtr;}else{Tcl_IncrRefCount(dictPtr);DECACHE_STACK_INFO();
objResultPtr =TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd2);CACHE_STACK_INFO();TclDecrRefCount(dictPtr);if(objResultPtr == NULL) {TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}}#ifndef TCL_COMPILE_DEBUGif(*(pc+9) == INST_POP) {NEXT_INST_V(10, cleanup,0);}#endifTRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_V(9, cleanup,1);case INST_DICT_APPEND:case INST_DICT_LAPPEND:
opnd =TclGetUInt4AtPtr(pc+1);
varPtr = &(compiledLocals[opnd]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}TRACE(("%u => ", opnd));if(TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;}else{DECACHE_STACK_INFO();
dictPtr =TclPtrGetVar(interp, varPtr, NULL, NULL, NULL,0, opnd);CACHE_STACK_INFO();}if(dictPtr == NULL) {TclNewObj(dictPtr);
allocateDict =1;}else{
allocateDict =Tcl_IsShared(dictPtr);if(allocateDict) {
dictPtr =Tcl_DuplicateObj(dictPtr);}}
result =Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valPtr);if(result != TCL_OK) {if(allocateDict) {TclDecrRefCount(dictPtr);}goto checkForCatch;}/* * Note that a non-existent key results in a NULL valPtr, which is a * case handled separately below. What we *can* say at this point is * that the write-back will always succeed. */switch(*pc) {case INST_DICT_APPEND:if(valPtr == NULL) {
valPtr = OBJ_AT_TOS;}else{if(Tcl_IsShared(valPtr)) {
valPtr =Tcl_DuplicateObj(valPtr);}Tcl_AppendObjToObj(valPtr, OBJ_AT_TOS);}break;case INST_DICT_LAPPEND:/* * More complex because list-append can fail. */if(valPtr == NULL) {
valPtr =Tcl_NewListObj(1, &OBJ_AT_TOS);}else if(Tcl_IsShared(valPtr)) {
valPtr =Tcl_DuplicateObj(valPtr);
result =Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);if(result != TCL_OK) {TclDecrRefCount(valPtr);if(allocateDict) {TclDecrRefCount(dictPtr);}goto checkForCatch;}}else{
result =Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);if(result != TCL_OK) {if(allocateDict) {TclDecrRefCount(dictPtr);}goto checkForCatch;}}break;default:Tcl_Panic("Should not happen!");}Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valPtr);if(TclIsVarDirectWritable(varPtr)) {if(allocateDict) {
Tcl_Obj *oldValuePtr = varPtr->value.objPtr;Tcl_IncrRefCount(dictPtr);if(oldValuePtr != NULL) {TclDecrRefCount(oldValuePtr);}
varPtr->value.objPtr = dictPtr;}
objResultPtr = dictPtr;}else{Tcl_IncrRefCount(dictPtr);DECACHE_STACK_INFO();
objResultPtr =TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd);CACHE_STACK_INFO();TclDecrRefCount(dictPtr);if(objResultPtr == NULL) {TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;goto checkForCatch;}}#ifndef TCL_COMPILE_DEBUGif(*(pc+5) == INST_POP) {NEXT_INST_F(6,2,0);}#endifTRACE_APPEND(("%.30s\n",O2S(objResultPtr)));NEXT_INST_F(5,2,1);}{int opnd, done;
Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr;
Var *varPtr;
Tcl_DictSearch *searchPtr;case INST_DICT_FIRST:
opnd =TclGetUInt4AtPtr(pc+1);TRACE(("%u => ", opnd));
dictPtr =POP_OBJECT();
searchPtr = (Tcl_DictSearch *)ckalloc(sizeof(Tcl_DictSearch));
result =Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,&valuePtr, &done);if(result != TCL_OK) {ckfree((char*) searchPtr);goto checkForCatch;}TclNewObj(statePtr);
statePtr->typePtr = &dictIteratorType;
statePtr->internalRep.twoPtrValue.ptr1 = (void*) searchPtr;
statePtr->internalRep.twoPtrValue.ptr2 = (void*) dictPtr;
varPtr = (compiledLocals + opnd);if(varPtr->value.objPtr) {if(varPtr->value.objPtr->typePtr != &dictIteratorType) {TclDecrRefCount(varPtr->value.objPtr);}else{Tcl_Panic("mis-issued dictFirst!");}}
varPtr->value.objPtr = statePtr;Tcl_IncrRefCount(statePtr);goto pushDictIteratorResult;case INST_DICT_NEXT:
opnd =TclGetUInt4AtPtr(pc+1);TRACE(("%u => ", opnd));
statePtr = compiledLocals[opnd].value.objPtr;if(statePtr == NULL || statePtr->typePtr != &dictIteratorType) {Tcl_Panic("mis-issued dictNext!");}
searchPtr = (Tcl_DictSearch *) statePtr->internalRep.twoPtrValue.ptr1;Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
pushDictIteratorResult:if(done) {TclNewObj(emptyPtr);PUSH_OBJECT(emptyPtr);PUSH_OBJECT(emptyPtr);}else{PUSH_OBJECT(valuePtr);PUSH_OBJECT(keyPtr);}TRACE_APPEND(("\"%.30s\" \"%.30s\"%d",O2S(OBJ_UNDER_TOS),O2S(OBJ_AT_TOS), done));
objResultPtr = constants[done];/* TODO: consider opt like INST_FOREACH_STEP4 */NEXT_INST_F(5,0,1);case INST_DICT_DONE:
opnd =TclGetUInt4AtPtr(pc+1);TRACE(("%u => ", opnd));
statePtr = compiledLocals[opnd].value.objPtr;if(statePtr == NULL) {Tcl_Panic("mis-issued dictDone!");}if(statePtr->typePtr == &dictIteratorType) {/* * First kill the search, and then release the reference to the * dictionary that we were holding. */
searchPtr = (Tcl_DictSearch *)
statePtr->internalRep.twoPtrValue.ptr1;Tcl_DictObjDone(searchPtr);ckfree((char*) searchPtr);
dictPtr = (Tcl_Obj *) statePtr->internalRep.twoPtrValue.ptr2;TclDecrRefCount(dictPtr);/* * Set the internal variable to an empty object to signify that we * don't hold an iterator. */TclDecrRefCount(statePtr);TclNewObj(emptyPtr);
compiledLocals[opnd].value.objPtr = emptyPtr;Tcl_IncrRefCount(emptyPtr);}NEXT_INST_F(5,0,0);}{int opnd, opnd2, i, length, allocdict;
Tcl_Obj **keyPtrPtr, *dictPtr;
DictUpdateInfo *duiPtr;
Var *varPtr;case INST_DICT_UPDATE_START:
opnd =TclGetUInt4AtPtr(pc+1);
opnd2 =TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd]);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}TRACE(("%u => ", opnd));if(TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;}else{DECACHE_STACK_INFO();
dictPtr =TclPtrGetVar(interp, varPtr, NULL, NULL, NULL,
TCL_LEAVE_ERR_MSG, opnd);CACHE_STACK_INFO();if(dictPtr == NULL) {goto dictUpdateStartFailed;}}if(TclListObjGetElements(interp, OBJ_AT_TOS, &length,&keyPtrPtr) != TCL_OK) {goto dictUpdateStartFailed;}if(length != duiPtr->length) {Tcl_Panic("dictUpdateStart argument length mismatch");}for(i=0; i<length ; i++) {
Tcl_Obj *valPtr;if(Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],&valPtr) != TCL_OK) {goto dictUpdateStartFailed;}
varPtr = &(compiledLocals[duiPtr->varIndices[i]]);while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}DECACHE_STACK_INFO();if(valPtr == NULL) {TclObjUnsetVar2(interp,localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
NULL,0);}else if(TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
valPtr, TCL_LEAVE_ERR_MSG,
duiPtr->varIndices[i]) == NULL) {CACHE_STACK_INFO();
dictUpdateStartFailed:
result = TCL_ERROR;goto checkForCatch;}CACHE_STACK_INFO();}NEXT_INST_F(9,0,0);case INST_DICT_UPDATE_END:
opnd =TclGetUInt4AtPtr(pc+1);
opnd2 =TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd]);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;while(TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;}TRACE(("%u => ", opnd));if(TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;}else{DECACHE_STACK_INFO();
dictPtr =TclPtrGetVar(interp, varPtr, NULL, NULL, NULL,0, opnd);CACHE_STACK_INFO();}if(dictPtr == NULL) {NEXT_INST_F(9,1,0);}if(Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
||TclListObjGetElements(interp, OBJ_AT_TOS, &length,&keyPtrPtr) != TCL_OK) {
result = TCL_ERROR;goto checkForCatch;}
allocdict =Tcl_IsShared(dictPtr);if(allocdict) {
dictPtr =Tcl_DuplicateObj(dictPtr);}for(i=0; i<length ; i++) {
Tcl_Obj *valPtr;
Var *var2Ptr;
var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]);while(TclIsVarLink(var2Ptr)) {
var2Ptr = var2Ptr->value.linkPtr;}if(TclIsVarDirectReadable(var2Ptr)) {
valPtr = var2Ptr->value.objPtr;}else{DECACHE_STACK_INFO();
valPtr =TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL,0,
duiPtr->varIndices[i]);CACHE_STACK_INFO();}if(valPtr == NULL) {Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);}else if(dictPtr == valPtr) {Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i],Tcl_DuplicateObj(valPtr));}else{Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr);}}if(TclIsVarDirectWritable(varPtr)) {Tcl_IncrRefCount(dictPtr);TclDecrRefCount(varPtr->value.objPtr);
varPtr->value.objPtr = dictPtr;}else{DECACHE_STACK_INFO();
objResultPtr =TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd);CACHE_STACK_INFO();if(objResultPtr == NULL) {if(allocdict) {TclDecrRefCount(dictPtr);}
result = TCL_ERROR;goto checkForCatch;}}NEXT_INST_F(9,1,0);}default:Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);}/* end of switch on opCode *//* * Division by zero in an expression. Control only reaches this point by * "goto divideByZero". */
divideByZero:DECACHE_STACK_INFO();Tcl_SetObjResult(interp,Tcl_NewStringObj("divide by zero", -1));Tcl_SetErrorCode(interp,"ARITH","DIVZERO","divide by zero", NULL);CACHE_STACK_INFO();
result = TCL_ERROR;goto checkForCatch;/* * Exponentiation of zero by negative number in an expression. Control * only reaches this point by "goto exponOfZero". */
exponOfZero:DECACHE_STACK_INFO();Tcl_SetObjResult(interp,Tcl_NewStringObj("exponentiation of zero by negative power", -1));Tcl_SetErrorCode(interp,"ARITH","DOMAIN","exponentiation of zero by negative power", NULL);CACHE_STACK_INFO();
result = TCL_ERROR;goto checkForCatch;/* * Block for variables needed to process exception returns. */{
ExceptionRange *rangePtr;/* Points to closest loop or catch exception * range enclosing the pc. Used by various * instructions and processCatch to process * break, continue, and errors. */
Tcl_Obj *valuePtr;const char*bytes;int length;#if TCL_COMPILE_DEBUGint opnd;#endif/* * An external evaluation (INST_INVOKE or INST_EVAL) returned * something different from TCL_OK, or else INST_BREAK or * INST_CONTINUE were called. */
processExceptionReturn:#if TCL_COMPILE_DEBUGswitch(*pc) {case INST_INVOKE_STK1:
opnd =TclGetUInt1AtPtr(pc+1);TRACE(("%u => ... after\"%.20s\": ", opnd, cmdNameBuf));break;case INST_INVOKE_STK4:
opnd =TclGetUInt4AtPtr(pc+1);TRACE(("%u => ... after\"%.20s\": ", opnd, cmdNameBuf));break;case INST_EVAL_STK:/* * Note that the object at stacktop has to be used before doing * the cleanup. */TRACE(("\"%.30s\"=> ",O2S(OBJ_AT_TOS)));break;default:TRACE(("=> "));}#endifif((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
rangePtr =GetExceptRangeForPc(pc,/*catchOnly*/0, codePtr);if(rangePtr == NULL) {TRACE_APPEND(("no encl. loop or catch, returning %s\n",StringForResultCode(result)));goto abnormalReturn;}if(rangePtr->type == CATCH_EXCEPTION_RANGE) {TRACE_APPEND(("%s ...\n",StringForResultCode(result)));goto processCatch;}while(cleanup--) {
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);}if(result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);TRACE_APPEND(("%s, range at %d, new pc %d\n",StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));NEXT_INST_F(0,0,0);}else{if(rangePtr->continueOffset == -1) {TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",StringForResultCode(result)));goto checkForCatch;}
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->continueOffset);TRACE_APPEND(("%s, range at %d, new pc %d\n",StringForResultCode(result),
rangePtr->codeOffset, rangePtr->continueOffset));NEXT_INST_F(0,0,0);}#if TCL_COMPILE_DEBUG}else if(traceInstructions) {if((result != TCL_ERROR) && (result != TCL_RETURN)) {
Tcl_Obj *objPtr =Tcl_GetObjResult(interp);TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%s\"\n",
result,O2S(objPtr)));}else{
Tcl_Obj *objPtr =Tcl_GetObjResult(interp);TRACE_APPEND(("%s, result=\"%s\"\n",StringForResultCode(result),O2S(objPtr)));}#endif}/* * Execution has generated an "exception" such as TCL_ERROR. If the * exception is an error, record information about what was being * executed when the error occurred. Find the closest enclosing catch * range, if any. If no enclosing catch range is found, stop execution * and return the "exception" code. */
checkForCatch:if((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes =GetSrcInfoForPc(pc, codePtr, &length);if(bytes != NULL) {DECACHE_STACK_INFO();Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);CACHE_STACK_INFO();}}
iPtr->flags &= ~ERR_ALREADY_LOGGED;/* * Clear all expansions that may have started after the last * INST_BEGIN_CATCH. */while((expandNestList != NULL) && ((catchTop == initCatchTop) ||(*catchTop <=(ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;TclDecrRefCount(expandNestList);
expandNestList = objPtr;}/* * We must not catch an exceeded limit. Instead, it blows outwards * until we either hit another interpreter (presumably where the limit * is not exceeded) or we get to the top-level. */if(TclLimitExceeded(iPtr->limit)) {#ifdef TCL_COMPILE_DEBUGif(traceInstructions) {fprintf(stdout," ... limit exceeded, returning %s\n",StringForResultCode(result));}#endifgoto abnormalReturn;}if(catchTop == initCatchTop) {#ifdef TCL_COMPILE_DEBUGif(traceInstructions) {fprintf(stdout," ... no enclosing catch, returning %s\n",StringForResultCode(result));}#endifgoto abnormalReturn;}
rangePtr =GetExceptRangeForPc(pc,/*catchOnly*/1, codePtr);if(rangePtr == NULL) {/* * This is only possible when compiling a [catch] that sends its * script to INST_EVAL. Cannot correct the compiler without * breakingcompat with previous .tbc compiled scripts. */#ifdef TCL_COMPILE_DEBUGif(traceInstructions) {fprintf(stdout," ... no enclosing catch, returning %s\n",StringForResultCode(result));}#endifgoto abnormalReturn;}/* * A catch exception range (rangePtr) was found to handle an * "exception". It was found either by checkForCatch just above or by * an instruction during break, continue, or error processing. Jump to * its catchOffset after unwinding the operand stack to the depth it * had when starting to execute the range's catch command. */
processCatch:while(CURR_DEPTH > *catchTop) {
valuePtr =POP_OBJECT();TclDecrRefCount(valuePtr);}#ifdef TCL_COMPILE_DEBUGif(traceInstructions) {fprintf(stdout," ... found catch at %d, catchTop=%d, ""unwound to %ld, new pc %u\n",
rangePtr->codeOffset, (int) (catchTop - initCatchTop -1),(long) *catchTop, (unsigned) rangePtr->catchOffset);}#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);NEXT_INST_F(0,0,0);/* Restart the execution loop at pc. *//* * end of infinite loop dispatching on instructions. *//* * Abnormal return code. Restore the stack to state it had when * starting to execute the ByteCode. Panic if the stack is below the * initial level. */
abnormalReturn:TCL_DTRACE_INST_LAST();while(tosPtr > initTosPtr) {
Tcl_Obj *objPtr =POP_OBJECT();Tcl_DecrRefCount(objPtr);}/* * Clear all expansions. */while(expandNestList) {
Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;TclDecrRefCount(expandNestList);
expandNestList = objPtr;}if(tosPtr < initTosPtr) {fprintf(stderr,"\nTclExecuteByteCode: abnormal return at pc %u: ""stack top %d < entry stack top %d\n",(unsigned)(pc - codePtr->codeStart),(unsigned) CURR_DEPTH, (unsigned)0);Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top");}}/* * Restore the stack to the state it had previous to this bytecode. */TclStackFree(interp, initCatchTop+1);return result;#undef iPtr}#ifdef TCL_COMPILE_DEBUG/* *---------------------------------------------------------------------- * * PrintByteCodeInfo -- * * This procedure prints a summary about a bytecode object to stdout. It * is called by TclExecuteByteCode when starting to execute the bytecode * object if tclTraceExec has the value 2 or more. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */static voidPrintByteCodeInfo(register ByteCode *codePtr)/* The bytecode whose summary is printed to * stdout. */{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;fprintf(stdout,"\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);fprintf(stdout," Source: ");TclPrintSource(stdout, codePtr->source,60);fprintf(stdout,"\nCmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,#ifdef TCL_COMPILE_STATS
codePtr->numSrcBytes?
((float)codePtr->structureSize)/codePtr->numSrcBytes :#endif0.0);#ifdef TCL_COMPILE_STATSfprintf(stdout," Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",(unsigned long) codePtr->structureSize,(unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)),
codePtr->numCodeBytes,(unsigned long) (codePtr->numLitObjects *sizeof(Tcl_Obj *)),(unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),(unsigned long) (codePtr->numAuxDataItems *sizeof(AuxData)),
codePtr->numCmdLocBytes);#endif/* TCL_COMPILE_STATS */if(procPtr != NULL) {fprintf(stdout," Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
procPtr, procPtr->refCount, procPtr->numArgs,
procPtr->numCompiledLocals);}}#endif/* TCL_COMPILE_DEBUG *//* *---------------------------------------------------------------------- * * ValidatePcAndStackTop -- * * This procedure is called by TclExecuteByteCode when debugging to * verify that the program counter and stack top are valid during * execution. * * Results: * None. * * Side effects: * Prints a message to stderr and panics if either the pc or stack top * are invalid. * *---------------------------------------------------------------------- */#ifdef TCL_COMPILE_DEBUGstatic voidValidatePcAndStackTop(register ByteCode *codePtr,/* The bytecode whose summary is printed to * stdout. */unsigned char*pc,/* Points to first byte of a bytecode * instruction. The program counter. */int stackTop,/* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */int stackLowerBound,/* Smallest legal value for stackTop. */int checkStack)/* 0 if the stack depth check should be * skipped. */{int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;/* Greatest legal value for stackTop. */unsigned relativePc = (unsigned) (pc - codePtr->codeStart);unsigned long codeStart = (unsigned long) codePtr->codeStart;unsigned long codeEnd = (unsigned long)(codePtr->codeStart + codePtr->numCodeBytes);unsigned char opCode = *pc;if(((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) {fprintf(stderr,"\nBad instruction pc 0x%p in TclExecuteByteCode\n",
pc);Tcl_Panic("TclExecuteByteCode execution failure: bad pc");}if((unsigned) opCode > LAST_INST_OPCODE) {fprintf(stderr,"\nBad opcode %d at pc %u in TclExecuteByteCode\n",(unsigned) opCode, relativePc);Tcl_Panic("TclExecuteByteCode execution failure: bad opcode");}if(checkStack &&((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {int numChars;const char*cmd =GetSrcInfoForPc(pc, codePtr, &numChars);fprintf(stderr,"\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
stackTop, relativePc, stackLowerBound, stackUpperBound);if(cmd != NULL) {
Tcl_Obj *message;TclNewLiteralStringObj(message,"\nexecuting ");Tcl_IncrRefCount(message);Tcl_AppendLimitedToObj(message, cmd, numChars,100, NULL);fprintf(stderr,"%s\n",Tcl_GetString(message));Tcl_DecrRefCount(message);}else{fprintf(stderr,"\n");}Tcl_Panic("TclExecuteByteCode execution failure: bad stack top");}}#endif/* TCL_COMPILE_DEBUG *//* *---------------------------------------------------------------------- * * IllegalExprOperandType -- * * Used by TclExecuteByteCode to append an error message to the interp * result when an illegal operand type is detected by an expression * instruction. The argument opndPtr holds the operand object in error. * * Results: * None. * * Side effects: * An error message is appended to the interp result. * *---------------------------------------------------------------------- */static voidIllegalExprOperandType(
Tcl_Interp *interp,/* Interpreter to which error information * pertains. */unsigned char*pc,/* Points to the instruction being executed * when the illegal type was found. */
Tcl_Obj *opndPtr)/* Points to the operand holding the value * with the illegal type. */{
ClientData ptr;int type;unsigned char opcode = *pc;const char*description, *operator= operatorStrings[opcode - INST_LOR];if(opcode == INST_EXPON) {operator="**";}if(GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {int numBytes;const char*bytes =Tcl_GetStringFromObj(opndPtr, &numBytes);if(numBytes ==0) {
description ="empty string";}else if(TclCheckBadOctal(NULL, bytes)) {
description ="invalid octal number";}else{
description ="non-numeric string";}}else if(type == TCL_NUMBER_NAN) {
description ="non-numeric floating-point value";}else if(type == TCL_NUMBER_DOUBLE) {
description ="floating-point value";}else{/* TODO: No caller needs this. Eliminate? */
description ="(big) integer";}Tcl_SetObjResult(interp,Tcl_ObjPrintf("can't use %s as operand of\"%s\"", description,operator));Tcl_SetErrorCode(interp,"ARITH","DOMAIN", description, NULL);}/* *---------------------------------------------------------------------- * * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about * that command's source: a pointer to its first byte and the number of * characters. * * Results: * If a command is found that encloses the program counter value, a * pointer to the command's source is returned and the length of the * source is stored at *lengthPtr. If multiple commands resulted in code * at pc, information about the closest enclosing command is returned. If * no matching command is found, NULL is returned and *lengthPtr is * unchanged. * * Side effects: * The CmdFrame at *cfPtr is updated. * *---------------------------------------------------------------------- */const char*TclGetSrcInfoForCmd(
Interp *iPtr,int*lenPtr){
CmdFrame *cfPtr = iPtr->cmdFramePtr;
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;returnGetSrcInfoForPc((unsigned char*) cfPtr->data.tebc.pc,
codePtr, lenPtr);}voidTclGetSrcInfoForPc(
CmdFrame *cfPtr){
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;if(cfPtr->cmd.str.cmd == NULL) {
cfPtr->cmd.str.cmd =GetSrcInfoForPc((unsigned char*) cfPtr->data.tebc.pc, codePtr,&cfPtr->cmd.str.len);}if(cfPtr->cmd.str.cmd != NULL) {/* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. */
ExtCmdLoc *eclPtr;
ECL *locPtr = NULL;int srcOffset, i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =Tcl_FindHashEntry(iPtr->lineBCPtr, (char*) codePtr);if(!hePtr) {return;}
srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);for(i=0; i < eclPtr->nuloc; i++) {if(eclPtr->loc[i].srcOffset == srcOffset) {
locPtr = eclPtr->loc+i;break;}}if(locPtr == NULL) {Tcl_Panic("LocSearch failure");}
cfPtr->line = locPtr->line;
cfPtr->nline = locPtr->nline;
cfPtr->type = eclPtr->type;if(eclPtr->type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = eclPtr->path;Tcl_IncrRefCount(cfPtr->data.eval.path);}/* * Do not set cfPtr->data.eval.path NULL for non-SOURCE. Needed for * cfPtr->data.tebc.codePtr. */}}static const char*GetSrcInfoForPc(unsigned char*pc,/* The program counter value for which to * return the closest command's source info. * This points to a bytecode instruction in * codePtr's code. */
ByteCode *codePtr,/* The bytecode sequence in which to look up * the command source for the pc. */int*lengthPtr)/* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */{registerint pcOffset = (pc - codePtr->codeStart);int numCmds = codePtr->numCommands;unsigned char*codeDeltaNext, *codeLengthNext;unsigned char*srcDeltaNext, *srcLengthNext;int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;int bestDist = INT_MAX;/* Distance of pc to best cmd's start pc. */int bestSrcOffset = -1;/* Initialized to avoid compiler warning. */int bestSrcLength = -1;/* Initialized to avoid compiler warning. */if((pcOffset <0) || (pcOffset >= codePtr->numCodeBytes)) {return NULL;}/* * Decode the code and source offset and length for each command. The * closest enclosing command is the last one whose code started before * pcOffset. */
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset =0;for(i =0; i < numCmds; i++) {if((unsigned) *codeDeltaNext == (unsigned)0xFF) {
codeDeltaNext++;
delta =TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext +=4;}else{
delta =TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;}
codeOffset += delta;if((unsigned) *codeLengthNext == (unsigned)0xFF) {
codeLengthNext++;
codeLen =TclGetInt4AtPtr(codeLengthNext);
codeLengthNext +=4;}else{
codeLen =TclGetInt1AtPtr(codeLengthNext);
codeLengthNext++;}
codeEnd = (codeOffset + codeLen -1);if((unsigned) *srcDeltaNext == (unsigned)0xFF) {
srcDeltaNext++;
delta =TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext +=4;}else{
delta =TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;}
srcOffset += delta;if((unsigned) *srcLengthNext == (unsigned)0xFF) {
srcLengthNext++;
srcLen =TclGetInt4AtPtr(srcLengthNext);
srcLengthNext +=4;}else{
srcLen =TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;}if(codeOffset > pcOffset) {/* Best cmd already found */break;}if(pcOffset <= codeEnd) {/* This cmd's code encloses pc */int dist = (pcOffset - codeOffset);if(dist <= bestDist) {
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;}}}if(bestDist == INT_MAX) {return NULL;}if(lengthPtr != NULL) {*lengthPtr = bestSrcLength;}return(codePtr->source + bestSrcOffset);}/* *---------------------------------------------------------------------- * * GetExceptRangeForPc -- * * Given a program counter value, return the closest enclosing * ExceptionRange. * * Results: * In the normal case, catchOnly is 0 (false) and this procedure returns * a pointer to the most closely enclosing ExceptionRange structure * regardless of whether it is a loop or catch exception range. This is * appropriate when processing a TCL_BREAK or TCL_CONTINUE, which will be * "handled" either by a loop exception range or a closer catch range. If * catchOnly is nonzero, this procedure ignores loop exception ranges and * returns a pointer to the closest catch range. If no matching * ExceptionRange is found that encloses pc, a NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */static ExceptionRange *GetExceptRangeForPc(unsigned char*pc,/* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */int catchOnly,/* If 0, consider either loop or catch * ExceptionRanges in search. If nonzero * consider only catch ranges (and ignore any * closer loop ranges). */
ByteCode *codePtr)/* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */{
ExceptionRange *rangeArrayPtr;int numRanges = codePtr->numExceptRanges;register ExceptionRange *rangePtr;int pcOffset = pc - codePtr->codeStart;registerint start;if(numRanges ==0) {return NULL;}/* * This exploits peculiarities of our compiler: nested ranges are always * *after* their containing ranges, so that by scanning backwards we are * sure that the first matching range is indeed the deepest. */
rangeArrayPtr = codePtr->exceptArrayPtr;
rangePtr = rangeArrayPtr + numRanges;while(--rangePtr >= rangeArrayPtr) {
start = rangePtr->codeOffset;if((start <= pcOffset) &&(pcOffset < (start + rangePtr->numCodeBytes))) {if((!catchOnly)|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {return rangePtr;}}}return NULL;}/* *---------------------------------------------------------------------- * * GetOpcodeName -- * * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used * in TclExecuteByteCode when debugging. It returns the name of the * bytecode instruction at a specified instruction pc. * * Results: * A character string for the instruction. * * Side effects: * None. * *---------------------------------------------------------------------- */#ifdef TCL_COMPILE_DEBUGstatic char*GetOpcodeName(unsigned char*pc)/* Points to the instruction whose name should * be returned. */{unsigned char opCode = *pc;return tclInstructionTable[opCode].name;}#endif/* TCL_COMPILE_DEBUG *//* *---------------------------------------------------------------------- * * TclExprFloatError -- * * This procedure is called when an error occurs during a floating-point * operation. It reads errno and sets interp->objResultPtr accordingly. * * Results: * interp->objResultPtr is set to hold an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */voidTclExprFloatError(
Tcl_Interp *interp,/* Where to store error message. */double value)/* Value returned after error; used to * distinguish underflows from overflows. */{const char*s;if((errno == EDOM) ||TclIsNaN(value)) {
s ="domain error: argument not in valid range";Tcl_SetObjResult(interp,Tcl_NewStringObj(s, -1));Tcl_SetErrorCode(interp,"ARITH","DOMAIN", s, NULL);}else if((errno == ERANGE) ||TclIsInfinite(value)) {if(value ==0.0) {
s ="floating-point value too small to represent";Tcl_SetObjResult(interp,Tcl_NewStringObj(s, -1));Tcl_SetErrorCode(interp,"ARITH","UNDERFLOW", s, NULL);}else{
s ="floating-point value too large to represent";Tcl_SetObjResult(interp,Tcl_NewStringObj(s, -1));Tcl_SetErrorCode(interp,"ARITH","OVERFLOW", s, NULL);}}else{
Tcl_Obj *objPtr =Tcl_ObjPrintf("unknown floating-point error, errno = %d", errno);Tcl_SetErrorCode(interp,"ARITH","UNKNOWN",Tcl_GetString(objPtr), NULL);Tcl_SetObjResult(interp, objPtr);}}#ifdef TCL_COMPILE_STATS/* *---------------------------------------------------------------------- * * TclLog2 -- * * Procedure used while collecting compilation statistics to determine * the log base 2 of an integer. * * Results: * Returns the log base 2 of the operand. If the argument is less than or * equal to zero, a zero is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */intTclLog2(registerint value)/* The integer for which to compute the log * base 2. */{registerint n = value;registerint result =0;while(n >1) {
n = n >>1;
result++;}return result;}/* *---------------------------------------------------------------------- * * EvalStatsCmd -- * * Implements the "evalstats" command that prints instruction execution * counts to stdout. * * Results: * Standard Tcl results. * * Side effects: * None. * *---------------------------------------------------------------------- */static intEvalStatsCmd(
ClientData unused,/* Unused. */
Tcl_Interp *interp,/* The current interpreter. */int objc,/* The number of arguments. */
Tcl_Obj *const objv[])/* The argument strings. */{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &iPtr->literalTable;
ByteCodeStats *statsPtr = &iPtr->stats;double totalCodeBytes, currentCodeBytes;double totalLiteralBytes, currentLiteralBytes;double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;double strBytesSharedMultX, strBytesSharedOnce;double numInstructions, currentHeaderBytes;long numCurrentByteCodes, numByteCodeLits;long refCountSum, literalMgmtBytes, sum;int numSharedMultX, numSharedOnce;int decadeHigh, minSizeDecade, maxSizeDecade, length, i;char*litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;#define Percent(a,b) ((a) * 100.0 / (b))
objPtr =Tcl_NewObj();Tcl_IncrRefCount(objPtr);
numInstructions =0.0;for(i =0; i <256; i++) {if(statsPtr->instructionCount[i] !=0) {
numInstructions += statsPtr->instructionCount[i];}}
totalLiteralBytes =sizeof(LiteralTable)+ iPtr->literalTable.numBuckets *sizeof(LiteralEntry *)+ (statsPtr->numLiteralsCreated *sizeof(LiteralEntry))+ (statsPtr->numLiteralsCreated *sizeof(Tcl_Obj))+ statsPtr->totalLitStringBytes;
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
* (sizeof(ByteCode) -sizeof(size_t) -sizeof(Tcl_Time));
literalMgmtBytes =sizeof(LiteralTable)+ (iPtr->literalTable.numBuckets *sizeof(LiteralEntry *))+ (iPtr->literalTable.numEntries *sizeof(LiteralEntry));
currentLiteralBytes = literalMgmtBytes
+ iPtr->literalTable.numEntries *sizeof(Tcl_Obj)+ statsPtr->currentLitStringBytes;
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;/* * Summary statistics, total and current source and ByteCode sizes. */Tcl_AppendPrintfToObj(objPtr,"\n----------------------------------------------------------------\n");Tcl_AppendPrintfToObj(objPtr,"Compilation and execution statistics for interpreter %#lx\n",
iPtr);Tcl_AppendPrintfToObj(objPtr,"\nNumber ByteCodes executed %ld\n",
statsPtr->numExecutions);Tcl_AppendPrintfToObj(objPtr,"Number ByteCodes compiled %ld\n",
statsPtr->numCompilations);Tcl_AppendPrintfToObj(objPtr," Mean executions/compile %.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);Tcl_AppendPrintfToObj(objPtr,"\nInstructions executed %.0f\n",
numInstructions);Tcl_AppendPrintfToObj(objPtr," Mean inst/compile %.0f\n",
numInstructions / statsPtr->numCompilations);Tcl_AppendPrintfToObj(objPtr," Mean inst/execution %.0f\n",
numInstructions / statsPtr->numExecutions);Tcl_AppendPrintfToObj(objPtr,"\nTotal ByteCodes %ld\n",
statsPtr->numCompilations);Tcl_AppendPrintfToObj(objPtr," Source bytes %.6g\n",
statsPtr->totalSrcBytes);Tcl_AppendPrintfToObj(objPtr," Code bytes %.6g\n",
totalCodeBytes);Tcl_AppendPrintfToObj(objPtr," ByteCode bytes %.6g\n",
statsPtr->totalByteCodeBytes);Tcl_AppendPrintfToObj(objPtr," Literal bytes %.6g\n",
totalLiteralBytes);Tcl_AppendPrintfToObj(objPtr," table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",(unsigned long)sizeof(LiteralTable),(unsigned long) (iPtr->literalTable.numBuckets *sizeof(LiteralEntry *)),(unsigned long) (statsPtr->numLiteralsCreated *sizeof(LiteralEntry)),(unsigned long) (statsPtr->numLiteralsCreated *sizeof(Tcl_Obj)),
statsPtr->totalLitStringBytes);Tcl_AppendPrintfToObj(objPtr," Mean code/compile %.1f\n",
totalCodeBytes / statsPtr->numCompilations);Tcl_AppendPrintfToObj(objPtr," Mean code/source %.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);Tcl_AppendPrintfToObj(objPtr,"\nCurrent (active) ByteCodes %ld\n",
numCurrentByteCodes);Tcl_AppendPrintfToObj(objPtr," Source bytes %.6g\n",
statsPtr->currentSrcBytes);Tcl_AppendPrintfToObj(objPtr," Code bytes %.6g\n",
currentCodeBytes);Tcl_AppendPrintfToObj(objPtr," ByteCode bytes %.6g\n",
statsPtr->currentByteCodeBytes);Tcl_AppendPrintfToObj(objPtr," Literal bytes %.6g\n",
currentLiteralBytes);Tcl_AppendPrintfToObj(objPtr," table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",(unsigned long)sizeof(LiteralTable),(unsigned long) (iPtr->literalTable.numBuckets *sizeof(LiteralEntry *)),(unsigned long) (iPtr->literalTable.numEntries *sizeof(LiteralEntry)),(unsigned long) (iPtr->literalTable.numEntries *sizeof(Tcl_Obj)),
statsPtr->currentLitStringBytes);Tcl_AppendPrintfToObj(objPtr," Mean code/source %.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);Tcl_AppendPrintfToObj(objPtr," Code + source bytes %.6g (%0.1f mean code/src)\n",(currentCodeBytes + statsPtr->currentSrcBytes),(currentCodeBytes / statsPtr->currentSrcBytes) +1.0);/* * Tcl_IsShared statistics check * * This gives the refcount of each obj as Tcl_IsShared was called for it. * Shared objects must be duplicated before they can be modified. */
numSharedMultX =0;Tcl_AppendPrintfToObj(objPtr,"\nTcl_IsShared object check (all objects):\n");Tcl_AppendPrintfToObj(objPtr," Object had refcount <=1 (not shared) %ld\n",
tclObjsShared[1]);for(i =2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {Tcl_AppendPrintfToObj(objPtr," refcount ==%d %ld\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];}Tcl_AppendPrintfToObj(objPtr," refcount >=%d %ld\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];Tcl_AppendPrintfToObj(objPtr," Total shared objects %d\n",
numSharedMultX);/* * Literal table statistics. */
numByteCodeLits =0;
refCountSum =0;
numSharedMultX =0;
numSharedOnce =0;
objBytesIfUnshared =0.0;
strBytesIfUnshared =0.0;
strBytesSharedMultX =0.0;
strBytesSharedOnce =0.0;for(i =0; i < globalTablePtr->numBuckets; i++) {for(entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {if(entryPtr->objPtr->typePtr == &tclByteCodeType) {
numByteCodeLits++;}(void)Tcl_GetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount *sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));if(entryPtr->refCount >1) {
numSharedMultX++;
strBytesSharedMultX += (length+1);}else{
numSharedOnce++;
strBytesSharedOnce += (length+1);}}}
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)- currentLiteralBytes;Tcl_AppendPrintfToObj(objPtr,"\nTotal objects (all interps) %ld\n",
tclObjsAlloced);Tcl_AppendPrintfToObj(objPtr,"Current objects %ld\n",(tclObjsAlloced - tclObjsFreed));Tcl_AppendPrintfToObj(objPtr,"Total literal objects %ld\n",
statsPtr->numLiteralsCreated);Tcl_AppendPrintfToObj(objPtr,"\nCurrent literal objects %d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));Tcl_AppendPrintfToObj(objPtr," ByteCode literals %ld (%0.1f%% of current literals)\n",
numByteCodeLits,Percent(numByteCodeLits, globalTablePtr->numEntries));Tcl_AppendPrintfToObj(objPtr," Literals reused > 1x %d\n",
numSharedMultX);Tcl_AppendPrintfToObj(objPtr," Mean reference count %.2f\n",((double) refCountSum) / globalTablePtr->numEntries);Tcl_AppendPrintfToObj(objPtr," Mean len, str reused >1x %.2f\n",(numSharedMultX ? strBytesSharedMultX/numSharedMultX :0.0));Tcl_AppendPrintfToObj(objPtr," Mean len, str used 1x %.2f\n",(numSharedOnce ? strBytesSharedOnce/numSharedOnce :0.0));Tcl_AppendPrintfToObj(objPtr," Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
sharingBytesSaved,Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared));Tcl_AppendPrintfToObj(objPtr," Bytes with sharing %.6g\n",
currentLiteralBytes);Tcl_AppendPrintfToObj(objPtr," table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",(unsigned long)sizeof(LiteralTable),(unsigned long) (iPtr->literalTable.numBuckets *sizeof(LiteralEntry *)),(unsigned long) (iPtr->literalTable.numEntries *sizeof(LiteralEntry)),(unsigned long) (iPtr->literalTable.numEntries *sizeof(Tcl_Obj)),
statsPtr->currentLitStringBytes);Tcl_AppendPrintfToObj(objPtr," Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);Tcl_AppendPrintfToObj(objPtr," String sharing savings %.6g = unshared %.6g - shared %.6g\n",(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);Tcl_AppendPrintfToObj(objPtr," Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
literalMgmtBytes,Percent(literalMgmtBytes, currentLiteralBytes));Tcl_AppendPrintfToObj(objPtr," table %lu + buckets %lu + entries %lu\n",(unsigned long)sizeof(LiteralTable),(unsigned long) (iPtr->literalTable.numBuckets *sizeof(LiteralEntry *)),(unsigned long) (iPtr->literalTable.numEntries *sizeof(LiteralEntry)));/* * Breakdown of current ByteCode space requirements. */Tcl_AppendPrintfToObj(objPtr,"\nBreakdown of current ByteCode requirements:\n");Tcl_AppendPrintfToObj(objPtr," Bytes Pct of Avg per\n");Tcl_AppendPrintfToObj(objPtr," total ByteCode\n");Tcl_AppendPrintfToObj(objPtr,"Total %12.6g 100.00%% %8.1f\n",
statsPtr->currentByteCodeBytes,
statsPtr->currentByteCodeBytes / numCurrentByteCodes);Tcl_AppendPrintfToObj(objPtr,"Header %12.6g %8.1f%% %8.1f\n",
currentHeaderBytes,Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes),
currentHeaderBytes / numCurrentByteCodes);Tcl_AppendPrintfToObj(objPtr,"Instructions %12.6g %8.1f%% %8.1f\n",
statsPtr->currentInstBytes,Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes),
statsPtr->currentInstBytes / numCurrentByteCodes);Tcl_AppendPrintfToObj(objPtr,"Literal ptr array %12.6g %8.1f%% %8.1f\n",
statsPtr->currentLitBytes,Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes),
statsPtr->currentLitBytes / numCurrentByteCodes);Tcl_AppendPrintfToObj(objPtr,"Exception table %12.6g %8.1f%% %8.1f\n",
statsPtr->currentExceptBytes,Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes),
statsPtr->currentExceptBytes / numCurrentByteCodes);Tcl_AppendPrintfToObj(objPtr,"Auxiliary data %12.6g %8.1f%% %8.1f\n",
statsPtr->currentAuxBytes,Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes),
statsPtr->currentAuxBytes / numCurrentByteCodes);Tcl_AppendPrintfToObj(objPtr,"Command map %12.6g %8.1f%% %8.1f\n",
statsPtr->currentCmdMapBytes,Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes),
statsPtr->currentCmdMapBytes / numCurrentByteCodes);/* * Detailed literal statistics. */Tcl_AppendPrintfToObj(objPtr,"\nLiteral string sizes:\n");Tcl_AppendPrintfToObj(objPtr," Up to length Percentage\n");
maxSizeDecade =0;for(i =31; i >=0; i--) {if(statsPtr->literalCount[i] >0) {
maxSizeDecade = i;break;}}
sum =0;for(i =0; i <= maxSizeDecade; i++) {
decadeHigh = (1<< (i+1)) -1;
sum += statsPtr->literalCount[i];Tcl_AppendPrintfToObj(objPtr," %10d %8.0f%%\n",
decadeHigh,Percent(sum, statsPtr->numLiteralsCreated));}
litTableStats =TclLiteralStats(globalTablePtr);Tcl_AppendPrintfToObj(objPtr,"\nCurrent literal table statistics:\n%s\n",
litTableStats);ckfree((char*) litTableStats);/* * Source and ByteCode size distributions. */Tcl_AppendPrintfToObj(objPtr,"\nSource sizes:\n");Tcl_AppendPrintfToObj(objPtr," Up to size Percentage\n");
minSizeDecade = maxSizeDecade =0;for(i =0; i <31; i++) {if(statsPtr->srcCount[i] >0) {
minSizeDecade = i;break;}}for(i =31; i >=0; i--) {if(statsPtr->srcCount[i] >0) {
maxSizeDecade = i;break;}}
sum =0;for(i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1<< (i+1)) -1;
sum += statsPtr->srcCount[i];Tcl_AppendPrintfToObj(objPtr," %10d %8.0f%%\n",
decadeHigh,Percent(sum, statsPtr->numCompilations));}Tcl_AppendPrintfToObj(objPtr,"\nByteCode sizes:\n");Tcl_AppendPrintfToObj(objPtr," Up to size Percentage\n");
minSizeDecade = maxSizeDecade =0;for(i =0; i <31; i++) {if(statsPtr->byteCodeCount[i] >0) {
minSizeDecade = i;break;}}for(i =31; i >=0; i--) {if(statsPtr->byteCodeCount[i] >0) {
maxSizeDecade = i;break;}}
sum =0;for(i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1<< (i+1)) -1;
sum += statsPtr->byteCodeCount[i];Tcl_AppendPrintfToObj(objPtr," %10d %8.0f%%\n",
decadeHigh,Percent(sum, statsPtr->numCompilations));}Tcl_AppendPrintfToObj(objPtr,"\nByteCode longevity (excludes Current ByteCodes):\n");Tcl_AppendPrintfToObj(objPtr," Up to ms Percentage\n");
minSizeDecade = maxSizeDecade =0;for(i =0; i <31; i++) {if(statsPtr->lifetimeCount[i] >0) {
minSizeDecade = i;break;}}for(i =31; i >=0; i--) {if(statsPtr->lifetimeCount[i] >0) {
maxSizeDecade = i;break;}}
sum =0;for(i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1<< (i+1)) -1;
sum += statsPtr->lifetimeCount[i];Tcl_AppendPrintfToObj(objPtr," %12.3f %8.0f%%\n",
decadeHigh/1000.0,Percent(sum, statsPtr->numByteCodesFreed));}/* * Instruction counts. */Tcl_AppendPrintfToObj(objPtr,"\nInstruction counts:\n");for(i =0; i <= LAST_INST_OPCODE; i++) {Tcl_AppendPrintfToObj(objPtr,"%20s %8ld ",
tclInstructionTable[i].name, statsPtr->instructionCount[i]);if(statsPtr->instructionCount[i]) {Tcl_AppendPrintfToObj(objPtr,"%6.1f%%\n",Percent(statsPtr->instructionCount[i], numInstructions));}else{Tcl_AppendPrintfToObj(objPtr,"0\n");}}#ifdef TCL_MEM_DEBUGTcl_AppendPrintfToObj(objPtr,"\nHeap Statistics:\n");TclDumpMemoryInfo((ClientData) objPtr,1);#endifTcl_AppendPrintfToObj(objPtr,"\n----------------------------------------------------------------\n");if(objc ==1) {Tcl_SetObjResult(interp, objPtr);}else{
Tcl_Channel outChan;char*str =Tcl_GetStringFromObj(objv[1], &length);if(length) {if(strcmp(str,"stdout") ==0) {
outChan =Tcl_GetStdChannel(TCL_STDOUT);}else if(strcmp(str,"stderr") ==0) {
outChan =Tcl_GetStdChannel(TCL_STDERR);}else{
outChan =Tcl_OpenFileChannel(NULL, str,"w",0664);}}else{
outChan =Tcl_GetStdChannel(TCL_STDOUT);}if(outChan != NULL) {Tcl_WriteObj(outChan, objPtr);}}Tcl_DecrRefCount(objPtr);return TCL_OK;}#endif/* TCL_COMPILE_STATS */#ifdef TCL_COMPILE_DEBUG/* *---------------------------------------------------------------------- * * StringForResultCode -- * * Procedure that returns a human-readable string representing a Tcl * result code such as TCL_ERROR. * * Results: * If the result code is one of the standard Tcl return codes, the result * is a string representing that code such as "TCL_ERROR". Otherwise, the * result string is that code formatted as a sequence of decimal digit * characters. Note that the resulting string must not be modified by the * caller. * * Side effects: * None. * *---------------------------------------------------------------------- */static const char*StringForResultCode(int result)/* The Tcl result code for which to generate a * string. */{static char buf[TCL_INTEGER_SPACE];if((result >= TCL_OK) && (result <= TCL_CONTINUE)) {return resultStrings[result];}TclFormatInt(buf, result);return buf;}#endif/* TCL_COMPILE_DEBUG *//* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */
