This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/packages/chr/chr_support.c
2015-10-13 08:17:51 +01:00

106 lines
2.2 KiB
C

#include <SWI-Prolog.h>
#include <stdlib.h>
#include <ctype.h>
/*
lookup_ht(HT,Key,Values) :-
term_hash(Key,Hash),
HT = ht(Capacity,_,Table),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
nonvar(Bucket),
( Bucket = K-Vs ->
K == Key,
Values = Vs
;
lookup(Bucket,Key,Values)
).
lookup([K - V | KVs],Key,Value) :-
( K = Key ->
V = Value
;
lookup(KVs,Key,Value)
).
*/
static foreign_t
pl_lookup_ht1(term_t ht, term_t pl_hash, term_t key, term_t values)
{
int capacity;
int hash;
int index;
term_t pl_capacity = PL_new_term_ref();
term_t table = PL_new_term_ref();
term_t bucket = PL_new_term_ref();
/* HT = ht(Capacity,_,Table) */
PL_get_arg(1, ht, pl_capacity);
PL_get_integer(pl_capacity, &capacity);
PL_get_arg(3, ht, table);
/* Index is (Hash mod Capacity) + 1 */
PL_get_integer(pl_hash, &hash);
index = (hash % capacity) + 1;
/* arg(Index,Table,Bucket) */
PL_get_arg(index, table, bucket);
/* nonvar(Bucket) */
if (PL_is_variable(bucket)) PL_fail;
if (PL_is_list(bucket)) {
term_t pair = PL_new_term_ref();
term_t k = PL_new_term_ref();
term_t vs = PL_new_term_ref();
while (PL_get_list(bucket, pair,bucket)) {
PL_get_arg(1, pair, k);
if ( PL_compare(k,key) == 0 ) {
/* Values = Vs */
PL_get_arg(2, pair, vs);
return PL_unify(values,vs);
}
}
PL_fail;
} else {
term_t k = PL_new_term_ref();
term_t vs = PL_new_term_ref();
PL_get_arg(1, bucket, k);
/* K == Key */
if ( PL_compare(k,key) == 0 ) {
/* Values = Vs */
PL_get_arg(2, bucket, vs);
return PL_unify(values,vs);
} else {
PL_fail;
}
}
}
static foreign_t
pl_memberchk_eq(term_t element, term_t maybe_list)
{
term_t head = PL_new_term_ref(); /* variable for the elements */
term_t list = PL_copy_term_ref(maybe_list); /* copy as we need to write */
while( PL_get_list(list, head, list) )
{ if ( PL_compare(element,head) == 0 )
PL_succeed ;
}
PL_fail;
}
/* INSTALL */
install_t
install_chr_support()
{
PL_register_foreign("memberchk_eq",2, pl_memberchk_eq, 0);
PL_register_foreign("lookup_ht1",4, pl_lookup_ht1, 0);
}