summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/struct/sets/m.c
diff options
context:
space:
mode:
Diffstat (limited to 'tcllib/modules/struct/sets/m.c')
-rw-r--r--tcllib/modules/struct/sets/m.c772
1 files changed, 772 insertions, 0 deletions
diff --git a/tcllib/modules/struct/sets/m.c b/tcllib/modules/struct/sets/m.c
new file mode 100644
index 0000000..820435e
--- /dev/null
+++ b/tcllib/modules/struct/sets/m.c
@@ -0,0 +1,772 @@
+/* struct::set - critcl - layer 3 definitions.
+ *
+ * -> Set functions.
+ * Implementations for all set commands.
+ */
+
+#include "s.h"
+#include "m.h"
+
+/* .................................................. */
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_ADD --
+ *
+ * Copies the argument tree over into this tree object. Uses direct
+ * access to internal data structures for matching tree objects, and
+ * goes through a serialize/deserialize combination otherwise.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Only internal, memory allocation changes ...
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_ADD (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set add SETVAR SET
+ * [0] [1] [2] [3]
+ */
+
+ SPtr vs, s;
+ Tcl_Obj* val;
+ int new = 0;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[3], &s) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
+ if (val == NULL) {
+ /* Create missing variable */
+
+ vs = s_dup (NULL);
+ val = s_new (vs);
+ (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
+
+ } else if (s_get (interp, val, &vs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (s->el.numEntries) {
+ int new, nx = 0;
+ Tcl_HashSearch hs;
+ Tcl_HashEntry* he;
+ CONST char* key;
+
+ for(he = Tcl_FirstHashEntry(&s->el, &hs);
+ he != NULL;
+ he = Tcl_NextHashEntry(&hs)) {
+ key = Tcl_GetHashKey (&s->el, he);
+ if (Tcl_FindHashEntry (&vs->el, key) != NULL) continue;
+ /* Key not known to vs, to be added */
+
+ /* _Now_ unshare the object, if required */
+
+ if (Tcl_IsShared (val)) {
+ val = Tcl_DuplicateObj (val);
+ (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
+ s_get (interp, val, &vs);
+ }
+
+ (void*) Tcl_CreateHashEntry(&vs->el, key, &new);
+ nx = 1;
+ }
+ if (nx) {
+ Tcl_InvalidateStringRep(val);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_CONTAINS --
+ *
+ * Copies this tree over into the argument tree. Uses direct access to
+ * internal data structures for matching tree objects, and goes through a
+ * serialize/deserialize combination otherwise.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Only internal, memory allocation changes ...
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_CONTAINS (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set contains SET ITEM
+ * [0] [1] [2] [3]
+ */
+
+ SPtr s;
+ CONST char* item;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "set item");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &s) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ item = Tcl_GetString (objv [3]);
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewIntObj (s_contains (s, item)));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_DIFFERENCE --
+ *
+ * Returns a list containing the ancestors of the named node.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_DIFFERENCE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set difference SETa SETb
+ * [0] [1] [2] [3]
+ */
+
+ SPtr sa, sb;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "A B");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, objv[3], &sb) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ s_new (s_difference (sa, sb)));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_EMPTY --
+ *
+ * Appends a value to an attribute of the named node.
+ * May create the attribute.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_EMPTY (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set empty SET
+ * [0] [1] [2]
+ */
+
+ SPtr s;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "set");
+ return TCL_ERROR;
+ }
+
+ if (objv[2]->typePtr == s_ltype ()) {
+ int lc;
+ Tcl_Obj** lv;
+ Tcl_ListObjGetElements(interp, objv[2], &lc, &lv);
+ Tcl_SetObjResult (interp, Tcl_NewIntObj (lc == 0));
+ return TCL_OK;
+ }
+
+ if (s_get (interp, objv[2], &s) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewIntObj (s_empty (s)));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_EQUAL --
+ *
+ * Returns a dictionary mapping from nodes to attribute values, for a
+ * named attribute.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_EQUAL (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set equal SETa SETb
+ * [0] [1] [2] [3]
+ */
+
+ SPtr sa, sb;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "A B");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, objv[3], &sb) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewIntObj (s_equal (sa, sb)));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_EXCLUDE --
+ *
+ * Returns a list of all direct or indirect descendants of the named
+ * node, possibly run through a Tcl command prefix for filtering.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory. Per the filter command prefix, if
+ * one has been specified.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_EXCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set exclude SETVAR ITEM
+ * [0] [1] [2] [3]
+ */
+
+ SPtr vs;
+ Tcl_Obj* val;
+ char* key;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
+ return TCL_ERROR;
+ }
+
+ val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
+ if (val == NULL) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, val, &vs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ key = Tcl_GetString (objv[3]);
+ if (s_contains (vs, key)) {
+ if (Tcl_IsShared (val)) {
+ val = Tcl_DuplicateObj (val);
+ (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
+ s_get (interp, val, &vs);
+ }
+
+ s_subtract1 (vs, key);
+ Tcl_InvalidateStringRep(val);
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_INCLUDE --
+ *
+ * Deletes the named nodes, but not its children. They are put into the
+ * place where the deleted node was. Complementary to sm_SPLICE.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_INCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set include SETVAR ITEM
+ * [0] [1] [2] [3]
+ */
+
+ SPtr vs;
+ Tcl_Obj* val;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
+ return TCL_ERROR;
+ }
+
+ val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
+ if (val == NULL) {
+ /* Create missing variable */
+
+ vs = s_dup (NULL);
+ s_add1 (vs, Tcl_GetString (objv[3]));
+ val = s_new (vs);
+
+ (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
+ } else {
+ /* Extend variable */
+ char* key;
+
+ if (s_get (interp, val, &vs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ key = Tcl_GetString (objv[3]);
+ if (!s_contains (vs, key)) {
+ if (Tcl_IsShared (val)) {
+ val = Tcl_DuplicateObj (val);
+ (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
+ s_get (interp, val, &vs);
+ }
+
+ s_add1 (vs, key);
+ Tcl_InvalidateStringRep(val);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_INTERSECT --
+ *
+ * Deletes the named node and its children.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_INTERSECT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set intersect ?SET...?
+ * [0] [1] [2]
+ */
+
+ SPtr sa, sb, next, acc;
+ int i;
+
+ if (objc == 2) {
+ /* intersect nothing = nothing */
+ Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
+ return TCL_OK;
+ }
+
+ for (i = 2; i < objc; i++) {
+ if (s_get (interp, objv[i], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ s_get (interp, objv[2], &sa);
+
+ if (objc == 3) {
+ /* intersect with itself = unchanged */
+ Tcl_SetObjResult (interp, s_new (s_dup (sa)));
+ return TCL_OK;
+ }
+
+ acc = sa;
+ for (i = 3; i < objc; i++) {
+ s_get (interp, objv[i], &sb);
+ next = s_intersect (acc, sb);
+ if (acc != sa) s_free (acc);
+ acc = next;
+ if (s_empty (acc)) break;
+ }
+
+ if (acc == sa) {
+ acc = s_dup (acc);
+ }
+
+ Tcl_SetObjResult (interp, s_new (acc));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_INTERSECT3 --
+ *
+ * Returns a non-negative integer number describing the distance between
+ * the named node and the root of the tree. A depth of 0 implies that
+ * the node is the root node.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_INTERSECT3 (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set intersect3 SETa SETb
+ * [0] [1] [2] [3]
+ */
+
+ SPtr sa, sb;
+ Tcl_Obj* lv [3];
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "A B");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, objv[3], &sb) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ lv [0] = s_new (s_intersect (sa, sb));
+ lv [1] = s_new (s_difference (sa, sb));
+ lv [2] = s_new (s_difference (sb, sa));
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_SIZE --
+ *
+ * Returns a list of all descendants of the named node, possibly run
+ * through a Tcl command prefix for filtering.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory. Per the filter command prefix, if
+ * one has been specified.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_SIZE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set size SET
+ * [0] [1] [2]
+ */
+
+ SPtr s;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "set");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &s) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewIntObj (s_size (s)));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_SUBSETOF --
+ *
+ * Parses a Tcl value containing a serialized tree and copies it over
+ * he existing tree.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_SUBSETOF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set subsetof SETa SETb
+ * [0] [1] [2] [3]
+ */
+
+ SPtr sa, sb;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "A B");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, objv[3], &sb) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewIntObj (s_subsetof (sa, sb)));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_SUBTRACT --
+ *
+ * Destroys the whole tree object.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Releases memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_SUBTRACT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set subtract SETVAR SET
+ * [0] [1] [2] [3]
+ */
+
+ SPtr vs, s;
+ Tcl_Obj* val;
+ int del;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
+ return TCL_ERROR;
+ }
+
+ val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
+ if (val == NULL) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, val, &vs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, objv[3], &s) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (s->el.numEntries) {
+ int new, dx = 0;
+ Tcl_HashSearch hs;
+ Tcl_HashEntry* he;
+ CONST char* key;
+
+ for(he = Tcl_FirstHashEntry(&s->el, &hs);
+ he != NULL;
+ he = Tcl_NextHashEntry(&hs)) {
+ key = Tcl_GetHashKey (&s->el, he);
+ if (Tcl_FindHashEntry (&vs->el, key) == NULL) continue;
+ /* Key known to vs, to be removed */
+
+ /* _Now_ unshare the object, if required */
+
+ if (Tcl_IsShared (val)) {
+ val = Tcl_DuplicateObj (val);
+ (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
+ s_get (interp, val, &vs);
+ }
+
+ Tcl_DeleteHashEntry (Tcl_FindHashEntry (&vs->el, key));
+ dx = 1;
+ }
+ if (dx) {
+ Tcl_InvalidateStringRep(val);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_SYMDIFF --
+ *
+ * Returns a boolean value signaling whether the named node exists in
+ * the tree. True implies existence, and false non-existence.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_SYMDIFF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set symdiff SETa SETb
+ * [0] [1] [2] [3]
+ */
+
+ SPtr sa, sb, xa, xb, u;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "A B");
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, objv[3], &sb) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (s_get (interp, objv[2], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (s_get (interp, objv[3], &sb) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ xa = s_difference (sa, sb);
+ xb = s_difference (sb, sa);
+ u = s_union (xa, xb);
+
+ s_free (xa);
+ s_free (xb);
+
+ Tcl_SetObjResult (interp, s_new (u));
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * sm_UNION --
+ *
+ * Returns the value of the named attribute at the given node.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May release and allocate memory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+sm_UNION (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: set union ?SET...?
+ * [0] [1] [2]
+ */
+
+ SPtr sa, acc;
+ int i;
+
+ if (objc == 2) {
+ /* union nothing = nothing */
+ Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
+ return TCL_OK;
+ }
+
+ for (i = 2; i < objc; i++) {
+ if (s_get (interp, objv[i], &sa) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ acc = s_dup (NULL);
+
+ for (i = 2; i < objc; i++) {
+ s_get (interp, objv[i], &sa);
+ s_add (acc, sa, NULL);
+ }
+
+ Tcl_SetObjResult (interp, s_new (acc));
+ return TCL_OK;
+}
+
+/* .................................................. */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
generated by cgit v0.12 at 2024-11-01 22:09:26 (GMT)