/*-------------------------------------------------------------------------*/
/* Prolog to Wam Compiler INRIA Rocquencourt - ChLoE Project */
/* C Run-time Daniel Diaz - 1991 */
/* */
/* Wam Implementation */
/* */
/* wam_engine.c */
/*-------------------------------------------------------------------------*/
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <setjmp.h>
#include <signal.h>
#define WAM_ENGINE
#include "wam_engine.h"
LibPrototype(extern int sscanf())
/*---------------------------------*/
/* Constants */
/*---------------------------------*/
#define SIGNAL_HANDLER X7369676E616C5F68616E646C6572
#define ERR_UNKNOWN_STACK "Error: Unknown stack <%s>"
/*---------------------------------*/
/* Type Definitions */
/*---------------------------------*/
/*---------------------------------*/
/* Global Variables */
/*---------------------------------*/
#ifdef WAM_PROFILE
static int max_local_used_size =0;
static int global_max_used_size =0;
static int max_trail_used_size =0;
static int nb_of_create_choice_point=0;
static int nb_of_update_choice_point=0;
static int nb_of_delete_choice_point=0;
#endif
static CodePtr cont_jmp; /* we use a global var to support DEC alpha */
/* copy term variables */
static WamWord *base_copy;
static WamWord vars[2048*2]; /* needs 2 words for a variable */
static WamWord *top_vars;
static WamWord glob_buff_save[NB_OF_USED_MACHINE_REGS + 1];
/*---------------------------------*/
/* Function Prototypes */
/*---------------------------------*/
static
void Untrail (WamWord *low_adr);
Bool Call_Next (CodePtr codep);
void Call_Next1 (CodePtr codep);
static
void Signal_Handler (int sig);
static
void Copy_Term_Rec (WamWord *dst_adr,WamWord *src_adr,
WamWord **p);
/*-------------------------------------------------------------------------*/
/* CREATE_CHOICE_POINT */
/* */
/*-------------------------------------------------------------------------*/
void Create_Choice_Point(CodePtr codep_alt,int arity)
{
WamWord *adr;
int i;
#ifdef WAM_PROFILE
nb_of_create_choice_point++;
#endif
adr=B;
B=Local_Top+CHOICE_STATIC_SIZE+arity;
ALTB(B)=codep_alt;
CPB(B) =CP;
EB(B) =E;
BB(B) =adr;
BCB(B) =BC;
HB(B) =H;
TRB(B) =TR;
for(i=0;i<arity;i++)
AB(B,i)=A(i);
}
/*-------------------------------------------------------------------------*/
/* UPDATE_CHOICE_POINT */
/* */
/*-------------------------------------------------------------------------*/
void Update_Choice_Point(CodePtr codep_alt,int arity)
{
int i;
#ifdef WAM_PROFILE
nb_of_update_choice_point++;
#endif
ALTB(B)=codep_alt;
Untrail(TRB(B));
CP=CPB(B);
E =EB(B);
BC=BCB(B);
H =HB(B);
for(i=0;i<arity;i++)
A(i)=AB(B,i);
}
/*-------------------------------------------------------------------------*/
/* DELETE_CHOICE_POINT */
/* */
/*-------------------------------------------------------------------------*/
void Delete_Choice_Point(int arity)
{
int i;
#ifdef WAM_PROFILE
nb_of_delete_choice_point++;
#endif
Untrail(TRB(B));
CP=CPB(B);
E =EB(B);
BC=BCB(B);
H =HB(B);
for(i=0;i<arity;i++)
A(i)=AB(B,i);
B=BB(B); /* warning B must be the last element restored */
}
/*-------------------------------------------------------------------------*/
/* UNTRAIL */
/* */
/*-------------------------------------------------------------------------*/
static void Untrail(WamWord *low_adr)
{
WamWord word;
WamWord *adr;
int nb;
while(TR>low_adr)
{
word=Trail_Pop;
adr=(WamWord *) (Trail_Value_Of(word));
switch(Trail_Tag_Of(word))
{
case TUV:
*adr=Make_Self_Ref(adr);
break;
case TOV:
*adr=Trail_Pop;
break;
case TMV:
nb=Trail_Pop;
TR-=nb;
Mem_Word_Cpy(adr,TR,nb)
break;
default: /* TFC */
(* ((int (*)()) adr)) ();
}
}
}
/*-------------------------------------------------------------------------*/
/* GET_CONSTANT */
/* */
/*-------------------------------------------------------------------------*/
Bool Get_Constant(AtomInf *atom,WamWord start_word)
{
WamWord word,tag,*adr;
Deref(start_word,word,tag,adr)
switch(tag)
{
case REF:
Bind_UV(adr,Tag_Value(CST,atom))
return TRUE;
case CST:
return (UnTag_CST(word)==atom);
}
return FALSE;
}
/*-------------------------------------------------------------------------*/
/* GET_INTEGER */
/* */
/*-------------------------------------------------------------------------*/
Bool Get_Integer(int n,WamWord start_word)
{
WamWord word,tag,*adr;
Deref(start_word,word,tag,adr)
switch(tag)
{
case REF:
Bind_UV(adr,Tag_Value(INT,n))
return TRUE;
case INT:
return (UnTag_INT(word)==n);
}
return FALSE;
}
/*-------------------------------------------------------------------------*/
/* GET_NIL */
/* */
/*-------------------------------------------------------------------------*/
Bool Get_Nil(WamWord start_word)
{
WamWord word,tag,*adr;
Deref(start_word,word,tag,adr)
if (tag==REF)
{
Bind_UV(adr,word_nil)
return TRUE;
}
return (word==word_nil);
}
/*-------------------------------------------------------------------------*/
/* GET_LIST */
/* */
/*-------------------------------------------------------------------------*/
Bool Get_List(WamWord start_word)
{
WamWord word,tag,*adr;
Deref(start_word,word,tag,adr)
switch(tag)
{
case REF:
Bind_UV(adr,Tag_Value(LST,H))
S=WRITE_MODE;
return TRUE;
case LST: /* init S, i.e. MODE=READ */
S=(WamWord *) UnTag_LST(word)+OFFSET_CAR;
return TRUE;
}
return FALSE;
}
/*-------------------------------------------------------------------------*/
/* GET_STRUCTURE */
/* */
/*-------------------------------------------------------------------------*/
Bool Get_Structure(AtomInf *f,int n,WamWord start_word)
{
WamWord word,tag,*adr;
Deref(start_word,word,tag,adr)
switch(tag)
{
case REF:
Bind_UV(adr,Tag_Value(STC,H))
Global_Push(Functor_Arity(f,n));
S=WRITE_MODE;
return TRUE;
case STC: /* init S, i.e. MODE=READ */
adr=UnTag_STC(word);
if (Functor_And_Arity(adr)!=Functor_Arity(f,n))
return FALSE;
S=adr+OFFSET_ARG;
return TRUE;
}
return FALSE;
}
/*-------------------------------------------------------------------------*/
/* PUT_X_VARIABLE */
/* */
/*-------------------------------------------------------------------------*/
void Put_X_Variable(int x,int a)
{
X(x)=A(a)=Make_Self_Ref(H);
Global_Push(X(x));
}
/*-------------------------------------------------------------------------*/
/* PUT_Y_VARIABLE */
/* */
/*-------------------------------------------------------------------------*/
void Put_Y_Variable(int y,int a)
{
WamWord word,*adr;
word=Make_Self_Ref(adr= &Y(E,y));
A(a)= *adr=word;
}
/*-------------------------------------------------------------------------*/
/* PUT_Y_UNSAFE_VALUE */
/* */
/*-------------------------------------------------------------------------*/
void Put_Y_Unsafe_Value(int y,int a)
{
WamWord word,tag,*adr;
Deref(Y(E,y),word,tag,adr)
if (tag==REF && adr>=(WamWord *) EE(E))
{
A(a)=Tag_Value(REF,H);
Globalize_Local_Unbound_Var(adr)
}
else
A(a)=(Global_UnMove(tag)) ? Tag_Value(REF,adr) : word;
}
/*-------------------------------------------------------------------------*/
/* PUT_CONSTANT */
/* */
/*-------------------------------------------------------------------------*/
void Put_Constant(AtomInf *atom,int a)
{
A(a)=Tag_Value(CST,atom);
}
/*-------------------------------------------------------------------------*/
/* PUT_LIST */
/* */
/*-------------------------------------------------------------------------*/
void Put_List(int a)
{
A(a)=Tag_Value(LST,H);
S=WRITE_MODE;
}
/*-------------------------------------------------------------------------*/
/* PUT_STRUCTURE */
/* */
/*-------------------------------------------------------------------------*/
void Put_Structure(AtomInf *f,int n,int a)
{
A(a)=Tag_Value(STC,H);
Global_Push(Functor_Arity(f,n));
S=WRITE_MODE;
}
/*-------------------------------------------------------------------------*/
/* UNIFY_VARIABLE */
/* */
/*-------------------------------------------------------------------------*/
void Unify_Variable(WamWord *start_adr)
{
WamWord word,tag;
if (S!=WRITE_MODE)
{
tag=Tag_Of(word= *S);
*start_adr=(Global_UnMove(tag)) ? Tag_Value(REF,S) : word;
S++;
}
else
{
*start_adr=word=Make_Self_Ref(H);
Global_Push(word);
}
}
/*-------------------------------------------------------------------------*/
/* UNIFY_VALUE */
/* */
/*-------------------------------------------------------------------------*/
Bool Unify_Value(WamWord start_word)
{
if (S!=WRITE_MODE)
{
if (!Unify(start_word,*S))
return FALSE;
S++;
return TRUE;
}
Global_Push(start_word);
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* UNIFY_LOCAL_VALUE */
/* */
/*-------------------------------------------------------------------------*/
Bool Unify_Local_Value(WamWord start_word)
{
WamWord word,tag,*adr;
if (S!=WRITE_MODE)
return Unify(start_word,*S++);
Deref(start_word,word,tag,adr)
if (tag==REF && Is_A_Local_Adr(adr))
Globalize_Local_Unbound_Var(adr)
else
Global_Push((Global_UnMove(tag)) ? Tag_Value(REF,adr) : word);
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* UNIFY_VOID */
/* */
/*-------------------------------------------------------------------------*/
void Unify_Void(int n)
{
WamWord *end_adr;
if (S!=WRITE_MODE)
S+=n;
else
for(end_adr=H+(n);H<end_adr;++H)
*H=Make_Self_Ref(H);
}
/*-------------------------------------------------------------------------*/
/* UNIFY_CONSTANT */
/* */
/*-------------------------------------------------------------------------*/
Bool Unify_Constant(AtomInf *atom)
{
WamWord word,tag,*adr;
if (S!=WRITE_MODE)
{
Deref(*S,word,tag,adr)
S++;
switch(tag)
{
case REF:
Bind_UV(adr,Tag_Value(CST,atom))
return TRUE;
case CST:
return (UnTag_CST(word)==atom);
}
return FALSE;
}
Global_Push(Tag_Value(CST,atom));
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* UNIFY_INTEGER */
/* */
/*-------------------------------------------------------------------------*/
Bool Unify_Integer(int n)
{
WamWord word,tag,*adr;
if (S!=WRITE_MODE)
{
Deref(*S,word,tag,adr)
S++;
switch(tag)
{
case REF:
Bind_UV(adr,Tag_Value(INT,n))
return TRUE;
case INT:
return (UnTag_INT(word)==n);
}
return FALSE;
}
Global_Push(Tag_Value(INT,n));
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* UNIFY_NIL */
/* */
/*-------------------------------------------------------------------------*/
Bool Unify_Nil(void)
{
WamWord word,tag,*adr;
if (S!=WRITE_MODE)
{
Deref(*S,word,tag,adr)
S++;
if (tag==REF)
{
Bind_UV(adr,word_nil)
return TRUE;
}
else
return (word==word_nil);
}
Global_Push(word_nil);
return TRUE;
}
/*-------------------------------------------------------------------------*/
/* ALLOCATE */
/* */
/*-------------------------------------------------------------------------*/
void Allocate(int n)
{
WamWord *adr;
adr=E;
E=Local_Top+ENVIR_STATIC_SIZE+n;
\
CPE(E)=(WamWord) CP;
EE(E) =(WamWord) adr;
}
/*-------------------------------------------------------------------------*/
/* SET_STACK_DEFAULTS */
/* */
/*-------------------------------------------------------------------------*/
void Set_Stack_Defaults(char *name,char *env_var_name,int default_size_kb)
{
int i;
for(i=0;i<NB_OF_STACKS;i++)
if (Lib2(strcmp,name,stk_tbl[i].name)==0)
break;
if (i==NB_OF_STACKS)
Fatal_Error(ERR_UNKNOWN_STACK,name);
stk_tbl[i].env_var_name=env_var_name;
stk_tbl[i].default_size=KBytes_To_Wam_Words(default_size_kb);
}
/*-------------------------------------------------------------------------*/
/* INIT_WAM_ENGINE */
/* */
/* the top of stack are initialized and space for feint first choice point */
/* must be reserved (see Call_Prolog). It's achieved by set B with a value */
/* greater than E (see Local_Top in wam_engine.h). The first real choice */
/* point (try / try_me_else) or the first environment (allocate) will not */
/* use words 0..CHOICE_STATIC_SIZE in local stack. So the space for a feint*/
/* choice point is preserved. */
/*-------------------------------------------------------------------------*/
void Init_Wam_Engine(void)
{
LibPrototype(extern int setlinebuf())
int i,x;
char *p;
Lib1(setlinebuf,stdout);
for(i=0;i<NB_OF_STACKS;i++)
{
stk_tbl[i].size=stk_tbl[i].default_size;
if (*stk_tbl[i].env_var_name)
{
p=(char *) Lib1(getenv,stk_tbl[i].env_var_name);
if (p && *p)
{
Lib3(sscanf,p,"%d",&x);
stk_tbl[i].size=KBytes_To_Wam_Words(x);
}
}
}
M_Allocate_Stacks();
Save_Machine_Regs(glob_buff_save);
reg_bank=Global_Stack; /* allocated X regs + other non alloc regs */
Global_Stack+=REG_BANK_SIZE; /* at the beginning of the heap */
Global_Size-=REG_BANK_SIZE;
Init_Atom_Pred();
word_nil=Tag_Value(CST,atom_nil); /* defined as a reg (see archi.def) */
Reinit_Wam_Engine();
}
/*-------------------------------------------------------------------------*/
/* REINIT_WAM_ENGINE */
/* */
/*-------------------------------------------------------------------------*/
void Reinit_Wam_Engine(void)
{
Prototype(Prefix(Call_Prolog_Fail))
E=B=BC=Local_Stack;
H=Global_Stack;
TR=Trail_Stack;
CP=NULL;
/* 1st choice point */
Create_Choice_Point((CodePtr) Prefix(Call_Prolog_Fail),0);
}
/*-------------------------------------------------------------------------*/
/* TERM_WAM_ENGINE */
/* */
/*-------------------------------------------------------------------------*/
void Term_Wam_Engine(void)
{
#ifdef WAM_PROFILE
int used,max_used;
WamWord *w;
int i;
#endif
Restore_Machine_Regs(glob_buff_save);
#ifdef WAM_PROFILE
Lib1(printf,"\n");
Lib1(printf,"WAM Profile informations\n\n");
Lib1(printf,"Stacks:\n");
for(i=0;i<NB_OF_STACKS;i++)
{
used=Stack_Top(i)-stk_tbl[i].stack;
w=stk_tbl[i].stack+stk_tbl[i].size-1;
while(w >= stk_tbl[i].stack && (*w==0 || *w==M_MAGIC))
w--;
max_used=w-stk_tbl[i].stack+1;
if (Global_Stack==stk_tbl[i].stack)
{
used +=REG_BANK_SIZE; /* see Init_Wam_Engine */
max_used+=REG_BANK_SIZE;
}
used*=sizeof(WamWord);
max_used*=sizeof(WamWord);
Lib5(printf," %-6s stack:%10d bytes %10d end use %10d max use\n",
stk_tbl[i].name,stk_tbl[i].size*sizeof(WamWord),used,max_used);
}
Lib1(printf,"\n");
Lib1(printf,"\n");
Lib1(printf,"Choice points:\n");
Lib2(printf," create :%10d (try)\n", nb_of_create_choice_point);
Lib2(printf," update :%10d (retry)\n",nb_of_update_choice_point);
Lib2(printf," delete :%10d (trust)\n",nb_of_delete_choice_point);
Lib1(printf,"\n");
#endif
}
/*-------------------------------------------------------------------------*/
/* CAPTURE_SIGNAL */
/* */
/*-------------------------------------------------------------------------*/
void Capture_Signal(sig)
{
Lib2(signal,sig,Signal_Handler);
}
/*-------------------------------------------------------------------------*/
/* SWITCH_REG_BANK */
/* */
/*-------------------------------------------------------------------------*/
void Switch_Reg_Bank(WamWord *new_reg_bank)
{
int i;
WamWord *p1,*p2;
if (reg_bank!=new_reg_bank)
{
p1=reg_bank+NB_OF_X_REGS;
p2=new_reg_bank+NB_OF_X_REGS;
for(i=0;i<NB_OF_NOT_ALLOC_REGS;i++)
*p2++=*p1++;
reg_bank=new_reg_bank;
}
}
/*-------------------------------------------------------------------------*/
/* CALL_PROLOG */
/* */
/* Call_Prolog runs the execution of one prolog goal. */
/* The current choice point is updated to set ALTB to Call_Prolog_Fail and */
/* CP is set to Call_Prolog_Success. At the end ALTB and CP are restored. */
/* To ensure that a choice point always exists before invoking Call_Prolog,*/
/* Init_Wam_Engine reserve the space for a feint choice point, i.e ALTB can*/
/* be modified safely. */
/* The intermediate call to Call_Next1 allocates on the C stack enough */
/* space for local variables declared in the called (i.e. with goto) fcts */
/* */
/* Call_Prolog returns TRUE if the predicate has succeed, FALSE otherwise. */
/* The called predicate can be non-deterministic. */
/*-------------------------------------------------------------------------*/
Bool Call_Prolog(CodePtr codep)
{
Prototype(Prefix(Call_Prolog_Success))
Prototype(Prefix(Call_Prolog_Fail))
Bool Call_Next();
WamWord *cur_chc_pt=B;
WamCont save_CP =CP;
WamCont save_ALTB =ALTB(cur_chc_pt);
Bool ok;
ALTB(cur_chc_pt)=(WamWord) Prefix(Call_Prolog_Fail); /* modify choice pnt */
Call_Execute_Prefix
CP=(WamCont) Prefix(Call_Prolog_Success);
ok=Call_Next(codep);
CP=save_CP; /* restore continuation */
ALTB(cur_chc_pt)=save_ALTB; /* restore choice point */
return ok;
}
/*-------------------------------------------------------------------------*/
/* CALL_PROLOG_NEXT_SOL */
/* */
/* Call_Prolog_Next_Sol bactracks over the next solution. */
/*-------------------------------------------------------------------------*/
Bool Call_Prolog_Next_Sol(void)
{
Prototype(Prefix(Call_Prolog_Success))
Prototype(Prefix(Call_Prolog_Fail))
Bool Call_Next();
WamCont save_CP =CP;
Bool ok;
Call_Execute_Prefix
CP=(WamCont) Prefix(Call_Prolog_Success);
ok=Call_Next(ALTB(B));
CP=save_CP; /* restore continuation */
return ok;
}
/*------------------------------------------------------------*/
/* Call_Next: save the context with setjmp. Since Call_Prolog */
/* can be nexted, I handle a stack of jumpers (i.e. contexts) */
/* directely in the C stack. The global variables p_jumper is */
/* the top of the stack and points to the current jumper. */
/* Similarly for the stack of machine register save buffers. */
/* When a (captured) signal X is received the prolog predicate*/
/* signal_handler(X) is called (see call.pl) */
/*------------------------------------------------------------*/
Bool Call_Next(CodePtr codep)
{
Prototype(Prefix(Pred_Name(SIGNAL_HANDLER,1)))
Prototype(Prefix(Pred_Name(ABORT,0)))
void Call_Next1();
int jmp_val;
jmp_buf *old_jumper=p_jumper;
jmp_buf new_jumper;
WamWord *old_buff_save=p_buff_save;
WamWord buff_save_machine_regs[NB_OF_USED_MACHINE_REGS + 1];
p_jumper= &new_jumper;
p_buff_save=buff_save_machine_regs;
Save_Machine_Regs(buff_save_machine_regs)
jmp_val=setjmp(*p_jumper);
Restore_Machine_Regs(buff_save_machine_regs)
if (jmp_val==0) /* normal call to codep */
Call_Next1(codep);
if (jmp_val<0) /* return from signal handler */
{
put_integer(-jmp_val,0)
Call_Next1((CodePtr) Prefix(Pred_Name(SIGNAL_HANDLER,1)));
}
if (jmp_val==3) /* return with a continuation in jmp_val */
Call_Next1(cont_jmp);
/* normal return */
p_jumper=old_jumper;
p_buff_save=old_buff_save;
return jmp_val-1;
}
/*------------------------------------------------------------*/
/* Call_Next1: to be sure that $sp at setjmp < $sp at longjmp */
/* reserve space for local variables of called (gotoed) fct */
/*------------------------------------------------------------*/
void Call_Next1(CodePtr codep)
{
int t[1024];
Foo(t);
M_Save_Control_Info
M_Indirect_Goto(codep)
}
/*------------------------------------------------------------*/
/* Foo: to be sure that gcc does not suppress the local array */
/* t in Call_Next1 (if yes I'll put Foo in another file !) */
/*------------------------------------------------------------*/
Foo(int *t)
{
}
/*------------------------------------------------------------*/
/* Call_Prolog_Fail: Prolog continuation after failure. */
/* Return in Call_Next with a longjmp (value 1) */
/*------------------------------------------------------------*/
Begin_Static_Wam_Code(Call_Prolog_Fail)
Save_Machine_Regs(p_buff_save)
longjmp(*p_jumper,FALSE+1);
End_Pred
/*------------------------------------------------------------*/
/* Call_Prolog_Success: Prolog continuation after success. */
/* Return in Call_Next with a longjmp (value 2) */
/*------------------------------------------------------------*/
Begin_Static_Wam_Code(Call_Prolog_Success)
Save_Machine_Regs(p_buff_save)
longjmp(*p_jumper,TRUE+1);
End_Pred
/*------------------------------------------------------------*/
/* Execute_A_Continuation: */
/* Similar to a nested Call_Prolog but faster, and if a fail */
/* occurs it is normally handled by the prolog engine, i.e. */
/* the last choice point is reconsidered. */
/* Return in Call_Next with a longjmp (value 3 cont_jmp=codep)*/
/*------------------------------------------------------------*/
void Execute_A_Continuation(CodePtr codep)
{
Save_Machine_Regs(p_buff_save)
cont_jmp=codep;
longjmp(*p_jumper,3);
}
/*------------------------------------------------------------*/
/* Signal_Handler: must restore some registers (e.g. on sparc)*/
/* get them form the last choice point (a fail will occurs) */
/* Return in Call_Next with a longjmp (value -sig) */
/*------------------------------------------------------------*/
static void Signal_Handler(int sig)
{
AtomInf *atom=Create_Atom("$handler_");
int b;
reg_bank=Global_Stack-REG_BANK_SIZE; /* restore reg_bank */
Lib2(signal,sig,Signal_Handler); /* re-arm signal (should use the mask) */
b=UnTag_INT(atom->g_elem.val);
if (b==0)
{
Lib2(printf,"system error - cannot catch throw(signal(%d))\n",sig);
exit(2);
}
B=Local_Stack+b;
#ifdef M_dec_alpha
TR=TRB(B); /* to improve since vars are not untrailed */
#endif
Update_Choice_Point(ALTB(B),0); /* restore WAM Registers */
Save_Machine_Regs(p_buff_save)
longjmp(*p_jumper,-sig);
}
/*-------------------------------------------------------------------------*/
/* UNIFY */
/* */
/*-------------------------------------------------------------------------*/
Bool Unify(WamWord start_u_word,WamWord start_v_word)
{
WamWord u_word,u_tag,*u_adr;
WamWord v_word,v_tag,*v_adr;
int i;
Deref(start_u_word,u_word,u_tag,u_adr)
Deref(start_v_word,v_word,v_tag,v_adr)
if (u_tag==REF)
{
if (v_tag==REF)
{
if (u_adr>v_adr)
Bind_UV(u_adr,Tag_Value(REF,v_adr))
else
if (v_adr>u_adr)
Bind_UV(v_adr,Tag_Value(REF,u_adr))
}
else
if (Global_UnMove(v_tag))
Bind_UV(u_adr,Tag_Value(REF,v_adr))
else
Bind_UV(u_adr,v_word)
return TRUE;
}
switch(v_tag)
{
case REF:
if (Global_UnMove(u_tag))
Bind_UV(v_adr,Tag_Value(REF,u_adr))
else
Bind_UV(v_adr,u_word)
return TRUE;
case INT:
case CST:
return (u_word==v_word); /* test tag and value */
case LST:
if (u_tag!=LST)
return FALSE;
u_adr=UnTag_LST(u_word);
v_adr=UnTag_LST(v_word);
if (u_adr==v_adr)
return TRUE;
return Unify(Car(u_adr),Car(v_adr)) &&
Unify(Cdr(u_adr),Cdr(v_adr));
default: /* v_tag==STC */
if (u_tag!=STC)
return FALSE;
u_adr=UnTag_STC(u_word);
v_adr=UnTag_STC(v_word);
if (u_adr==v_adr)
return TRUE;
if (Functor_And_Arity(u_adr) != Functor_And_Arity(v_adr))
return FALSE;
i=Arity(u_adr);
do
{
--i;
if (!Unify(Arg(u_adr,i),Arg(v_adr,i)))
return FALSE;
}
while(i);
return TRUE;
}
}
/*-------------------------------------------------------------------------*/
/* TERM_COMPARE */
/* */
/*-------------------------------------------------------------------------*/
int Term_Compare(WamWord start_u_word,WamWord start_v_word)
{
WamWord u_word,u_tag,*u_adr;
WamWord v_word,v_tag,*v_adr;
AtomInf *u_functor;
int u_arity;
WamWord *u_arg_adr;
AtomInf *v_functor;
int v_arity;
WamWord *v_arg_adr;
int i,x;
Deref(start_u_word,u_word,u_tag,u_adr)
Deref(start_v_word,v_word,v_tag,v_adr)
switch(u_tag)
{
case REF:
return (v_tag!=REF) ? -1 : u_adr-v_adr;
case INT:
if (v_tag==REF)
return 1;
return (v_tag!=INT) ? -1 : u_word-v_word;
case CST:
if (v_tag==REF || v_tag==INT)
return 1;
return (v_tag!=CST) ? -1 : Lib2(strcmp,UnTag_CST(u_word)->name,
UnTag_CST(v_word)->name);
}
/* u_tag==LST/STC */
if ((v_functor=Get_Compound(v_tag,v_word,&v_arity,&v_arg_adr))==NULL)
return 1; /* v_tag!=LST/STC */
u_functor=Get_Compound(u_tag,u_word,&u_arity,&u_arg_adr);
if (u_arity!=v_arity)
return u_arity-v_arity;
if (u_functor!=v_functor)
return Lib2(strcmp,u_functor->name,v_functor->name);
for(i=0;i<u_arity;i++)
if ((x=Term_Compare(*u_arg_adr++,*v_arg_adr++))!=0)
return x;
return 0;
}
/*-------------------------------------------------------------------------*/
/* PROPER_LIST_LENGTH */
/* */
/* returns the length of a list ended with [] or -1 if it not a proper list*/
/*-------------------------------------------------------------------------*/
int Proper_List_Length(WamWord start_word)
{
WamWord word,tag,*adr;
int n=0;
for(;;)
{
Deref(start_word,word,tag,adr)
if (word==word_nil)
return n;
if (tag!=LST)
return -1;
n++;
adr=UnTag_LST(word);
start_word=Cdr(adr);
}
}
/*-------------------------------------------------------------------------*/
/* TERM_SIZE */
/* */
/*-------------------------------------------------------------------------*/
int Term_Size(WamWord start_word)
{
WamWord word,tag,*adr;
int i;
int n;
Deref(start_word,word,tag,adr)
switch(tag)
{
case REF:
case INT:
case CST:
return 1;
case LST:
adr=UnTag_LST(word);
return 1+Term_Size(Car(adr))+Term_Size(Cdr(adr));
default: /* tag==STC */
adr=UnTag_STC(word);
n=2; /* tagged word + f_n */
i=Arity(adr);
do
{
--i;
n+=Term_Size(Arg(adr,i));
}
while(i);
return n;
}
}
/*-------------------------------------------------------------------------*/
/* COPY_TERM */
/* */
/* Copies a non contiguous term, the result is a contiguous term. */
/*-------------------------------------------------------------------------*/
void Copy_Term(WamWord *dst_adr,WamWord *src_adr)
{
WamWord *qtop,*base;
WamWord *p;
base_copy=dst_adr++;
base=top_vars=vars;
Copy_Term_Rec(base_copy,src_adr,&dst_adr);
/* restore original self references */
qtop=top_vars;
while(qtop!=base)
{
p=(WamWord *) (*--qtop); /* address to restore */
*p=*--qtop; /* word to restore */
}
}
/*-------------------------------------------------------------------------*/
/* COPY_TERM_REC */
/* */
/*-------------------------------------------------------------------------*/
static void Copy_Term_Rec(WamWord *dst_adr,WamWord *src_adr,WamWord **p)
{
WamWord word,tag,*adr;
WamWord *q;
int i;
int n;
Deref(*src_adr,word,tag,adr)
switch(tag)
{
case REF:
q=*p;
if (adr<q && adr>=base_copy) /* already a copy */
{
*dst_adr=word;
return;
}
*top_vars++ = word; /* word to restore */
*top_vars++ = (WamWord) adr; /* address to restore */
*adr=*dst_adr=Tag_Value(REF,dst_adr); /* bind to a new copy */
return;
case INT:
case CST:
*dst_adr=word;
return;
case LST:
adr=UnTag_LST(word);
q=*p;
*p=&Cdr(q)+1;
Copy_Term_Rec(&Car(q),&Car(adr),p);
Copy_Term_Rec(&Cdr(q),&Cdr(adr),p);
*dst_adr=Tag_Value(LST,q);
return;
default: /* tag==STC */
adr=UnTag_STC(word);
q=*p;
Functor_And_Arity(q)=Functor_And_Arity(adr);
n=Arity(adr);
*p=&Arg(q,n-1)+1;
for(i=0;i<n;i++)
Copy_Term_Rec(&Arg(q,i),&Arg(adr,i),p);
*dst_adr=Tag_Value(STC,q);
return;
}
}
/*-------------------------------------------------------------------------*/
/* COPY_CONTIGUOUS_TERM */
/* */
/* Copies a contiguous term, the result is a contiguous term. */
/*-------------------------------------------------------------------------*/
void Copy_Contiguous_Term(WamWord *dst_adr,WamWord *src_adr)
#define Old_Adr_To_New_Adr(adr) ((dst_adr)+((adr)-(src_adr)))
{
WamWord word,*adr;
WamWord *q;
int i;
int n;
word=*src_adr;
switch(Tag_Of(word))
{
case REF:
adr=UnTag_REF(word);
q=Old_Adr_To_New_Adr(adr);
*dst_adr=Tag_Value(REF,q);
if (adr>src_adr) /* only useful for Global_UnMove() */
Copy_Contiguous_Term(q,adr);
return;
case INT:
case CST:
*dst_adr=word;
return;
case LST:
adr=UnTag_LST(word);
q=Old_Adr_To_New_Adr(adr);
Copy_Contiguous_Term(&Car(q),&Car(adr));
Copy_Contiguous_Term(&Cdr(q),&Cdr(adr));
*dst_adr=Tag_Value(LST,q);
return;
default: /* tag==STC */
adr=UnTag_STC(word);
q=Old_Adr_To_New_Adr(adr);
Functor_And_Arity(q)=Functor_And_Arity(adr);
n=Arity(adr);
for(i=0;i<n;i++)
Copy_Contiguous_Term(&Arg(q,i),&Arg(adr,i));
*dst_adr=Tag_Value(STC,q);
return;
}
}
/*-------------------------------------------------------------------------*/
/* FATAL_ERROR */
/* */
/*-------------------------------------------------------------------------*/
void Fatal_Error(char *format,...)
{
va_list arg_ptr;
printf("\nFatal Error: ");
va_start(arg_ptr,format);
vprintf(format,arg_ptr);
va_end(arg_ptr);
printf("\n");
exit(1);
}
syntax highlighted by Code2HTML, v. 0.9.1