/[dtapublic]/projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclresult.c

Diff of /projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclresult.c

Parent Directory | Revision Log | View Patch Patch

-revision 66 by dashley,
Sun Oct 30 21:57:38 2016 UTC
+revision 71 by dashley,
Sat Nov  5 11:07:06 2016 UTC
 Line 1
  /* $Header$ */
  /*
   * tclResult.c --
   *
   *      This file contains code to manage the interpreter result.
   *
   * Copyright (c) 1997 by Sun Microsystems, Inc.
   *
   * See the file "license.terms" for information on usage and redistribution
   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   *
   * RCS: @(#) $Id: tclresult.c,v 1.1.1.1 2001/06/13 04:45:53 dtashley Exp $
   */
  #include "tclInt.h"
  /*
   * Function prototypes for local procedures in this file:
   */
  static void             ResetObjResult _ANSI_ARGS_((Interp *iPtr));
  static void             SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
                              int newSpace));
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_SaveResult --
   *
   *      Takes a snapshot of the current result state of the interpreter.
   *      The snapshot can be restored at any point by
   *      Tcl_RestoreResult. Note that this routine does not
   *      preserve the errorCode, errorInfo, or flags fields so it
   *      should not be used if an error is in progress.
   *
   *      Once a snapshot is saved, it must be restored by calling
   *      Tcl_RestoreResult, or discarded by calling
   *      Tcl_DiscardResult.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      Resets the interpreter result.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_SaveResult(interp, statePtr)
      Tcl_Interp *interp;         /* Interpreter to save. */
      Tcl_SavedResult *statePtr;  /* Pointer to state structure. */
  {
      Interp *iPtr = (Interp *) interp;
      /*
       * Move the result object into the save state.  Note that we don't need
       * to change its refcount because we're moving it, not adding a new
       * reference.  Put an empty object into the interpreter.
       */
      statePtr->objResultPtr = iPtr->objResultPtr;
      iPtr->objResultPtr = Tcl_NewObj();
      Tcl_IncrRefCount(iPtr->objResultPtr);
      /*
       * Save the string result.
       */
      statePtr->freeProc = iPtr->freeProc;
      if (iPtr->result == iPtr->resultSpace) {
          /*
           * Copy the static string data out of the interp buffer.
           */
          statePtr->result = statePtr->resultSpace;
          strcpy(statePtr->result, iPtr->result);
          statePtr->appendResult = NULL;
      } else if (iPtr->result == iPtr->appendResult) {
          /*
           * Move the append buffer out of the interp.
           */
          statePtr->appendResult = iPtr->appendResult;
          statePtr->appendAvl = iPtr->appendAvl;
          statePtr->appendUsed = iPtr->appendUsed;
          statePtr->result = statePtr->appendResult;
          iPtr->appendResult = NULL;
          iPtr->appendAvl = 0;
          iPtr->appendUsed = 0;
      } else {
          /*
           * Move the dynamic or static string out of the interpreter.
           */
          statePtr->result = iPtr->result;
          statePtr->appendResult = NULL;
      }
      iPtr->result = iPtr->resultSpace;
      iPtr->resultSpace[0] = 0;
      iPtr->freeProc = 0;
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_RestoreResult --
   *
   *      Restores the state of the interpreter to a snapshot taken
   *      by Tcl_SaveResult.  After this call, the token for
   *      the interpreter state is no longer valid.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      Restores the interpreter result.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_RestoreResult(interp, statePtr)
      Tcl_Interp* interp;         /* Interpreter being restored. */
      Tcl_SavedResult *statePtr;  /* State returned by Tcl_SaveResult. */
  {
      Interp *iPtr = (Interp *) interp;
      Tcl_ResetResult(interp);
      /*
       * Restore the string result.
       */
      iPtr->freeProc = statePtr->freeProc;
      if (statePtr->result == statePtr->resultSpace) {
          /*
           * Copy the static string data into the interp buffer.
           */
          iPtr->result = iPtr->resultSpace;
          strcpy(iPtr->result, statePtr->result);
      } else if (statePtr->result == statePtr->appendResult) {
          /*
           * Move the append buffer back into the interp.
           */
          if (iPtr->appendResult != NULL) {
              ckfree((char *)iPtr->appendResult);
          }
          iPtr->appendResult = statePtr->appendResult;
          iPtr->appendAvl = statePtr->appendAvl;
          iPtr->appendUsed = statePtr->appendUsed;
          iPtr->result = iPtr->appendResult;
      } else {
          /*
           * Move the dynamic or static string back into the interpreter.
           */
          iPtr->result = statePtr->result;
      }
      /*
       * Restore the object result.
       */
      Tcl_DecrRefCount(iPtr->objResultPtr);
      iPtr->objResultPtr = statePtr->objResultPtr;
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_DiscardResult --
   *
   *      Frees the memory associated with an interpreter snapshot
   *      taken by Tcl_SaveResult.  If the snapshot is not
   *      restored, this procedure must be called to discard it,
   *      or the memory will be lost.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      None.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_DiscardResult(statePtr)
      Tcl_SavedResult *statePtr;  /* State returned by Tcl_SaveResult. */
  {
      TclDecrRefCount(statePtr->objResultPtr);
      if (statePtr->result == statePtr->appendResult) {
          ckfree(statePtr->appendResult);
      } else if (statePtr->freeProc) {
          if ((statePtr->freeProc == TCL_DYNAMIC)
                  || (statePtr->freeProc == (Tcl_FreeProc *) free)) {
              ckfree(statePtr->result);
          } else {
              (*statePtr->freeProc)(statePtr->result);
          }
      }
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_SetResult --
   *
   *      Arrange for "string" to be the Tcl return value.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      interp->result is left pointing either to "string" (if "copy" is 0)
   *      or to a copy of string. Also, the object result is reset.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_SetResult(interp, string, freeProc)
      Tcl_Interp *interp;         /* Interpreter with which to associate the
                                   * return value. */
      register char *string;      /* Value to be returned.  If NULL, the
                                   * result is set to an empty string. */
      Tcl_FreeProc *freeProc;     /* Gives information about the string:
                                   * TCL_STATIC, TCL_VOLATILE, or the address
                                   * of a Tcl_FreeProc such as free. */
  {
      Interp *iPtr = (Interp *) interp;
      int length;
      register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
      char *oldResult = iPtr->result;
      if (string == NULL) {
          iPtr->resultSpace[0] = 0;
          iPtr->result = iPtr->resultSpace;
          iPtr->freeProc = 0;
      } else if (freeProc == TCL_VOLATILE) {
          length = strlen(string);
          if (length > TCL_RESULT_SIZE) {
              iPtr->result = (char *) ckalloc((unsigned) length+1);
              iPtr->freeProc = TCL_DYNAMIC;
          } else {
              iPtr->result = iPtr->resultSpace;
              iPtr->freeProc = 0;
          }
          strcpy(iPtr->result, string);
      } else {
          iPtr->result = string;
          iPtr->freeProc = freeProc;
      }
      /*
       * If the old result was dynamically-allocated, free it up.  Do it
       * here, rather than at the beginning, in case the new result value
       * was part of the old result value.
       */
      if (oldFreeProc != 0) {
          if ((oldFreeProc == TCL_DYNAMIC)
                  || (oldFreeProc == (Tcl_FreeProc *) free)) {
              ckfree(oldResult);
          } else {
              (*oldFreeProc)(oldResult);
          }
      }
      /*
       * Reset the object result since we just set the string result.
       */
      ResetObjResult(iPtr);
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_GetStringResult --
   *
   *      Returns an interpreter's result value as a string.
   *
   * Results:
   *      The interpreter's result as a string.
   *
   * Side effects:
   *      If the string result is empty, the object result is moved to the
   *      string result, then the object result is reset.
   *
   *----------------------------------------------------------------------
   */
  char *
  Tcl_GetStringResult(interp)
       register Tcl_Interp *interp; /* Interpreter whose result to return. */
  {
      /*
       * If the string result is empty, move the object result to the
       * string result, then reset the object result.
       */
      if (*(interp->result) == 0) {
          Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
                  TCL_VOLATILE);
      }
      return interp->result;
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_SetObjResult --
   *
   *      Arrange for objPtr to be an interpreter's result value.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      interp->objResultPtr is left pointing to the object referenced
   *      by objPtr. The object's reference count is incremented since
   *      there is now a new reference to it. The reference count for any
   *      old objResultPtr value is decremented. Also, the string result
   *      is reset.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_SetObjResult(interp, objPtr)
      Tcl_Interp *interp;         /* Interpreter with which to associate the
                                   * return object value. */
      register Tcl_Obj *objPtr;   /* Tcl object to be returned. If NULL, the
                                   * obj result is made an empty string
                                   * object. */
  {
      register Interp *iPtr = (Interp *) interp;
      register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
      iPtr->objResultPtr = objPtr;
      Tcl_IncrRefCount(objPtr);   /* since interp result is a reference */
      /*
       * We wait until the end to release the old object result, in case
       * we are setting the result to itself.
       */
      TclDecrRefCount(oldObjResult);
      /*
       * Reset the string result since we just set the result object.
       */
      if (iPtr->freeProc != NULL) {
          if ((iPtr->freeProc == TCL_DYNAMIC)
                  || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
              ckfree(iPtr->result);
          } else {
              (*iPtr->freeProc)(iPtr->result);
          }
          iPtr->freeProc = 0;
      }
      iPtr->result = iPtr->resultSpace;
      iPtr->resultSpace[0] = 0;
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_GetObjResult --
   *
   *      Returns an interpreter's result value as a Tcl object. The object's
   *      reference count is not modified; the caller must do that if it
   *      needs to hold on to a long-term reference to it.
   *
   * Results:
   *      The interpreter's result as an object.
   *
   * Side effects:
   *      If the interpreter has a non-empty string result, the result object
   *      is either empty or stale because some procedure set interp->result
   *      directly. If so, the string result is moved to the result object
   *      then the string result is reset.
   *
   *----------------------------------------------------------------------
   */
  Tcl_Obj *
  Tcl_GetObjResult(interp)
      Tcl_Interp *interp;         /* Interpreter whose result to return. */
  {
      register Interp *iPtr = (Interp *) interp;
      Tcl_Obj *objResultPtr;
      int length;
      /*
       * If the string result is non-empty, move the string result to the
       * object result, then reset the string result.
       */
      if (*(iPtr->result) != 0) {
          ResetObjResult(iPtr);
          objResultPtr = iPtr->objResultPtr;
          length = strlen(iPtr->result);
          TclInitStringRep(objResultPtr, iPtr->result, length);
          if (iPtr->freeProc != NULL) {
              if ((iPtr->freeProc == TCL_DYNAMIC)
                      || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
                  ckfree(iPtr->result);
              } else {
                  (*iPtr->freeProc)(iPtr->result);
              }
              iPtr->freeProc = 0;
          }
          iPtr->result = iPtr->resultSpace;
          iPtr->resultSpace[0] = 0;
      }
      return iPtr->objResultPtr;
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_AppendResultVA --
   *
   *      Append a variable number of strings onto the interpreter's string
   *      result.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      The result of the interpreter given by the first argument is
   *      extended by the strings in the va_list (up to a terminating NULL
   *      argument).
   *
   *      If the string result is empty, the object result is moved to the
   *      string result, then the object result is reset.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_AppendResultVA (interp, argList)
      Tcl_Interp *interp;         /* Interpreter with which to associate the
                                   * return value. */
      va_list argList;            /* Variable argument list. */
  {
  #define STATIC_LIST_SIZE 16
      Interp *iPtr = (Interp *) interp;
      char *string, *static_list[STATIC_LIST_SIZE];
      char **args = static_list;
      int nargs_space = STATIC_LIST_SIZE;
      int nargs, newSpace, i;
      /*
       * If the string result is empty, move the object result to the
       * string result, then reset the object result.
       */
      if (*(iPtr->result) == 0) {
          Tcl_SetResult((Tcl_Interp *) iPtr,
                  TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
                  TCL_VOLATILE);
      }
      /*
       * Scan through all the arguments to see how much space is needed
       * and save pointers to the arguments in the args array,
       * reallocating as necessary.
       */
      nargs = 0;
      newSpace = 0;
      while (1) {
          string = va_arg(argList, char *);
          if (string == NULL) {
              break;
          }
          if (nargs >= nargs_space) {
              /*
               * Expand the args buffer
               */
              nargs_space += STATIC_LIST_SIZE;
              if (args == static_list) {
                  args = (void *)ckalloc(nargs_space * sizeof(char *));
                  for (i = 0; i < nargs; ++i) {
                      args[i] = static_list[i];
                  }
              } else {
                  args = (void *)ckrealloc((void *)args,
                          nargs_space * sizeof(char *));
              }
          }
          newSpace += strlen(string);
          args[nargs++] = string;
      }
      /*
       * If the append buffer isn't already setup and large enough to hold
       * the new data, set it up.
       */
      if ((iPtr->result != iPtr->appendResult)
              || (iPtr->appendResult[iPtr->appendUsed] != 0)
              || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
         SetupAppendBuffer(iPtr, newSpace);
      }
      /*
       * Now go through all the argument strings again, copying them into the
       * buffer.
       */
      for (i = 0; i < nargs; ++i) {
          string = args[i];
          strcpy(iPtr->appendResult + iPtr->appendUsed, string);
          iPtr->appendUsed += strlen(string);
      }
      /*
       * If we had to allocate a buffer from the heap,
       * free it now.
       */
      if (args != static_list) {
          ckfree((void *)args);
      }
  #undef STATIC_LIST_SIZE
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_AppendResult --
   *
   *      Append a variable number of strings onto the interpreter's string
   *      result.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      The result of the interpreter given by the first argument is
   *      extended by the strings given by the second and following arguments
   *      (up to a terminating NULL argument).
   *
   *      If the string result is empty, the object result is moved to the
   *      string result, then the object result is reset.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
  {
      Tcl_Interp *interp;
      va_list argList;
      interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
      Tcl_AppendResultVA(interp, argList);
      va_end(argList);
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_AppendElement --
   *
   *      Convert a string to a valid Tcl list element and append it to the
   *      result (which is ostensibly a list).
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      The result in the interpreter given by the first argument is
   *      extended with a list element converted from string. A separator
   *      space is added before the converted list element unless the current
   *      result is empty, contains the single character "{", or ends in " {".
   *
   *      If the string result is empty, the object result is moved to the
   *      string result, then the object result is reset.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_AppendElement(interp, string)
      Tcl_Interp *interp;         /* Interpreter whose result is to be
                                   * extended. */
      CONST char *string;         /* String to convert to list element and
                                   * add to result. */
  {
      Interp *iPtr = (Interp *) interp;
      char *dst;
      int size;
      int flags;
      /*
       * If the string result is empty, move the object result to the
       * string result, then reset the object result.
       */
      if (*(iPtr->result) == 0) {
          Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
                  TCL_VOLATILE);
      }
      /*
       * See how much space is needed, and grow the append buffer if
       * needed to accommodate the list element.
       */
      size = Tcl_ScanElement(string, &flags) + 1;
      if ((iPtr->result != iPtr->appendResult)
              || (iPtr->appendResult[iPtr->appendUsed] != 0)
              || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
         SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
      }
      /*
       * Convert the string into a list element and copy it to the
       * buffer that's forming, with a space separator if needed.
       */
      dst = iPtr->appendResult + iPtr->appendUsed;
      if (TclNeedSpace(iPtr->appendResult, dst)) {
          iPtr->appendUsed++;
          *dst = ' ';
          dst++;
      }
      iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
  }
  /*
   *----------------------------------------------------------------------
   *
   * SetupAppendBuffer --
   *
   *      This procedure makes sure that there is an append buffer properly
   *      initialized, if necessary, from the interpreter's result, and
   *      that it has at least enough room to accommodate newSpace new
   *      bytes of information.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      None.
   *
   *----------------------------------------------------------------------
   */
  static void
  SetupAppendBuffer(iPtr, newSpace)
      Interp *iPtr;               /* Interpreter whose result is being set up. */
      int newSpace;               /* Make sure that at least this many bytes
                                   * of new information may be added. */
  {
      int totalSpace;
      /*
       * Make the append buffer larger, if that's necessary, then copy the
       * result into the append buffer and make the append buffer the official
       * Tcl result.
       */
      if (iPtr->result != iPtr->appendResult) {
          /*
           * If an oversized buffer was used recently, then free it up
           * so we go back to a smaller buffer.  This avoids tying up
           * memory forever after a large operation.
           */
          if (iPtr->appendAvl > 500) {
              ckfree(iPtr->appendResult);
              iPtr->appendResult = NULL;
              iPtr->appendAvl = 0;
          }
          iPtr->appendUsed = strlen(iPtr->result);
      } else if (iPtr->result[iPtr->appendUsed] != 0) {
          /*
           * Most likely someone has modified a result created by
           * Tcl_AppendResult et al. so that it has a different size.
           * Just recompute the size.
           */
          iPtr->appendUsed = strlen(iPtr->result);
      }
      totalSpace = newSpace + iPtr->appendUsed;
      if (totalSpace >= iPtr->appendAvl) {
          char *new;
          if (totalSpace < 100) {
              totalSpace = 200;
          } else {
              totalSpace *= 2;
          }
          new = (char *) ckalloc((unsigned) totalSpace);
          strcpy(new, iPtr->result);
          if (iPtr->appendResult != NULL) {
              ckfree(iPtr->appendResult);
          }
          iPtr->appendResult = new;
          iPtr->appendAvl = totalSpace;
      } else if (iPtr->result != iPtr->appendResult) {
          strcpy(iPtr->appendResult, iPtr->result);
      }
      Tcl_FreeResult((Tcl_Interp *) iPtr);
      iPtr->result = iPtr->appendResult;
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_FreeResult --
   *
   *      This procedure frees up the memory associated with an interpreter's
   *      string result. It also resets the interpreter's result object.
   *      Tcl_FreeResult is most commonly used when a procedure is about to
   *      replace one result value with another.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      Frees the memory associated with interp's string result and sets
   *      interp->freeProc to zero, but does not change interp->result or
   *      clear error state. Resets interp's result object to an unshared
   *      empty object.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_FreeResult(interp)
      register Tcl_Interp *interp; /* Interpreter for which to free result. */
  {
      register Interp *iPtr = (Interp *) interp;
      if (iPtr->freeProc != NULL) {
          if ((iPtr->freeProc == TCL_DYNAMIC)
                  || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
              ckfree(iPtr->result);
          } else {
              (*iPtr->freeProc)(iPtr->result);
          }
          iPtr->freeProc = 0;
      }
      ResetObjResult(iPtr);
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_ResetResult --
   *
   *      This procedure resets both the interpreter's string and object
   *      results.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      It resets the result object to an unshared empty object. It
   *      then restores the interpreter's string result area to its default
   *      initialized state, freeing up any memory that may have been
   *      allocated. It also clears any error information for the interpreter.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_ResetResult(interp)
      register Tcl_Interp *interp; /* Interpreter for which to clear result. */
  {
      register Interp *iPtr = (Interp *) interp;
      ResetObjResult(iPtr);
      if (iPtr->freeProc != NULL) {
          if ((iPtr->freeProc == TCL_DYNAMIC)
                  || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
              ckfree(iPtr->result);
          } else {
              (*iPtr->freeProc)(iPtr->result);
          }
          iPtr->freeProc = 0;
      }
      iPtr->result = iPtr->resultSpace;
      iPtr->resultSpace[0] = 0;
      iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
  }
  /*
   *----------------------------------------------------------------------
   *
   * ResetObjResult --
   *
   *      Procedure used to reset an interpreter's Tcl result object.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      Resets the interpreter's result object to an unshared empty string
   *      object with ref count one. It does not clear any error information
   *      in the interpreter.
   *
   *----------------------------------------------------------------------
   */
  static void
  ResetObjResult(iPtr)
      register Interp *iPtr;      /* Points to the interpreter whose result
                                   * object should be reset. */
  {
      register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
      if (Tcl_IsShared(objResultPtr)) {
          TclDecrRefCount(objResultPtr);
          TclNewObj(objResultPtr);
          Tcl_IncrRefCount(objResultPtr);
          iPtr->objResultPtr = objResultPtr;
      } else {
          if ((objResultPtr->bytes != NULL)
                  && (objResultPtr->bytes != tclEmptyStringRep)) {
              ckfree((char *) objResultPtr->bytes);
          }
          objResultPtr->bytes  = tclEmptyStringRep;
          objResultPtr->length = 0;
          if ((objResultPtr->typePtr != NULL)
                  && (objResultPtr->typePtr->freeIntRepProc != NULL)) {
              objResultPtr->typePtr->freeIntRepProc(objResultPtr);
          }
          objResultPtr->typePtr = (Tcl_ObjType *) NULL;
      }
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_SetErrorCodeVA --
   *
   *      This procedure is called to record machine-readable information
   *      about an error that is about to be returned.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      The errorCode global variable is modified to hold all of the
   *      arguments to this procedure, in a list form with each argument
   *      becoming one element of the list.  A flag is set internally
   *      to remember that errorCode has been set, so the variable doesn't
   *      get set automatically when the error is returned.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_SetErrorCodeVA (interp, argList)
      Tcl_Interp *interp;         /* Interpreter in which to access the errorCode
                                   * variable. */
      va_list argList;            /* Variable argument list. */
  {
      char *string;
      int flags;
      Interp *iPtr = (Interp *) interp;
      /*
       * Scan through the arguments one at a time, appending them to
       * $errorCode as list elements.
       */
      flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
      while (1) {
          string = va_arg(argList, char *);
          if (string == NULL) {
              break;
          }
          (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
                  (char *) NULL, string, flags);
          flags |= TCL_APPEND_VALUE;
      }
      iPtr->flags |= ERROR_CODE_SET;
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_SetErrorCode --
   *
   *      This procedure is called to record machine-readable information
   *      about an error that is about to be returned.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      The errorCode global variable is modified to hold all of the
   *      arguments to this procedure, in a list form with each argument
   *      becoming one element of the list.  A flag is set internally
   *      to remember that errorCode has been set, so the variable doesn't
   *      get set automatically when the error is returned.
   *
   *----------------------------------------------------------------------
   */
          /* VARARGS2 */
  void
  Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
  {
      Tcl_Interp *interp;
      va_list argList;
      /*
       * Scan through the arguments one at a time, appending them to
       * $errorCode as list elements.
       */
      interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
      Tcl_SetErrorCodeVA(interp, argList);
      va_end(argList);
  }
  /*
   *----------------------------------------------------------------------
   *
   * Tcl_SetObjErrorCode --
   *
   *      This procedure is called to record machine-readable information
   *      about an error that is about to be returned. The caller should
   *      build a list object up and pass it to this routine.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      The errorCode global variable is modified to be the new value.
   *      A flag is set internally to remember that errorCode has been
   *      set, so the variable doesn't get set automatically when the
   *      error is returned.
   *
   *----------------------------------------------------------------------
   */
  void
  Tcl_SetObjErrorCode(interp, errorObjPtr)
      Tcl_Interp *interp;
      Tcl_Obj *errorObjPtr;
  {
      Interp *iPtr;
      iPtr = (Interp *) interp;
      Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
      iPtr->flags |= ERROR_CODE_SET;
  }
  /*
   *-------------------------------------------------------------------------
   *
   * TclTransferResult --
   *
   *      Copy the result (and error information) from one interp to
   *      another.  Used when one interp has caused another interp to
   *      evaluate a script and then wants to transfer the results back
   *      to itself.
   *
   *      This routine copies the string reps of the result and error
   *      information.  It does not simply increment the refcounts of the
   *      result and error information objects themselves.
   *      It is not legal to exchange objects between interps, because an
   *      object may be kept alive by one interp, but have an internal rep
   *      that is only valid while some other interp is alive.
   *
   * Results:
   *      The target interp's result is set to a copy of the source interp's
   *      result.  The source's error information "$errorInfo" may be
   *      appended to the target's error information and the source's error
   *      code "$errorCode" may be stored in the target's error code.
   *
   * Side effects:
   *      None.
   *
   *-------------------------------------------------------------------------
   */
  void
  TclTransferResult(sourceInterp, result, targetInterp)
      Tcl_Interp *sourceInterp;   /* Interp whose result and error information
                                   * should be moved to the target interp.
                                   * After moving result, this interp's result
                                   * is reset. */
      int result;                 /* TCL_OK if just the result should be copied,
                                   * TCL_ERROR if both the result and error
                                   * information should be copied. */
      Tcl_Interp *targetInterp;   /* Interp where result and error information
                                   * should be stored.  If source and target
                                   * are the same, nothing is done. */
  {
      Interp *iPtr;
      Tcl_Obj *objPtr;
      if (sourceInterp == targetInterp) {
          return;
      }
      if (result == TCL_ERROR) {
          /*
           * An error occurred, so transfer error information from the source
           * interpreter to the target interpreter.  Setting the flags tells
           * the target interp that it has inherited a partial traceback
           * chain, not just a simple error message.
           */
          iPtr = (Interp *) sourceInterp;
          if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
              Tcl_AddErrorInfo(sourceInterp, "");
          }
          iPtr->flags &= ~(ERR_ALREADY_LOGGED);
          Tcl_ResetResult(targetInterp);
          objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
                  TCL_GLOBAL_ONLY);
          Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
                  TCL_GLOBAL_ONLY);
          objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
                  TCL_GLOBAL_ONLY);
          Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr,
                  TCL_GLOBAL_ONLY);
          ((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
      }
      ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
      Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
      Tcl_ResetResult(sourceInterp);
  }
  /* End of tclresult.c */

 Legend:



Removed from v.66
 


changed lines


 
Added in v.71
 Legend:



Removed from v.66
 


changed lines


 
Added in v.71
-Removed from v.66
+Added in v.71

dashley@gmail.com	ViewVC Help
Powered by ViewVC 1.1.25