/* ----------------------------------------------------------
% (C)1992 Institute for New Generation Computer Technology
% (Read COPYRIGHT for detailed information.)
----------------------------------------------------------- */
/*--------------------------------------------------------------------
* cu-Prolog III (Constraint Unification Prolog)
* ICOT in Cooperation with SIRAI@sccs.chukyo-u.ac.jp
* << main.c >>
* 88.11.23 Ver.2.00 OS command
* 90.4.1 rewrite refute, syspred (ver.3.0)
* 91.12 cu-Prolog III
* 92.7 ICOT Free Software Release
* 92.10.5 patch (init_status(): set globval vars)
* 92.10.29 patch (up_init(): reset termset log)
* 93.7.15 init_status() shp %Z(hash list)
* 93.7.30 add decode_args(),heap_alloc()
* 93.8.2 speedup 93.8.31 initialize_pointer()
* 93.9.22 gc, sample/marcus.p
* 94.5.20 PST unify, sample/hpsg.p
* 94.7.6--13 speedup, unify.c etc.
* 94.9.2 statistics (%S command)
* 94.9.27 atom_to_str/2
* 94.10.25,27 for HELIOS, debug maisub.c
--------------------------------------------------------------------*/
#include "version.h"
#define COPYRIGHT "Institute for New Generation Computer Technology (ICOT)\n\t\tTokyo, Japan 1991-94"
#define MAIN 1
#define HELIOS 0 /* if used as substance in Helios, 1 */
#include "include.h"
#include <signal.h>
struct itrace *newflist_save;
void main(argc,argv)
int argc;
char *argv[];
{
void on_interrupt(),decode_args();
int i;
fp=stdin; /* default input */
for(argv++, i = 1; i < argc; i++, argv++)
decode_args(*argv); /* decode arguments */
prepare(); /* set flag etc. */
utop = &ustack[0];
signal(SIGINT, on_interrupt);
setjmp(reset);
setjmp(unbreak_reset);
while(1){
f_list = NULL;
usp = utop;
chp = &cheap[1]; /* save constraints heap pointer */
hp = &heap[1]; /* save user heap pointer */
ep = &eheap[1]; /* save user stack pointer */
newflist_save = newf_list; /* save old c.t. trace */
prolog_execution();
fflush(stdout); /* for HELIOS */
}
}
void decode_args(arg) /* decode arguments */
char *arg;
{
int size;
if (arg[0] == '-') {
size = atoi(arg+2)*1000;
if (size > 0)
switch (arg[1])
{
case 'H': HEAP_SIZE=size; break;
case 'S': SHEAP_SIZE=size; break;
case 'E': ESP_SIZE=size; break;
case 'C': CHEAP_SIZE=size; break;
case 'U': USTACK_SIZE=size; break;
case 'N': NAME_SIZE=size; break;
}
}
else if ((fp = fopen(arg,"r")) == NULL) {
printf("***Error*** Can't open '%s' \n",arg);
fp = stdin;
}
else {
printf(">>> open %s \n",arg);
settimer();
}
}
/* for statistics checking */
void init_statistics()
{
STAT_REFUTE=STAT_BACKTRACK_DEEP=STAT_BACKTRACK_SHAL=0;
STAT_FOLD=STAT_UNFOLD=STAT_DEF=0;
}
void print_statistics()
{
printf("--- statistics ----\n");
printf("[PROLOG] refute: %d + shallow backtrack: %d (deep backtrack: %d)\n",
STAT_REFUTE, STAT_BACKTRACK_SHAL, STAT_BACKTRACK_DEEP);
printf("[UNFOLD/FOLD] unfold: %d fold: %d definition: %d\n",
STAT_UNFOLD, STAT_FOLD, STAT_DEF);
init_statistics();
}
void prolog_execution()
{
#if HELIOS != 1
if(tty && KEYIN) putcursor(); /* print cursor */
#endif
advance; /* read next one char into cbuf */
switch (cbuf) {
case '"': { /* read file */
advance;
settimer(); /* set timer */
readfile();
break;
}
case EOF: { /* file end */
set_eof();
#if HELIOS != 1
printtime(); /* print execution time */
#endif
break;
}
case '%': { /* flag statement */
next();
systemcommand(cbuf);
break;
}
case '#': { /* os command interpreter */
advance;
oscommand();
break;
}
case ':':
case '?': { /* question clause */
init_statistics();
check_recursion();
questionclause();
break;
}
case '@':{ /* modularize clause */
advance;
init_statistics();
check_recursion();
trans_routine();
break;
}
case '$': /* define new predicate */
advance;
defnewfunc();
break;
case '.':
skipline;
break;
default :
init_statistics();
defclause(); /* definition clause */
}
}
/* ------------------------------------------------------------
Error handler
------------------------------------------------------------ */
void on_interrupt()
{
error("\nInterrupt\n");
}
void error_detail(t,e,s)
struct term *t;
struct pair *e;
char *s;
{
if ((wfp != stdout) && (wfp != stderr)) fclose(wfp);
wfp = stderr;
Pterm(t,e);
error(s);
}
void error(s)
char *s;
{
if ((wfp != stdout) && (wfp != stderr)) {
if (wfp != NULL) fclose(wfp); /* in %w command */
wfp = stderr;
}
#if HELIOS == 1
wfp = stderr;
#endif
if (utop != &ustack[0]) { /* restore stack */
utop = &ustack[0];
undo(utop);
}
if (!KEYIN) { /* error in reading a file */
while (cbuf != '\n') { next(); putc(cbuf,stderr); }
tprint1("\n**** error in reading file (%s) ****\n",s);
fclose(fp);
fp = stdin;
if ((shp -sheap) >= ((SHEAPTOP - sheap) * 0.95))
tprint0("\n***** Caution *****\n System heap is full! \n Restart cu-Prolog with -S option (-S xxx: system heap size)\n")
}
else
{
tprint1("\n%s\n", s);
skipline;
if ((shp -sheap) >= ((SHEAPTOP - sheap) * 0.95))
garbagecollect(); /* 93.9.22 */
#if HELIOS != 1
printtime(); /* print execution time */
#endif
}
wfp = stdout;
newf_list = newflist_save; /* c.t. trace */
freeheap();
longjmp(reset, 0); /* in main() */
}
/*------------------------------------------------
heap allocation
------------------------------------------------*/
void system_heap_alloc()
{
if (NULL == (sheap=(int *)malloc(SHEAP_SIZE+1)))
{
printf("***** No memories for system heap *****\n");
exit(0);
} /* system heap */
shp = &sheap[0];
SHEAPTOP = &sheap[(int)(SHEAP_SIZE/SHEAP_UNIT)];
}
void user_heap_alloc()
{
if (NULL == (heap=(int *)malloc(HEAP_SIZE+1)))
{
printf("***** No memories for user heap *****\n");
exit(0);
} /* user heap */
hp=Heap_Max=&heap[0];
HEAPTOP = &heap[(int)(HEAP_SIZE/HEAP_UNIT)];
}
void cstr_heap_alloc()
{
if (NULL == (cheap=(int *)malloc(CHEAP_SIZE+1)))
{
printf("***** No memories for constraint heap *****\n");
exit(0);
} /* constraints/pst heap */
chp = Cheap_Max = &cheap[0];
CHEAPTOP = &cheap[(int)(CHEAP_SIZE/CHEAP_UNIT)];
}
void env_heap_alloc()
{
if (NULL == (eheap = (struct pair *)malloc(ESP_SIZE+1)))
{
printf("***** No memories for environment heap *****\n");
exit(0);
} /* environment heap */
ep = Esp_Max = &eheap[0];
ESPTOP = &eheap[(int)(ESP_SIZE/ESP_UNIT)];
}
void ustack_alloc()
{
if (NULL == (ustack = (struct ustack *)malloc(USTACK_SIZE+1)))
{
printf("***** No memories for user stack *****\n");
exit(0);
} /* user stack */
usp = Stack_Max = &ustack[0];
STACKTOP = &ustack[(int)(USTACK_SIZE/USTACK_UNIT)];
}
void name_heap_alloc()
{
if (NULL == (nheap = (char *)malloc(NAME_SIZE+1)))
{
printf("***** No memories for name string heap *****\n");
exit(0);
} /* name string heap */
nhp= &nheap[0];
NHEAPTOP = &nheap[(int)(NAME_SIZE/NAME_UNIT)];
}
void heap_alloc() /* allocate system/user heaps */
{
system_heap_alloc();
user_heap_alloc();
cstr_heap_alloc();
env_heap_alloc();
ustack_alloc();
name_heap_alloc();
}
void heap_realloc() /* reallocate system/user heaps */
{
#if SUN4 == 1
cfree((char *)sheap); SHEAP_SIZE=SHEAP_SIZE*1.2; system_heap_alloc();
#else
free(heap); HEAP_SIZE *= 1.2;
free(cheap); CHEAP_SIZE *= 1.2;
free(eheap); ESP_SIZE *= 1.2;
free(ustack); USTACK_SIZE *= 1.2;
free(nheap); NAME_SIZE *= 1.2;
heap_alloc();
#endif /* SUN4 */
init_status();
}
void initialize_pointer() /* initialize heap pointers */
{
shp = &sheap[0];
SHEAPTOP = &sheap[(int)(SHEAP_SIZE/SHEAP_UNIT)];
hp=Heap_Max=&heap[0];
HEAPTOP = &heap[(int)(HEAP_SIZE/HEAP_UNIT)];
chp = Cheap_Max = &cheap[0];
CHEAPTOP = &cheap[(int)(CHEAP_SIZE/CHEAP_UNIT)];
ep = Esp_Max = &eheap[0];
ESPTOP = &eheap[(int)(ESP_SIZE/ESP_UNIT)];
usp = Stack_Max = &ustack[0];
STACKTOP = &ustack[(int)(USTACK_SIZE/USTACK_UNIT)];
nhp= &nheap[0];
NHEAPTOP = &nheap[(int)(NAME_SIZE/NAME_UNIT)];
}
void prepare() /* system preparation */
{
tty = isatty(0);
heap_alloc(); /* heap/stack allocation */
init_status(); /* initialize global vars */
/* default status */
wfp = stdout; /* with echo back */
lfp = NULL; /* no log file */
ECHO_BACK = FALSE;
Handle_Undefined = FALSE; /* fail return */
Modular_mode; /* solution flag */
Notrace_mode; /* trace flag */
MODULARMAX = Modmax_def;
Refcount = REFMAX;
Print_Depth = 32;
/* push_status(); */ /* save f_list, etc. */
#if HELIOS != 1
open_title(); /* opening title */
#endif
}
void init_status() /* initialize global vars */
{
int i;
initialize_pointer(); /* 93.8.31 */
/* initialize global vars */
refute_node_count = -1; /* refute node counter*/
v_number = 0; /* temporary var number */
p_number = 0;
v_list = NULL_TERM; /* temporary var list */
pv_list = NULL_TERM;
f_list = (struct func *)NULL; /* new function list entry */
o_list = (struct operator *)NULL;
newf_list = (struct itrace *)NULL; /* new function definition */
initialize_psttable();
Def_Modified = 0; /* user pred not modified */
GENSYM = FNUMBER = 0;
for(i = 0; i < HASH_SIZE; hash_list[i++] = NULL)
; /* initialize hash table */
init_heap_max(); /* cf. new.c */
init_syspred(); /* initialize system predicates */
}
void open_title() /* opening title */
{
printf("\n\t******* cu - Prolog III Ver. %s *******\n",VERSION);
printf("\t[COPYRIGHT] %s\n",COPYRIGHT);
/* printf("\t%s mode",(Is_Msolvable ? "M-solvable" : "All Modular")); */
printf("\tType '%%h' for help.\n\n");
printf("\t[Heap=%dK System_heap=%dK Env_stack=%dK Cstr_heap=%dK\n",(int)(HEAP_SIZE/1000),(int)(SHEAP_SIZE/1000),(int)(ESP_SIZE/1000),(int)(CHEAP_SIZE/1000));
printf("\t Ustack=%dK Name_heap=%dK]\n",(int)(USTACK_SIZE/1000),(int)(NAME_SIZE/1000));
}
void print_constant() /* print constant list */
{
struct func *f;
int i;
for (i = 0; i < HASH_SIZE; i++)
for (f = hash_list[i]; f != NULL; f = f->f_link)
if (f->f_arity == 0)
tprint2("%s/%x ",f->f_name,f);
NL;
}
void show_hash_list() /* for DEBUG 93.7.16*/
{
int i;
struct func *f;
for (i=0; i<HASH_SIZE; i++)
{
if (hash_list[i] == (struct func *)NULL) continue;
printf("<%d>:",i);
for(f=hash_list[i];f!=(struct func *)NULL;f=f->f_link)
printf("%s ",f->f_name);
printf(" | ");
}
putchar('\n');
}
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
systemcommand()
process cu-Prolog system (%) commands
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
void systemcommand(c) /* % command */
int c;
{
switch(c)
{
case 'C': /* change cat() functor */
set_category();
break;
case 'D': /* maximum of print depth */
readword(nbuf);
Print_Depth = atoi(nbuf);
break;
case 'G': /* garbage collection */
garbagecollect();
break;
case 'H': /* for debug */
print_hash_table();
break;
case 'L': /* list trace definition */
tprint0("\n +-- List new predicate --<vars, terms>--+\n");
Shownewfunc();
break;
case 'M': /* maximum of variables in transformation */
readword(nbuf);
MODULARMAX = atoi(nbuf);
if (MODULARMAX < 0)
MODULARMAX = Modmax_def;
break;
case 'N': /* for debug */
show_heap_max();
break;
case 'P': /* Preprocess Constraints */
readword(nbuf);
preprocess_constraints(nbuf);
break;
case 'Q': /* QUIT cu-prolog */
quit_prolog();
return;
case 'R': /* system reset */
tprint0("System initialized\n");
prepare();
break;
case 'S': /* system statistics */
print_statistics();
break;
case 'X': /* print constant (for debug) */
tprint0("+++++ print constants +++++\n");
print_constant();
break;
case 'Y': /* edit predicates (for debug) */
tprint0("+++++ edit predicates +++++\n");
edit_predicate();
break;
case 'Z': /* show hash table (for debug) */
tprint0("+++++ show hash table +++++\n");
show_hash_list();
break;
case 'a': /* all modular mode */
tprint0("\n ___ all modular mode ___\n");
Modular_mode;
break;
case 'c': /* maximum of refute counter */
readword(nbuf);
Refcount = atoi(nbuf);
if (Refcount <= 0) Refcount = REFMAX; /* default */
break;
case 'd': /* list definition */
readword(nbuf);
showdef(nbuf);
break;
case 'f': /* free space */
tprint0("show the status of memory allocation\n");
freeheap();
break;
case 'h': /* help menu */
tprint0("** Usage:\tcuprolog [-Hxxx][-Sxxx][-Exxx][-Cxxx][-Uxxx][-Nxxx][filename]\n");
tprint1("** %% commands (ver.%s) **",VERSION);
tprint0(" (prompt _:normal, $:trace, >:step)\n");
helpmenu();
break;
case 'l': /* log file */
readword(nbuf);
loghandle(nbuf);
break;
case 'n': /* change genfunc name */
readword(genname);
break;
case 'o': /* M-Solvable mode */
tprint0("\n ___ M-solvable mode ___\n");
Msolvable_mode;
break;
case 'p': /* set/reset spy flag */
readword(nbuf);
spyswitch(nbuf);
break;
case 's': /* step trace on/off */
stepswitch();
break;
case 't': /* trace on */
traceswitch();
break;
case 'u': /* undefined predicate handling */
Handle_Undefined = (Handle_Undefined == TRUE) ?
FALSE : TRUE;
tprint1("Undefined Predicates causes %s\n",
((Handle_Undefined == TRUE) ? "ERROR" : "FAIL"));
break;
case 'w': /* write file */
readword(nbuf);
filewrite(nbuf); /* save program */
break;
default: /* else */
break;
}
skipline; /* skip one line */
}
void garbagecollect() /* garbage collection */
{
if (fp != stdin) return; /*fclose(fp);*/
if ((wfp != stdout) && (wfp != stderr)) fclose(wfp);
settimer(); /* set timer */
tprint0("====== Garbage Collection ======\n");
strcpy(nbuf, "TEMPF.###"); /* temporary file */
delete_tmp(); /* delete old temp file */
tprint0("--->");
filewrite(nbuf); /* save program to nbuf */
init_status(); /* initialize shp, f_list, etc. */
tprint0("--->");
set_inputfile(nbuf);
/* wfp = NULL; no echo back */
}
void edit_predicate() /* edit predicate */
{
tprint0("++++++++ Garbage Collection +++++++++\n");
strcpy(nbuf, "TEMPF.prd"); /* temporary file */
system("rm -f TEMPF.prd"); /* delete old temp file */
tprint0("++++++++ Step 1: write file \n");
filewrite(nbuf); /* save program */
/* pop_status(); */ /* initialize shp, f_list, etc. */
system("$EDITOR TEMPF.prd"); /* edit */
tprint0("++++++++ Step 2: read file \n");
set_inputfile(nbuf);
}
void trans_routine() /* modular translation routine (@ C1,C2,...,Cn.) */
{
register struct term *t;
struct clause *c;
if (Is_Steptrace && isspy(MODULAR_P)) CTstep;
else if (Is_Normaltrace && isspy(MODULAR_P)) CTnormal;
else CTnotrace;
up_init(); /* reset termset log (92/10/29) */
v_number = 0; v_list = NULL;
p_number = 0; pv_list = NULL;
reread = FALSE;
clear_psttable();
t = Rterm(1200,TEMPORAL); /* read constraints */
if (tokentype != FULLSTOP) error("Syntax error --- . missing");
skipline;
NL;
settimer(); /* set timer */
if (is_clause(t))
c = (struct clause *)t;
else
c = Nclause(t, NULL_CL, TEMPORAL);
modular(c,v_list,v_number+p_number);
#if HELIOS != 1
if (fp == stdin) printtime(); /* print execution time */
#endif
undo(utop); /* pop user stack ( u : static var ) */
}
void questionclause() /* ?-g1,g2,...gm;c1,c2...cn. */
{
register struct term *q;
struct eclause *co;
struct pair *e;
struct node *Last_Node, *Initial_Goal;
struct term *initial_vlist;
struct clause *c;
int Status, refute();
if (Is_Steptrace && isspy(MODULAR_P)) CTstep;
else if (Is_Normaltrace && isspy(MODULAR_P)) CTnormal;
else CTnotrace;
up_init(); /* reset termset log (92/10/29) */
v_number = 0; v_list = NULL;
p_number = 0; pv_list = NULL;
clear_psttable();
reread = FALSE;
q = Rterm(1200,TEMPORAL); /* read goal */
if (tokentype!=FULLSTOP) error("Syntax error --- . expected");
skipline; /* skip CR */
renum_pvars((struct pstvar *)pv_list,v_number);
e = Nenv(v_number+p_number); /* initial environments */
settimer();
if ((Pred(q) == CONSTRAINT_P) || (Pred(q) == CONSTRAINT2_P)) {
c = (is_clause(Arg2(q))) ? (struct clause *)Arg2(q) :
Nclause(Arg2(q),NULL_CL,TEMPORAL);
co = transform(NULL_ECL,c,e);
if (co == (struct eclause *)MFAIL)
{
tprint0("no (unsatisfied constraints)\n");
#if HELIOS != 1
if (fp == stdin) printtime();
#endif
refute_node_count = -1;
undo(utop);
return;
}
q = Arg1(q);
}
else {
co = NULL_ECL;
}
if ((Pred(q) != QUERY1_P) && (Pred(q) != QUERY2_P))
error("Syntax error --- Query Predicate was expected");
f_list = NULL; /* temp. pred list */
c = (is_clause(Arg1(q))) ? (struct clause *)Arg1(q) :
Nclause(Arg1(q),NULL_CL,TEMPORAL);
Initial_Goal = Last_Node
= Newnode(c,co,e,NULL_NODE,NULL_NODE);
Last_BT = NULL; Last_SKIP = NULL;
Status = DOWN;
initial_vlist = v_list;
/* refutation */
while (1) {
if (refute(Initial_Goal,Last_Node,Status) == FALSE){
#if HELIOS==1
printf("result:");
#endif
tprint0("no.\n");
break;
}
else if (initial_vlist == NULL) {
#if HELIOS==1
printf("result:");
#endif
tprint0("true.\n");
break;
}
else {
#if HELIOS==1
printf("result:");
Pclause(Initial_Goal->n_clause, Initial_Goal->n_env);
printf("\n");
break;
#endif
if ((fp != stdin) ||
(Panswer(Initial_Goal,initial_vlist) == FALSE)) break;
}
Status = BACKTRACK;
Last_BT = Last_Node = backtrack_node(Last_BT);
}
#if HELIOS != 1
if (fp == stdin) printtime();
#endif
/* freeheap(); */
/* newf_list=index_newflist(newf_list,newflist_save); register itrace list */
/* index_funclist(f_list); tmp. pred -> hash */
refute_node_count = -1; /* refute node counter */
undo(utop); /* pop user stack ( u : static var ) */
}
void defclause() /* definition clause read & set */
{
register struct term *t;
register struct clause *c, *cstr;
v_number = 0; v_list = NULL;
p_number = 0; pv_list = NULL;
up_init(); /* reset termset log (92/10/29) */
reread = FALSE;
t = Rterm(1200,STINGY);
if (tokentype != FULLSTOP) error("Syntax error --- . was expected");
skipline;
if (isvar(t)) error("Syntax error --- Variables cannot be asserted");
rename_var_names((struct var *)v_list); /* STINGY -> ETERNAL */
if ((Pred(t) == CONSTRAINT_P) || (Pred(t) == CONSTRAINT2_P)) {
cstr = (is_clause(Arg2(t))) ? (struct clause *)Arg2(t) :
Nclause(Arg2(t),NULL_CL,ETERNAL);
t = Arg1(t);
}
else cstr = NULL;
if (Pred(t) == DEF_P) {
if (isvar(Arg1(t))) {
tprint0(">>>>> ");
Pterm(t,NULL_ENV);
tprint0(" <<<<<");
error("Syntax error --- Variables cannot be asserted");
}
if (is_clause(Arg2(t)))
c = Nclause(Arg1(t),(struct clause *)Arg2(t),ETERNAL);
else
c = Nclause(Arg1(t),
Nclause(Arg2(t),NULL_CL,ETERNAL), ETERNAL);
}
else if (is_functor(t))
c = Nclause(t,NULL_CL,ETERNAL);
else error("Illegal definition");
if (p_number != 0) {
renum_pvars((struct pstvar *)pv_list,v_number);
}
index_set(c, cstr, 'z');
}
void rename_var_names(v)
struct var *v;
{
while (v != (struct var *)NULL) {
truncate_varname(v->v_name,nbuf);
v->v_name = nalloc(nbuf,ETERNAL);
v = v->v_link;
}
}
void truncate_varname(n,nbuf)
char n[], nbuf[];
{
register int i = 0;
while ((n[i] != '\0') && (i < 7)) {
if (n[i] == '_') break;
nbuf[i] = n[i];
i++;
}
nbuf[i] = '\0';
}
void renum_pvars(pvs,vnum)
struct pstvar *pvs;
int vnum;
{
while (pvs != (struct pstvar *)NULL) {
pvs->v_number += vnum;
pvs = (struct pstvar *)pvs->v_link;
}
}
void defnewfunc() /* definition clause read & set */
{
register struct term *t;
register struct itrace *it;
struct clause *c;
v_number = 0; v_list = NULL;
p_number = 0; pv_list = NULL;
up_init(); /* reset termset log (92/10/29) */
reread = FALSE;
t = Rterm(1200,STINGY);
if (tokentype != FULLSTOP) error("Syntax error --- . was expected");
skipline;
if (Pred(t) != EQSIGN_P) error("Illegal itrace definition");
rename_var_names((struct var *)v_list); /* STINGY -> ETERNAL */
c = (is_clause(Arg2(t))) ? (struct clause *)Arg2(t) :
Nclause(Arg2(t),NULL_CL,ETERNAL);
it = snew(itrace);
it->it_clause = Nclause(Arg1(t),c,ETERNAL);
it->it_anumber = v_number+p_number;
it->it_cnumber = literalnumber(c);
it->it_link = newf_list;
newf_list = it;
Pred(Arg1(t))->f_integ = it;
}
syntax highlighted by Code2HTML, v. 0.9.1