Itcl - the [incr Tcl] extension

        /*
         *  Create a "destructed" table to keep track of which destructors
         *  have been invoked.  This is used in ItclDestructBase to make
         *  sure that all base class destructors have been called,
         *  explicitly or implicitly.
         */
        contextIoPtr->destructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitObjHashTable(contextIoPtr->destructed);
        Tcl_InitHashTable(contextIoPtr->destructed, TCL_ONE_WORD_KEYS);

        /*
         *  Destruct the object starting from the most-specific class.
         *  If all goes well, return the null string as the result.
         */
        callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
        Tcl_NRAddCallback(interp, FinalizeDeleteObject, contextIoPtr,

    Itcl_ListElem *elem;
    ItclClass *iclsPtr;

    if (contextIoPtr->flags & ITCL_OBJECT_CLASS_DESTRUCTED) {
        return TCL_OK;
    }
    /*
     *  Look for a destructor in this class, and if found,
     *  Ensure a destructor for this class is not already invoked yet.
     *  invoke it.
     */
    if (Tcl_FindHashEntry(contextIoPtr->destructed,
            (char *)contextIclsPtr->namePtr) == NULL) {
            (char *)contextIclsPtr) == NULL) {
        /*
         *  Look for a destructor in this class, and if found, invoke it.
         */
        result = Itcl_InvokeMethodIfExists(interp, "destructor",
            contextIclsPtr, contextIoPtr, 0, NULL);
        if (result != TCL_OK) {
            return TCL_ERROR;
        }
    }

         [itcl::find classes test_delete*] \
         [namespace children :: test_delete*] \
         [namespace which -command test_delete_base] \
         [namespace which -command test_delete] \
         [itcl::find objects test_delete*]
} {{} {} {} {} {} {}}

test delete-2.4 {object destructors get invoked properly} {
test delete-2.4 {object destructors get invoked properly} -body {
    lsort $test_delete_watch
} -cleanup {
    set test_delete_watch {}
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}
} -result {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}

test delete-2.5 {object destructors get invoked properly, bug [987067386fa2edae]} -setup {
    variable ::test_delete_watch {}
    itcl::class ::test_delete_base {
        destructor {
            global ::test_delete_watch
            lappend test_delete_watch "base $this"
        }
    }
    namespace eval itcl_test_ns {
      # class in NS with different name than base
      itcl::class test_delete_other {
        inherit ::test_delete_base
        destructor {
            global ::test_delete_watch
            lappend test_delete_watch "derivate-other $this"
        }
      }
      # class in NS with different name than base
      itcl::class test_delete_base {
        inherit ::test_delete_base
        destructor {
            global ::test_delete_watch
            lappend test_delete_watch "derivate-same $this"
        }
      }
    }
} -body {
    itcl_test_ns::test_delete_other test_del_other
    itcl_test_ns::test_delete_base test_del_base
    itcl::delete object test_del_other test_del_base
    set test_delete_watch
} -cleanup {
    set test_delete_watch {}
    namespace delete itcl_test_ns
    itcl::delete class ::test_delete_base
} -result {{derivate-other ::test_del_other} {base ::test_del_other} {derivate-same ::test_del_base} {base ::test_del_base}}

# ----------------------------------------------------------------------
#  Deleting class namespaces
# ----------------------------------------------------------------------
test delete-3.1 {redefine classes with inheritance} {
    variable ::test_delete_watch ""
    itcl::class test_delete_base {

test delete-5.4 {scoped command names are decoded properly} {
    list [catch {itcl::delete object {namespace inscope ::xyzzy xxx}} msg] $msg \
         [catch {itcl::delete object {namespace inscope :: xxx yyy}} msg] $msg \
         [catch {itcl::delete object {namespace inscope :: xyzzy}} msg] $msg
} {1 {unknown namespace "::xyzzy"} 1 {malformed command "namespace inscope :: xxx yyy": should be "namespace inscope namesp command"} 1 {object "namespace inscope :: xyzzy" not found}}

namespace delete test_delete_name test_delete2
catch { namespace delete test_delete_name test_delete2 }

::tcltest::cleanupTests
return