/*-------------------------------------------------------------------------*/
/* Prolog To Wam Compiler INRIA Rocquencourt - ChLoE Project */
/* C Run-time Daniel Diaz - 1991 */
/* */
/* Atoms and Predicates Tables Management */
/* */
/* atom_pred.c */
/*-------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#define ATOM_PRED
#include "wam_engine.h"
/*---------------------------------*/
/* Constants */
/*---------------------------------*/
#define BLOCK_SIZE 32
#define NO_INDEX 0
#define VAR_INDEX 1
#define CST_INDEX 2
#define INT_INDEX 3
#define LST_INDEX 4
#define STC_INDEX 5
/*---------------------------------*/
/* Type Definitions */
/*---------------------------------*/
/*---------------------------------*/
/* Global Variables */
/*---------------------------------*/
int char_type[256]= {
/* nul soh stx etx eot enq ack bel bs ht nl vt np cr so si */
EOF,LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA,
/* dle dc1 dc2 dc3 dc4 nak syn etb can em sub esc fs gs rs us */
LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA, LA,
/* spc ! " # $ % & ' ( ) * + , - . / */
LA, SC, DQ, SY, SY, CM, SY, QT, PC, PC, SY, SY, PC, SY, SY, SY,
/* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */
DI, DI, DI, DI, DI, DI, DI, DI, DI, DI, SY, SC, SY, SY, SY, SY,
/* @ A B C D E F G H I J K L M N O */
SY, CL, CL, CL, CL, CL, CL, CL, CL, CL, CL, CL, CL, CL, CL, CL,
/* P Q R S T U V W X Y Z [ \ ] ^ _ */
CL, CL, CL, CL, CL, CL, CL, CL, CL, CL, CL, PC, SY, PC, SY, UL,
/* ` a b c d e f g h i j k l m n o */
BQ, SL, SL, SL, SL, SL, SL, SL, SL, SL, SL, SL, SL, SL, SL, SL,
/* p q r s t u v w x y z { | } ~ del */
SL, SL, SL, SL, SL, SL, SL, SL, SL, SL, SL, PC, PC, PC, SY, LA
/* 0x80 ... 0xff = 0 (!=EOF since EOF== -1) */
};
/* dynamic clause management variables */
#ifdef CDEBUG
static PredInf *last_pred;
#endif
/*---------------------------------*/
/* Function Prototypes */
/*---------------------------------*/
static
Bool G_Assign_Element (GVarElt *g_elem,WamWord gval_word,
Bool backtrack,Bool copy);
static
Bool G_Assign_Array (GVarElt *g_elem,WamWord *stc_adr,
Bool extend,Bool copy);
static
void G_Free_Element (GVarElt *g_elem);
static
void G_Copy_Element (GVarElt *dst_g_elem,GVarElt *src_g_elem);
static
void G_Untrail (void);
static
WamWord G_Read_Element (GVarElt *g_elem,WamWord gval_word);
static
GVarElt *G_Get_Element (WamWord gvar_word);
static
void Extend_HTable (char **t);
static
PredInf *Get_Pred_And_Index (WamWord start_word,
int *index_nb,long *key,Bool create);
static
void Add_To_List (long **list,long **to_add,Bool asserta);
#ifdef CDEBUG /* to debug the program */
static
void Verify_Dynamic_Clauses(void);
static
void Verify_List (long *p,int index_nb);
static
void Verify_Hash (char *t,int index_nb);
#endif
#define Init_Dynamic_Info(dyn) \
{ \
dyn->seq_chain=dyn->var_ind_chain=dyn->lst_ind_chain=NULL; \
dyn->cst_htbl=dyn->int_htbl=dyn->stc_htbl=NULL; \
dyn->count_a= -1; \
dyn->count_z= 0; \
dyn->consult_count=consult_count; \
}
/*-------------------------------------------------------------------------*/
/* INIT_ATOM_PRED */
/* */
/*-------------------------------------------------------------------------*/
void Init_Atom_Pred(void)
{
atom_tbl=Hash_Table(MAX_ATOM_TBL_SIZE,sizeof(AtomInf),0);
if (atom_tbl==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
atom_nil =Create_Atom("[]");
atom_dot =Create_Atom(".");
atom_curly_brackets=Create_Atom("{}");
atom_fail =Create_Atom("fail");
atom_g_array =Create_Atom("g_array");
atom_g_array_extend=Create_Atom("g_array_extend");
atom_inf =Create_Atom("<");
atom_eq =Create_Atom("=");
atom_sup =Create_Atom(">");
atom_compiler =Create_Atom(COMPILER);
atom_wam_version =Create_Atom(WAM_VERSION);
pred_tbl=Hash_Table(MAX_PRED_TBL_SIZE,sizeof(PredInf),sizeof(long));
if (pred_tbl==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
oper_tbl=Hash_Table(MAX_OPER_TBL_SIZE,sizeof(OperInf),sizeof(long));
if (oper_tbl==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
consult_count=0;
}
/*-------------------------------------------------------------------------*/
/* CREATE_ALLOCATE_ATOM */
/* */
/*-------------------------------------------------------------------------*/
AtomInf *Create_Allocate_Atom(char *name)
{
char *name1;
name1=(char *) Lib1(strdup,name);
return Create_Atom(name1);
}
/*-------------------------------------------------------------------------*/
/* CREATE_ATOM */
/* */
/*-------------------------------------------------------------------------*/
AtomInf *Create_Atom(char *name)
{
AtomInf atom_info;
AtomInf *atom;
char *p;
int c_type;
int lg;
Bool indentifier;
Bool symbols;
if (atom=(AtomInf *) Hash_Lookup(atom_tbl,(char *) (&name),H_FIND))
return atom; /* already exists */
atom_info.name =name;
atom_info.has_quote =FALSE;
indentifier=(*name && char_type[*name]==SL); /* small letter */
symbols =(*name);
for(lg=0,p=name;*p;p++)
{
c_type=char_type[*p];
if ((c_type & (UL | CL | SL | DI))==0)
indentifier=FALSE;
if (c_type!=SY)
symbols=FALSE;
if (c_type==QT)
atom_info.has_quote=TRUE;
}
lg=p-name;
if (indentifier)
{
atom_info.type=IDENTIFIER_ATOM;
atom_info.needs_quote=FALSE;
}
else
if (symbols)
{
atom_info.type=SYMBOL_ATOM;
atom_info.needs_quote=(lg==1 && *name=='.');
}
else
if (lg==1 && char_type[*name]==SC)
{
atom_info.type=SOLO_ATOM;
atom_info.needs_quote=FALSE;
}
else
{
atom_info.type=OTHER_ATOM;
atom_info.needs_quote=! (lg==2 &&
(name[0]=='[' && name[1]==']' ||
name[0]=='{' && name[1]=='}') );
}
atom_info.length=lg;
atom_info.g_elem.size=0;
atom_info.g_elem.val =G_VAR_INITIAL_VALUE;
atom=(AtomInf *) Hash_Lookup(atom_tbl,(char *) &atom_info,H_UPDATE);
if ((long) atom == -1)
Fatal_Error(ERR_ATOM_TBL_FULL);
return atom;
}
/*-------------------------------------------------------------------------*/
/* LOOKUP_ATOM */
/* */
/*-------------------------------------------------------------------------*/
AtomInf *Lookup_Atom(char *name)
{
return (AtomInf *) Hash_Lookup(atom_tbl,(char *) (&name),H_FIND);
}
/*-------------------------------------------------------------------------*/
/* CREATE_PRED_TABLE */
/* */
/*-------------------------------------------------------------------------*/
PredTbl Create_Pred_Table(int size)
{
PredTbl tbl;
if (size==0)
return NULL;
tbl=Hash_Table(size,sizeof(PredInf),sizeof(long));
if (tbl==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
return tbl;
}
/*-------------------------------------------------------------------------*/
/* CREATE_PRED */
/* */
/* if module_nb==0 lookup in the public table. */
/*-------------------------------------------------------------------------*/
PredInf *Create_Pred(AtomInf *functor,int arity,int module_nb,CodePtr codep)
{
PredTbl tbl=(module_nb==0) ? pred_tbl : module_tbl[module_nb].pred_tbl;
PredInf pred_info;
PredInf *pred;
pred_info.f_n =Make_Pred_Key(functor,arity);
pred_info.owner_mod_nb=module_nb;
pred_info.codep =codep;
if (codep)
pred_info.dynamic=NULL;
else
{
if ((pred_info.dynamic=(DynPInf *) Lib1(malloc,sizeof(DynPInf)))==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
Init_Dynamic_Info(pred_info.dynamic);
}
pred=(PredInf *) Hash_Lookup(tbl,(char *) &pred_info,H_UPDATE);
if ((long) pred == -1)
Fatal_Error(ERR_PRED_TBL_FULL);
return pred;
}
/*-------------------------------------------------------------------------*/
/* LOOKUP_PRED */
/* */
/* if module_nb==0 lookup in the public table. */
/*-------------------------------------------------------------------------*/
PredInf *Lookup_Pred(AtomInf *functor,int arity,int module_nb)
{
PredTbl tbl=(module_nb==0) ? pred_tbl : module_tbl[module_nb].pred_tbl;
return (PredInf *) Hash_Fast_Find_Int(tbl,Make_Pred_Key(functor,arity));
}
/*-------------------------------------------------------------------------*/
/* DELETE_PRED */
/* */
/* if module_nb==0 delete in the public table. */
/*-------------------------------------------------------------------------*/
void Delete_Pred(AtomInf *functor,int arity,int module_nb)
{
PredTbl tbl=(module_nb==0) ? pred_tbl : module_tbl[module_nb].pred_tbl;
long key=Make_Pred_Key(functor,arity);
Hash_Lookup(tbl,(char *) &key,H_DELETE);
}
/*-------------------------------------------------------------------------*/
/* CREATE_OPER */
/* */
/*-------------------------------------------------------------------------*/
OperInf *Create_Oper(AtomInf *atom,int type,int prec,int left,int right)
{
OperInf oper_info;
OperInf *oper;
oper_info.a_t =Make_Oper_Key(atom,type);
oper_info.prec =prec;
oper_info.left =left;
oper_info.right=right;
oper=(OperInf *) Hash_Lookup(oper_tbl,(char *) &oper_info,H_UPDATE);
if ((long) oper == -1)
Fatal_Error(ERR_OPER_TBL_FULL);
return oper;
}
/*-------------------------------------------------------------------------*/
/* LOOKUP_OPER */
/* */
/*-------------------------------------------------------------------------*/
OperInf *Lookup_Oper(AtomInf *atom,int type)
{
return (OperInf *) Hash_Fast_Find_Int(oper_tbl,Make_Oper_Key(atom,type));
}
/*-------------------------------------------------------------------------*/
/* DELETE_OPER */
/* */
/*-------------------------------------------------------------------------*/
OperInf *Delete_Oper(AtomInf *atom,int type)
{
long key=Make_Oper_Key(atom,type);
return (OperInf *) Hash_Lookup(oper_tbl,(char *) &key,H_DELETE);
}
/*-------------------------------------------------------------------------*/
/* CREATE_SWT_TABLE */
/* */
/*-------------------------------------------------------------------------*/
SwtTbl Create_Swt_Table(int size)
{
SwtTbl t;
if ((t=Hash_Table(size+8,sizeof(SwtInf),sizeof(long)))==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
return t;
}
/*-------------------------------------------------------------------------*/
/* CREATE_SWT_ELEMENT */
/* */
/*-------------------------------------------------------------------------*/
void Create_Swt_Element(SwtTbl t,long key,CodePtr codep)
{
SwtInf swt_info;
swt_info.key =key;
swt_info.c.codep=codep;
Hash_Lookup(t,(char *) &swt_info,H_CREATE);
}
/*-------------------------------------------------------------------------*/
/* GET_FUNCTOR_ARITY */
/* */
/* returns the functor (NULL if the term is not callable), initializes the */
/* arity and the adress of the first argument (if arity>0). */
/*-------------------------------------------------------------------------*/
AtomInf *Get_Functor_Arity(WamWord start_word,int *arity,WamWord **arg_adr)
{
WamWord word,tag,*adr;
Deref(start_word,word,tag,adr)
switch(tag)
{
case CST:
*arity=0;
return UnTag_CST(word);
case LST:
adr=UnTag_LST(word);
*arity=2;
*arg_adr=&Car(adr);
return atom_dot;
case STC:
adr=UnTag_STC(word);
*arity=Arity(adr);
*arg_adr=&Arg(adr,0);
return Functor(adr);
default:
return NULL;
}
}
/*-------------------------------------------------------------------------*/
/* GET_COMPOUND */
/* */
/* as Get_Functor_Arity but the word is dereferenced and must be a compound*/
/* term (LST or a STC) */
/*-------------------------------------------------------------------------*/
AtomInf *Get_Compound(WamWord tag,WamWord word,int *arity,WamWord **arg_adr)
{
WamWord *adr;
switch(tag)
{
case LST:
adr=UnTag_LST(word);
*arity=2;
*arg_adr=&Car(adr);
return atom_dot;
case STC:
adr=UnTag_STC(word);
*arity=Arity(adr);
*arg_adr=&Arg(adr,0);
return Functor(adr);
default:
return NULL;
}
}
/*-------------------------------------------------------------------------*/
/* Global variable management */
/* */
/* A global variable allows the user to associate an information to an atom*/
/* There are 3 types of information (2 basic types + 1 constructor): */
/* */
/* - copy of a term, builtin: g_assign[b](Gvar,Term) */
/* - link to a term, builtin: g_link(Gvar,Term) */
/* - array of k infos, builtin: g_{assign[b]/link}(Gvar,g_array(...)) */
/* */
/* The assignments can be backtrackble (g_assignb/g_link) or not (g_assign)*/
/* (backtrackable = assignments are undone when backtracking occurs). */
/* */
/* Internal represention: */
/* */
/* An information has a type GVarElt which is a structure with 2 fields */
/* 'size' (indicationg the type of the element) and 'val': */
/* */
/* size<0: an array of -size elements, */
/* val (GVarElt *) points the first element. */
/* */
/* size=0: a link to a term, */
/* val (WamWord) is the staring word of the term. */
/* */
/* size>0: a copy of a term whose size is 'size', */
/* val (WamWord *) is the address of the copy of the term */
/* (space for the copy obtained by malloc). */
/*-------------------------------------------------------------------------*/
/*-------------------------------------------------------------------------*/
/* G_ASSIGN */
/* */
/*-------------------------------------------------------------------------*/
Bool G_Assign(WamWord gvar_word,WamWord gval_word,Bool backtrack,Bool copy)
{
GVarElt *g_elem;
if ((g_elem=G_Get_Element(gvar_word))==NULL)
return FALSE;
return G_Assign_Element(g_elem,gval_word,backtrack,copy);
}
/*-------------------------------------------------------------------------*/
/* G_ASSIGN_ELEMENT */
/* */
/*-------------------------------------------------------------------------*/
static Bool G_Assign_Element(GVarElt *g_elem,WamWord gval_word,
Bool backtrack,Bool copy)
{
WamWord word,tag,*adr;
AtomInf *atom;
int size;
int size_base=0;
GVarElt save_g_elem;
save_g_elem=*g_elem;
Deref(gval_word,word,tag,adr)
if (tag==STC)
{
adr=UnTag_STC(word);
atom=Functor(adr);
if (atom==atom_g_array || atom==atom_g_array_extend) /* an array */
{
if (!G_Assign_Array(g_elem,adr,atom==atom_g_array_extend,copy))
return FALSE;
goto finish;
}
}
if (!copy || tag==CST || tag==INT) /* a link */
{
if (tag==REF && Is_A_Local_Adr(adr))
{
word=Tag_Value(REF,H);
Globalize_Local_Unbound_Var(adr);
}
g_elem->size=0;
g_elem->val=Global_UnMove(tag) ? Tag_Value(REF,adr) : word;
goto finish;
}
/* a copy */
size=Term_Size(word);
if ((adr=(WamWord *) Lib1(malloc,size*sizeof(WamWord)))==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
g_elem->size=size+size_base;
g_elem->val=(WamWord) adr;
Copy_Term(adr,&word);
finish:
if (backtrack)
{
Trail_Push(save_g_elem.val); /* push frame (see G_Untrail) */
Trail_Push(save_g_elem.size);
Trail_Push(g_elem);
Trail_FC(G_Untrail)
}
else
G_Free_Element(&save_g_elem);
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* G_GET_ELEMENT */
/* */
/*-------------------------------------------------------------------------*/
static GVarElt *G_Get_Element(WamWord gvar_word)
{
WamWord word,tag,*adr;
WamWord word1;
AtomInf *atom;
int arity;
WamWord *arg_adr;
GVarElt *g_elem;
int i,size;
int index;
if ((atom=Get_Functor_Arity(gvar_word,&arity,&arg_adr))==NULL)
{
Lib1(printf,ERR_ILLEGAL_G_VAR_NAME);
return NULL;
}
g_elem=&(atom->g_elem);
for(i=0;i<arity;i++)
{
size=g_elem->size;
word1=*arg_adr;
deref:
Deref(word1,word,tag,adr)
if (tag!=INT)
{
Global_Push(word1=Tag_Value(REF,H));
if (!G_Read(word,word1))
return NULL;
goto deref;
}
index=UnTag_INT(word);
if (tag!=INT || size>=0 || (unsigned) index>= -size)
{
Lib1(printf,ERR_ILLEGAL_G_ARRAY_INDEX);
Lib2(printf," <%d>",index);
if (word1!=*arg_adr)
{
Lib1(printf," given by <");
Simple_Write_Term(*arg_adr);
Lib1(printf,">");
}
Lib2(printf," for <%s>\n",atom->name);
return NULL;
}
g_elem=(GVarElt *) (g_elem->val)+index;
arg_adr++;
}
return g_elem;
}
/*-------------------------------------------------------------------------*/
/* G_ASSIGN_ARRAY */
/* */
/*-------------------------------------------------------------------------*/
static Bool G_Assign_Array(GVarElt *g_elem,WamWord *stc_adr,Bool extend,
Bool copy)
{
WamWord word,tag,*adr;
int arity;
Bool same_init_value;
WamWord init_word;
WamWord lst_word;
int src_size,new_size;
GVarElt save_g_elem;
GVarElt *p,*src_p;
int i;
arity=Arity(stc_adr);
Deref(Arg(stc_adr,0),word,tag,adr)
new_size=(tag==LST) ? Proper_List_Length(word) : UnTag_INT(word);
if (!(new_size>0 && (tag==INT && arity<=2 || tag==LST && arity==1)))
{
Lib1(printf,ERR_ILLEGAL_G_ARRAY_DECL);
return FALSE;
}
if (tag==INT)
{
same_init_value=TRUE;
init_word=(arity==1) ? G_VAR_INITIAL_VALUE : Arg(stc_adr,1);
}
else
{
same_init_value=FALSE;
lst_word=word;
}
if (extend && g_elem->size<0)
{
src_size=-g_elem->size;
src_p=(GVarElt *) (g_elem->val);
}
else
src_size=0;
save_g_elem=*g_elem;
if ((p=(GVarElt *) Lib1(malloc,new_size*sizeof(GVarElt)))==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
g_elem->size=-new_size;
g_elem->val=(WamWord) p;
for(i=0;i<new_size;i++)
{
if (!same_init_value)
{
Get_List(lst_word);
Unify_Variable(&init_word);
Unify_Variable(&lst_word);
}
if (src_size>0)
{
src_size--;
G_Copy_Element(p++,src_p++);
}
else
{
p->size=0;
p->val=G_VAR_INITIAL_VALUE;
if (!G_Assign_Element(p++,init_word,FALSE,copy))
{
Lib1(free,(char *) g_elem->val);
*g_elem=save_g_elem;
return FALSE;
}
}
}
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* G_FREE_ELEMENT */
/* */
/*-------------------------------------------------------------------------*/
static void G_Free_Element(GVarElt *g_elem)
{
int size;
GVarElt *p;
int i;
size=g_elem->size;
if (size==0) /* a link: nothing */
return;
if (size<0) /* an array: recursively free elts */
{
size=-size;
p=(GVarElt *)(g_elem->val);
for(i=0;i<size;i++)
G_Free_Element(p++);
}
/* a copy or an array: free */
Lib1(free,(char *) g_elem->val);
}
/*-------------------------------------------------------------------------*/
/* G_COPY_ELEMENT */
/* */
/*-------------------------------------------------------------------------*/
static void G_Copy_Element(GVarElt *dst_g_elem,GVarElt *src_g_elem)
{
WamWord *adr;
GVarElt *p;
int size;
int i;
size=dst_g_elem->size=src_g_elem->size;
if (size==0) /* a link: copy */
{
dst_g_elem->val=src_g_elem->val;
return;
}
if (size<0) /* an array: alloc + recursively copy elts */
{
size=-size;
if ((p=(GVarElt *) Lib1(malloc,size*sizeof(GVarElt)))==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
dst_g_elem->val=(WamWord) p;
dst_g_elem=p;
src_g_elem=(GVarElt *)(src_g_elem->val);
for(i=0;i<size;i++)
G_Copy_Element(dst_g_elem++,src_g_elem++);
return;
}
/* a copy: alloc + copy */
if ((adr=(WamWord *) Lib1(malloc,size*sizeof(WamWord)))==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
dst_g_elem->val=(WamWord) adr;
Copy_Contiguous_Term(adr,(WamWord *) src_g_elem->val);
}
/*-------------------------------------------------------------------------*/
/* G_UNTRAIL */
/* */
/*-------------------------------------------------------------------------*/
static void G_Untrail(void)
{
GVarElt *g_elem;
g_elem=(GVarElt *) Trail_Pop; /* pop frame (see G_Assign_Element) */
G_Free_Element(g_elem);
g_elem->size=Trail_Pop;
g_elem->val =Trail_Pop;
}
/*-------------------------------------------------------------------------*/
/* G_READ */
/* */
/*-------------------------------------------------------------------------*/
Bool G_Read(WamWord gvar_word,WamWord gval_word)
{
GVarElt *g_elem;
if ((g_elem=G_Get_Element(gvar_word))==NULL)
return FALSE;
return G_Read_Element(g_elem,gval_word);
}
/*-------------------------------------------------------------------------*/
/* G_READ_ELEMENT */
/* */
/*-------------------------------------------------------------------------*/
static WamWord G_Read_Element(GVarElt *g_elem,WamWord gval_word)
{
WamWord word;
int size=g_elem->size;
GVarElt *p;
int i;
if (size==0) /* a link: unify */
return Unify(g_elem->val,gval_word);
if (size>0) /* a copy: copy+unify */
{
Copy_Contiguous_Term(H,(WamWord *) g_elem->val);
word=*H;
if (Global_UnMove(Tag_Of(word)))
word=Tag_Value(REF,H);
H+=size;
return Unify(word,gval_word);
}
/* an array: unify with array([elt1,...]) */
size=-size;
p=(GVarElt *) g_elem->val;
if (!Get_Structure(atom_g_array,1,gval_word))
return FALSE;
Unify_Variable(&gval_word);
for(i=0;i<size;i++)
{
if (!Get_List(gval_word))
return FALSE;
Unify_Variable(&word);
Unify_Variable(&gval_word);
if (!G_Read_Element(p++,word))
return FALSE;
}
return Get_Nil(gval_word);
}
/*-------------------------------------------------------------------------*/
/* G_ARRAY_SIZE */
/* */
/*-------------------------------------------------------------------------*/
Bool G_Array_Size(WamWord gvar_word,WamWord size_word)
{
GVarElt *g_elem;
if ((g_elem=G_Get_Element(gvar_word))==NULL || g_elem->size>=0)
return FALSE;
return Get_Integer(-g_elem->size,size_word);
}
/*-------------------------------------------------------------------------*/
/* Dynamic clause management */
/* */
/* Dynamic clauses are stored in clause frames allocated by malloc. */
/* The frame consists of: */
/* */
/* - a number (<0 if asserta >=0 if assertz) to order them. */
/* - a forward sequential chain (chronological chain). */
/* - a backward sequential chain (chronological chain). */
/* - a forward indexing chain */
/* - a backward indexing chain */
/* - the size of the Prolog term */
/* - the corresponding Prolog term of the form [Head|Body] for Head:-Body*/
/* */
/* For a dynamic predicate the structure DynPInfo has 6 entry-points for */
/* clause chaining: 1 for the sequential chain, 5 for indexing chains, */
/* depending on the first argument of the Head: */
/* */
/* - seq_chain : a chain to the first clause */
/* - var_ind_chain: a chain to the first clause with a var as 1st arg */
/* - cst_htbl : a hash table: key=cst/info=chain to the first clause */
/* - int_htbl : a hash table: key=int/info=chain to the first clause */
/* - lst_ind_chain: a chain to the first clause with a list as 1st arg */
/* - stc_htbl : a hash table: key=f_n/info=chain to the first clause */
/* */
/* dynamic predicate are always public (should be improved) */
/*-------------------------------------------------------------------------*/
/*-------------------------------------------------------------------------*/
/* ADD_NEW_CLAUSE */
/* */
/*-------------------------------------------------------------------------*/
Bool Add_New_Clause(WamWord start_word,Bool asserta)
{
PredInf *pred;
int index_nb;
long key;
long *clause;
DynPInf *dyn;
char **p_htbl;
SwtInf swt_info;
SwtInf *swt;
int size;
if ((pred=Get_Pred_And_Index(start_word,&index_nb,&key,TRUE))==NULL)
return FALSE;
dyn=pred->dynamic;
size=Term_Size(start_word);
clause=(long *)
Lib1(malloc,(DYNAMIC_CLAUSE_STATIC_SIZE+size)*sizeof(WamWord));
if (clause==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
Clause_Number(clause)=(asserta) ? dyn->count_a-- : dyn->count_z++;
Add_To_List(&dyn->seq_chain,(long **) &Seq_Chain_F(clause),asserta);
Clause_Size(clause)=size;
Copy_Term(&Clause(clause),&start_word);
if (index_nb==NO_INDEX)
{
Ind_Chain_F(clause)=NULL;
Ind_Chain_B(clause)=NULL;
#ifdef CDEBUG
last_pred=pred;
Verify_Dynamic_Clauses();
#endif
return TRUE;
}
if (index_nb==VAR_INDEX || index_nb==LST_INDEX)
{
Add_To_List((long **) dyn+index_nb,
(long **) &Ind_Chain_F(clause),asserta);
#ifdef CDEBUG
last_pred=pred;
Verify_Dynamic_Clauses();
#endif
return TRUE;
}
p_htbl=(char **) dyn+index_nb;
if (*p_htbl==NULL)
if ((*p_htbl=Hash_Table(BLOCK_SIZE,sizeof(SwtInf),sizeof(long)))==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
swt_info.key=key;
swt_info.c.ind_chain=NULL;
swt=(SwtInf *) Hash_Lookup(*p_htbl,(char *) &swt_info,H_ADD);
if ((long) swt== -1)
{
Extend_HTable(p_htbl);
swt=(SwtInf *) Hash_Lookup(*p_htbl,(char *) &swt_info,H_ADD);
}
Add_To_List(&(swt->c.ind_chain),(long **) &Ind_Chain_F(clause),asserta);
#ifdef CDEBUG
last_pred=pred;
Verify_Dynamic_Clauses();
#endif
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* GET_PRED_AND_INDEX */
/* */
/*-------------------------------------------------------------------------*/
static PredInf *Get_Pred_And_Index(WamWord start_word,
int *index_nb,long *key,Bool create)
{
WamWord word,tag,*adr;
WamWord *first_arg_adr;
AtomInf *functor;
int arity;
PredInf *pred;
Deref(start_word,word,tag,adr)
adr=UnTag_LST(word);
if ((functor=Get_Functor_Arity(Car(adr),&arity,&first_arg_adr))==NULL)
{
Lib1(printf,ERR_ILLEGAL_GOAL);
return NULL;
}
if ((pred=Lookup_Pred(functor,arity,0))==NULL && create)
pred=Create_Pred(functor,arity,0,NULL);
if (pred && pred->codep)
{
Lib3(printf,ERR_STATIC_PREDICATE,functor->name,arity);
return NULL;
}
if (arity==0)
*index_nb=NO_INDEX;
else
{
Deref(*first_arg_adr,word,tag,adr)
switch(tag)
{
case REF:
*index_nb=VAR_INDEX;
break;
case CST:
*index_nb=CST_INDEX;
*key=(long) UnTag_CST(word);
break;
case INT:
*index_nb=INT_INDEX;
*key=UnTag_INT(word);
break;
case LST:
*index_nb=LST_INDEX;
break;
default: /* tag==STC */
*index_nb=STC_INDEX;
*key=(long) Functor_And_Arity(UnTag_STC(word));
break;
}
}
return pred;
}
/*-------------------------------------------------------------------------*/
/* ADD_TO_LIST */
/* */
/*-------------------------------------------------------------------------*/
static void Add_To_List(long **list,long **to_add,Bool asserta)
{
if (!asserta)
while(*list)
list=(long **) *list;
if ((to_add[0]=*list)!=NULL)
(*list)[1]=(long) to_add;
to_add[1]=(long *) list;
*list=(long *) to_add;
}
/*-------------------------------------------------------------------------*/
/* EXTEND_HTABLE */
/* */
/*-------------------------------------------------------------------------*/
static void Extend_HTable(char **t)
{
char *t1;
SwtInf *swt;
SwtInf *swt1;
long *clause;
t1=Hash_Table(Hash_Table_Size(*t)+BLOCK_SIZE,sizeof(SwtInf),sizeof(long));
if (t1==NULL)
Fatal_Error(ERR_ALLOC_FAULT);
for(swt=(SwtInf *) Hash_Lookup(*t,NULL,H_NEXT);swt;
swt=(SwtInf *) Hash_Lookup(*t,(char *) swt,H_NEXT))
{
if (swt->c.ind_chain) /* do not copy if no entries longer exist */
{
swt1=(SwtInf *) Hash_Lookup(t1,(char *) swt,H_CREATE);
clause=Clause_From_Ind_Chain_F(swt1->c.ind_chain);
Ind_Chain_B(clause)=(long *) &(swt1->c.ind_chain);
}
}
Hash_Delete_Table(*t);
*t=t1;
}
/*-------------------------------------------------------------------------*/
/* SCAN_FIRST_CLAUSE */
/* */
/*-------------------------------------------------------------------------*/
Bool Scan_First_Clause(WamWord start_word,DynScan *scan)
{
PredInf *pred;
int index_nb;
long key;
DynPInf *dyn;
char *htbl;
SwtInf *swt;
if ((pred=Get_Pred_And_Index(start_word,&index_nb,&key,FALSE))==NULL)
return FALSE;
dyn=pred->dynamic;
switch(index_nb)
{
case NO_INDEX:
case VAR_INDEX:
scan->xxx_is_seq_chain=TRUE;
scan->xxx_ind_chain=dyn->seq_chain;
scan->var_ind_chain=NULL;
break;
case LST_INDEX:
scan->xxx_is_seq_chain=FALSE;
scan->xxx_ind_chain=dyn->lst_ind_chain;
scan->var_ind_chain=dyn->var_ind_chain;
break;
default:
scan->xxx_is_seq_chain=FALSE;
htbl=((char **) dyn)[index_nb];
if (htbl && (swt=(SwtInf *) Hash_Fast_Find_Int(htbl,key))!=NULL)
scan->xxx_ind_chain=swt->c.ind_chain;
else
scan->xxx_ind_chain=NULL;
scan->var_ind_chain=dyn->var_ind_chain;
}
#ifdef CDEBUG
last_pred=pred;
#endif
return Scan_Next_Clause(scan);
}
/*-------------------------------------------------------------------------*/
/* SCAN_NEXT_CLAUSE */
/* */
/* This function uses the structure DynScan pointed by scan to get dynamic */
/* clauses. This structure contains 3 input cells (must be set): */
/* */
/* - xxx_is_seq_chain: the cell xxx_ind_chain points to seq_chain */
/* - xxx_ind_chain : current cst/int/lst/stc indexing chain */
/* - var_ind_chain : current var indexing chain */
/* */
/* Since a clause with a variable as 1st argument can be used by all */
/* callers, two chains are traversed: var_ind_chain and xxx_ind_chain */
/* (xxx=cst/int/lst/stc). scan->var_ind_chain points the next clause with a*/
/* var as 1st arg and scan->xxx_ind_chain points the next clause with the */
/* appropriate index. the clause choosen is the one with the smaller clause*/
/* number between var_clause and xxx_clause. */
/* There is a special case when the first argument of the caller is a var */
/* or when the arity is 0: then all clauses must be taken into account. */
/* To do this xxx_ind_chain=seq_chain (and scan->xxx_is_seq_chain is TRUE) */
/* and var_ind_chain points to NULL */
/* */
/* When a clause is found, 3 output cells are set: */
/* */
/* - cur_clause: points the current clause frame */
/* - cur_word : a Prolog term corresponding to the clause [Head|Body] */
/* - is_last : is there another possible clause after this one ? */
/*-------------------------------------------------------------------------*/
Bool Scan_Next_Clause(DynScan *scan)
{
long *xxx_ind_chain,*var_ind_chain;
long *xxx_clause, *var_clause;
int xxx_nb, var_nb;
long *clause;
int n;
xxx_ind_chain=scan->xxx_ind_chain;
if (xxx_ind_chain)
{
xxx_clause=(scan->xxx_is_seq_chain)
? Clause_From_Seq_Chain_F(xxx_ind_chain)
: Clause_From_Ind_Chain_F(xxx_ind_chain);
xxx_nb =Clause_Number(xxx_clause);
}
else
xxx_nb =INT_GREATEST_VALUE;
var_ind_chain =scan->var_ind_chain;
if (var_ind_chain)
{
var_clause=Clause_From_Ind_Chain_F(var_ind_chain);
var_nb =Clause_Number(var_clause);
}
else
var_nb =INT_GREATEST_VALUE;
if (xxx_nb<=var_nb)
{
if (xxx_nb==INT_GREATEST_VALUE)
{
#ifdef CDEBUG
Verify_Dynamic_Clauses();
#endif
return FALSE;
}
clause=xxx_clause;
scan->xxx_ind_chain=(long *) (*xxx_ind_chain);
}
else
{
clause=var_clause;
scan->var_ind_chain=(long *) (*var_ind_chain);
}
scan->cur_clause=clause;
scan->is_last=(scan->xxx_ind_chain==NULL && scan->var_ind_chain==NULL);
n=Clause_Size(clause);
Copy_Contiguous_Term(H,&Clause(clause));
scan->cur_word=*H;
H+=n;
#ifdef CDEBUG
Verify_Dynamic_Clauses();
#endif
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* DELETE_CURRENT_CLAUSE */
/* */
/* This function deletes the current clause pointed by scan->cur_clause. */
/*-------------------------------------------------------------------------*/
void Delete_Current_Clause(DynScan *scan_info)
{
long *clause=scan_info->cur_clause;
long *clause1;
long **seq_chain_back;
long **ind_chain_back;
seq_chain_back=(long **) Seq_Chain_B(clause);
ind_chain_back=(long **) Ind_Chain_B(clause);
if ((*seq_chain_back=Seq_Chain_F(clause))!=NULL)
{
clause1=Clause_From_Seq_Chain_F(*seq_chain_back);
Seq_Chain_B(clause1)=(long *) seq_chain_back;
}
/* test also if no index */
if (ind_chain_back && (*ind_chain_back=Ind_Chain_F(clause))!=NULL)
{
clause1=Clause_From_Ind_Chain_F(*ind_chain_back);
Ind_Chain_B(clause1)=(long *) ind_chain_back;
}
Lib1(free,clause);
#ifdef CDEBUG
Verify_Dynamic_Clauses();
#endif
}
#ifdef CDEBUG
/*-------------------------------------------------------------------------*/
/* VERIFY_DYNAMIC_CLAUSES */
/* */
/* (debug function) */
/*-------------------------------------------------------------------------*/
static void Verify_Dynamic_Clauses(void)
{
PredInf *pred=last_pred;
AtomInf *functor=Atom_Of_Pred(pred);
int arity=Arity_Of_Pred(pred);
DynPInf *dyn=pred->dynamic;
Lib4(printf,"\nPred %s/%d (dyn:0x%06x)",functor->name,arity,pred->dynamic);
Lib4(printf," count_a:%d count_z:%d consult:%d\n",
dyn->count_a,dyn->count_z,dyn->consult_count);
Lib1(printf,"\nSEQ:\n");
Verify_List(dyn->seq_chain,NO_INDEX);
Lib1(printf,"\nVAR:\n");
Verify_List(dyn->var_ind_chain,VAR_INDEX);
Lib1(printf,"\nCST:\n");
Verify_Hash(dyn->cst_htbl,CST_INDEX);
Lib1(printf,"\nINT:\n");
Verify_Hash(dyn->int_htbl,INT_INDEX);
Lib1(printf,"\nLST:\n");
Verify_List(dyn->lst_ind_chain,LST_INDEX);
Lib1(printf,"\nSTC:\n");
Verify_Hash(dyn->stc_htbl,STC_INDEX);
}
/*-------------------------------------------------------------------------*/
/* VERIFY_HASH */
/* */
/* (debug function) */
/*-------------------------------------------------------------------------*/
static void Verify_Hash(char *t,int index_nb)
{
SwtInf *buff_ptr;
if (t==NULL)
return;
for(buff_ptr=(SwtInf *) Hash_Lookup(t,NULL,H_NEXT);buff_ptr;
buff_ptr=(SwtInf *) Hash_Lookup(t,(char *) buff_ptr,H_NEXT))
{
Lib2(printf," val (0x%06x)",&(buff_ptr->c.ind_chain));
if (index_nb==CST_INDEX)
Lib2(printf," <%s>\n",((AtomInf *) (buff_ptr->key))->name);
if (index_nb==INT_INDEX)
Lib2(printf," <%d>\n",buff_ptr->key);
if (index_nb==STC_INDEX)
Lib3(printf," <%s/%d>\n",Functor_Name(buff_ptr->key),
Arity_Of(buff_ptr->key));
Verify_List(buff_ptr->c.ind_chain,index_nb);
}
}
/*-------------------------------------------------------------------------*/
/* VERIFY_LIST */
/* */
/* (debug function) */
/*-------------------------------------------------------------------------*/
static void Verify_List(long *p,int index_nb)
{
long *clause;
long *ind_chain_b;
long *ind_chain_f;
long *clause_b;
long *clause_f;
while(p)
{
clause_f=clause_b=NULL;
if (index_nb==NO_INDEX)
{
clause=Clause_From_Seq_Chain_F(p);
if ((ind_chain_b=Seq_Chain_B(clause))!=NULL)
clause_b=Clause_From_Seq_Chain_F(ind_chain_b);
if ((ind_chain_f=Seq_Chain_F(clause))!=NULL)
clause_f=Clause_From_Seq_Chain_F(ind_chain_f);
}
else
{
clause=Clause_From_Ind_Chain_F(p);
if ((ind_chain_b=Ind_Chain_B(clause))!=NULL)
clause_b=Clause_From_Ind_Chain_F(ind_chain_b);
if ((ind_chain_f=Ind_Chain_F(clause))!=NULL)
clause_f=Clause_From_Ind_Chain_F(ind_chain_f);
}
Lib4(printf," %3d %3d 0x%06x ",
Clause_Number(clause),Clause_Size(clause),clause);
Lib3(printf," 0x%06x <-> 0x%06x ",clause_b,clause_f);
Simple_Write_Term(Clause(clause));
Lib2(printf,"\n",clause);
p=(long *) (*p);
}
}
#endif
/*-------------------------------------------------------------------------*/
/* REINIT_DYNAMIC_PRED */
/* */
/* what_to_do : 0 = abolish / 1 = init consult / 2 = retract all clauses */
/*-------------------------------------------------------------------------*/
Bool Reinit_Dynamic_Pred(AtomInf *functor,int arity,int what_to_do)
{
PredInf *pred;
DynPInf *dyn;
long *seq_chain;
long *clause;
if ((pred=Lookup_Pred(functor,arity,0))==NULL)
return TRUE; /* like sicstus */
if (pred->codep)
{
Lib3(printf,ERR_STATIC_PREDICATE,functor->name,arity);
return FALSE;
}
dyn=pred->dynamic;
if (what_to_do==1 && dyn->consult_count==consult_count)
return TRUE;
seq_chain=dyn->seq_chain;
while(seq_chain) /* remove all clauses */
{
clause=Clause_From_Seq_Chain_F(seq_chain);
seq_chain=Seq_Chain_F(clause);
Lib1(free,clause);
}
if (dyn->cst_htbl)
Hash_Delete_Table(dyn->cst_htbl);
if (dyn->int_htbl)
Hash_Delete_Table(dyn->int_htbl);
if (dyn->stc_htbl)
Hash_Delete_Table(dyn->stc_htbl);
if (what_to_do==0)
Delete_Pred(functor,arity,0);
else
Init_Dynamic_Info(dyn)
return TRUE;
}
syntax highlighted by Code2HTML, v. 0.9.1