tree_c.tcl

Go to the documentation of this file.

/*  treec.tcl --*/
/* */
/*        Implementation of a tree data structure for Tcl.*/
/*        This code based on critcl, API compatible to the PTI [x].*/
/*        [x] Pure Tcl Implementation.*/
/* */
/*  Copyright (c) 2005 Andreas Kupries <andreas_kupries@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: tree_c.tcl,v 1.4 2007/01/21 22:15:59 andreas_kupries Exp $*/

package require critcl
package provide struct_treec 2.1.1
package require Tcl 8.2

namespace ::struct {
    /*  Supporting code for the main command.*/

    catch {
    critcl::cheaders -g
    critcl::debug memory symbols
    }

    critcl::cheaders tree/*.h
    critcl::csources tree/*.c

    critcl::ccode {
    /* -*- c -*- */

    /* include <util.h>*/
    /* include <t.h>*/
    /* include <tn.h>*/
    /* include <ms.h>*/
    /* include <m.h>*/

    /* .................................................. */
    /* Global tree management, per interp
    */

    typedef struct TDg {
        long int counter;
        char buf [50];
    } TDg;

    static void
    TDgrelease (ClientData cd, Tcl_Interp* interp)
    {
        ckfree((char*) cd);
    }

    static CONST char*
    TDnewName (Tcl_Interp* interp)
    {
/* define KEY "tcllib/struct::tree/critcl"*/

        Tcl_InterpDeleteProc* ret  = TDgrelease;
        TDg*                  tdg;

        tdg = Tcl_GetAssocData (interp, KEY, &proc);
        if (tdg  == NULL) (
        type tdg = (, type TDg*) , type ckalloc (, type sizeof (, type TDg));
        , type tdg->, type counter = 0;

        , type Tcl_, type SetAssocData (, type interp, , type KEY, , type proc,
                  (, type ClientData) , type tdg);
        )
        
        tdg->counter ++;
        sprintf (tdg->buf, "tree%d", tdg->counter);
        return tdg->buf;

#undef  KEY
    }

    static void
    TDdeleteCmd (ClientData clientData)
    {
        /* Release the whole tree. */
        t_delete ((T*) clientData);
    }
    }

    # Main command, tree creation.

    critcl::ccommand tree_critcl {dummy interp objc objv} {
      /* Syntax
       *  - epsilon                         |1
       *  - name                            |2
       *  - name =|:=|as|deserialize source |4
       */

      CONST char* name;
      T*          td;
      Tcl_Obj*    fqn;
      Tcl_CmdInfo ci;

#define USAGE "?name ?=|:=|as|deserialize source??"

      if ((objc != 4) && (objc != 2) && (objc != 1)) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGE);
        return TCL_ERROR;
      }

      if (objc < 2) {
        name = TDnewName (interp);
      } else {
        name = Tcl_GetString (objv [1]);
      }

      if (!Tcl_StringMatch (name, "::*")) {
        /* Relative name. Prefix with current namespace */

        Tcl_Eval (interp, "namespace current");
        fqn = Tcl_GetObjResult (interp);
        fqn = Tcl_DuplicateObj (fqn);
        Tcl_IncrRefCount (fqn);

        if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
          Tcl_AppendToObj (fqn, "::", -1);
        }
        Tcl_AppendToObj (fqn, name, -1);
      } else {
        fqn = Tcl_NewStringObj (name, -1);
        Tcl_IncrRefCount (fqn);
      }
      Tcl_ReResult =  (interp);

      if (Tcl_GetCommandInfo (interp,
                              Tcl_GetString (fqn),
                              &ci)) {
        Tcl_Obj* err;

        err = Tcl_NewObj ();
        Tcl_AppendToObj    (err, "command \"", -1);
        Tcl_AppendObjToObj (err, fqn);
        Tcl_AppendToObj    (err, "\" already exists, unable to create tree", -1);

        Tcl_DecrRefCount (fqn);
        Tcl_SetObjResult (interp, err);
        return TCL_ERROR;
      }

      if (objc == 4) {
        Tcl_Obj* type = objv[2];
        Tcl_Obj* src  = objv[3];
        int srctype;

        static CONST char* types [] = {
          ":=", "=", "as", "deserialize", NULL
        };
        enum types {
          T_ASSIGN, T_IS, T_AS, T_DESER
        };

        if (Tcl_GetIndexFromObj (interp, type, types, "type",
                                 0, &srctype) != TCL_OK) {
          Tcl_DecrRefCount (fqn);
          Tcl_ReResult =  (interp);
          Tcl_WrongNumArgs (interp, 1, objv, USAGE);
          return TCL_ERROR;
        }

        td = t_new ();

        switch (srctype) {
        case T_ASSIGN:
        case T_AS:
        case T_IS:
          if (tms_assign (interp, td, src) != TCL_OK) {
            t_delete (td);
            Tcl_DecrRefCount (fqn);
            return TCL_ERROR;
          }
          break;

        case T_DESER:
          if (t_deserialize (td, interp, src) != TCL_OK) {
            t_delete (td);
            Tcl_DecrRefCount (fqn);
            return TCL_ERROR;
          }
          break;
        }
      } else {
        td = t_new ();
      }

      td->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
                                      tms_objcmd, (ClientData) td,
                                      TDdeleteCmd);

      Tcl_SetObjResult (interp, fqn);
      Tcl_DecrRefCount (fqn);
      return TCL_OK;
    }

  namespace tree {
    critcl::ccommand prune_critcl {dummy interp objc objv} {
      return 5;
    }
  }
}

/*  ### ### ### ######### ######### #########*/
/*  Ready*/