1/* BEGIN LICENSE BLOCK
2 * Version: CMPL 1.1
3 *
4 * The contents of this file are subject to the Cisco-style Mozilla Public
5 * License Version 1.1 (the "License"); you may not use this file except
6 * in compliance with the License.  You may obtain a copy of the License
7 * at www.eclipse-clp.org/license.
8 *
9 * Software distributed under the License is distributed on an "AS IS"
10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
11 * the License for the specific language governing rights and limitations
12 * under the License.
13 *
14 * The Original Code is  The ECLiPSe Constraint Logic Programming System.
15 * The Initial Developer of the Original Code is  Cisco Systems, Inc.
16 * Portions created by the Initial Developer are
17 * Copyright (C) 1996-2006 Cisco Systems, Inc.  All Rights Reserved.
18 *
19 * Contributor(s):
20 *
21 * END LICENSE BLOCK */
22
23/*----------------------------------------------------------------------
24 * System:	ECLiPSe Constraint Logic Programming System
25 * Version:	$Id: bip_bag.c,v 1.1 2008/06/30 17:43:51 jschimpf Exp $
26 *
27 * Contents:	Built-ins for the bag-primitives
28 *
29 *		This file has been factored out of bip_record.c in 05/2006
30 *----------------------------------------------------------------------*/
31
32#include	"config.h"
33#include        "sepia.h"
34#include        "types.h"
35#include        "embed.h"
36#include        "mem.h"
37#include        "error.h"
38#include	"dict.h"
39
40#include        <stdio.h>	/* for sprintf() */
41
42/*----------------------------------------------------------------------
43 * Bag primitives:
44 *
45 * bag_create(-Bag)
46 * bag_enter(+Bag, +Term)
47 * bag_dissolve(+Bag, -List)
48 * CAUTION: The bag can no longer be accessed after bag_dissolve/2 !
49 *
50 * empty bag:	pword *pw1 = {TLIST|pw1, TNIL}
51 *
52 * 3-elem bag:	pword *pw1 = {TLIST|pw4, TLIST|pw2}
53 *		pword *pw2 = {Term1,     TLIST|pw3}
54 *		pword *pw3 = {Term2,     TLIST|pw4}
55 *		pword *pw4 = {Term3,     TNIL}
56 *
57 *----------------------------------------------------------------------*/
58
59
60/* INSTANCE TYPE DECLARATION */
61
62typedef struct {
63    pword		list[2];
64    uword		size;
65    uword		ref_ctr;
66} t_heap_bag;
67
68
69/* METHODS */
70static void _free_heap_bag(t_heap_bag *obj);
71static t_heap_bag * _copy_heap_bag(t_heap_bag *obj);
72static void _mark_heap_bag(t_heap_bag *obj);
73static int _tostr_heap_bag(t_heap_bag *obj, char *buf, int quoted);
74static int _strsz_heap_bag(t_heap_bag *obj, int quoted);
75
76static void
77_erase_heap_bag(t_heap_bag *obj)	/* obj != NULL */
78{
79    pword cdr;
80    cdr = obj->list[1];
81    while (IsList(cdr.tag))
82    {
83	pword *pw = cdr.val.ptr;
84	free_heapterm(pw);
85	cdr = pw[1];
86	hg_free_size((generic_ptr)(pw), 2*sizeof(pword));
87    }
88    Make_List(obj->list, obj->list);	/* reinitialize */
89    Make_Nil(&obj->list[1]);
90    obj->size = 0;
91}
92
93static void
94_free_heap_bag(t_heap_bag *obj)		/* obj != NULL */
95{
96    if (--obj->ref_ctr <= 0)
97    {
98	_erase_heap_bag(obj);
99	hg_free_size(obj, sizeof(t_heap_bag));
100#ifdef DEBUG_RECORD
101	p_fprintf(current_err_, "\n_free_heap_bag(0x%x)", obj);
102	ec_flush(current_err_);
103#endif
104    }
105}
106
107static t_heap_bag *
108_copy_heap_bag(t_heap_bag *obj)		/* obj != NULL */
109{
110    ++obj->ref_ctr;
111    return obj;
112}
113
114static void
115_mark_heap_bag(t_heap_bag *obj)		/* obj != NULL */
116{
117    pword *pw = obj->list;
118    while (IsList(pw[1].tag))		/* for all bag elements */
119    {
120	pw = pw[1].val.ptr;
121	mark_dids_from_heapterm(pw);
122    }
123}
124
125
126static int
127_tostr_heap_bag(t_heap_bag *obj, char *buf, int quoted)	/* obj != NULL */
128{
129#define STRSZ_BAG 18
130    sprintf(buf, "'BAG'(16'%08x)", (int)(word) obj);	/* possibly truncated */
131    return STRSZ_BAG;
132}
133
134
135static int
136_strsz_heap_bag(t_heap_bag *obj, int quoted)	/* obj != NULL */
137{
138    return STRSZ_BAG;
139}
140
141
142/* CLASS DESCRIPTOR (method table) */
143
144t_ext_type heap_bag_tid = {
145    (void (*)(t_ext_ptr)) _free_heap_bag,
146    (t_ext_ptr (*)(t_ext_ptr)) _copy_heap_bag,
147    (void (*)(t_ext_ptr)) _mark_heap_bag,
148    (int (*)(t_ext_ptr,int)) _strsz_heap_bag,
149    (int (*)(t_ext_ptr,char *,int)) _tostr_heap_bag,
150    0,	/* equal */
151    (t_ext_ptr (*)(t_ext_ptr)) _copy_heap_bag,
152    0,	/* get */
153    0	/* set */
154};
155
156
157/* PROLOG INTERFACE */
158
159static int
160p_bag_create(value vbag, type tbag)
161{
162    t_heap_bag *obj;
163    pword bag;
164
165    Check_Ref(tbag);
166
167    /* INSTANCE INITIALISATION */
168    obj = (t_heap_bag *) hg_alloc_size(sizeof(t_heap_bag));
169    obj->size = 0;
170    obj->ref_ctr = 1;
171    Make_List(obj->list, obj->list);	/* pointer to last element (self) */
172    Make_Nil(&obj->list[1]);
173    bag = ec_handle(&heap_bag_tid, (t_ext_ptr) obj);
174    Return_Unify_Pw(vbag, tbag, bag.val, bag.tag);
175}
176
177static int
178p_bag_enter(value vbag, type tbag, value vterm, type tterm)
179{
180    t_heap_bag *obj;
181    pword copy_pw, *pw;
182    int err;
183
184    Get_Typed_Object(vbag, tbag, &heap_bag_tid, obj);
185
186    if ((err = create_heapterm(&copy_pw, vterm, tterm)) != PSUCCEED)
187	{ Bip_Error(err); }
188    a_mutex_lock(&SharedDataLock);
189    pw = (pword *) hg_alloc_size(2*sizeof(pword));
190    move_heapterm(&copy_pw, pw);
191    Make_Nil(pw + 1);
192    Make_List(obj->list[0].val.ptr + 1, pw);
193    obj->list[0].val.ptr = pw;
194    ++obj->size;
195    a_mutex_unlock(&SharedDataLock);
196    Succeed_;
197}
198
199static int
200p_bag_retrieve(value vbag, type tbag, value vl, type tl)
201{
202    t_heap_bag *obj;
203    pword list;
204    register pword *car, *cdr, *pw;
205
206    Get_Typed_Object(vbag, tbag, &heap_bag_tid, obj);
207    Check_Output_List(tl);
208    pw = &obj->list[1];
209    cdr = &list;
210    while (IsList(pw->tag))
211    {
212	pw = pw->val.ptr;
213        car = TG;
214        Push_List_Frame();
215        Make_List(cdr, car);
216	get_heapterm(pw, car);
217        cdr = car + 1;
218	pw += 1;
219    }
220    Make_Nil(cdr);
221    Return_Unify_Pw(vl, tl, list.val, list.tag);
222}
223
224static int
225p_bag_erase(value vbag, type tbag)
226{
227    t_heap_bag *obj;
228    Get_Typed_Object(vbag, tbag, &heap_bag_tid, obj);
229    _erase_heap_bag(obj);
230    Succeed_;
231}
232
233static int
234p_bag_count(value vbag, type tbag, value vc, type tc)
235{
236    t_heap_bag *obj;
237    Check_Output_Integer(tc);
238    Get_Typed_Object(vbag, tbag, &heap_bag_tid, obj);
239    Return_Unify_Integer(vc, tc, obj->size);
240}
241
242static int
243p_bag_dissolve(value vbag, type tbag, value vl, type tl)
244{
245    int res = p_bag_retrieve(vbag, tbag, vl, tl);
246    p_handle_free(vbag, tbag);
247    return res;
248}
249
250
251/*----------------------------------------------------------------------
252 * Initialisation
253 *----------------------------------------------------------------------*/
254
255void
256bip_bag_init(int flags)
257{
258    if (flags & INIT_SHARED)
259    {
260	(void) built_in(in_dict("bag_create", 1), p_bag_create, B_SAFE|U_SIMPLE);
261	(void) built_in(in_dict("bag_enter", 2), p_bag_enter, B_SAFE|U_NONE);
262	(void) built_in(in_dict("bag_count", 2), p_bag_count, B_SAFE|U_NONE);
263	(void) built_in(in_dict("bag_erase", 1), p_bag_erase, B_SAFE|U_NONE);
264	(void) built_in(in_dict("bag_retrieve", 2), p_bag_retrieve, B_UNSAFE|U_FRESH);
265	(void) built_in(in_dict("bag_dissolve", 2), p_bag_dissolve, B_UNSAFE|U_FRESH);
266	(void) built_in(in_dict("bag_abolish", 1), p_handle_free, B_SAFE|U_NONE);
267    }
268}
269
270