TIP 89: Try/Catch Exception Handling in the Core

Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2017 Conference, Houston/TX, US, Oct 16-20
Send your abstracts to tclconference@googlegroups.com
by Aug 21.
Author:         Tom Wilkason <tom.wilkason@cox.net>
Author:         Frank Pilhofer <520065607613-0001@t-online.de>
State:          Withdrawn
Type:           Project
Vote:           Pending
Created:        11-Mar-2002
Post-History:   
Discussions-To: news:comp.lang.tcl
Tcl-Version:    8.6
Obsoleted-By:	329

Abstract

This TIP proposes the addition of a try...catch...finally command to provide a more robust and powerful exception handling mechanism.

Rationale

Exceptions are currently supported very well in Tcl, in fact they are a major advantage over many other languages. However the mechanism to catch and handle the errors is someone limited and does not promote the full use of existing error codes. Wrapper procedures can be written to improve on this, however both a performance and compatibility penalty is incurred.

This TIP proposes adding a try/catch command to the Tcl core (or C based Tcl library). This implementation is not unlike those found in C++, C#, Java and Python (to name a few languages).

An argument to add this to the core is that it modernizes the Tcl exception handling without impacting performance in any other way. try/catch are isolated commands that can easily be added, and do not interact with other commands or require other changes. try/catch is not an isolated extension that is useful for special purposes only. These commands, if implemented into the core, will be useful for any script currently using the catch construct.

Specification

I propose the following two commands be added to Tcl:

Examples

throw

    throw DEVICE "Could not write to device"

try only (no practical use)

    try {
       incr i
    }

try - catch

    try {
       incr i
    } catch * {
       set i 0
    }

try - finally

    try {
       . config -cursor watch
       #do some busy stuff here, don't care about errors
    } finally {
       . config -cursor arrow
    }

try - catch - catch

    try {
       ;# Some code that will cause an error
    } catch {{POSIX *} eCode eMessage} {
       ;# Statements to handle POSIX type errors
    } catch {NULL eCode eMessage} {
       ;# Statements to handle NULL (a user created) type errors
    } catch {* eMessage} {
       ;# Statements to handle all other errors
    }

try - catch - catch - finally

    try {
       ;# Some code that will cause an error
    } catch {POSIX eCode eMessage} {
       ;# Statements to handle POSIX type errors
    } catch {* eCode eMessage} {
       ;# Statements to handle all other errors
    } finally {
       ;# Statements to execute whether an error occurred or not
    }

Re-throw try - catch - finally

    try {
       try {
          set b [expr {$a/0}]
       } catch {ARITH} {
          if {$a == 0} {
             throw   ;# re-throw to outer try
          }
       } finally {
          set b 1    ;# will execute before throw above
       }
    } catch {ARITH eCode eMessage} {
       ;# This will catch the inner throw
       puts "$res"
    }

Revisions: Tom Wilkason March 26, 2002

Reference Implementation

 /*
  * Implementation of try/catch and throw commands according to TIP 89
  */

 #include <tcl.h>

 /*
  * We keep a stack of contexts; whenever we have to handle an error,
  * i.e. are executing a catch {} clause, we store the current error
  * (errorCode, errorInfo and message), so that a throw with no arguments
  * can re-throw it.
  *
  * This is interpreter-specific data. Each element is a list, with the
  * last element being the most current one.
  */

 typedef struct {
   Tcl_Obj * errorCodeStack;
   Tcl_Obj * errorInfoStack;
   Tcl_Obj * errorMsgStack;
   Tcl_Obj * errorCodeName;
   Tcl_Obj * errorInfoName;
 } TryCatchTsd;

 /*
  * Throw an Exception
  *
  * throw ?<type> ?<message>? ?<info>??
  *
  * Throws an exception with the errorCode <type>, the message <message>
  * and the errorInfo <info>.
  *
  * An instance of throw with no arguments can be used within a catch or
  * finally block to immediately re-throw the current exception that is
  * being handled by the catch block.
  */

 static int
 Tcl_ThrowObjCmd (ClientData clientData, Tcl_Interp *interp,
                  int objc, Tcl_Obj *CONST objv[])
 {
   TryCatchTsd * myTsd = (TryCatchTsd *) clientData;

   if (objc < 1 || objc > 4) {
     Tcl_AppendResult (interp, "wrong # args: should be \"",
                       Tcl_GetStringFromObj (objv[0], NULL),
                       " ?<type> ?<message>? ?<info>??\"", NULL);
     return TCL_ERROR;
   }

   /*
    * Re-throw an error
    */

   if (objc < 2) {
     Tcl_Obj *errorCode, *errorInfo, *errorMsg;
     int lastelement;

     Tcl_ListObjLength (interp, myTsd->errorMsgStack, &lastelement);

     if (lastelement < 1) {
       Tcl_AppendResult (interp, "error: throw with no parameters ",
                         "outside of a catch",
                         NULL);
       return TCL_ERROR;
     }

     lastelement--;
     Tcl_ListObjIndex (interp, myTsd->errorMsgStack,
                       lastelement, &errorMsg);
     Tcl_ListObjIndex (interp, myTsd->errorCodeStack,
                       lastelement, &errorCode);
     Tcl_ListObjIndex (interp, myTsd->errorInfoStack,
                       lastelement, &errorInfo);

     Tcl_ResetResult (interp);
     Tcl_SetObjResult (interp, errorMsg);
     Tcl_SetObjErrorCode (interp, errorCode);

 #ifdef _TCLINT
     Tcl_ObjSetVar2 (interp, myTsd->errorInfoName, NULL, errorInfo,
                     TCL_GLOBAL_ONLY);
     interp->flags = ERR_IN_PROGRESS;
 #else
     Tcl_AddErrorInfo (interp, Tcl_GetStringFromObj (errorInfo, NULL));
 #endif
     return TCL_ERROR;
   }

   /*
    * throw with parameters
    */

   Tcl_ResetResult (interp);

   if (objc >= 3) {
     Tcl_SetObjResult (interp, objv[2]);
   } else {
     /*
      * fabricate some error message for human consumption
      */

     Tcl_AppendResult (interp, "error: ",
                       Tcl_GetStringFromObj (objv[1], NULL),
                       NULL);
   }

   Tcl_SetObjErrorCode (interp, objv[1]);

   if (objc >= 4) {
 #ifdef _TCLINT
     Tcl_ObjSetVar2 (interp, myTsd->errorInfoName, NULL, objv[3],
                     TCL_GLOBAL_ONLY);
     interp->flags = ERR_IN_PROGRESS;
 #else
     Tcl_AddErrorInfo (interp, Tcl_GetStringFromObj (objv[3], NULL));
 #endif
   }

   /*
    * throw error
    */

   return TCL_ERROR;
 }

 /*
  * exception handling
  *
  * try body ?catch {type-list ?ecvar? ?msgvar? ?infovar?} body ...?
  *          ?finally body?
  */

 static int
 Tcl_TryObjCmd (ClientData clientData, Tcl_Interp *interp,
                int objc, Tcl_Obj *CONST objv[])
 {
   TryCatchTsd * myTsd = (TryCatchTsd *) clientData;
   int currentIndex, finallyIndex, catchInfoLength, hasCatch;
   char * blockType;
   int res;

   /*
    * first check for syntactic correctness before doing anything
    */

   if (objc < 2) {
     Tcl_AppendResult (interp, "wrong # args: should be \"",
                       Tcl_GetStringFromObj (objv[0], NULL),
                       " body ",
                       "?catch {type-list ?ecvar? ?msgvar? ?infovar?} ",
                       "body ...? ",
                       "?finally body?\"", NULL);
     return TCL_ERROR;
   }

   currentIndex = 2;
   finallyIndex = -1;
   hasCatch = 0;

   while (currentIndex < objc) {
     blockType = Tcl_GetStringFromObj (objv[currentIndex], NULL);

     if (strcmp (blockType, "catch") == 0) {
       Tcl_Obj * typeList;
       int typeListLength;

       if (currentIndex+2 >= objc ||
           Tcl_ListObjLength (interp, objv[currentIndex+1],
                              &catchInfoLength) != TCL_OK ||
           (catchInfoLength < 1 && catchInfoLength > 4) ||
           Tcl_ListObjIndex (interp, objv[currentIndex+1],
                             0, &typeList) != TCL_OK ||
           Tcl_ListObjLength (interp, typeList,
                              &typeListLength) != TCL_OK) {
         Tcl_AppendResult (interp, "invalid syntax in catch clause: ",
                           "should be \"",
                           "catch {type-list ?ecvar? ?msgvar? ?infovar?} ",
                           "body\"", NULL);
         return TCL_ERROR;
       }
       hasCatch = 1;
       currentIndex += 3;
     }
     else if (strcmp (blockType, "finally") == 0) {
       if (currentIndex+2 != objc) {
         Tcl_AppendResult (interp, "trailing args after finally clause",
                           NULL);
         return TCL_ERROR;
       }
       finallyIndex = currentIndex;
       currentIndex += 2;
     }
     else {
       Tcl_AppendResult (interp, "invalid syntax: should be \"",
                         Tcl_GetStringFromObj (objv[0], NULL),
                         " body ",
                         "?catch {type-list ?ecvar? ?msgvar? ?infovar?} ",
                         "body ...? ",
                         "?finally body?\"", NULL);
       return TCL_ERROR;
     }
   }

   /*
    * Eval main body
    */

   res = Tcl_EvalObjEx (interp, objv[1], 0);

   /*
    * In case of error, check the catch clauses
    */

   if (res == TCL_ERROR) {
     Tcl_Obj *errorCode, *errorInfo, *errorMsg;
     int errorCodeLength, stackLength;

     errorMsg = Tcl_GetObjResult (interp);
     errorCode = Tcl_ObjGetVar2 (interp, myTsd->errorCodeName, NULL,
                                 TCL_GLOBAL_ONLY);
     errorInfo = Tcl_ObjGetVar2 (interp, myTsd->errorInfoName, NULL,
                                 TCL_GLOBAL_ONLY);

     /*
      * After an error has happened, errorCode and errorInfo should
      * exist.
      */

     if (errorCode == NULL || errorInfo == NULL) {
       Tcl_AppendResult (interp, "assertion error in try: ",
                         "no errorCode or no errorInfo",
                         NULL);
       return TCL_ERROR;
     }

     if (Tcl_ListObjLength (interp, errorCode, &errorCodeLength) != TCL_OK) {
       Tcl_AppendResult (interp, "assertion error in try: "
                         "errorCode is not a list",
                         NULL);
       return TCL_ERROR;
     }

     /*
      * push error data on stack, so that throw can rethrow the error
      */

     Tcl_ListObjAppendElement (interp, myTsd->errorMsgStack, errorMsg);
     Tcl_ListObjAppendElement (interp, myTsd->errorCodeStack, errorCode);
     Tcl_ListObjAppendElement (interp, myTsd->errorInfoStack, errorInfo);

     /*
      * Look for a matching clause
      */

     currentIndex = 2;

     while (currentIndex < objc) {
       blockType = Tcl_GetStringFromObj (objv[currentIndex], NULL);

       if (strcmp (blockType, "catch") == 0) {
         int typeListLength, matchIndex;
         Tcl_Obj *typeList;

         Tcl_ListObjIndex  (interp, objv[currentIndex+1], 0, &typeList);
         Tcl_ListObjLength (interp, typeList, &typeListLength);

         if (typeListLength > errorCodeLength) {
           currentIndex += 3;
           continue;
         }

         for (matchIndex=0; matchIndex<typeListLength; matchIndex++) {
           Tcl_Obj *errorCodeItem, *typeListItem;
           const char *errorCodeItemStr, *typeListItemStr;

           Tcl_ListObjIndex (interp, errorCode, matchIndex, &errorCodeItem);
           Tcl_ListObjIndex (interp, typeList, matchIndex, &typeListItem);

           errorCodeItemStr = Tcl_GetStringFromObj (errorCodeItem, NULL);
           typeListItemStr = Tcl_GetStringFromObj (typeListItem, NULL);

           if (!Tcl_StringMatch (errorCodeItemStr, typeListItemStr)) {
             break;
           }
         }

         if (matchIndex >= typeListLength) {
           /* matching catch clause found */
           break;
         }

         /* continue looking */
         currentIndex += 3;
       }
       else {
         /* not a catch clause - there are no matching catch clauses */
         currentIndex = objc;
         break;
       }
     }

     /*
      * Did we find a matching catch clause?
      */

     if (currentIndex < objc) {
       Tcl_Obj *ecvar, *msgvar, *infovar;

       Tcl_ListObjLength (interp, objv[currentIndex+1], &catchInfoLength);

       /*
        * set variables with error data
        */

       if (catchInfoLength >= 2) {
         Tcl_ListObjIndex (interp, objv[currentIndex+1], 1, &ecvar);
         Tcl_ObjSetVar2 (interp, ecvar, NULL, errorCode, 0);
       }

       if (catchInfoLength >= 3) {
         Tcl_ListObjIndex (interp, objv[currentIndex+1], 2, &msgvar);
         Tcl_ObjSetVar2 (interp, msgvar, NULL, errorMsg, 0);
       }

       if (catchInfoLength >= 4) {
         Tcl_ListObjIndex (interp, objv[currentIndex+1], 3, &infovar);
         Tcl_ObjSetVar2 (interp, infovar, NULL, errorInfo, 0);
       }

       /*
        * call body; the error code of this body takes precedence
        */

       res = Tcl_EvalObjEx (interp, objv[currentIndex+2], 0);
     }

     /*
      * pop error data from stack
      */

     Tcl_ListObjLength (interp, myTsd->errorMsgStack, &stackLength);
     stackLength--;
     Tcl_ListObjReplace (interp, myTsd->errorMsgStack,
                         stackLength, 1, 0, NULL);
     Tcl_ListObjReplace (interp, myTsd->errorCodeStack,
                         stackLength, 1, 0, NULL);
     Tcl_ListObjReplace (interp, myTsd->errorInfoStack,
                         stackLength, 1, 0, NULL);
   }

   /*
    * Execute finally body. Preserve errorCode and friends; they might
    * be corrupted by the code in the body - e.g. by a try in the code,
    * or in a proc called by the code.
    */

   if (finallyIndex != -1) {
     Tcl_Obj *errorCode, *errorInfo, *errorMsg;
     int finallyres, origres=res;

     errorMsg = Tcl_GetObjResult (interp);
     Tcl_IncrRefCount (errorMsg);

     if (origres == TCL_ERROR) {
       errorCode = Tcl_ObjGetVar2 (interp, myTsd->errorCodeName, NULL,
                                   TCL_GLOBAL_ONLY);
       errorInfo = Tcl_ObjGetVar2 (interp, myTsd->errorInfoName, NULL,
                                   TCL_GLOBAL_ONLY);
       Tcl_IncrRefCount (errorCode);
       Tcl_IncrRefCount (errorInfo);
     }

     finallyres = Tcl_EvalObjEx (interp, objv[finallyIndex+1], 0);

     /*
      * An Error in the finally clause takes precedence, else restore
      * previous error data
      */

     if (finallyres != TCL_OK) {
       res = finallyres;
     }
     else {
       Tcl_SetObjResult (interp, errorMsg);

       if (origres == TCL_ERROR) {
         Tcl_SetObjErrorCode (interp, errorCode);
 #ifdef _TCLINT
         Tcl_ObjSetVar2 (interp, myTsd->errorInfoName, NULL, errorInfo,
                         TCL_GLOBAL_ONLY);
         interp->flags = ERR_IN_PROGRESS;
 #else
         Tcl_AddErrorInfo (interp, Tcl_GetStringFromObj (errorInfo, NULL));
 #endif
       }
     }

     Tcl_DecrRefCount (errorMsg);

     if (origres == TCL_ERROR) {
       Tcl_DecrRefCount (errorCode);
       Tcl_DecrRefCount (errorInfo);
     }
   }

   /*
    * Pass along return code
    */

   return res;
 }

 /*
  * ----------------------------------------------------------------------
  *
  * "Main" function, install our commands in the Tcl interpreter
  *
  * ----------------------------------------------------------------------
  */

 #undef TCL_STORAGE_CLASS
 #define TCL_STORAGE_CLASS DLLEXPORT
 EXTERN int
 Trycatch_Init (Tcl_Interp *interp)
 {
   TryCatchTsd * myTsd;

 #ifdef USE_TCL_STUBS
   if (Tcl_InitStubs (interp, TCL_VERSION, 0) == NULL) {
     return TCL_ERROR;
   }
 #else
   if (Tcl_PkgRequire (interp, "Tcl", TCL_VERSION, 1) == NULL) {
     return TCL_ERROR;
   }
 #endif

   /*
    * Allocate Tsd
    */

   myTsd = (TryCatchTsd *) Tcl_Alloc (sizeof (TryCatchTsd));
   myTsd->errorCodeStack = Tcl_NewObj ();
   myTsd->errorInfoStack = Tcl_NewObj ();
   myTsd->errorMsgStack  = Tcl_NewObj ();
   myTsd->errorCodeName  = Tcl_NewStringObj ("errorCode", -1);
   myTsd->errorInfoName  = Tcl_NewStringObj ("errorInfo", -1);

   /*
    * add commands
    */

   Tcl_CreateObjCommand (interp, "throw", Tcl_ThrowObjCmd,
                         (ClientData) myTsd, NULL);
   Tcl_CreateObjCommand (interp, "try", Tcl_TryObjCmd,
                         (ClientData) myTsd, NULL);

   /*
    * Ready
    */

   Tcl_PkgProvide (interp, "trycatch", "0.1");
   return TCL_OK;
 }

Copyright

This document has been placed in the public domain.

History