/*-------------------------------------------------------------------------*/
/* Prolog To Wam Compiler INRIA Rocquencourt - CLoE Project */
/* C Run-time Daniel Diaz - 1994 */
/* */
/* Inline builtin library */
/* */
/* lib_inline.c */
/*-------------------------------------------------------------------------*/
#include <stdlib.h>
#include "wam_engine.h"
/*---------------------------------*/
/* Constants */
/*---------------------------------*/
#define ERR_ILLEGAL_ARGUMENT "\nError: Illegal argument\n"
/*---------------------------------*/
/* Type Definitions */
/*---------------------------------*/
/*---------------------------------*/
/* Global Variables */
/*---------------------------------*/
/*---------------------------------*/
/* Function Prototypes */
/*---------------------------------*/
/* Type tests */
#define Tag_Is_Var(t) ((t)==REF)
#define Tag_Is_Nonvar(t) (!Tag_Is_Var(t))
#define Tag_Is_Atom(t) ((t)==CST)
#define Tag_Is_Integer(t) ((t)==INT)
#define Tag_Is_Number(t) (Tag_Is_Integer(t))
#define Tag_Is_Atomic(t) (Tag_Is_Atom(t) || Tag_Is_Number(t))
#define Tag_Is_Compound(t) ((t)==STC || (t)==LST)
#define Tag_Is_Callable(t) ((t)==CST || (t)==STC || (t)==LST)
#define Type_Test(test,x) \
{ \
WamWord word,tag,*adr; \
\
Deref(x,word,tag,adr) \
return CPP_CAT(test,(tag)); \
}
/*-------------------------------------------------------------------------*/
/* BLT_1_VAR/... */
/* */
/*-------------------------------------------------------------------------*/
Bool Blt_1_var (WamWord x) { Type_Test(Tag_Is_Var,x) }
Bool Blt_1_nonvar (WamWord x) { Type_Test(Tag_Is_Nonvar,x) }
Bool Blt_1_atom (WamWord x) { Type_Test(Tag_Is_Atom,x) }
Bool Blt_1_integer (WamWord x) { Type_Test(Tag_Is_Integer,x) }
Bool Blt_1_number (WamWord x) { Type_Test(Tag_Is_Number,x) }
Bool Blt_1_atomic (WamWord x) { Type_Test(Tag_Is_Atomic,x) }
Bool Blt_1_compound(WamWord x) { Type_Test(Tag_Is_Compound,x) }
Bool Blt_1_callable(WamWord x) { Type_Test(Tag_Is_Callable,x) }
/*-------------------------------------------------------------------------*/
/* BLT_3_ARG */
/* */
/*-------------------------------------------------------------------------*/
Bool Blt_3_arg(WamWord word_indice,WamWord word_term,WamWord sub_term)
{
WamWord word,tag,*adr;
int arity;
WamWord *arg1_adr;
int no_arg;
Deref(word_indice,word,tag,adr)
if (tag!=INT)
{
Lib1(printf,ERR_ILLEGAL_ARGUMENT);
return(FALSE);
}
no_arg=UnTag_INT(word)-1;
Deref(word_term,word,tag,adr)
if (tag==LST)
{
adr=UnTag_LST(word);
return no_arg==0 && Unify(sub_term,Car(adr)) ||
no_arg==1 && Unify(sub_term,Cdr(adr));
}
if (tag==STC)
{
adr=UnTag_STC(word);
arity=Arity(adr);
return (unsigned) no_arg<arity && Unify(sub_term,Arg(adr,no_arg));
}
Lib1(printf,ERR_ILLEGAL_ARGUMENT);
return FALSE;
}
/*-------------------------------------------------------------------------*/
/* BLT_3_FUNCTOR */
/* */
/*-------------------------------------------------------------------------*/
Bool Blt_3_functor(WamWord word_term,WamWord word_functor,WamWord word_arity)
{
WamWord word,tag,*adr;
WamWord tag_functor;
int arity;
Deref(word_term,word,tag,adr)
switch(tag)
{
case INT:
return Get_Integer(UnTag_INT(word),word_functor) &&
Get_Integer(0,word_arity);
case CST:
return Get_Constant(UnTag_CST(word),word_functor) &&
Get_Integer(0,word_arity);
case LST:
return Get_Constant(atom_dot,word_functor) &&
Get_Integer(2,word_arity);
case STC:
adr=UnTag_STC(word);
return Get_Constant(Functor(adr),word_functor) &&
Get_Integer(Arity(adr),word_arity);
}
/* tag==REF */
Deref(word_functor,word,tag,adr)
if (tag!=CST && tag!=INT)
{
Lib1(printf,ERR_ILLEGAL_ARGUMENT);
return FALSE;
}
tag_functor =tag;
word_functor=word;
Deref(word_arity,word,tag,adr)
arity=UnTag_INT(word);
if (tag!=INT || (unsigned) arity>MAX_ARITY)
{
Lib1(printf,ERR_ILLEGAL_ARGUMENT);
return FALSE;
}
if (tag_functor==CST && UnTag_CST(word_functor)==atom_dot && arity==2)
return (Get_List(word_term)) ? Unify_Void(2), TRUE : FALSE;
if (tag_functor==CST && arity>0)
return (Get_Structure(UnTag_CST(word_functor),arity,word_term)) ?
Unify_Void(arity), TRUE : FALSE;
if (arity!=0)
return FALSE;
switch(tag_functor)
{
case CST:
return Get_Constant(UnTag_CST(word_functor),word_term);
case INT:
return Get_Integer(UnTag_INT(word_functor),word_term);
}
return FALSE;
}
/*-------------------------------------------------------------------------*/
/* BLT_2_TERM_UNIV */
/* */
/*-------------------------------------------------------------------------*/
Bool Blt_2_term_univ(WamWord u_word,WamWord v_word)
{
WamWord word,tag,*adr;
WamWord car_word;
int lst_length;
WamWord *arg1_adr;
WamWord *u_adr,*lst_adr,*stc_adr;
WamWord functor_word,functor_tag;
AtomInf *functor;
int arity;
Deref(u_word,word,tag,u_adr)
switch(tag)
{
case REF:
goto list_to_term;
/* from term to list functor+args */
case INT:
case CST:
car_word=word;
lst_length=1+0;
break;
case LST:
adr=UnTag_LST(word);
car_word=Tag_Value(CST,atom_dot);
lst_length=1+2;
arg1_adr=&Car(adr);
break;
case STC:
adr=UnTag_LST(word);
car_word=Tag_Value(CST,Functor(adr));
lst_length=1+Arity(adr);
arg1_adr=&Arg(adr,0);
break;
}
for(;;)
{
if (!Get_List(v_word) || !Unify_Value(car_word))
return FALSE;
Unify_Variable(&v_word);
if (--lst_length==0)
break;
car_word=*arg1_adr++;
}
return Get_Nil(v_word);
/* from list functor+args to term */
list_to_term:
Deref(v_word,word,tag,adr)
if (tag!=LST)
goto error;
lst_adr=UnTag_LST(word);
Deref(Car(lst_adr),functor_word,functor_tag,adr)
if (functor_tag!=CST && functor_tag!=INT)
goto error;
Deref(Cdr(lst_adr),word,tag,adr)
if (word==word_nil)
{
Bind_UV(u_adr,functor_word);
return TRUE;
}
else
if (functor_tag==INT || tag!=LST)
goto error;
functor=UnTag_CST(functor_word);
stc_adr=H;
H++; /* reserve space for f/n maybe lost if a list */
arity=0;
for(;;)
{
arity++;
lst_adr=UnTag_LST(word);
Deref(Car(lst_adr),word,tag,adr)
Global_Push(word);
Deref(Cdr(lst_adr),word,tag,adr)
if (word==word_nil)
break;
if (tag!=LST)
goto error;
}
if (functor==atom_dot && arity==2) /* a list */
u_word=Tag_Value(LST,stc_adr+1);
else
{
*stc_adr=Functor_Arity(functor,arity);
u_word=Tag_Value(STC,stc_adr);
}
Bind_UV(u_adr,u_word);
return TRUE;
error:
Lib1(printf,ERR_ILLEGAL_ARGUMENT);
return FALSE;
}
/* Term Comparison (see also ../src/builtin.h) */
/*-------------------------------------------------------------------------*/
/* BLT_3_COMPARE */
/* */
/*-------------------------------------------------------------------------*/
Bool Blt_3_compare(WamWord word_cmp,WamWord x,WamWord y)
{
int c=Term_Compare(x,y);
AtomInf *atom;
atom=(c<0) ? atom_inf : (c==0) ? atom_eq : atom_sup;
return Get_Constant(atom,word_cmp);
}
/* Mathematics (see also ../src/builtin.h) */
/*-------------------------------------------------------------------------*/
/* LOAD_MATH_EXPRESSION */
/* */
/*-------------------------------------------------------------------------*/
Bool Load_Math_Expression(WamWord exp,WamWord *result)
#define Eval_2 Prefix(X6576616C_2)
{
Prototype(Eval_2)
WamWord word,tag,*adr;
Bool ret;
WamWord a1;
WamWord *save_reg_bank=reg_bank;
WamWord local_reg_bank[REG_BANK_SIZE];
Switch_Reg_Bank(local_reg_bank);
A(0)=exp;
put_x_variable(1,1)
a1=A(1);
ret=Call_Prolog((CodePtr) Eval_2);
Deref(a1,word,tag,adr)
*result=word;
Switch_Reg_Bank(save_reg_bank);
return ret;
}
syntax highlighted by Code2HTML, v. 0.9.1