Logo Search packages:      
Sourcecode: tcllib version File versions  Download package

t.c

/* struct::tree - critcl - layer 1 definitions
 * (c) Tree functions
 */

#include <t.h>
#include <tn.h>
#include <util.h>

/* .................................................. */

T*
t_new (void)
{
    T* t = ALLOC (T);

    Tcl_InitHashTable (&t->node, TCL_STRING_KEYS);

    t->cmd   = NULL;
    t->counter     = 0;
    t->nodes       = NULL;
    t->nnodes      = 0;
    t->leaves      = NULL;
    t->nleaves     = 0;
    t->root  = tn_new (t, "root");
    t->structure = 0;

    return t;
}

void
t_delete (T* t)
{
    /* Delete a tree in toto. Recursively deletes all nodes first,
     * starting at root. This also handles the nodes/leaves lists.
     * Then the name -> node mapping, and the object name. The
     */

    tn_delete (t->root);

    Tcl_DeleteHashTable(&t->node);

    t->cmd = NULL;
    ckfree ((char*) t);
}

/* .................................................. */

void
t_structure (T* t)
{
    /* Computes all structural data,
     * then declares it valid.
   */

    tn_structure (t->root, 0);
    t->structure = 1;
}

/* .................................................. */

int
t_deserialize (T* dst, Tcl_Interp* interp, Tcl_Obj* src)
{
    int           listc;
    Tcl_Obj** listv;
    int           nodes;

    int           root   = -1;
    int*      parent = NULL;

    /* Basic checks:
     * - Is the input a list ?
     * - Is its length a multiple of three ?
     *
     * structure:  node-name parent-index attr-dict
     *               i+0           i+1      i+2
     */

#define NAME(i)     (i)
#define PARENT(i) ((i)+1)
#define ATTR(i)     ((i)+2)

    if (Tcl_ListObjGetElements (interp, src, &listc, &listv) != TCL_OK) {
      return TCL_ERROR;
    }
    if ((listc % 3) != 0) {
      Tcl_AppendResult (interp,
                    "error in serialization: list length not a multiple of 3.",
                    NULL);
      return TCL_ERROR;
    }

    nodes = listc/3;

    /* Iterate and check the attribute dictionaries for listness and
     * size (even length).
     */

    {
      int     ac;
      Tcl_Obj** av;
      int i, j;

      for (i = 0, j = 0;
           i < listc;
           i += 3, j++) {

          ASSERT_BOUNDS (ATTR(i), listc);
          ASSERT_BOUNDS (j,       nodes);

          if (Tcl_ListObjGetElements (interp, listv [ATTR(i)],
                              &ac, &av) != TCL_OK) {
            return TCL_ERROR;
          }
          if ((ac % 2) != 0) {
            Tcl_AppendResult (interp,
                          "error in serialization: malformed attribute dictionary.",
                          NULL);
            return TCL_ERROR;
          }
      }
    }

    /* Iterate to locate the definition of root. Fails if there is none,
     * or more than one.
     */

    {
      int i, j;
      CONST char* parent;

      for (i = 0, j = 0, root = -1;
           i < listc;
           i += 3, j++) {
          /* j == i/3 */

          ASSERT_BOUNDS (PARENT(i), listc);
          ASSERT_BOUNDS (j,         nodes);

          parent = Tcl_GetString (listv [PARENT(i)]);

          if (0 == strcmp ("", parent)) {
            if (root >= 0) {
                Tcl_AppendResult (interp,
                              "error in serialization: multiple root nodes.",
                              NULL);
                return TCL_ERROR;
            }

            root = j;
          }
      }

      if (root < 0) {
          Tcl_AppendResult (interp,
                        "error in serialization: no root specified.",
                        NULL);
          return TCL_ERROR;
      }
    }

    /* Iterate again, check that the non-empty parent references
     * are ok. We use the information we have about root to skip
     * over the empty reference. We save the extracted and parsed
     * references in a temp. allocated array.
     */

    {
      int i, j, index, res;
      Tcl_Obj* p;

      parent = NALLOC (nodes, int);

      ASSERT_BOUNDS (root, nodes);
      parent [root] = -1; /* Sensible, unused */

      for (i = 0, j = 0;
           i < listc;
           i += 3, j++) {
          /* j == i/3 */

          ASSERT_BOUNDS (PARENT(i), listc);
          ASSERT_BOUNDS (j,         nodes);

          if (j == root)
            continue;

          p = listv [PARENT(i)];
          res = Tcl_GetIntFromObj (interp, p, &index);

          if (
            (res != TCL_OK) ||
            (index < 0) ||
            (index >= listc) ||
            ((index % 3) != 0)
            ) {
            Tcl_ResetResult (interp);
            Tcl_AppendResult (interp,
                          "error in serialization: bad parent reference \"",
                          Tcl_GetString (p),
                          "\".", NULL);
            ckfree ((char*) parent);
            return TCL_ERROR;
          }

          if (index == i) {
            /* Found a cyclic reference (direct cycle, node defines
             * itself as its parent)
             */

            Tcl_AppendResult (interp,
                          "error in serialization: cycle detected.",
                          NULL);
            ckfree ((char*) parent);
            return TCL_ERROR;
          }

          parent [j] = index/3;
      }
    }

    /* Iteration over the parent information from the last phase.  We
     * are looking for indirect cycles. We detect them indirectly. If
     * there are cycles we are unable to tag all nodes starting from the
     * root. A tag means that the depth of the node can be computed, and
     * for nodes in a cycle this is not possible.
     */

    {
      int* tag = NALLOC (nodes, int);
      int  i;
      int  changed = 1; /* Flag that last iteration tagged new nodes */
      int  done    = 0; /* #nodes tagged */

      for (i = 0; i < nodes; i++) {

          ASSERT_BOUNDS (i, nodes);
          tag [i] = 0;
      }

      ASSERT_BOUNDS (root, nodes);
      tag [root] = 1;
      done ++;

      while (changed) {
          changed = 0;

          for (i = 0; i < nodes; i++) {
            ASSERT_BOUNDS (i, nodes);
            if (tag [i])
                continue;

            /* Assert: parent [i] in 0 .. nodes-1 */
            ASSERT_BOUNDS (parent[i], nodes);
            if (!tag [parent [i]])
                continue;

            tag [i] = 1;
            changed = 1;
            done ++;
          }
      }

      ckfree ((char*) tag);

      if (done < nodes) {
          Tcl_AppendResult (interp,
                        "error in serialization: cycle detected.",
                        NULL);

          ckfree ((char*) parent);
          return TCL_ERROR;
      }
    }

    /* Last iteration. Check that the node names are unique.
     */

    {
      int         i, j, new;
      Tcl_HashTable nx;

      Tcl_InitHashTable (&nx, TCL_STRING_KEYS);

      for (i = 0, j = 0;
           i < listc;
           i += 3, j++) {

          ASSERT_BOUNDS (NAME(i), listc);
          ASSERT_BOUNDS (j,       nodes);

          Tcl_CreateHashEntry (&nx, Tcl_GetString (listv [NAME(i)]),
                         &new);

          if (!new) {
            Tcl_AppendResult (interp,
                          "error in serialization: duplicate node names.",
                          NULL);
            Tcl_DeleteHashTable(&nx);
            ckfree ((char*) parent);
            return TCL_ERROR;
          }
      }

      Tcl_DeleteHashTable(&nx);
    }

    /* The serialization has been successfully validated now.
     * We create the nodes, their attributes, and link them
     * into the proper structure per the root and parent
     * information provided to us by the validation.
     */

    {
      int i, j;
      TN** nv = NALLOC (nodes, TN*);
      TN* n;
      TN* p;

      tn_delete (dst->root);

      for (i = 0, j = 0;
           i < listc;
           i += 3, j++) {
          /* j == i/3 */

          ASSERT_BOUNDS (NAME(i), listc);
          ASSERT_BOUNDS (j,       nodes);

          nv [j] = tn_new (dst, Tcl_GetString (listv [NAME(i)]));
      }

      dst->root = nv [root];

      for (i = 0, j = 0;
           i < listc;
           i += 3, j++) {
          /* j == i/3 */

          ASSERT_BOUNDS (ATTR(i),   listc);
          ASSERT_BOUNDS (j,         nodes);

          if (j == root) {
            /* We don't append the node, this has already been covered,
             * but we have to process the attributes.
             */

            tn_set_attr (nv [j], interp, listv [ATTR(i)]);
            continue;
          }

          ASSERT_BOUNDS (parent[j], nodes);

          n = nv [j];
          p = nv [parent [j]];

          tn_append (p, n);
          tn_set_attr (n, interp, listv [ATTR(i)]);
      }

      ckfree ((char*) nv);
    }

    ckfree ((char*) parent);
    return TCL_OK;
}

/* .................................................. */

int
t_assign (T* dst, T* src)
{
    tn_delete (dst->root);
    dst->root = tn_dup (dst, src->root);
    return TCL_OK;
}

/* .................................................. */

CONST char*
t_newnodename (T* t)
{
    int ok;
    Tcl_HashEntry* he;

    do {
      t->counter ++;
      sprintf (t->handle, "node%d", t->counter);

      /* Check that there is no node using that name already */
      he = Tcl_FindHashEntry (&t->node, t->handle);
      ok = (he == NULL);
    } while (!ok);

    return t->handle;
}

/* .................................................. */

void
t_dump (TPtr t, FILE* f)
{
    /* Write the structural data of the
     * tree (i.e. internal pointers) to
     * the file, as aid in debugging
     */

    Tcl_HashSearch hs;
    Tcl_HashEntry* he;
    TNPtr n;

    fprintf (f, "T (%p) {\n",t);fflush(f);
    fprintf (f, ".   Lstart %p '%s'\n", t->leaves, t->leaves?Tcl_GetString(t->leaves->name):"");fflush(f);
    fprintf (f, ".   Nstart %p '%s'\n", t->nodes,  t->nodes ?Tcl_GetString(t->nodes ->name):"");fflush(f);

    for (he = Tcl_FirstHashEntry (&t->node, &hs);
       he != NULL;
       he = Tcl_NextHashEntry (&hs)) {
      n = (TNPtr) Tcl_GetHashValue(he);
      fprintf (f, ".   N [%p '%s']",n,Tcl_GetString(n->name))   ;fflush(f);
      fprintf (f, " %p",n->tree);fflush(f);
      fprintf (f, " %p '%s'",n->prevleaf,n->prevleaf?Tcl_GetString(n->prevleaf->name):"");fflush(f);
      fprintf (f, " %p '%s'",n->nextleaf,n->nextleaf?Tcl_GetString(n->nextleaf->name):"");fflush(f);
      fprintf (f, " %p '%s'",n->prevnode,n->prevnode?Tcl_GetString(n->prevnode->name):"");fflush(f);
      fprintf (f, " %p '%s'",n->nextnode,n->nextnode?Tcl_GetString(n->nextnode->name):"");fflush(f);
      fprintf (f, " %p '%s'",n->parent  ,n->parent  ?Tcl_GetString(n->parent->name)  :"");fflush(f);
      fprintf (f, "\n");fflush(f);
    }
    fprintf (f, "}\n");fflush(f);
}

/* .................................................. */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index