/* ----------------------------------------------------------
% (C)1992 Institute for New Generation Computer Technology
% (Read COPYRIGHT for detailed information.)
----------------------------------------------------------- */
/*=====================================================================
* cu-Prolog III (Constraint Unification Prolog)
* Copyright: Institute for New Generation Computer Technology,Japan
* 1989--91
==================================================================== */
/*--------------------------------------------------------------------
* <<<< new.c >>>>
* memory management
* 93.8.2 speedup
* 94.6.28 speedup
--------------------------------------------------------------------*/
#define DEBUG 0 /* if Debug 1 else 0 */
#define NEW 1
#include "include.h"
#include <math.h>
/* struct allocation macro int a:arity */
int TERM_SIZE = (sizeof(struct term) / sizeof(int));
int FUNC_SIZE = (sizeof(struct func) / sizeof(int));
int POINTER_SIZE = (sizeof(struct term *) / sizeof(int));
#if SUN4 == 1
#define Termalloc(a) (struct term *)salloc(TERM_SIZE + a * POINTER_SIZE)
#define tempterm(a) (struct term *)alloc(TERM_SIZE + a * POINTER_SIZE)
#define mediterm(a) (struct term *)challoc(TERM_SIZE + a * POINTER_SIZE)
#define funcalloc(a) (struct func *)salloc(FUNC_SIZE + a * POINTER_SIZE)
#else
#define Termalloc(a) (struct term *)salloc(TERM_SIZE + (a-1) * POINTER_SIZE)
#define tempterm(a) (struct term *)alloc(TERM_SIZE + (a-1) * POINTER_SIZE)
#define mediterm(a) (struct term *)challoc(TERM_SIZE + (a-1) * POINTER_SIZE)
#define funcalloc(a) (struct func *)salloc(FUNC_SIZE + (a-1) * POINTER_SIZE)
#endif
void print_hash_table() /* for debug */
{
register int i,empty=0,conflict=0;
int conflict_max=0,total_length=0;
float mean, d;
register struct func *f;
for (i = 0; i < HASH_SIZE; i++){
printf("[%d]",i);
for (f = hash_list[i],conflict=0; f != NULL;
f = f->f_link,conflict++)
printf("%s/%d ",f->f_name,f->f_arity);
putchar('\n');
total_length += conflict;
if (conflict == 0) empty++;
if (conflict_max < conflict) conflict_max=conflict;
}
mean = (float)total_length/(float)HASH_SIZE;
for (i =d=0; i < HASH_SIZE; i++)
{
for (f = hash_list[i],conflict=0; f != NULL;
f = f->f_link,conflict++)
d+= (float)(conflict - mean)*(float)(conflict - mean)/HASH_SIZE;
}
printf("empty = %d/%d (%.2f), longest = %d, total=%d,\naverage_length=%.2f, d=%.3f\n",
empty, HASH_SIZE, ((float)empty/(float)HASH_SIZE),
conflict_max, total_length,
((float)total_length/(float)(HASH_SIZE-empty)),
sqrt(d));
}
int hash(fname)
char *fname;
{
register int h = 0, factor;
/* for (factor = strlen(fname) + 1; *fname != '\0'; fname++, factor--) */
/* for (factor = 1; *fname != '\0'; fname++, factor++)
h+= ((*fname) * factor); */
for (; *fname != '\0'; fname++)
h+= (unsigned char)(*fname); /* for EUC Kanji 94.10.27 */
if (h < 0) return(0);
else return(h % HASH_SIZE);
}
int *salloc(n) /* system heap allocation */
register int n;
{
register int *p;
#if DEBUG == 1
if (shp < SHEAPBOTTOM)
error("system heap underflow");
#endif
p = shp;
shp += n;
if (shp < SHEAPTOP)
return(p);
else
error("system heap overflow");
}
int *alloc(n) /* user heap allocation */
register int n;
{
register int *p;
/* - hp */
p = hp;
hp += n;
#if DEBUG == 1
if (hp < HEAPBOTTOM){
sprintf(nbuf,"hp = %d : user heap underflow",hp);
error(nbuf);
}
#endif
if (hp < HEAPTOP)
return(p);
else
error("user heap overflow");
}
int *challoc(n) /* constraints/pst heap allocation */
register int n;
{
register int *p;
p = chp;
chp += n;
#if DEBUG == 1
if (chp < CHEAPBOTTOM){
sprintf(nbuf,"chp = %d : constraints heap underflow",chp);
error(nbuf);
}
#endif
if (chp < CHEAPTOP)
return(p);
else
error("constraints heap overflow");
}
struct pair *ealloc(n) /* envionment stack allocation */
register int n;
{
register struct pair *p;
p = ep;
ep += n;
#if DEBUG == 1
if (ep < eheap){
sprintf(nbuf,"ep = %d : environment stack underflow",ep);
error(nbuf);
}
#endif
if (ep < ESPTOP)
return(p);
else
error("environment stack overflow");
}
char *nalloc(n,flag) /* name string heap allocation */
register char *n;
int flag;
{
register char *p;
register int q;
register struct func *f;
if ((&nheap[0] <= n) && (n <= nhp)) return(n);
if ((f = exist_fname(n)) != NULL) return(f->f_name);
/* - nhp */
switch (flag) {
case ETERNAL:
case MEDIUM:
q = strlen(n)+1;
p = nhp;
nhp += q;
if(nhp > NHEAPTOP) error("name heap overflow");
break;
default : /* TEMPORAL or STINGY */
q = strlen(n)+4;
p = (char *)alloc(q / sizeof(int));
}
strcpy(p,n);
return(p);
}
struct term *Nnum(nbuf,flag) /* make number */
char *nbuf;
int flag;
{
register struct term *n;
float x;
double atof();
MEMORY_ALLOC(n,term,flag);
n->type.ident = ATOMIC_TYPE;
sscanf(nbuf,"%f",&x);
n->tag.n_value = x;
if (x == ((float)((int)x))) n->t_arity = INT_NUM;
else n->t_arity = FLOAT_NUM;
return(n);
}
struct term *Nnum_val(x,flag) /* make a term representing x */
register float x;
int flag;
{
register struct term *n;
MEMORY_ALLOC(n,term,flag);
n->type.ident = ATOMIC_TYPE;
if (x == ((float)((int)x))) n->t_arity = INT_NUM;
else n->t_arity = FLOAT_NUM;
n->tag.n_value = x;
return(n);
}
struct term *Nstr(x, flag) /* make a term representing x */
char *x;
int flag;
{
register struct term *s;
MEMORY_ALLOC(s,term,flag);
s->type.ident = ATOMIC_TYPE;
s->t_arity = STRING;
if (flag==STINGY) flag=ETERNAL;
s->tag.s_value = nalloc(x,flag);
return(s);
}
struct pst *Npst(flag)
int flag;
{
register struct pst *p;
struct pstvar *pv;
MEMORY_ALLOC(p,pst,flag);
p->type = PST_TYPE;
MEMORY_ALLOC(pv,pstvar,flag);
pv->v_type = VAR_PST_TYPE;
pv->v_name = vname(Anonymous_var);
pv->v_number = p_number++;
pv->v_link = pv_list;
pv->old_var = NULL;
p->p_var = pv_list = (struct term *)pv;
p->p_lists = NULL_ECL;
return(p);
}
struct eclause *Neclause(val,env,tail,flag)
struct term *val;
struct pair *env;
struct eclause *tail;
int flag;
{
struct eclause *obj;
MEMORY_ALLOC(obj,eclause,flag);
obj->c_type = ECLAUSE_TYPE;
obj->c_env = env;
obj->c_form = val;
obj->c_link = tail;
return(obj);
}
struct term *Npst_item(p,pobj,next)
struct pair *p;
struct eclause *pobj;
struct pst_item *next;
{
struct pst_item *t;
t = cnew(pst_item);
t->p_var = p;
t->p_lists = pobj;
t->p_link = next;
return((struct term *)t);
}
/* psttable (temporal PST area) functions */
/* initialize_psttable()
clear_psttable()
find_pstitem()
remove_pstitem()
remove_pstitem_if_not_equal()
record_pstobjects()
record_pstlists()
*/
int psttable_size()
{
int i;
struct pst_item *pi;
for (pi = psttable,i=0; pi != NULL; pi=pi->p_link,i++)
;
return(i);
}
void initialize_psttable()
{
psttable = snew(pst_item);
}
void clear_psttable()
{
psttable->p_link = NULL_PSTIT;
}
struct pst_item *find_pstitem(t,e)
struct term *t;
struct pair *e;
{
register struct pair *p;
register struct pst_item *table = psttable->p_link;
if (e==NULL_ENV)
return(NULL_PSTIT);
t = ((struct pst *)t)->p_var;
down(p,t,e);
while (table != NULL_PSTIT) {
if (table->p_var <= p) {
if (table->p_var == p) return(table);
else return(NULL_PSTIT);
}
table = table->p_link;
}
return(table);
}
/* remove (t,e) from psttable if it is not equal pitem */
struct pst_item *remove_pstitem_if_not_equal(t,e,pitem)
struct term *t;
struct pair *e;
struct pst_item *pitem;
{
struct pst_item *object, *target;
struct pair *p;
if (e==NULL_ENV) /* 94.5.20 H.Tsuda*/
return(NULL_PSTIT);
t = ((struct pst *)t)->p_var;
down(p,t,e);
target = psttable;
while ((object = target->p_link) != NULL_PSTIT) {
if (object->p_var <= p) {
if (object->p_var == p)
{
if (object == pitem) return(pitem); /* doesn't remove */
upush(&(target->p_link));
target->p_link = object->p_link;
return(object);
}
else return(NULL_PSTIT);
}
target = object;
}
return(object);
}
struct pst_item *remove_pstitem(t,e) /* remove (t,e) from psttable */
struct term *t;
struct pair *e;
{
return(
remove_pstitem_if_not_equal(t,e, NULL_PSTIT)
);
}
struct pst_item *record_pstobjects(t,e)
struct pst *t;
struct pair *e;
{
struct pst_item *entry = psttable;
struct term *tt = t->p_var;
struct pair *p;
down(p,tt,e);
while(entry->p_link != NULL_PSTIT) {
if (p > entry->p_link->p_var) break;
entry = entry->p_link;
}
upush(&(entry->p_link));
entry->p_link = (struct pst_item *)
Npst_item(p,NULL_ECL,entry->p_link);
entry = entry->p_link;
entry->p_lists = record_pstlists(t->p_lists,e);
/* printf("PSTtable size = %d\n",psttable_size()); */
return(entry);
}
struct eclause *record_pstlists(ptt,e)
struct eclause *ptt;
struct pair *e;
{
struct eclause *props, *pre;
if (ptt == NULL_ECL) return(ptt);
pre = props = Npstobj(ptt->c_form, e, NULL_ECL, MEDIUM);
for (ptt = ptt->c_link; ptt != NULL_ECL; ) {
props->c_link =
Npstobj(ptt->c_form, e, NULL_ECL, MEDIUM);
props = props->c_link;
ptt = ptt->c_link;
}
return(pre);
}
/* ------------------------- */
struct term *Nfile(x)
FILE *x;
{
register struct term *t;
t = cnew(term);
t->type.ident = ATOMIC_TYPE;
t->t_arity = FILE_POINTER;
t->tag.f_value = x;
return(t);
}
struct term *Nvar(nbuf,flag) /* make new var */
char *nbuf;
int flag;
{
register struct var *v;
/* + nbuf */
/* - v_number, v_list, shp */
MEMORY_ALLOC(v,var,flag);
v->v_type = VAR_GLOBAL_TYPE;
v->v_number = v_number++;
v->v_name = (nbuf==Anonymous_VarName) ? Anonymous_VarName :
nalloc(nbuf,flag);
v->v_link = (struct var *)v_list;
v_list = (struct term *)v;
v->v_constraint = NULL_CL; /* for CAHC 89.6.16 */
v->v_component = (struct component *)NULL;
v->v_head_occur = 0; /* var occurrence in the head */
v->v_occurrence = 1; /* var occurrence */
return(v_list);
}
struct term *varsearch(varname) /* search varname in v_list */
char *varname;
{
register struct term *v;
for (v = v_list; v != NULL; v = vlink(v))
if (streq(varname, vname(v))) {
((struct var *)v)->v_occurrence++;
return(v);
}
return(NULL);
}
void reset_voccurrence(v) /* all v_occurrence = 0 */
register struct term *v;
{
while (v != NULL_TERM) {
((struct var *)v)->v_occurrence = 0;
v = vlink(v);
}
}
/* move v_occurrence->v_head_occur, v_occurrence=0*/
void move_voccurrence(v)
register struct term *v;
{
while (v != NULL_TERM) {
((struct var *)v)->v_head_occur = ((struct var *)v)->v_occurrence;
((struct var *)v)->v_occurrence = 0;
v = vlink(v);
}
}
void recalc_voccur_sub(t) /* subroutine for recacl_voccurrence() */
struct term *t;
{
if (t == NULL_TERM || isconst(t)) return;
switch (t->type.ident) {
case VAR_VOID_TYPE: /* var */
case VAR_GLOBAL_TYPE:
((struct var *)t)->v_occurrence++;
case VAR_PST_TYPE:
case ATOMIC_TYPE:
case CONST_LIST_TYPE:
return;
case PST_TYPE:
{
register struct eclause *ec;
for (ec=(struct eclause *)((struct pst *)t)->p_lists;
ec != NULL_ECL; ec=ec->c_link)
recalc_voccur_sub(Arg2(ec->c_form));
return;
}
/* case ECLAUSE_TYPE:
register struct eclause *ec;
for (ec=(struct eclause *)t; ec != NULL_ECL;
ec=ec->c_link)
recalc_voccur_sub(Arg2(ec->c_form));
return; */
case CLAUSE_TYPE:
case LIST_TYPE:
recalc_voccur_sub(head_of_list(t));
recalc_voccur_sub(tail_of_list(t));
return;
default: /* complex term */
{
register int i, j=Pred(t)->f_arity;
for (i = 0; i < j; i++)
recalc_voccur_sub(Arg(t,i));
}
}
}
void decrement_vacuous(t) /* decrement voccurrence of vacuous position */
struct term *t;
{
register struct func *f;
register int i;
register struct term *arg;
if (isvar(t)) return; /* 94.12.2 call(X):-X. */
for (f = Pred(t),i = f->f_arity - 1; i >= 0; i--)
{
arg = Arg(t,i);
if (isvar(arg) && Component(f,i) == NULL)
vdecrement(arg);
}
}
void recalc_voccurrence(cl,v) /* cl == H :- C. */
struct clause *cl;
struct term *v;
{
register struct clause *c;
if (cl == NULL_CL ||
v == NULL_TERM) return;
reset_voccurrence(v); /* all voccurrence=0 */
recalc_voccur_sub(cl->c_form); /* check head */
move_voccurrence(v); /* body var -> head var */
for (c = cl->c_link; c != NULL; c = c->c_link) /* check body */
recalc_voccur_sub(c->c_form);
for (c = cl->c_link; c != NULL; c = c->c_link) /* vacuous vars */
decrement_vacuous(c->c_form);
}
struct func *exist_fname(fname) /* search predicate name */
char *fname;
{
register struct func *f;
for (f = hash_list[hash(fname)]; f != NULL; f = f->f_link)
if (streq(fname,f->f_name)) return(f);
return(NULL);
}
struct func *Predicate(fname, arity) /* search fname/arity */
char *fname; /* if not exist, make Nfunc */
int arity;
{
register struct func *f;
f = funcsearch(fname,arity);
if (f == NULL) return(Nfunc(USERFUN,fname,arity));
else return(f);
}
struct func *funcsearch(fname, arity) /* search fname/arity */
char *fname;
int arity;
{
register struct func *f;
register int compare;
for (f = hash_list[hash(fname)]; f != NULL; f = f->f_link)
{
if ((compare = strcmp(fname,f->f_name)) > 0)
return(NULL);
if ((compare == 0) && (f->f_arity == arity))
return(f);
}
return(NULL);
}
int pred_compare(f1,f2) /* pred compare -1 <, 0: =, 1 > */
struct func *f1,*f2;
{
register int cmp;
cmp = strcmp(f1->f_name,f2->f_name);
if (cmp != 0) return(cmp);
return(f2->f_arity - f1->f_arity);
}
void index_func(fnew) /* store predicate fnew into hash-table */
struct func *fnew;
{
struct func *flist;
register struct func *f, *flast;
int i = hash(fnew->f_name);
flist = hash_list[i];
if ((flist == NULL) || (pred_compare(fnew,flist) > 0))
{
hash_list[i] = fnew;
fnew->f_link = flist;
return;
}
for (flast=flist, f=flist->f_link; f != NULL; flast = f, f = f->f_link)
{
i = pred_compare(fnew,f);
if (i > 0) break;
if (i==0) {
/* sprintf(nbuf,"function `%s' is already used",fnew->f_name);
error(nbuf); */
return;
}
}
flast->f_link = fnew;
fnew->f_link = f;
return;
}
struct itrace *index_newflist(fl,it)
struct itrace *fl,*it;
{
register struct itrace *t, *top, *s, *temp;
if (fl==it) return(fl);
top = temp = new(itrace);
for (t=fl; t != it; t=t->it_link) {
if (in_sheap(t)) {
temp->it_link = t;
temp = t;
}
else {
temp->it_link = s = snew(itrace);
s->it_anumber = t->it_anumber;
s->it_cnumber = t->it_cnumber;
temp = s;
}
temp->it_clause = up_itrace_clause(t->it_clause,t->it_anumber);
}
temp->it_link=it;
return(top->it_link);
}
struct operator *op_search(fname,otype)
char *fname;
register int otype;
{
register struct operator *o;
register struct func *f;
f = (otype != INFIX) ? funcsearch(fname,1) : funcsearch(fname,2);
if (f == NULL) return(NULL);
for (o=o_list; o != NULL; o=o->o_link)
if ((f == o->o_func) && (otype == (o->o_type & INFIX)))
return(o);
return(NULL);
}
struct func *Nfunc(ftype, n, a) /* make new function */
int ftype; /* predicate type in include.h */
char *n; /* functor name */
int a; /* arity */
{
register struct func *f, *ff;
int i;
/* - FNUMBER, const_list,f_list, shp */
f = funcalloc(a);
f->f_arity = a;
f->f_name = nalloc(n,ETERNAL);
f->f_setcount = 0; /* number of def clauses */
f->f_unitcount = 0; /* number of unit clauses */
f->def.f_set = NULL;
f->f_number = FNUMBER++;
f->f_integ = NULL;
if (ftype != TEMPFUN)
{ f->f_mark = (a > 0) ? (ftype | VACUITY_NOCHECK) : ftype;
index_func(f);
}
else
{ f->f_mark = (a > 0) ? (USERFUN | VACUITY_NOCHECK) :
USERFUN;
ff = f_list;
f_list = f;
f->f_link = ff;
}
for (i = 0; i < a; i++) Component(f,i)=NULL;
return(f);
}
struct term *Nterm(n,flag)
int n; /* arity */
int flag;
{
struct term *t; /* alloc term in sheap */
/* if (n > VMAX) error("Too many arguments"); */
switch (flag) {
case TEMPORAL:
t = tempterm(n); break;
case ETERNAL:
case STINGY:
t = Termalloc(n); break;
default: /* MEDIUM */
t = mediterm(n);
}
t->t_arity = n;
return(t);
}
struct pair *Nenv(n) /* new environment for n vars */
register int n;
{
register struct pair *p;
register int i;
p = ealloc(n);
for(i = 0; i < n; i++)
{
p[i].p_body = NULL;
p[i].p_env = NULL;
}
return(p);
}
struct clause *Nlist(head,body,flag)
struct term *head;
struct clause *body;
int flag;
{
register struct clause *c;
MEMORY_ALLOC(c,clause,flag);
c->c_type = (novar(head) &&
((body == (struct clause *)NIL) ||
(body->c_type == CONST_LIST_TYPE))) ?
CONST_LIST_TYPE : LIST_TYPE;
c->c_form = head;
c->c_link = body;
return(c);
}
struct clause *Nclause(head,body,flag)
struct term *head;
struct clause *body;
int flag;
{
register struct clause *c;
MEMORY_ALLOC(c,clause,flag);
c->c_type = CLAUSE_TYPE;
c->c_form = head;
c->c_link = body;
return(c);
}
struct set *setconcat(slist, s) /* add s to the end of slist */
struct set *slist,*s;
{
register struct set *ss;
if (slist == NULL) return(s);
for(ss = slist; ss->s_link != NULL; ss = ss->s_link) ;
ss->s_link = s;
return(slist);
}
int literalnumber(c) /* number of literals in c */
register struct clause *c;
{
register int i;
for (i = 0; c != NULL; c = c->c_link, i++);
return(i);
}
int is_ground(t) /* check whether t is ground. */
struct term *t;
{
if (t == NULL_TERM || isconst(t)) return(TRUE);
switch (t->type.ident) {
case VAR_VOID_TYPE: /* var */
case VAR_PST_TYPE:
case ATOMIC_TYPE:
case CONST_LIST_TYPE:
return(TRUE);
case VAR_GLOBAL_TYPE:
case PST_TYPE:
return(FALSE);
case CLAUSE_TYPE:
case LIST_TYPE:
if (is_ground(head_of_list(t)) && is_ground(tail_of_list(t)))
return(TRUE);
else return(FALSE);
default: /* complex term */
{
register int i, j=Pred(t)->f_arity;
for (i = 0; i < j; i++)
if (is_ground(Arg(t,i)) == FALSE) return(FALSE);
return(TRUE);
}
}
}
void index_set(chead,con,flag)
struct clause *chead, *con;
char flag;
{
struct set *s;
if (issystem(Pred(chead->c_form))) {
sprintf(nbuf,"Caution!! : %s is a system predicate.\n",
Pred(chead->c_form)->f_name);
error(nbuf);
}
s = snew(set);
s->s_clause = chead;
recalc_voccurrence(chead, v_list);
s->s_vlist = v_list;
s->s_anumber = v_number+p_number;
s->s_constraint = con;
s->s_link = NULL;
s->s_ground_head = is_ground(chead->c_form); /* head is ground? */
add_set(s,flag);
}
void add_set(s,flag) /* add definition s to the end */
struct set *s;
char flag; /* 'a' or 'z' */
{
register struct func *f = s->s_clause->c_form->type.t_func;
struct set *setconcat();
/* check set_bodynumber */
s->s_bodynumber = literalnumber(s->s_clause->c_link);
if (flag == 'z') f->def.f_set = setconcat(f->def.f_set, s);
else
{
s->s_link = f->def.f_set;
f->def.f_set = s;
}
f->f_setcount++;
if is_unitclause(s) f->f_unitcount++;
/* add_f_cbind(s->s_clause->c_form); *//* calc f_cbind[] */
Def_Modified = 1; /* def modified flag (global v.) */
}
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
user stack operations:
upush(), undo()
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
void upush(p)
register int *p;
{
/* - usp */
if (p == NULL) return;
usp->u_addr = p;
(usp++)->u_val = *p;
/* for MS-DOS large model *//*
#if MSDOS == 2
usp->u_addr = p + 1;
(usp++)->u_val = *(p + 1);
#endif
*/
#if DEBUG == 1
if (p < HEAPBOTTOM || p > HEAPTOP)
error("out of range in upush");
if (usp < STACKBOTTOM)
error("user stack underflow");
#endif
if (usp > STACKTOP)
error("user stack overflow");
}
void undo(u)
register struct ustack *u;
{
/* - usp */
#if DEBUG == 1
if (u < STACKBOTTOM)
error("user stack underpop");
#endif
/* if (u > usp)
error("user stack overpop");
if (usp > Stack_Max) Stack_Max = usp;
if (chp > Cheap_Max) Cheap_Max = chp;
if (hp > Heap_Max) Heap_Max = hp;
if (ep > Esp_Max) Esp_Max = ep;
=====> backtrack_node()
*/
while(usp > u) {
--usp;
#if DEBUG == 1
if (usp->u_addr < HEAPBOTTOM || usp->u_addr > HEAPTOP)
fprintf(stderr, " over heap (undo)%x/%x\n",usp,STACKBOTTOM);
#endif
if (usp->u_addr == NULL) return;
else *(usp->u_addr) = usp->u_val;
}
}
syntax highlighted by Code2HTML, v. 0.9.1