1# treec.tcl -- 2# 3# Implementation of a tree data structure for Tcl. 4# This code based on critcl, API compatible to the PTI [x]. 5# [x] Pure Tcl Implementation. 6# 7# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> 8# 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11# 12# RCS: @(#) $Id: tree_c.tcl,v 1.6 2008/03/25 07:15:34 andreas_kupries Exp $ 13 14package require critcl 15# @sak notprovided struct_treec 16package provide struct_treec 2.1.1 17package require Tcl 8.2 18 19namespace eval ::struct { 20 # Supporting code for the main command. 21 22 catch { 23 #critcl::cheaders -g 24 #critcl::debug memory symbols 25 } 26 27 critcl::cheaders tree/*.h 28 critcl::csources tree/*.c 29 30 critcl::ccode { 31 /* -*- c -*- */ 32 33 #include <util.h> 34 #include <t.h> 35 #include <tn.h> 36 #include <ms.h> 37 #include <m.h> 38 39 /* .................................................. */ 40 /* Global tree management, per interp 41 */ 42 43 typedef struct TDg { 44 long int counter; 45 char buf [50]; 46 } TDg; 47 48 static void 49 TDgrelease (ClientData cd, Tcl_Interp* interp) 50 { 51 ckfree((char*) cd); 52 } 53 54 static CONST char* 55 TDnewName (Tcl_Interp* interp) 56 { 57#define KEY "tcllib/struct::tree/critcl" 58 59 Tcl_InterpDeleteProc* proc = TDgrelease; 60 TDg* tdg; 61 62 tdg = Tcl_GetAssocData (interp, KEY, &proc); 63 if (tdg == NULL) { 64 tdg = (TDg*) ckalloc (sizeof (TDg)); 65 tdg->counter = 0; 66 67 Tcl_SetAssocData (interp, KEY, proc, 68 (ClientData) tdg); 69 } 70 71 tdg->counter ++; 72 sprintf (tdg->buf, "tree%d", tdg->counter); 73 return tdg->buf; 74 75#undef KEY 76 } 77 78 static void 79 TDdeleteCmd (ClientData clientData) 80 { 81 /* Release the whole tree. */ 82 t_delete ((T*) clientData); 83 } 84 } 85 86 # Main command, tree creation. 87 88 critcl::ccommand tree_critcl {dummy interp objc objv} { 89 /* Syntax 90 * - epsilon |1 91 * - name |2 92 * - name =|:=|as|deserialize source |4 93 */ 94 95 CONST char* name; 96 T* td; 97 Tcl_Obj* fqn; 98 Tcl_CmdInfo ci; 99 100#define USAGE "?name ?=|:=|as|deserialize source??" 101 102 if ((objc != 4) && (objc != 2) && (objc != 1)) { 103 Tcl_WrongNumArgs (interp, 1, objv, USAGE); 104 return TCL_ERROR; 105 } 106 107 if (objc < 2) { 108 name = TDnewName (interp); 109 } else { 110 name = Tcl_GetString (objv [1]); 111 } 112 113 if (!Tcl_StringMatch (name, "::*")) { 114 /* Relative name. Prefix with current namespace */ 115 116 Tcl_Eval (interp, "namespace current"); 117 fqn = Tcl_GetObjResult (interp); 118 fqn = Tcl_DuplicateObj (fqn); 119 Tcl_IncrRefCount (fqn); 120 121 if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { 122 Tcl_AppendToObj (fqn, "::", -1); 123 } 124 Tcl_AppendToObj (fqn, name, -1); 125 } else { 126 fqn = Tcl_NewStringObj (name, -1); 127 Tcl_IncrRefCount (fqn); 128 } 129 Tcl_ResetResult (interp); 130 131 if (Tcl_GetCommandInfo (interp, 132 Tcl_GetString (fqn), 133 &ci)) { 134 Tcl_Obj* err; 135 136 err = Tcl_NewObj (); 137 Tcl_AppendToObj (err, "command \"", -1); 138 Tcl_AppendObjToObj (err, fqn); 139 Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); 140 141 Tcl_DecrRefCount (fqn); 142 Tcl_SetObjResult (interp, err); 143 return TCL_ERROR; 144 } 145 146 if (objc == 4) { 147 Tcl_Obj* type = objv[2]; 148 Tcl_Obj* src = objv[3]; 149 int srctype; 150 151 static CONST char* types [] = { 152 ":=", "=", "as", "deserialize", NULL 153 }; 154 enum types { 155 T_ASSIGN, T_IS, T_AS, T_DESER 156 }; 157 158 if (Tcl_GetIndexFromObj (interp, type, types, "type", 159 0, &srctype) != TCL_OK) { 160 Tcl_DecrRefCount (fqn); 161 Tcl_ResetResult (interp); 162 Tcl_WrongNumArgs (interp, 1, objv, USAGE); 163 return TCL_ERROR; 164 } 165 166 td = t_new (); 167 168 switch (srctype) { 169 case T_ASSIGN: 170 case T_AS: 171 case T_IS: 172 if (tms_assign (interp, td, src) != TCL_OK) { 173 t_delete (td); 174 Tcl_DecrRefCount (fqn); 175 return TCL_ERROR; 176 } 177 break; 178 179 case T_DESER: 180 if (t_deserialize (td, interp, src) != TCL_OK) { 181 t_delete (td); 182 Tcl_DecrRefCount (fqn); 183 return TCL_ERROR; 184 } 185 break; 186 } 187 } else { 188 td = t_new (); 189 } 190 191 td->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), 192 tms_objcmd, (ClientData) td, 193 TDdeleteCmd); 194 195 Tcl_SetObjResult (interp, fqn); 196 Tcl_DecrRefCount (fqn); 197 return TCL_OK; 198 } 199 200 namespace eval tree { 201 critcl::ccommand prune_critcl {dummy interp objc objv} { 202 return 5; 203 } 204 } 205} 206 207# ### ### ### ######### ######### ######### 208## Ready 209