1# stackc.tcl --
2#
3#       Implementation of a stack 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) 2008 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: stack_c.tcl,v 1.1 2008/06/19 23:03:35 andreas_kupries Exp $
13
14package require critcl
15# @sak notprovided struct_stackc
16package provide struct_stackc 1.3.1
17package require Tcl 8.4
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 stack/*.h
28    critcl::csources stack/*.c
29
30    critcl::ccode {
31	/* -*- c -*- */
32
33	#include <util.h>
34	#include <s.h>
35	#include <ms.h>
36	#include <m.h>
37
38	/* .................................................. */
39	/* Global stack management, per interp
40	*/
41
42	typedef struct SDg {
43	    long int counter;
44	    char buf [50];
45	} SDg;
46
47	static void
48	SDgrelease (ClientData cd, Tcl_Interp* interp)
49	{
50	    ckfree((char*) cd);
51	}
52
53	static CONST char*
54	SDnewName (Tcl_Interp* interp)
55	{
56#define KEY "tcllib/struct::stack/critcl"
57
58	    Tcl_InterpDeleteProc* proc = SDgrelease;
59	    SDg*                  sdg;
60
61	    sdg = Tcl_GetAssocData (interp, KEY, &proc);
62	    if (sdg  == NULL) {
63		sdg = (SDg*) ckalloc (sizeof (SDg));
64		sdg->counter = 0;
65
66		Tcl_SetAssocData (interp, KEY, proc,
67				  (ClientData) sdg);
68	    }
69
70	    sdg->counter ++;
71	    sprintf (sdg->buf, "stack%d", sdg->counter);
72	    return sdg->buf;
73
74#undef  KEY
75	}
76
77	static void
78	SDdeleteCmd (ClientData clientData)
79	{
80	    /* Release the whole stack. */
81	    st_delete ((S*) clientData);
82	}
83    }
84
85    # Main command, stack creation.
86
87    critcl::ccommand stack_critcl {dummy interp objc objv} {
88      /* Syntax
89       *  - epsilon                         |1
90       *  - name                            |2
91       */
92
93      CONST char* name;
94      S*          sd;
95      Tcl_Obj*    fqn;
96      Tcl_CmdInfo ci;
97
98#define USAGE "?name?"
99
100      if ((objc != 2) && (objc != 1)) {
101        Tcl_WrongNumArgs (interp, 1, objv, USAGE);
102        return TCL_ERROR;
103      }
104
105      if (objc < 2) {
106        name = SDnewName (interp);
107      } else {
108        name = Tcl_GetString (objv [1]);
109      }
110
111      if (!Tcl_StringMatch (name, "::*")) {
112        /* Relative name. Prefix with current namespace */
113
114        Tcl_Eval (interp, "namespace current");
115        fqn = Tcl_GetObjResult (interp);
116        fqn = Tcl_DuplicateObj (fqn);
117        Tcl_IncrRefCount (fqn);
118
119        if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
120          Tcl_AppendToObj (fqn, "::", -1);
121        }
122        Tcl_AppendToObj (fqn, name, -1);
123      } else {
124        fqn = Tcl_NewStringObj (name, -1);
125        Tcl_IncrRefCount (fqn);
126      }
127      Tcl_ResetResult (interp);
128
129      if (Tcl_GetCommandInfo (interp,
130                              Tcl_GetString (fqn),
131                              &ci)) {
132        Tcl_Obj* err;
133
134        err = Tcl_NewObj ();
135        Tcl_AppendToObj    (err, "command \"", -1);
136        Tcl_AppendObjToObj (err, fqn);
137        Tcl_AppendToObj    (err, "\" already exists, unable to create stack", -1);
138
139        Tcl_DecrRefCount (fqn);
140        Tcl_SetObjResult (interp, err);
141        return TCL_ERROR;
142      }
143
144      sd = st_new();
145      sd->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
146				      stms_objcmd, (ClientData) sd,
147				      SDdeleteCmd);
148
149      Tcl_SetObjResult (interp, fqn);
150      Tcl_DecrRefCount (fqn);
151      return TCL_OK;
152    }
153}
154
155# ### ### ### ######### ######### #########
156## Ready
157