File: graph_c.tcl

package info (click to toggle)
tcllib 1.20%2Bdfsg-1
  • links: PTS
  • area: main
  • in suites: bullseye
  • size: 68,064 kB
  • sloc: tcl: 216,842; ansic: 14,250; sh: 2,846; xml: 1,766; yacc: 1,145; pascal: 881; makefile: 107; perl: 84; f90: 84; python: 33; ruby: 13; php: 11
file content (158 lines) | stat: -rw-r--r-- 3,683 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
# graphc.tcl --
#
#       Implementation of a graph data structure for Tcl.
#       This code based on critcl, API compatible to the PTI [x].
#       [x] Pure Tcl Implementation.
#
# Copyright (c) 2006,2019 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.

package require critcl
# @sak notprovided struct_graphc
package provide struct_graphc 2.4.3
package require Tcl 8.2

namespace eval ::struct {
    # Supporting code for the main command.

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

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

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

	#include <global.h>
	#include <objcmd.h>
	#include <graph.h>

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

	static void gg_delete (ClientData clientData)
	{
	    /* Release the whole graph. */
	    g_delete ((G*) clientData);
	}
    }

    # Main command, graph creation.

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

	CONST char* name;
	G*          g;
	Tcl_Obj*    fqn;
	Tcl_CmdInfo ci;

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

	if (objc < 2) {
	    name = gg_new (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_ResetResult (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 graph", -1);

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

	if (objc == 4) {
	    /* Construction with immediate initialization */
	    /* through deserialization */

	    Tcl_Obj* type = objv[2];
	    Tcl_Obj* src  = objv[3];
	    int      srctype;

	    static CONST char* types [] = {
		":=", "=", "as", "deserialize", NULL
	    };
	    enum types {
		G_ASSIGN, G_IS, G_AS, G_DESER
	    };

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

	    g = g_new ();

	    switch (srctype) {
		case G_ASSIGN:
		case G_AS:
		case G_IS:
		if (g_ms_assign (interp, g, src) != TCL_OK) {
		    g_delete (g);
		    Tcl_DecrRefCount (fqn);
		    return TCL_ERROR;
		}
		break;

		case G_DESER:
		if (g_deserialize (g, interp, src) != TCL_OK) {
		    g_delete (g);
		    Tcl_DecrRefCount (fqn);
		    return TCL_ERROR;
		}
		break;
	    }
	} else {
	    g = g_new ();
	}

	g->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
                                       g_objcmd, (ClientData) g,
                                       gg_delete);

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

# ### ### ### ######### ######### #########
## Ready