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(©_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(©_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