Wild Life: def_proto.h File Reference

ptr_psi_term copy(ptr_psi_term t, long copy_flag, long heap_flag)

copy

Definition: copy.c:248

long to_heap

Definition: def_glob.h:905

#define FALSE

Standard boolean.

Definition: def_const.h:275

void eval_global_var ( ptr_psi_term t )

eval_global_var

Parameters

t	- ptr_psi_term t

EVAL_GLOBAL_VAR(t) Dereference a global variable.

Definition at line 1440 of file lefun.c.

References wl_stack::aaaa_3, wl_stack::bbbb_3, clear_copy(), wl_psi_term::coref, deref_ptr, eval_copy(), global_it, wl_definition::global_value, wl_definition::init_value, wl_stack::next, NULL, psi_term_ptr, push_psi_ptr_value(), STACK, STACK_ALLOC, traceline(), wl_psi_term::type, wl_stack::type, wl_definition::type_def, and undo_stack.

 {
   deref_ptr(t);
 
   /* Global variable (not persistent) */
 
   traceline("dereferencing variable %P\n",t);
   
   /* Trails the heap RM: Nov 10 1993  */
   if(!t->type->global_value) {
 
     /* Trail the heap !! */
     {
       ptr_stack n;
       n=STACK_ALLOC(stack);
       n->type=psi_term_ptr;
       n->aaaa_3= (GENERIC *) &(t->type->global_value);
       n->bbbb_3= (GENERIC *) NULL;
       n->next=undo_stack;
       undo_stack=n;
     }
 
 
     clear_copy();
     t->type->global_value=eval_copy(t->type->init_value,STACK);
 
   }
 
   /* var_occurred=TRUE; RM: Feb  4 1994  */
 
   if(t->type->type_def==(def_type)global_it && t!=t->type->global_value) {
     /*traceline("dereferencing variable %P\n",t);*/
     push_psi_ptr_value(t,(GENERIC *)&(t->coref));
     t->coref=t->type->global_value;
   }
 }

ptr_psi_term exact_copy	(	ptr_psi_term	t,
		long	heap_flag
	)

exact_copy

Parameters

t	- ptr_psi_term t
heap_flag	- long heap_flag

Definition at line 176 of file copy.c.

References copy(), EXACT_FLAG, FALSE, and to_heap.

177 { to_heap=FALSE; return (copy(t, EXACT_FLAG, heap_flag)); }

EXACT_FLAG

#define EXACT_FLAG

flag to copy function in copy.c to indicate kind of copy

Definition: def_const.h:1306

ptr_psi_term copy(ptr_psi_term t, long copy_flag, long heap_flag)

copy

Definition: copy.c:248

long to_heap

Definition: def_glob.h:905

#define FALSE

Standard boolean.

Definition: def_const.h:275

void exit_if_true ( long exitflag )

exit_if_true

Parameters

exitflag - long exitflag

Definition at line 55 of file lib.c.

 {
   if (exitflag) {
     printf("\n\n*** Execution is not allowed to continue.\n");
     /*exit_life(TRUE);*/
     exit(EXIT_FAILURE);
   }
 }

void exit_life ( long nl_flag )

exit_life

Parameters

nl_flag - long nl_flag

Definition at line 2219 of file built_ins.c.

References garbage_time, life_end, life_start, NOTQUIET, and open_input_file().

 {
   (void)open_input_file("stdin");
   (void)times(&life_end);
   if (NOTQUIET) { /* 21.1 */
     if (nl_flag) printf("\n");
     printf("*** Exiting Wild_Life  ");
     printf("[%1.3fs cpu, %1.3fs gc (%2.1f%%)]\n",
            (life_end.tms_utime-life_start.tms_utime)/60.0,
            garbage_time,
            garbage_time*100 / ((life_end.tms_utime-life_start.tms_utime)/60.0)
        );
   }
 
 #ifdef ARITY  /*  RM: Mar 29 1993  */
   arity_end();
 #endif
   
   exit(EXIT_SUCCESS);
 }

char * expand_file_name ( char * s )

expand_file_name

Parameters

s - char *s

EXPAND_FILE_NAME(str) Return the expansion of file name STR. For the time being all this does is replace '~' by the HOME directory if no user is given, or tries to find the user.

Definition at line 537 of file token.c.

References STRLEN.

 {
   char *r;
   char *home; // *getenv();
   struct passwd *pw;
   /* char *user="eight character name"; 18.5 */
   char userbuf[STRLEN];
   char *user=userbuf;
   char *t1,*t2;
 
   r=s;
   if (s[0]=='~') {
     t1=s+1;
     t2=user;
     while (*t1!=0 && *t1!='/') {
       *t2= *t1;
       *t2++;
       *t1++;
     }
     *t2=0;
     if ((int)strlen(user)>0) {
       pw = getpwnam(user);
       if (pw) {
     user=pw->pw_dir;
     r=(char *)malloc(strlen(user)+strlen(t1)+1);
     sprintf(r,"%s%s",user,t1);
       }
       else
     /* if (warning()) printf("couldn't find user '%s'.\n",user) */;
     }
     else {
       home=getenv("HOME");
       if (home) {
     r=(char *)malloc(strlen(home)+strlen(s)+1);
     sprintf(r,"%s%s",home,s+1);
       }
       else
     /* if (warning()) printf("no HOME directory.\n") */;
     }
   }
 
   /* printf("*** Using file name: '%s'\n",r); */
   
   return r;
 }

ptr_module extract_module_from_name ( char * str )

extract_module_from_name

Parameters

str	- char *str

EXTRACT_MODULE_FROM_NAME Return the module corresponding to "module#symbol". Return NULL if only "#symbol".

Definition at line 116 of file modules.c.

References create_module(), legal_in_name(), and NULL.

 {
   char *s;
   ptr_module result=NULL;
 
   s=str;
   while(legal_in_name(*s))
     s++;
   if(s!=str && *s=='#' /* && *(s+1)!=0 */) {
     *s=0;
     result=create_module(str);
     *s='#';
     /*
     printf("Extracted module name '%s' from '%s'\n",result->module_name,str);
     */
   }
   
   return result;
 }

long f_check_out ( ptr_psi_term t )

f_check_out

Parameters

t	- ptr_psi_term t

f_check_out(t) checks out functions too.

Definition at line 1046 of file lefun.c.

References check_func_flag, check_out(), and TRUE.

 {
   check_func_flag=TRUE;
   return check_out(t);
 }

void fail_all ( )

fail_all

FAIL_ALL() This routines provokes a total failure, in case of a bad error (out of memory, abort, etc...). All goals are abandoned.

Definition at line 189 of file memory.c.

References abort_life(), choice_stack, goal_stack, NULL, open_input_file(), output_stream, stdin_cleareof(), TRUE, and undo_stack.

 {
   output_stream=stdout;     
   choice_stack=NULL;
   goal_stack=NULL;
   undo_stack=NULL;
   (void)abort_life(TRUE);
   /* printf("\n*** Abort\n"); */
   stdin_cleareof();
   (void)open_input_file("stdin");
 }

long featcmp	(	char *	str1,
		char *	str2
	)

featcmp

Parameters

str1	- char *str1
str2	- char *str2

FEATCMP(s1,s2) Compares two strings which represent features, for use in FIND or INSERT. This differs from strcmp for those strings that represent integers. These are compared as integers. In addition, all integers are considered to be less than all strings that do not represent integers.

Definition at line 106 of file trees.c.

References is_int().

 {
   long len1,len2,sgn1,sgn2;
   char *s1,*s2;
 
   if(str1==str2)
     return 0;
   
   /* if (*str1==0 && *str2==0) return 0; "" bug is unaffected -- PVR 23.2.94 */
 
   if(*(str1+1)==0 && *(str2+1)==0)
     return *str1 - *str2;
   
   
   s1=str1; /* Local copies of the pointers */
   s2=str2;
 
   if (is_int(&s1,&len1,&sgn1)) {
     if (is_int(&s2,&len2,&sgn2)) {
       if (sgn1!=sgn2) return (sgn2-sgn1); /* Check signs first */
       if (len1!=len2) return (len1-len2); /* Then check lengths */
       return strcmp(s1,s2); /* Use strcmp only if same sign and length */
     }
     else
       return -1;
   }
   else {
     if (is_int(&s2,&len2,&sgn2))
       return 1;
     else
       return strcmp(s1,s2);
   }
 }

void feature_insert	(	char *	keystr,
		ptr_node *	tree,
		ptr_psi_term	psi
	)

feature_insert

Parameters

keystr	- char *keystr
tree	- ptr_node *tree
psi	- ptr_psi_term psi

FEATURE_INSERT(keystr,tree,psi) Insert the psi_term psi into the attribute tree. If the feature already exists, create a call to the unification function.

Definition at line 251 of file parser.c.

References FEATCMP, find(), stack_copy_psi_term(), stack_insert_copystr(), and Syntaxerrorline().

 {
   ptr_node loc;
   ptr_psi_term stk_psi;
 
   //  printf("before find in feature_insert feature=%s\n",keystr);
   if ((loc=find(FEATCMP,keystr,*tree))) {
     /* Give an error message if there is a duplicate feature: */
     Syntaxerrorline("duplicate feature %s\n",keystr);
   }
   else {
     /* If the feature does not exist, insert it. */
     stk_psi=stack_copy_psi_term(*psi); // 19.8 */
     stack_insert_copystr(keystr,tree,(GENERIC)stk_psi); /* 10.8 */
   }
 }

void fetch_def	(	ptr_psi_term	u,
		long	allflag
	)

fetch_def

Parameters

u	- ptr_psi_term u
allflag	- long allflag

FETCH_DEF(psi_term) Fetch the type definition of a psi_term and execute it. That is, get the list of (term,predicate) pairs that define the type. Unify the psi_term with the term, then prove the predicate.

This routine only gets the pairs that are defined in the type itself, not those defined in any types above it. This is the correct behavior for enumerating type disjunctions–all higher constraints have already been checked.

The above is true if allflag==FALSE. If allflag==TRUE then all constraints are executed, not just those defined in the type itself.

Definition at line 1208 of file login.c.

References wl_triple_list::aaaa_4, wl_psi_term::attr_list, wl_triple_list::bbbb_4, wl_triple_list::cccc_4, clear_copy(), DEFRULES, deref_ptr, eval_copy(), i_eval_args(), int_ptr, wl_triple_list::next, NULL, wl_definition::properties, prove, push2_ptr_value(), push_goal(), RMASK, SMASK, STACK, wl_psi_term::status, traceline(), wl_psi_term::type, and unify.

 {
   ptr_triple_list prop;
   ptr_psi_term v,w;
   ptr_definition utype;
   
   /* Uses SMASK because called from check_out */
   push2_ptr_value(int_ptr,(GENERIC *)&(u->status),(GENERIC)(u->status & SMASK));
   u->status=(4 & SMASK) | (u->status & RMASK);
   
   utype=u->type;
   prop=u->type->properties;
   if (prop) {
     
     traceline("fetching definition of %P\n",u);
     
     while (prop) {
       if (allflag || prop->cccc_4==utype) {
         clear_copy();
         v=eval_copy(prop->aaaa_4,STACK);
         w=eval_copy(prop->bbbb_4,STACK);
         
         if (w) push_goal(prove,(ptr_psi_term)w,(ptr_psi_term)DEFRULES,NULL);
         
         deref_ptr(v);
         v->status=4;
         push_goal(unify,(ptr_psi_term)u,(ptr_psi_term)v,NULL);
         (void)i_eval_args(v->attr_list);
       }
       prop=prop->next;
     }
   }
 }

void fetch_def_lazy	(	ptr_psi_term	u,
		ptr_definition	old1,
		ptr_definition	old2,
		ptr_node	old1attr,
		ptr_node	old2attr,
		long	old1stat,
		long	old2stat
	)

fetch_def_lazy

Parameters

u	-ptr_psi_term u
old1	- ptr_definition old1
old2	- ptr_definition old2
old1attr	- ptr_node old1attr
old2attr	- ptr_node old2attr
old1stat	- long old1stat
old2stat	- long old2stat

FETCH_DEF_LAZY(psi_term,type1,type2,attr_list1,attr_list2) Fetch the type definition of a psi_term and execute it. That is, get the list of (term,pred) pairs that define the type. 'Term' is one of the type's attributes and 'pred' is a constraint. Unify the psi_term with the term, then prove pred.

Only those (term,pred) pairs are executed whose original type is below both type1 and type2, the types of the two psi-terms whose unification created psi_term. This avoids doing much superfluous work.

The above behavior is correct for a psi_term when always_check==TRUE for that psi_term. If always_check==FALSE for a psi_term, then if it does not have attributes it is not checked, and the addition of an attribute will force checking to occur.

Example:

:: t(a=>one,b=>two,c=> X) | thing(X).

psi_term = A:t (it can be any psi_term of type t) term = t(a=>one,b=>two,c=> X) pred = thing(X)

Definition at line 1276 of file login.c.

References wl_triple_list::aaaa_4, wl_definition::always_check, wl_psi_term::attr_list, wl_triple_list::bbbb_4, wl_triple_list::cccc_4, clear_copy(), DEFRULES, deref_ptr, eval_copy(), FALSE, i_eval_args(), int_ptr, matches(), wl_triple_list::next, NULL, wl_definition::properties, prove, push_goal(), push_ptr_value(), STACK, wl_psi_term::status, traceline(), wl_psi_term::type, and unify.

 {
   ptr_triple_list prop;
   ptr_psi_term v,w;
   long checked1, checked2;
   long m1, m2;
   
   if (!u->type->always_check) if (u->attr_list==NULL) return;
   
   push_ptr_value(int_ptr,(GENERIC *)&(u->status));
   u->status=4;
   
   prop=u->type->properties;
   if (prop) {
     traceline("fetching partial definition of %P\n",u);
     
     checked1 = old1attr || old1->always_check;
     checked2 = old2attr || old2->always_check;
 
     /* checked1 = (old1stat==4); */ /* 18.2.94 */
     /* checked2 = (old2stat==4); */
     
     while (prop) {
       /* Only do those constraints that have not yet been done: */
       /* In matches, mi is TRUE iff oldi <| prop->cccc_1.            */
       if (!checked1) m1=FALSE; else (void)matches(old1,prop->cccc_4,&m1);
       if (!checked2) m2=FALSE; else (void)matches(old2,prop->cccc_4,&m2);
       if (!m1 && !m2) {
     /* At this point, prop->cccc_1 is an attribute that has not yet */
     /* been checked. */
     clear_copy();
     v=eval_copy(prop->aaaa_4,STACK);
     w=eval_copy(prop->bbbb_4,STACK);
     
     if (w) push_goal(prove,(ptr_psi_term)w,(ptr_psi_term)DEFRULES,NULL);
     
     deref_ptr(v);
     v->status=4;
     push_goal(unify,(ptr_psi_term)u,(ptr_psi_term)v,NULL);
     (void)i_eval_args(v->attr_list);
       }
       prop=prop->next;
     }
   }
 }

long file_exists ( char * s )

file_exists

Parameters

s - char *s

Definition at line 1711 of file built_ins.c.

References expand_file_name(), FALSE, and TRUE.

 {
   FILE *f;
   char *e;
   long success=FALSE;
   
   e=expand_file_name(s);
   if ((f=fopen(e,"r"))) {
     (void)fclose(f);
     success=TRUE;
   }
   return success;
 }

ptr_psi_term fileptr2stream	(	FILE *	fp,
		ptr_definition	typ
	)

fileptr2stream

Parameters

fp	- FILE *fp
typ	- ptr_definition typ removed * DJD = prior to 2.29

Definition at line 688 of file sys.c.

References BYTEDATA_DATA, FP_NONE, and make_bytedata().

 {
   ptr_psi_term result = make_bytedata(typ,sizeof(struct a_stream));
   ((ptr_stream)BYTEDATA_DATA(result))->fp = fp;
   ((ptr_stream)BYTEDATA_DATA(result))->op = FP_NONE;
   return result;
 }

ptr_node find	(	long	comp,
		char *	keystr,
		ptr_node	tree
	)

find

Parameters

comp	- long comp
keystr	- char *keystr
tree	- ptr_node tree

FIND(comp,keystr,tree) Return the NODE address corresponding to key KEYSTR in TREE using function COMP to compare keys.

Definition at line 394 of file trees.c.

References Errorline(), FALSE, featcmp(), FEATCMP, intcmp(), INTCMP, wl_node::left, NULL, wl_node::right, STRCMP, and TRUE.

 {
   ptr_node result;
   long cmp;
   long to_do=TRUE;
 
   /*
     if(comp==strcmp)
     printf("%s ",keystr);
     */
     
   do {
     if (tree==NULL) {
       result=NULL;
       to_do=FALSE;
     }
     else {
       if (comp == INTCMP)
     cmp = intcmp((long)keystr,(long) (tree)->key);
       else if (comp == FEATCMP)
     cmp = featcmp(keystr,(tree)->key);
       else if (comp == STRCMP)
     cmp = strcmp(keystr,(tree)->key);
       else
     Errorline("Bad comp in general_insert.\n");
 
       if (cmp<0)
     tree=tree->left;
       else
     if (cmp==0) {
       result=tree;
       to_do=FALSE;
     }
       else
     tree=tree->right;
     }
   } while (to_do);
 
 
   /* RM: Jan 27 1993 
     if(comp==strcmp)
     printf("Find: '%s' -> %x\n",keystr,result);
     */
   
   return result;
 }

void find_adults ( )

find_adults

FIND_ADULTS() Returns the list of all the maximal types (apart from top) in the symbol table. That is, types which have no parents. This routine modifies the global variable 'adults'.

Definition at line 549 of file types.c.

References adults, first_definition, HEAP_ALLOC, wl_int_list::next, wl_definition::next, NULL, wl_definition::parents, wl_definition::type_def, type_it, and wl_int_list::value_1.

 {
   ptr_definition d;
   ptr_int_list l;
 
   for(d=first_definition;d;d=d->next)
     if(d->type_def==(def_type)type_it && d->parents==NULL) {
       l=HEAP_ALLOC(int_list);
       l->value_1=(GENERIC)d;
       l->next=adults;
       adults=l;
     }
 }

ptr_node find_data	(	GENERIC	p,
		ptr_node	t
	)

find_data

Parameters

p	- GENERIC p
t	- ptr_node t

FIND_DATA(p,t) Return the node containing the data P in tree T. This is a linear search and can be used to find the key to some data if it is unkown. Return NULL if no key corresponds to data P.

Definition at line 452 of file trees.c.

References wl_node::data, wl_node::left, NULL, and wl_node::right.

 {
   ptr_node r=NULL;
 
   if(t) 
     if(t->data==p)
       r=t;
     else {
       r=find_data(p,t->left);
       if(r==NULL)
     r=find_data(p,t->right);
     }
   
   return r;
 }

ptr_module find_module ( char * module )

find_module

Parameters

module char *module

FIND_MODULE(module) Return a module if it exists.

Definition at line 54 of file modules.c.

References wl_node::data, FEATCMP, find(), and NULL.

 {
   ptr_node nodule;
 
   nodule=find(FEATCMP,(char *)module,module_table);
   if(nodule)
     return (ptr_module)(nodule->data);
   else
     return NULL;
 }

void forbid_variables ( ptr_node n )

FORBID_VARIABLES This inserts the value of the dereferenced variables into the PRINTED_POINTERS tree, so that they will never be printed as NAME:value inside a psi-term. Each variable is printed as NAME = VALUE by the PRINT_VARIABLES routine.

Definition at line 334 of file print.c.

References wl_node::data, deref_ptr, heap_insert(), INTCMP, wl_node::key, wl_node::left, printed_pointers, and wl_node::right.

 {
   ptr_psi_term v;
   
   if(n) {
     forbid_variables(n->right);
     v=(ptr_psi_term )n->data;
     deref_ptr(v);
     (void)heap_insert(INTCMP,(char *)v,&printed_pointers,(GENERIC)n->key);
     forbid_variables(n->left);
   }
 }

void garbage ( )

garbage

GARBAGE() The garbage collector. This routine is called whenever memory is getting low. It returns TRUE if insufficient memory was freed to allow the interpreter to carry on working.

This is a half-space GC, it first explores all known structures, then compresses the heap and the stack, then during the second pass assigns all the new addresses.

Bugs will appear if the collector is called during parsing or other such routines which are 'unsafe'. In order to avoid this problem, before one of these routines is invoked the program will check to see whether there is enough memory available to work, and will call the GC if not (this is a fix, because it is not possible to determine in advance what the size of a psi_term read by the parser will be).

Definition at line 1530 of file memory.c.

References assert, bounds_undo_stack(), check(), clear_copy(), compress(), FALSE, garbage_time, gc_time, heap_pointer, ignore_eff, last_garbage_time, life_time, mem_base, mem_limit, NULL, other_base, other_limit, pass, pointer_names, print_gc_info(), printed_pointers, stack_info(), stack_pointer, TRUE, and verbose.

 {
   GENERIC addr;
   struct tms garbage_start_time,garbage_end_time;
   long start_number_cells, end_number_cells;
 
   start_number_cells = (stack_pointer-mem_base) + (mem_limit-heap_pointer);
 
   (void)times(&garbage_start_time);
 
   /* Time elapsed since last garbage collection */
   life_time=(garbage_start_time.tms_utime - last_garbage_time.tms_utime)/60.0;
 
 
   if (verbose) {
     fprintf(stderr,"*** Garbage Collect "); /*  RM: Jan 26 1993  */
     fprintf(stderr,"\n*** Begin");
     print_gc_info(FALSE);
     (void)fflush(stderr);
   }
 
   /* reset the other base */
   for (addr = other_base; addr < other_limit; addr ++)
     *addr = 0;
 
   pass=1;
 
   check();
 #ifdef GCVERBOSE
   fprintf(stderr,"- Done pass 1 ");
 #endif
 
   assert(bounds_undo_stack());
   compress();
 #ifdef GCVERBOSE
   fprintf(stderr,"- Done compress ");
 #endif
 
   pass=2;
 
   check();
   assert(bounds_undo_stack());
 #ifdef GCVERBOSE
   fprintf(stderr,"- Done pass 2\n");
 #endif
 
   clear_copy();
 
   printed_pointers=NULL;
   pointer_names=NULL;
   
   (void)times(&garbage_end_time);
   gc_time=(garbage_end_time.tms_utime - garbage_start_time.tms_utime)/60.0;
   garbage_time+=gc_time;
 
   if (verbose) {
     fprintf(stderr,"*** End  ");
     print_gc_info(TRUE); /*  RM: Jan 26 1993  */
     stack_info(stderr);
     (void)fflush(stderr);
   }
 
   last_garbage_time=garbage_end_time;
 
   end_number_cells = (stack_pointer-mem_base) + (mem_limit-heap_pointer);
   assert(end_number_cells<=start_number_cells);
   
   ignore_eff=FALSE;
 
 }

ptr_node general_insert	(	long	comp,
		char *	keystr,
		ptr_node *	tree,
		GENERIC	info,
		long	heapflag,
		long	copystr,
		long	bkflag
	)

ptr_node general_insert

Parameters

comp	- long comp
keystr	- char *keystr
tree	- ptr_node *tree
info	- GENERIC info
heapflag	- long heapflag
copystr	- long copystr
bkflag	- long bkflag

GENERAL_INSERT(comp,keystr,tree,info,heapflag,copystr,bkflag) General tree insertion routine. comp = comparison routine for insertion. keystr = the insertion key. tree = the tree to insert in. info = the information to insert. heapflag = HEAP or STACK for heap or stack allocation of insertion node. copystr = TRUE iff copy the keystr to the heap on insertion. bkflag = 1 iff the insertion is backtrackable (trailed with trail check). 2 iff the insertion must always be trailed. Returns a pointer to the node containing the pair (keystr,info).

Here KEYSTR can be either a pointer to a string, an integer, or a feature. COMP is the function to call to compare 2 keys so it has three possible values: COMP==strcmp(), COMP==intcmp(), or COMP==featcmp(). COMP(a,b) should return n where: n=0 if a=b; n>0 if a>b; n<0 if a<b.

Definition at line 224 of file trees.c.

References Errorline(), FALSE, featcmp(), FEATCMP, HEAP, HEAP_ALLOC, heap_copy_string(), int_ptr, intcmp(), INTCMP, wl_node::key, NULL, push_ptr_value(), push_ptr_value_global(), STACK_ALLOC, STRCMP, and TRUE.

 {
   long cmp;
   ptr_node result;
   long to_do=TRUE;
 
   
   do {
     if (*tree==NULL) {
       if (bkflag==1) push_ptr_value(int_ptr,(GENERIC *)tree);
       else if (bkflag==2) push_ptr_value_global(int_ptr,(GENERIC *)tree);
       *tree = (heapflag==HEAP) ? HEAP_ALLOC(node): STACK_ALLOC(node);
       result= *tree;
       (*tree)->key = copystr ? heap_copy_string(keystr) : keystr;
       (*tree)->left=NULL;
       (*tree)->right=NULL;
       (*tree)->data=info;
       to_do=FALSE;
     }
     else {
       if (comp == INTCMP)
     cmp = intcmp((long)keystr,(long) (*tree)->key);
       else if (comp == FEATCMP)
     cmp = featcmp(keystr,(*tree)->key);
       else if (comp == STRCMP)
     cmp = strcmp(keystr,(*tree)->key);
       else
     Errorline("Bad comp in general_insert.\n");
 
       if (cmp<0)
     tree=(&((*tree)->left));
       else
     if (cmp==0) {
           if (bkflag)
             Errorline("attempt to overwrite an existing feature; ignored.\n");
           else
         (*tree)->data=info;
       result= *tree;
       to_do=FALSE;
     }
     else
       tree=(&((*tree)->right));
     }
   } while (to_do);
   
   return result;
 }

long get_arg	(	ptr_psi_term	g,
		ptr_psi_term *	arg,
		char *	number
	)

get_arg

Parameters

g	- ptr_psi_term g
arg	- ptr_psi_term *arg
number	- char *number

GET_ARG assign the argument "number" of the goal "g" in "arg". return FALSE if bad argument.

Definition at line 25 of file templates.c.

References wl_psi_term::attr_list, wl_node::data, FALSE, FEATCMP, find(), and TRUE.

 {
     ptr_node n;
 
     if ((n = find (FEATCMP, number, g->attr_list)))
         return (*arg = (ptr_psi_term) n->data) ? TRUE: FALSE;
     else
         return FALSE;
 }

GENERIC get_attr	(	ptr_psi_term	t,
		char *	attrname
	)

get_attr

Parameters

t	- ptr_psi_term t
attrname	- char *attrname

Get the GENERIC value of a psi-term's attribute

Definition at line 265 of file token.c.

References wl_psi_term::attr_list, wl_node::data, FEATCMP, and find().

 {
   ptr_node n=find(FEATCMP,attrname,t->attr_list);
   return n->data;
 }

int get_module	(	ptr_psi_term	psi,
		ptr_module *	module
	)

get_module

Parameters

psi	- ptr_psi_term psi
module	- ptr_module *module

GET_MODULE(psi,module,resid) Convert a psi-term to a module. The psi-term must be a string.

Definition at line 1226 of file modules.c.

References deref_ptr, Errorline(), FALSE, find_module(), wl_definition::keyword, NULL, overlap_type(), quoted_string, wl_keyword::symbol, TRUE, wl_psi_term::type, and wl_psi_term::value_3.

 {
   int success=TRUE;
   char *s;
   
   *module=NULL;
   
   deref_ptr(psi);
   if(overlap_type(psi->type,quoted_string) && psi->value_3)
     s=(char *)psi->value_3;
   else
     s=psi->type->keyword->symbol;
   
   *module=find_module(s);
   if(!(*module)) {
     Errorline("undefined module \"%s\"\n",s);
     success=FALSE;
   }
   
   return success;
 }

void get_one_arg	(	ptr_node	t,
		ptr_psi_term *	a
	)

get_one_arg

Parameters

t	- ptr_node t
a	- ptr_psi_term *a

GET_ONE_ARG(attr_list,arg1) Get the argument labelled '1' as quickly as possible from the binary tree ATTR_LIST, place it in ARG1. This routine nearly always makes a direct hit.

Definition at line 99 of file login.c.

References wl_node::data, FEATCMP, find(), wl_node::key, NULL, and one.

 {
   ptr_node n;
   
   *a=NULL;
   if (t) {
     if (t->key==one) {
       *a=(ptr_psi_term)t->data;
     }
     else {
       n=find(FEATCMP,one,t);
       if (n==NULL)
     *a=NULL;
       else
     *a=(ptr_psi_term)n->data;
     }
   }
 }

void get_one_arg_addr	(	ptr_node	t,
		ptr_psi_term **	a
	)

get_one_arg_addr

Parameters

t	- ptr_node t
a	- ptr_psi_term **a

GET_ONE_ARG_ADDR(attr_list,arg1addr) Get address of slot in the attr_list that points to the argument labelled '1' as quickly as possible from the binary tree ATTR_LIST. This routine nearly always makes a direct hit.

Definition at line 132 of file login.c.

References wl_node::data, FEATCMP, find(), wl_node::key, NULL, and one.

 {
   ptr_node n;
   //  ptr_psi_term *b;
   
   *a=NULL;
   if (t) {
     if (t->key==one)
       *a= (ptr_psi_term *)(&t->data);
     else {
       n=find(FEATCMP,one,t);
       if (n==NULL)
     *a=NULL;
       else
     *a= (ptr_psi_term *)(&n->data);
     }
   }
 }

long get_real_value	(	ptr_psi_term	t,
		REAL *	v,
		long *	n
	)

get_real_value

Parameters

t	- ptr_psi_term t
v	- REAL *v
n	- long *n

GET_REAL_VALUE(t,v,n) Check if psi_term T is a real number. Return N=TRUE iff T <| REAL. If T has a real value then set V to that value. Also force the type of T to REAL if REAL <| T. This is used in all the arithmetic built-in functions to get their arguments.

Definition at line 261 of file built_ins.c.

References def_ptr, FALSE, heap_pointer, i_check_out(), int_ptr, matches(), push_ptr_value(), REAL, real, wl_psi_term::status, TRUE, wl_psi_term::type, and wl_psi_term::value_3.

 {
   long success=FALSE;
   long smaller;
   if (t) {
     success=matches(t->type,real,&smaller);
     if (success) {
       *n=FALSE;
       if (smaller) {
     if (t->value_3) {
       *v= *(REAL *)t->value_3;
       *n=TRUE;
     }
       }
       else {
     if((GENERIC)t<heap_pointer) { /*  RM: Jun  8 1993  */
       push_ptr_value(def_ptr,(GENERIC *)&(t->type));
       push_ptr_value(int_ptr,(GENERIC *)&(t->status));
       t->type=real;
       t->status=0;
       (void)i_check_out(t);
     }
       }
     }
   }
   return success;
 }

FILE * get_stream ( ptr_psi_term t )

get_stream

Parameters

t	- ptr_psi_term t

Get the psi-term's STREAM attribute

Definition at line 278 of file token.c.

References get_attr(), and STREAM.

 {
   return (FILE *) ((ptr_psi_term)get_attr(t,STREAM))->value_3;
 }

void get_two_args	(	ptr_node	t,
		ptr_psi_term *	a,
		ptr_psi_term *	b
	)

get_two_args

Parameters

t	- ptr_node t,
a	- ptr_psi_term *a
b	- ptr_psi_term *b

GET_TWO_ARGS(attr_list,arg1,arg2) Get the arguments labelled '1' and '2' as quickly as possible from the binary tree ATTR_LIST, place them in ARG1 and ARG2. This routine nearly always makes a direct hit.

Definition at line 47 of file login.c.

References wl_node::data, FEATCMP, find(), wl_node::key, NULL, one, wl_node::right, and two.

 {
   ptr_node n;
   
   *a=NULL;
   *b=NULL;
   if (t) {
     if (t->key==one) {
       *a=(ptr_psi_term )t->data;
       n=t->right;
       if (n) 
     if (n->key==two)
       *b=(ptr_psi_term )n->data;
     else {
       n=find(FEATCMP,two,t);
       if(n==NULL)
         *b=NULL;
       else
         *b=(ptr_psi_term )n->data;
     }
       else
     *b=NULL;
     }
     else {
       n=find(FEATCMP,one,t);
       if (n==NULL)
     *a=NULL;
       else
     *a=(ptr_psi_term )n->data;
       n=find(FEATCMP,two,t);
       if (n==NULL)
     *b=NULL;
       else
     *b=(ptr_psi_term )n->data;
     }
   }
 }

int GetBoolOption ( char * name )

GetBoolOption.

Parameters

name	- char *name

Definition at line 64 of file memory.c.

References GetStrOption().

 {
   char *s;
   s=GetStrOption(name,"off");
   return strcmp(s,"off");
 }

int GetIntOption	(	char *	name,
		int	def
	)

GetIntOption.

Parameters

name	- char *name
def	- int def

Definition at line 78 of file memory.c.

References GetStrOption().

 {
   char *s;
   char buffer_loc[40];
 
   (void)snprintf(buffer_loc,40,"%d",def);
   s=GetStrOption(name,buffer_loc);
   return atof(s);
 }

char * GetStrOption	(	char *	name,
		char *	def
	)

GetStrOption.

Parameters

name	- char *name
def	- char *def

STUFF FOR PARSING COMMAND LINE ARGS

Definition at line 41 of file memory.c.

References arg_c, and arg_v.

 {
   int i;
   char *result=def;
   int l=strlen(name);
   
   for(i=1; i<arg_c; i++)
     if(arg_v[i][0]=='-' && (int)strlen(arg_v[i])>=l+1)
       if(!strncmp(arg_v[i]+1,name,l))
     if(arg_v[i][l+1]=='=')
       result=arg_v[i]+l+2;
     else
       result=arg_v[i]+l+1;  
   
   return result;
 }

long glb	(	ptr_definition	t1,
		ptr_definition	t2,
		ptr_definition *	t3,
		ptr_int_list *	c3
	)

glb

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2
t3	- ptr_definition *t3
c3	- ptr_int_list *c3

GLB(t1,t2,t3) This function returns the Greatest Lower Bound of two types T1 and T2 in T3.

T3 = T1 /\ T2

If T3 is not a simple type then C3 is its code, and T3=NULL.

It also does some type comparing, and returns

0 if T3 = bottom 1 if T1 = T2 2 if T1 <| T2 ( T3 = T1 ) 3 if T1 |> T2 ( T3 = T2 ) 4 otherwise ( T3 strictly <| T1 and T3 strictly <| T2 )

These results are used for knowing when to inherit properties or release residuations. The t3 field is NULL iff a new type is needed to represent the result.

RM: May 7 1993 Fixed bug in when multiple word code

Definition at line 1481 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, nothing, NULL, STACK_ALLOC, top, TRUE, and wl_int_list::value_1.

 {
   ptr_int_list c1,c2;
   long result=0;
   unsigned long v1,v2,v3;
   int e1,e2,b; /*  RM: May  7 1993  */
 
 
   
   *c3=NULL;
   
   if (t1==t2) { 
     result=1;
     *t3= t1;
   }
   else if (t1==top) {
     *t3= t2;
     if (t2==top)
       result=1;
     else
       result=3;
   }
   else if (t2==top) {
     result=2;
     *t3= t1;
   }
   else {
     /* printf("glb of %s and %s\n",
        t1->keyword->combined_name,
        t2->keyword->combined_name); */
        
     c1=t1->code;
     c2=t2->code;
 
     e1=TRUE;e2=TRUE;b=TRUE;
     
     if (c1!=NOT_CODED && c2!=NOT_CODED) {
       result=0;
       while (c1 && c2) {
 
         *c3 = STACK_ALLOC(int_list);
         (*c3)->next=NULL;
 
         v1=(unsigned long)(c1->value_1);
         v2=(unsigned long)(c2->value_1);
         v3=v1 & v2;
 
     /* printf("v1=%d, v2=%d, v3=%d\n",v1,v2,v3); */
     
         (*c3)->value_1=(GENERIC)v3;
 
     if(v3!=v1) /*  RM: May  7 1993  */
       e1=FALSE;
     if(v3!=v2)
       e2=FALSE;
     if(v3)
       b=FALSE;
     
         c1=c1->next;
         c2=c2->next;
         c3= &((*c3)->next);
       }
       *t3=NULL;
 
       if(b) /*  RM: May  7 1993  */
     result=0; /* 0 if T3 = bottom */
       else
     if(e1)
       if(e2)
         result=1; /* 1 if T1 = T2 */
       else
         result=2; /* 2 if T1 <| T2 ( T3 = T1 ) */
     else
       if(e2)
         result=3; /* 3 if T1 |> T2 ( T3 = T2 ) */
       else
         result=4; /* 4 otherwise */
     }
   }
   
   if (!result) *t3=nothing;
   
   /* printf("result=%d\n\n",result); */
   
   return result;
 }

long glb_code	(	long	f1,
		GENERIC	c1,
		long	f2,
		GENERIC	c2,
		long *	f3,
		GENERIC *	c3
	)

glb_code

Parameters

f1	- long f1
c1	- GENERIC c1
f2	- long f2
c2	- GENERIC c2
f3	- long *f3
c3	- GENERIC *c3

GLB_CODE(f1,c1,f2,c2,f3,c3) (21.9) Calculate glb of two type codes C1 and C2, put result in C3. Return a result value (see comments of glb(..)).

Sorts are stored as a 'Variant Record': f1==TRUE: c1 is a ptr_definition (an interned symbol). f1==FALSE: c1 is a ptr_int_list (a sort code). The result (f3,c3) is also in this format. This is needed to correctly handle psi-terms that don't have a sort code (for example, functions, predicates, and singleton sorts). The routine handles a bunch of special cases that keep f3==TRUE. Other than that, it is almost a replica of the inner loop of glb(..).

Definition at line 1351 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, NULL, STACK_ALLOC, top, TRUE, and wl_int_list::value_1.

 {
   long result=0;
   unsigned long v1,v2,v3;
   ptr_int_list cd1,cd2,*cd3; /* sort codes */
 
   /* First, the cases where c1 & c2 are ptr_definitions: */
   if (f1 && f2) {
     if ((ptr_definition)c1==(ptr_definition)c2) {
       *c3=c1;
       result=1;
     }
     else if ((ptr_definition)c1==top) {
       *c3=c2;
       if ((ptr_definition)c2==top)
         result=1;
       else
         result=3;
     }
     else if ((ptr_definition)c2==top) {
       *c3=c1;
       result=2;
     }
     /* If both inputs are either top or the same ptr_definition */
     /* then can return quickly with a ptr_definition. */
     if (result) {
       *f3=TRUE; /* c3 is ptr_definition (an interned symbol) */
       return result;
     }
   }
   /* In the other cases, can't return with a ptr_definition: */
   cd1=(ptr_int_list)(f1?(GENERIC)((ptr_definition)c1)->code:c1);
   cd2=(ptr_int_list)(f2?(GENERIC)((ptr_definition)c2)->code:c2);
   cd3=(ptr_int_list*)c3;
   *f3=FALSE; /* cd3 is ptr_int_list (a sort code) */
   if (cd1==NOT_CODED) {
     if (cd2==NOT_CODED) {
       if (c1==c2) {
         *cd3=cd1;
         result=1;
       }
       else
         result=0;
     }
     else if (cd2==top->code) {
       *cd3=cd1;
       result=2;
     }
     else
       result=0;
   }
   else if (cd1==top->code) {
     if (cd2==top->code) {
       *cd3=cd1;
       result=1;
     }
     else {
       *cd3=cd2;
       result=3;
     }
   }
   else if (cd2==NOT_CODED)
     result=0;
   else if (cd2==top->code) {
     *cd3=cd1;
     result=2;
   }
   else while (cd1 && cd2) {
     /* Bit operations needed only if c1 & c2 coded & different from top */
     *cd3 = STACK_ALLOC(int_list);
     (*cd3)->next=NULL;
     
     v1=(unsigned long)(cd1->value_1);
     v2=(unsigned long)(cd2->value_1);
     v3=v1 & v2;
     (*cd3)->value_1=(GENERIC)v3;
     
     if (v3) {
       if (v3<v1 && v3<v2)
         result=4;
       else if (result!=4)
         if (v1<v2)
           result=2;
         else if (v1>v2)
           result=3;
         else
           result=1;
     }
     else if (result)
       if (v1 || v2)
         result=4;
         
     cd1=cd1->next;
     cd2=cd2->next;
     cd3= &((*cd3)->next);
   }
 
   return result;
 }

long glb_value	(	long	result,
		long	f,
		GENERIC	c,
		GENERIC	value1,
		GENERIC	value2,
		GENERIC *	value
	)

glb_value

Parameters

result	- long result
f	- long f
c	- GENERIC c
value1	- GENERIC value1
value2	- GENERIC value2
value	- GENERIC *value

GLB_VALUE(result,f,c,value1,value2,value) Do the comparison of the value fields of two psi-terms. This is used in conjunction with glb_code to correctly implement completeness for disequality for psi-terms with non-NULL value fields. This must be preceded by a call to glb_code, since it uses the outputs of that call.

result result of preceding glb_code call (non-NULL iff non-empty intersec.) f,c sort intersection (sortflag & code) of preceding glb_code call. value1 value field of first psi-term. value2 value field of second psi-term. value output value field (if any).

Definition at line 1290 of file types.c.

References wl_definition::code, FALSE, NULL, quoted_string, REAL, real, sub_CodeType(), and TRUE.

 {
   ptr_int_list code;
 
   if (!result) return FALSE;
   if (value1==NULL) {
     *value=value2;
     return TRUE;
   }
   if (value2==NULL) {
     *value=value1;
     return TRUE;
   }
   /* At this point, both value fields are non-NULL */
   /* and must be compared. */
 
   /* Get a pointer to the sort code */
   code = f ? ((ptr_definition)c)->code : (ptr_int_list)c;
 
   /* This rather time-consuming analysis is necessary if both objects */
   /* have non-NULL value fields.  Note that only those objects with a */
   /* non-NULL value field needed for disentailment are looked at.     */
   if (sub_CodeType(code,real->code)) {
     *value=value1;
     return (*(REAL *)value1 == *(REAL *)value2);
   }
   else if (sub_CodeType(code,quoted_string->code)) {
     *value=value1;
     return (!strcmp((char *)value1,(char *)value2));
   }
   else {
     /* All other sorts with 'value' fields always return TRUE, that is, */
     /* the value field plays no role in disentailment. */
     *value=value1;
     return TRUE;
   }
 }

void global_error_check	(	ptr_node	n,
		int *	error,
		int *	eval_2
	)

global_error_check

Parameters

n	- ptr_node n
error	- int *error
eval_2	- int *eval_2

Definition at line 2591 of file built_ins.c.

References wl_psi_term::attr_list, wl_node::data, deref_eval(), deref_ptr, error_psi_term, Errorline(), FALSE, get_two_args(), global_error_check(), global_it, wl_node::left, leftarrowsym, NULL, wl_node::right, TRUE, wl_psi_term::type, wl_definition::type_def, undef_it, and wl_psi_term::value_3.

 {
   if (n) {
     ptr_psi_term t,a1,a2;
     int bad_init=FALSE;
     global_error_check(n->left, error, eval_2);
 
     t=(ptr_psi_term)n->data;
     deref_ptr(t);
     if (t->type==leftarrowsym) {
       get_two_args(t->attr_list,&a1,&a2);
       if (a1==NULL || a2==NULL) {
         Errorline("%P is an incorrect global variable declaration (%E).\n",t);
     *error=TRUE;
     bad_init=TRUE;
       } else {
     deref_ptr(a1);
     deref_ptr(a2);
     t=a1;
         if (deref_eval(a2)) *eval_2=TRUE;
       }
     }
     if (!bad_init && t->type->type_def!=(def_type)undef_it && t->type->type_def!=(def_type)global_it) {
       Errorline("%T %P cannot be redeclared as a global variable (%E).\n",
         t->type->type_def,
         t);
       t->type=error_psi_term->type;
       t->value_3=NULL; /*  RM: Mar 23 1993  */
       *error=TRUE;
     }
 
     global_error_check(n->right, error, eval_2);
   }
 }

void global_one ( ptr_psi_term t )

global_one

Parameters

t	- ptr_psi_term t

Definition at line 2651 of file built_ins.c.

References wl_psi_term::attr_list, clear_copy(), deref_ptr, get_two_args(), global_it, HEAP, wl_definition::init_value, leftarrowsym, quote_copy(), stack_psi_term(), wl_psi_term::type, and wl_definition::type_def.

 {
   ptr_psi_term u; // ,val;
 
   if (t->type==leftarrowsym) {
     get_two_args(t->attr_list,&t,&u);
     deref_ptr(t);
     deref_ptr(u);
   }
   else
     u=stack_psi_term(4);
   
   clear_copy();
   t->type->type_def=(def_type)global_it;
   t->type->init_value=quote_copy(u,HEAP); /*  RM: Mar 23 1993  */
 
   /* eval_global_var(t);   RM: Feb  4 1994  */
   
   /*  RM: Nov 10 1993 
       val=t->type->global_value;
       if (val && (GENERIC)val<heap_pointer) {
       deref_ptr(val);
       push_psi_ptr_value(val,&(val->coref));
       val->coref=u;
       } else
       t->type->global_value=u;
   */
 }

void global_tree ( ptr_node n )

global_tree

Parameters

n	- ptr_node n

Definition at line 2631 of file built_ins.c.

References wl_node::data, deref_ptr, global_one(), global_tree(), wl_node::left, and wl_node::right.

 {
   if (n) {
     ptr_psi_term t;
     global_tree(n->left);
 
     t=(ptr_psi_term)n->data;
     deref_ptr(t);
     global_one(t);
 
     global_tree(n->right);
   }
 }

int global_unify	(	ptr_psi_term	u,
		ptr_psi_term	v
	)

global_unify

Parameters

u	- ptr_psi_term u
v	- ptr_psi_term v

GLOBAL_UNIFY(u,v) Unify two psi-terms, where it is known that V is on the heap (a persistent variable).

This routine really matches U and V, it will only succeed if V is more general than U. U will then be bound to V.

Definition at line 1053 of file modules.c.

References wl_psi_term::attr_list, c_abort(), wl_psi_term::coref, deref_ptr, Errorline(), FALSE, glb(), global_unify_attr(), heap_pointer, overlap_type(), push_psi_ptr_value(), quoted_string, REAL, real, release_resid(), wl_psi_term::resid, traceline(), TRUE, wl_psi_term::type, and wl_psi_term::value_3.

 {
   int success=TRUE;
   int compare;
   ptr_definition new_type;
   ptr_int_list new_code;
 
   deref_ptr(u);
   deref_ptr(v);
 
   traceline("match persistent %P with %P\n",u,v);
 
   /* printf("u=%ld, v=%ld, heap_pointer=%ld\n",u,v,heap_pointer);*/
 
   /* printf("u=%s, v=%s\n",
      u->type->keyword->symbol,
      v->type->keyword->symbol); */
   
   if((GENERIC)u>=heap_pointer) {
     Errorline("cannot unify persistent values\n");
     return c_abort();
   }
   
   /**** U is on the stack, V is on the heap ****/
   
   /**** Calculate their Greatest Lower Bound and compare them ****/
   compare=glb(u->type,v->type,&new_type,&new_code);
   
   /* printf("compare=%d\n",compare); */
   
   if (compare==1 || compare==3) { /* Match only */
     
     /**** Check for values ****/
     if(v->value_3) {
       if(u->value_3) {
     if(u->value_3!=v->value_3) { /* One never knows */
       if (overlap_type(v->type,real))
         success=(*((REAL *)u->value_3)==(*((REAL *)v->value_3)));
       else if (overlap_type(v->type,quoted_string))
         success=(strcmp((char *)u->value_3,(char *)v->value_3)==0);
       else
         return FALSE; /* Don't unify CUTs and STREAMs and things */
     }
       }
     }
     else
       if(u->value_3)
     return FALSE;
     
     if(success) {
       /**** Bind the two psi-terms ****/
       push_psi_ptr_value(u,(GENERIC *)&(u->coref));
       u->coref=v;
       
       /**** Match the attributes ****/
       success=global_unify_attr(u->attr_list,v->attr_list);
 
       /*
     if(!success)
     warningline("attributes don't unify in %P and %P\n",u,v);
     */
       
       if(success && u->resid)
     release_resid(u);
     }
   }
   else
     success=FALSE;
   
   return success;
 }

int global_unify_attr	(	ptr_node	u,
		ptr_node	v
	)

global_unify_attr

Parameters

u	- ptr_node u
v	- ptr_node v

GLOBAL_UNIFY_ATTR(u,v) Unify the attributes of two terms, one on the heap, one on the stack. This is really matching, so all features of U must appear in V.

Definition at line 1135 of file modules.c.

References wl_node::data, dummy_printf(), FALSE, featcmp(), global_unify(), wl_node::key, wl_node::left, NULL, wl_node::right, and TRUE.

 {
   int success=TRUE;
   ptr_node temp;
   long cmp;
 
   if(u)
     if(v) {
       /*  RM: Feb 16 1993  Avoid C optimiser bug */
       (void)dummy_printf("%s %s\n",u->key,v->key);
       
       cmp=featcmp(u->key,v->key);
       if(cmp<0) {
     temp=u->right;
     u->right=NULL;
     success=global_unify_attr(u,v->left) && global_unify_attr(temp,v);
     u->right=temp;
       }
       else
     if(cmp>0) {
       temp=u->left;
       u->left=NULL;
       success=global_unify_attr(u,v->right) && global_unify_attr(temp,v);
       u->left=temp;
     }
     else {
       success=
         global_unify_attr(u->left,v->left) &&
           global_unify_attr(u->right,v->right) &&
         global_unify((ptr_psi_term)u->data,(ptr_psi_term)v->data);
     }
     }
     else
       success=FALSE;
   
   return success;
 }

void go_through ( ptr_psi_term t )

go_through

Parameters

t	- ptr_psi_term t

GO_THROUGH(t) This routine goes through all the sub_terms of psi_term T to determine which pointers need to have names given to them for printing because they are referred to elsewhere. T is a dereferenced psi_term.

Definition at line 282 of file print.c.

References wl_psi_term::attr_list, and go_through_tree().

 {
   if (t->attr_list)
     go_through_tree(t->attr_list);
 
   /*
   if(r=t->resid)
     while(r) {
       if(r->goal->pending)
     go_through(r->goal->aaaa_1);
       r=r->next;
     } */
 }

void go_through_tree ( ptr_node t )

go_through_tree

Parameters

t	- ptr_node t

GO_THROUGH_TREE(t) Explore all the pointers in the attribute tree T. Pointers that occur more than once will need a tag.

Definition at line 258 of file print.c.

References check_pointer(), wl_node::data, wl_node::left, and wl_node::right.

 {
   if (t) {
     if (t->left) {
       go_through_tree(t->left);
     }
     check_pointer((ptr_psi_term)t->data);
     if (t->right) {
       go_through_tree(t->right);
     }
   }
 
 }

ptr_goal GoalFromPsiTerm ( ptr_psi_term psiTerm )

GoalFromPsiTerm.

Parameters

psiTerm - ptr_psi_term psiTerm

not used anymore, but interesting

Definition at line 3992 of file xpred.c.

References aim, Errorline(), FALSE, wl_residuation::goal, wl_residuation::next, NULL, and wl_psi_term::resid.

 {
   ptr_residuation resid;
   ptr_goal aim;
   
   if(psiTerm == NULL)
     {
       Errorline("X error in GoalFromPsiTerm: psiTerm is null\n");
       return FALSE;
     }
   
   if((resid = psiTerm->resid) == NULL)
     {
       Errorline("X error in GoalFromPsiTerm: psiTerm has no residuating functions\n");
       return FALSE;
     }
   
   if(resid->next != NULL)
     {
       Errorline("X error in GoalFromPsiTerm: psiTerm has more than one residuating function\n");
       return FALSE;
     }
   
   if((aim = resid->goal) == NULL)
     {
       Errorline("X error in GoalFromPsiTerm: psiTerm has no goal\n");
       return FALSE;
     }
   
   return aim;
 }

char ** group_features	(	char **	f,
		ptr_node	n
	)

group_features

Parameters

f	- char **f
n	- ptr_node n

Definition at line 34 of file lib.c.

References wl_node::key, wl_node::left, NULL, and wl_node::right.

 {
   *f=NULL;
   if(n) {
     if(n->left)
       f=group_features(f,n->left);
     *f=n->key;
     f++;
     if(n->right)
       f=group_features(f,n->right);
   }
   
   return f;
 }

void handle_interrupt ( )

HANDLE_INTERRUPT.

This deals with an eventual interrupt. Return TRUE if execution continues normally, otherwise abort query, toggle trace on or off, or quit Wild_Life (suicide).

Definition at line 52 of file interrupt.c.

References abort_life(), DIGIT, EOLN, exit_life(), FALSE, input_state, interrupted, open_input_file(), prompt, quietflag, read_char(), restore_state(), show_count(), stdin_cleareof(), stepcount, stepflag, steptrace, trace, TRUE, and verbose.

 {
   ptr_psi_term old_state_loc;
   char *old_prompt;
   int old_quiet; /* 21.1 */
   long c,d; /* 21.12 (prev. char) */
   long count;
 
   if (interrupted) printf("\n");
   interrupted=FALSE;
   old_prompt=prompt;
   old_quiet=quietflag; /* 21.1 */
   steptrace=FALSE;
 
   /* new_state(&old_state_loc); */
   old_state_loc=input_state;
   (void)open_input_file("stdin");
   stdin_cleareof();
 
   StartAgain:
   do {
     printf("*** Command ");
     prompt="(q,c,a,s,t,h)?";
     quietflag=FALSE; /* 21.1 */
     
     do {
       c=read_char();
     } while (c!=EOLN && c>0 && c<=32);
   
     d=c;
     count=0;
     while (DIGIT(d)) { count=count*10+(d-'0'); d=read_char(); }
 
     while (d!=EOLN && d!=EOF) d=read_char();
 
     if (c=='h' || c=='?') {
       printf("*** [Quit (q), Continue (c), Abort (a), Step (s,RETURN), Trace (t), Help (h,?)]\n");
     }
 
   } while (c=='h' || c=='?');
   
   prompt=old_prompt;
   quietflag=old_quiet; /* 21.1 */
   
   switch (c) {
   case 'v':
   case 'V':
     verbose=TRUE;
     break;
   case 'q':
   case 'Q':
   case EOF:
     if (c==EOF) printf("\n");
     exit_life(FALSE);
     break;
   case 'a':
   case 'A':
     (void)abort_life(FALSE);
     show_count();
     break;
   case 'c':
   case 'C':
     trace=FALSE;
     stepflag=FALSE;
     break;
   case 't':
   case 'T':
     trace=TRUE;
     stepflag=FALSE;
     break;
   case 's':
   case 'S':
   case EOLN:
     trace=TRUE;
     stepflag=TRUE;
     break;
   case '0': case '1': case '2': case '3': case '4':
   case '5': case '6': case '7': case '8': case '9':
     trace=TRUE;
     stepflag=TRUE;
     if (count>0) {
       stepcount=count;
       stepflag=FALSE;
     }
     break;
   default:
     goto StartAgain;
   }
   input_state=old_state_loc;
   restore_state(input_state);
 }

long has_non_alpha ( char * s )

has_non_alpha

Parameters

s - char *s

Return TRUE iff s contains a character that is not alphanumeric.

Definition at line 418 of file print.c.

References FALSE, ISALPHA, and TRUE.

 {
   while (*s) {
     if (!ISALPHA(*s)) return TRUE;
     s++;
   }
   return FALSE;
 }

long has_rules ( ptr_pair_list r )

has_rules

Parameters

r	- ptr_pair_list r

Return TRUE iff there are some rules r This is true for a user-defined function or predicate with a definition, and for a type with constraints.

Definition at line 5101 of file built_ins.c.

References wl_pair_list::aaaa_2, FALSE, wl_pair_list::next, NULL, and TRUE.

 {
   if (r==NULL) return FALSE;
   while (r) {
     if (r->aaaa_2!=NULL) return TRUE;
     r=r->next;
   }
   return FALSE;
 }

int hash_code	(	ptr_hash_table	table,
		char *	symbol
	)

HASH_CODE.

Parameters

table	- ptr_hash_table table
symbol	- char *symbol

Return the hash code for a symbol

Definition at line 79 of file hash_table.c.

References rand_array, and wl_hash_table::size.

 {
   int n=0;
   
   /* printf("code of %s ",symbol); */
   
   while(*symbol) {
     n ^= rand_array[*symbol]+rand_array[n&255];
     n++;
     symbol++;
   }
   
   n &= (table->size-1);
   
   
   /* printf("=%d\n",n); */
   
   return n;
 }

ptr_hash_table hash_create ( int size )

HASH_CREATE.

Parameters

size	- int size

Create a hash-table for max size keywords.

Definition at line 25 of file hash_table.c.

References NULL, and wl_hash_table::size.

 {
   ptr_hash_table new;
   int i;
   
   new=(ptr_hash_table)malloc(sizeof(struct wl_hash_table));
   new->size=size;
   new->used=0;
   new->data=(ptr_keyword *)malloc(size*sizeof(ptr_keyword));
   for(i=0;i<size;i++)
     new->data[i]=NULL;
   return new;
 }

void hash_display ( ptr_hash_table table )

HASH_DISPLAY.

Parameters

table - ptr_hash_table table

Display a symbol table (for debugging).

Definition at line 174 of file hash_table.c.

References hash_code().

 {
   int i;
   int n;
   char *s;
   int c=0;
   int t=0;
   
   printf("*** Hash table %lx:\n",(long)table);
   printf("Size: %d\n",table->size);
   printf("Used: %d\n",table->used);
   
   for(i=0;i<table->size;i++)
     if(table->data[i]) {
       t++;
       s=table->data[i]->symbol;
       n=hash_code(table,s);
       
       printf("%4d %4d %s %s\n",
          i,
          n,
          i==n?"ok   ":"*bad*",
          s);
       
       if(i!=n)
     c++;
     }
   
   printf("Really used: %d\n",t);
   printf("Collisions: %d = %1.3f%%\n",
      c,
      100.0*c/(double)t);
 }

void hash_expand	(	ptr_hash_table	table,
		int	new_size
	)

HASH_EXPAND.

Parameters

table	- ptr_hash_table table
new_size	- int new_size

Allocate a bigger hash table.

Definition at line 47 of file hash_table.c.

References wl_hash_table::data, hash_insert(), NULL, wl_hash_table::size, and wl_hash_table::used.

 {
   ptr_keyword *old_data;
   int old_size;
   int i;
 
   
   old_data=table->data;
   old_size=table->size;
 
   table->size=new_size; /* Must be power of 2 */
   table->used=0;
   table->data=(ptr_keyword *)malloc(new_size*sizeof(ptr_keyword));
   
   for(i=0;i<new_size;i++)
     table->data[i]=NULL;
   
   for(i=0;i<old_size;i++)
     if(old_data[i])
       hash_insert(table,old_data[i]->symbol,old_data[i]);
 
   free(old_data);
 }

int hash_find	(	ptr_hash_table	table,
		char *	symbol
	)

hash_find

Parameters

table	- ptr_hash_table table
symbol	- char *symbol

Definition at line 106 of file hash_table.c.

References wl_hash_table::data, hash_code(), wl_hash_table::size, and wl_keyword::symbol.

 {
   int n;
   int i=1;
   
   n=hash_code(table,symbol);
   
   while(table->data[n] && strcmp(table->data[n]->symbol,symbol)) {
     /* Not a direct hit... */
     n+= i*i;
     /* i++; */
     n &= table->size-1;
   }
   
   return n;
 }

void hash_insert	(	ptr_hash_table	table,
		char *	symbol,
		ptr_keyword	keyword
	)

HASH_INSERT.

Parameters

table	- ptr_hash_table table
symbol	- char *symbol
keyword	- ptr_keyword keyword

Add a symbol and data to a table. Overwrite previous data.

Definition at line 151 of file hash_table.c.

References wl_hash_table::data, hash_expand(), hash_find(), wl_hash_table::size, and wl_hash_table::used.

 {
   int n;
 
   n=hash_find(table,symbol);
 
   /* printf("inserting %s at %d keyword %x\n",symbol,n,keyword); */
   
   if(!table->data[n])
     table->used++;
   table->data[n]=keyword;
   
   if(table->used*2>table->size)
     hash_expand(table,table->size*2);
 }

ptr_keyword hash_lookup	(	ptr_hash_table	table,
		char *	symbol
	)

HASH_LOOKUP.

Parameters

table	- ptr_hash_table table
symbol	- char *symbol

Look up a symbol in the symbol table.

Definition at line 131 of file hash_table.c.

References wl_hash_table::data, and hash_find().

 {
   int n;
   
   n=hash_find(table,symbol);
   
   /* printf("found %s at %d keyword %x\n",symbol,n,table->data[n]); */
   
   return table->data[n];
 }

void heap_add_int_attr	(	ptr_psi_term	t,
		char *	attrname,
		long	value
	)

heap_add_int_attr

Parameters

t	- ptr_psi_term t
attrname	- char *attrname
value	- long value

Add an attribute whose value is an integer to a psi-term that does not yet contains this attribute.

Definition at line 74 of file token.c.

References wl_psi_term::attr_list, FEATCMP, heap_alloc(), heap_copy_string(), heap_insert(), heap_psi_term(), integer, REAL, wl_psi_term::type, and wl_psi_term::value_3.

 {
   ptr_psi_term t1;
 
   t1=heap_psi_term(4);
   t1->type=integer;
   t1->value_3=heap_alloc(sizeof(REAL));
   *(REAL *)t1->value_3 = (REAL) value;
 
   (void)heap_insert(FEATCMP,heap_copy_string(attrname),&(t->attr_list), (GENERIC)t1);
 }

void heap_add_psi_attr	(	ptr_psi_term	t,
		char *	attrname,
		ptr_psi_term	g
	)

heap_add_psi_attr

Parameters

t	- ptr_psi_term t
attrname	- char *attrname
g	- ptr_psi_term g

Attach a psi-term to another as an attribute.

Definition at line 226 of file token.c.

References wl_psi_term::attr_list, FEATCMP, heap_copy_string(), and heap_insert().

 {
   (void)heap_insert(FEATCMP,heap_copy_string(attrname),&(t->attr_list),(GENERIC) g);
 }

void heap_add_str_attr	(	ptr_psi_term	t,
		char *	attrname,
		char *	str
	)

heap_add_str_attr

Parameters

t	- ptr_psi_term t
attrname	- char *attrname
str	- char *str

Add an attribute whose value is a string to a psi-term that does not yet contains this attribute.

Definition at line 151 of file token.c.

References wl_psi_term::attr_list, FEATCMP, heap_copy_string(), heap_insert(), heap_psi_term(), quoted_string, wl_psi_term::type, and wl_psi_term::value_3.

 {
   ptr_psi_term t1;
 
   t1=heap_psi_term(4);
   t1->type=quoted_string;
   t1->value_3=(GENERIC)heap_copy_string(str);
 
   (void)heap_insert(FEATCMP,heap_copy_string(attrname),&(t->attr_list),(GENERIC) t1);
 }

GENERIC heap_alloc ( long s )

heap_alloc

Parameters

s - long s

HEAP_ALLOC(s) This returns a pointer to S bytes of memory in the heap. Alignment is taken into account in the following manner: the macro ALIGN is supposed to be a power of 2 and the pointer returned is a multiple of ALIGN.

Definition at line 1616 of file memory.c.

References ALIGN, Errorline(), heap_pointer, and stack_pointer.

 {
     if (s & (ALIGN-1))
       s = s - (s & (ALIGN-1))+ALIGN;
     /* assert(s % sizeof(*heap_pointer) == 0); */
     s /= sizeof (*heap_pointer);
   
     heap_pointer -= s;
 
     if (stack_pointer>heap_pointer)
       Errorline("the heap overflowed into the stack.\n");
 
     return heap_pointer;
 }

ptr_psi_term heap_copy_psi_term ( psi_term t )

heap_copy_psi_term

Parameters

t	- psi_term t

HEAP_COPY_PSI_TERM(tok) Return the address of a copy of TOK on the HEAP.

Definition at line 226 of file parser.c.

References global_time_stamp, and HEAP_ALLOC.

 {
   ptr_psi_term p;
   
   p=HEAP_ALLOC(psi_term);
   (*p)=t;
 #ifdef TS
   p->time_stamp=global_time_stamp; /* 9.6 */
 #endif
   
   return p;
 }

char * heap_copy_string ( char * s )

heap_copy_string

Parameters

s - char *s

HEAP_COPY_STRING(string) Make a copy of the string in the heap, and return a pointer to that. Exceptions: "1" and "2" are unique (and in the heap).

Definition at line 172 of file trees.c.

References heap_ncopy_string().

173 { return heap_ncopy_string(s,strlen(s)); }

heap_ncopy_string

char * heap_ncopy_string(char *s, int n)

heap_ncopy_string

Definition: trees.c:150

ptr_node heap_insert	(	long	comp,
		char *	keystr,
		ptr_node *	tree,
		GENERIC	info
	)

heap_insert

Parameters

comp	- long comp
keystr	- char *keystr
tree	- ptr_node *tree
info	- GENERIC info

HEAP_INSERT(comp,keystr,tree,info) Insert the pointer INFO under the reference KEYSTR in the binary tree TREE stored in the heap. Return the pointer to the node of KEYSTR.

Definition at line 320 of file trees.c.

References FALSE, general_insert(), and HEAP.

 {
 
   return general_insert(comp,keystr,tree,info,HEAP,FALSE,0L);
 }

void heap_insert_copystr	(	char *	keystr,
		ptr_node *	tree,
		GENERIC	info
	)

heap_insert_copystr

Parameters

keystr	- char *keystr
tree	- ptr_node *tree
info	- GENERIC info

HEAP_INSERT_COPYSTR(keystr,tree,info) Insert the pointer INFO under the reference string KEYSTR (which is a feature name) in the binary tree TREE. KEYSTR is copied to the heap. A potential additional node allocated to TREE is put on the heap.

Definition at line 284 of file trees.c.

References FEATCMP, general_insert(), HEAP, and TRUE.

 {
   (void)general_insert(FEATCMP,keystr,tree,info,HEAP,TRUE,0L);
 }

void heap_mod_int_attr	(	ptr_psi_term	t,
		char *	attrname,
		long	value
	)

heap_mod_int_attr

Parameters

t	- ptr_psi_term t
attrname	- char *attrname
value	- long value

Modify an attribute whose value is an integer to a psi-term that already contains this attribute with another integer value.

Definition at line 116 of file token.c.

References wl_psi_term::attr_list, wl_node::data, FEATCMP, find(), REAL, and wl_psi_term::value_3.

 {
   ptr_node n;
   ptr_psi_term t1;
 
   n=find(FEATCMP,attrname,t->attr_list);
   t1=(ptr_psi_term)n->data;
   *(REAL *)t1->value_3 = (REAL) value;
 }

void heap_mod_str_attr	(	ptr_psi_term	t,
		char *	attrname,
		char *	str
	)

heap_mod_str_attr

Parameters

t	- ptr_psi_term t
attrname	- char *attrname
str	- char *str

Modify an attribute whose value is a string to a psi-term that already contains this attribute with another integer value.

Definition at line 191 of file token.c.

References wl_psi_term::attr_list, wl_node::data, FEATCMP, find(), heap_copy_string(), and wl_psi_term::value_3.

 {
   ptr_node n;
   ptr_psi_term t1;
 
   n=find(FEATCMP,attrname,t->attr_list);
   t1=(ptr_psi_term)n->data;
   t1->value_3=(GENERIC)heap_copy_string(str);
 }

char * heap_ncopy_string	(	char *	s,
		int	n
	)

heap_ncopy_string

Parameters

s	- char *s
n	- int n

HEAP_NCOPY_STRING(string,length) Make a copy of the string in the heap, and return a pointer to that. Exceptions: "1" and "2" are unique (and in the heap).

Definition at line 150 of file trees.c.

References heap_alloc(), one, and two.

 {
   char *p;
   
   if (s==one || s==two) return s;
 
   p=(char *)heap_alloc(n+1);
   strncpy(p,s,n);
   p[n]='\0';
   
   return p;
 }

char * heap_nice_name ( )

heap_nice_name

Generate a nice-looking new variable name.

Definition at line 63 of file print.c.

References gen_sym_counter, heap_copy_string(), perr(), and STRLEN.

 {
   string tmp1,tmp2;
   char g,len; // ,leading_a;
 
   g= ++gen_sym_counter;
   len=2;
   strcpy(tmp2,"");
   do {
     g--;
     /* Prefix one character to tmp2: */
     (void)snprintf(tmp1,2,"%c",g%26+'A');
     strcat(tmp1,tmp2);
     strcpy(tmp2,tmp1);
     g=g/26;
     len++;
   } while (g>0 && len<STRLEN);
   if (len>=STRLEN)
     perr("Variable name too long -- the universe has ceased to exist.");
 
   strcpy(tmp1,"_");
   strcat(tmp1,tmp2);
   
   return heap_copy_string(tmp1);
 }

ptr_psi_term heap_psi_term ( long stat )

heap_psi_term

Parameters

stat	- long stat

Create a new psi_term on the heap with value '@' (top) and no attributes.

Definition at line 75 of file lefun.c.

References wl_psi_term::attr_list, wl_psi_term::coref, FALSE, wl_psi_term::flags, global_time_stamp, HEAP_ALLOC, NULL, QUOTED_TRUE, wl_psi_term::resid, wl_psi_term::status, top, wl_psi_term::type, and wl_psi_term::value_3.

 {
   ptr_psi_term result;
 
   result=HEAP_ALLOC(psi_term);
   result->type=top;
   result->status=stat;
   result->flags=stat?QUOTED_TRUE:FALSE; /* 14.9 */
   result->attr_list=NULL;
   result->coref=NULL;
 #ifdef TS
   result->time_stamp=global_time_stamp; /* 9.6 */
 #endif
   result->resid=NULL;
   result->value_3=NULL;
 
   return result;
 }

long hidden_type ( ptr_definition t )

hidden_type

Parameters

t	- ptr_definition t

Return TRUE iff T is a type that should not show up as part of the type hierarchy, i.e. it is an internal hidden type.

Definition at line 3672 of file built_ins.c.

References comment, constant, functor, and variable.

 {
   return (/* (t==conjunction) || 19.8 */
       /* (t==disjunction) || RM: Dec  9 1992 */
       (t==constant) || (t==variable) ||
       (t==comment) || (t==functor));
 }

long i_check_out ( ptr_psi_term t )

i_check_out

Parameters

t	- ptr_psi_term t

i_check_out(t) checks out everything except functions. When a function is encountered, check_out returns immediately without looking inside it.

Definition at line 1033 of file lefun.c.

References check_func_flag, check_out(), and FALSE.

 {
   check_func_flag=FALSE;
   return check_out(t);
 }

long i_eval_args ( ptr_node n )

i_eval_args

Parameters

n	- ptr_node n

I_EVAL_ARGS(n) N is an attribute tree, the attributes must be examined, if any reveal themselves to need evaluating then return FALSE.

Definition at line 874 of file lefun.c.

References check_func_flag, eval_args(), and FALSE.

 {
   check_func_flag=FALSE;
   return eval_args(n);
 }

long in_set	(	char *	str,
		long	set
	)

in_set

Parameters

str	- char *str
set	- long set

Return TRUE iff string (considered as number) is in the set This routine only recognizes the strings "1", "2", "3", represented as numbers 1, 2, 4.

Definition at line 1316 of file lefun.c.

References FALSE, featcmp(), and TRUE.

 {
   if (set&1 && !featcmp(str,"1")) return TRUE;
   if (set&2 && !featcmp(str,"2")) return TRUE;
   if (set&4 && !featcmp(str,"3")) return TRUE;
   if (set&8 && !featcmp(str,"4")) return TRUE;
   return FALSE;
 }

ptr_psi_term inc_heap_copy ( ptr_psi_term t )

inc_heap_copy

Parameters

t	- ptr_psi_term t

There is a bug in inc_heap_copy

Definition at line 206 of file copy.c.

References copy(), EXACT_FLAG, to_heap, and TRUE.

207 { to_heap=TRUE; return (copy(t, EXACT_FLAG, TRUE)); }

EXACT_FLAG

#define EXACT_FLAG

flag to copy function in copy.c to indicate kind of copy

Definition: def_const.h:1306

TRUE

#define TRUE

Standard boolean.

Definition: def_const.h:268

ptr_psi_term copy(ptr_psi_term t, long copy_flag, long heap_flag)

copy

Definition: copy.c:248

long to_heap

Definition: def_glob.h:905

void infoline	(	char *	format,
			...
	)

infoline

Parameters

format	- char *format
...

Definition at line 281 of file error.c.

References assert, display_psi(), FALSE, input_file_name, NOTQUIET, parse_ok, perr_i(), perr_s(), print_code(), print_def_type(), print_operator_kind(), and psi_term_line_number.

 {
   va_list VarArg;
   //  int l;        
   char buffer_loc[5];   
   char *p; 
   unsigned long lng2; 
   char *cptr; 
   ptr_int_list pil;  
   ptr_psi_term psi;  
   operator kind; 
   def_type t ; 
   
   va_start(VarArg,format);
   if (NOTQUIET)
     {
       
       //      vinfoline(format, stdout, VarArg);
       //#define vinfoline(format, outfile, xxxx)  { 
       for (p=format;p &&  *p; p++) 
     { 
       if (*p == '%') 
         { 
           p++; 
           switch (*p) 
         { 
         case 'd': 
         case 'x': 
           buffer_loc[0] = '%'; 
           buffer_loc[1] = 'l'; 
           buffer_loc[2] = *p; 
           buffer_loc[3] = 0; 
           lng2 = va_arg(VarArg,long); 
           fprintf(stdout, buffer_loc, lng2); 
           break; 
         case 's': 
           buffer_loc[0] = '%'; 
           buffer_loc[1] = *p; 
           buffer_loc[2] = 0; 
           cptr = va_arg(VarArg,char *); 
           fprintf(stdout, buffer_loc, cptr); 
           break; 
         case 'C': 
           /* type coding as bin string */ 
           pil = va_arg(VarArg,ptr_int_list); 
           print_code(stdout,pil); 
           break; 
         case 'P': 
           psi = va_arg(VarArg,ptr_psi_term); 
           display_psi(stdout,psi); 
           break; 
         case 'O': 
           kind = va_arg(VarArg,operator); 
           print_operator_kind(stdout,kind); 
           break; 
         case 'T': 
           assert(stdout==stderr); 
           t = va_arg(VarArg,def_type); 
           print_def_type(t); 
           break; 
         case 'E': 
           assert(stdout==stderr); 
           perr_i("near line %ld",psi_term_line_number); 
           if (strcmp(input_file_name,"stdin")) {       
             perr_s(" in file 042%s042",input_file_name); 
           }                        
           parse_ok=FALSE;                      
           break;                           
         case '%':                          
           (void)putc(*p,stdout);                   
           break;                           
         default: 
           fprintf(stdout,"<%c follows %% : report bug >", *p); 
           break; 
         } 
         } 
       else 
         (void)putc(*p,stdout); 
     }
     } 
   va_end(VarArg); 
 } 

void inherit_always_check ( )

inherit_always_check

INHERIT_ALWAYS_CHECK() The 'always_check' flag, if false, should be propagated to a sort's children. This routine does a closure on this propagation operation for all declared sorts.

Definition at line 1068 of file types.c.

References FALSE, and one_pass_always_check().

 {
   long change;
 
   do {
     change=FALSE;
     one_pass_always_check(&change);
   } while (change);
 }

void init_built_in_types ( )

init_built_in_types

INIT_BUILT_IN_TYPES Initialise the symbol tree with the built-in types. Declare all built-in predicates and functions. Initialise system type variables. Declare all standard operators.

Called by life.c

Definition at line 6155 of file built_ins.c.

References aborthooksym, abortsym, add_module1, add_module2, add_module3, alist, all_public_symbols(), and, apply, bi_module, boolpredsym, built_in, c_abort(), c_alias(), c_and(), c_append_file(), c_apply(), c_args(), c_ascii(), c_assert_first(), c_assert_last(), c_bk_assign(), c_boolpred(), c_char(), c_chdir(), c_clause(), c_close(), c_combined_name(), c_concatenate(), c_cond(), c_copy_pointer(), c_copy_term(), c_current_module(), c_declaration(), c_delay_check(), c_deref_length(), c_diff(), c_diff_address(), c_disj(), c_display_modules(), c_display_persistent(), c_dynamic(), c_equal(), c_eval(), c_eval_disjunction(), c_eval_inplace(), c_exist_feature(), c_exists(), c_exists_choice(), c_fail(), c_feature_values(), c_features(), c_get(), c_get_choice(), c_global(), c_global_assign(), c_gt(), c_gtoe(), c_halt(), c_implies(), c_initrandom(), c_int2string(), c_is_function(), c_is_predicate(), c_is_sort(), c_listing(), c_load(), c_lt(), c_ltoe(), c_module_name(), c_non_strict(), c_nonvar(), c_not(), c_not_implemented(), c_op(), c_open_in(), c_open_module(), c_open_out(), c_ops(), c_or(), c_page_width(), c_parse(), c_persistent(), c_print_codes(), c_print_depth(), c_print_variables(), c_private(), c_private_feature(), c_project(), c_psi2string(), c_public(), c_put(), c_put_err(), c_pwrite(), c_pwriteq(), c_random(), c_read_psi(), c_read_token(), c_repeat(), c_replace(), c_retract(), c_rootsort(), c_same_address(), c_set_choice(), c_set_input(), c_set_module(), c_set_output(), c_setq(), c_split_double(), c_static(), c_string2psi(), c_string_address(), c_string_length(), c_strip(), c_sub_string(), c_succeed(), c_such_that(), c_trace_input(), c_undo(), c_unify_func(), c_unify_pred(), c_var(), c_write(), c_write_canonical(), c_write_err(), c_writeq(), c_writeq_err(), c_xor(), call_handlersym, calloncesym, wl_definition::code, colonsym, commasym, comment, constant, cut, day_attr, delay_checksym, disj_nil, disjunction, dynamicsym, encodesym, eof, eqsym, error_psi_term, eval_argsym, final_dot, final_question, funcsym, function_it, functor, fx_sym, fy_sym, hash_lookup(), heap_psi_term(), hour_attr, iff, inputfilesym, insert_math_builtins(), insert_sys_builtins(), insert_system_builtins(), insert_type_builtins(), integer, wl_definition::keyword, leftarrowsym, lf_false, lf_true, life_or, listingsym, loadsym, minus_symbol, minute_attr, month_attr, new_built_in(), nil, no_module, NOT_CODED, nothing, null_psi_term, nullsym, one, opsym, predicate_it, predsym, wl_keyword::public, quote, quoted_string, real, second_attr, set_current_module(), staticsym, stream, succeed, such_that, wl_keyword::symbol, wl_module::symbol_table, syntax_module, three, timesym, top, tracesym, TRUE, two, wl_psi_term::type, wl_definition::type_def, type_it, typesym, update_symbol(), variable, weekday_attr, xf_sym, xfx_sym, xfy_sym, year_attr, yf_sym, and yfx_sym.

 {
   ptr_definition t;
 
   /* symbol_table=NULL;   RM: Feb  3 1993  */
 
   
   
   /*  RM: Jan 13 1993  */
   /* Initialize the minimum syntactic symbols */
   (void)set_current_module(syntax_module); /*  RM: Feb  3 1993  */
   and=update_symbol(syntax_module,",");  
   (void)update_symbol(syntax_module,"[");
   (void)update_symbol(syntax_module,"]");
   (void)update_symbol(syntax_module,"(");
   (void)update_symbol(syntax_module,")");
   (void)update_symbol(syntax_module,"{");
   (void)update_symbol(syntax_module,"}");
   (void)update_symbol(syntax_module,".");
   (void)update_symbol(syntax_module,"?");
 
   
   cut           =update_symbol(syntax_module,"!");
   colonsym      =update_symbol(syntax_module,":");
   commasym      =update_symbol(syntax_module,",");
   disj_nil              =update_symbol(syntax_module,"{}");
   eof           =update_symbol(syntax_module,"end_of_file");
   eqsym         =update_symbol(syntax_module,"=");
   leftarrowsym      =update_symbol(syntax_module,"<-");
   funcsym       =update_symbol(syntax_module,"->");
   life_or               =update_symbol(syntax_module,";");/* RM: Apr 6 1993  */
   minus_symbol          =update_symbol(syntax_module,"-");/* RM: Jun 21 1993 */
   predsym       =update_symbol(syntax_module,":-");
   quote         =update_symbol(syntax_module,"`");
   such_that     =update_symbol(syntax_module,"|");
   top           =update_symbol(syntax_module,"@");
   typesym       =update_symbol(syntax_module,"::");
 
   /*  RM: Jul  7 1993  */
   final_dot     =update_symbol(syntax_module,"< . >");
   final_question    =update_symbol(syntax_module,"< ? >");
 
   
   
   /*  RM: Feb  3 1993  */
   (void)set_current_module(bi_module);
   error_psi_term=heap_psi_term(4); /* 8.10 */
   error_psi_term->type=update_symbol(bi_module,"*** ERROR ***");
   error_psi_term->type->code=NOT_CODED;
 
   apply         =update_symbol(bi_module,"apply");
   boolean       =update_symbol(bi_module,"bool");
   boolpredsym       =update_symbol(bi_module,"bool_pred");
   built_in      =update_symbol(bi_module,"built_in");
   calloncesym           =update_symbol(bi_module,"call_once");
   /* colon sym */
   /* comma sym */
   comment       =update_symbol(bi_module,"comment");
 
   
   /*  RM: Dec 11 1992  conjunctions have been totally scrapped it seems */
   /* conjunction=update_symbol("*conjunction*"); 19.8 */
 
   constant      =update_symbol(bi_module,"*constant*");
   disjunction       =update_symbol(bi_module,"disj");/*RM:9 Dec 92*/
   lf_false      =update_symbol(bi_module,"false");
   functor       =update_symbol(bi_module,"functor");
   iff           =update_symbol(bi_module,"cond");
   integer       =update_symbol(bi_module,"int");
   alist     =update_symbol(bi_module,"cons");/*RM:9 Dec 92*/
   nothing       =update_symbol(bi_module,"bottom");
   nil           =update_symbol(bi_module,"nil");/*RM:9 Dec 92*/
   quoted_string     =update_symbol(bi_module,"string");
   real          =update_symbol(bi_module,"real");
   stream        =update_symbol(bi_module,"stream");
   succeed       =update_symbol(bi_module,"succeed");
   lf_true       =update_symbol(bi_module,"true");
   timesym       =update_symbol(bi_module,"time");
   variable      =update_symbol(bi_module,"*variable*");
   opsym         =update_symbol(bi_module,"op");
   loadsym       =update_symbol(bi_module,"load");
   dynamicsym        =update_symbol(bi_module,"dynamic");
   staticsym     =update_symbol(bi_module,"static");
   encodesym     =update_symbol(bi_module,"encode");
   listingsym        =update_symbol(bi_module,"c_listing");
   /* provesym       =update_symbol(bi_module,"prove"); */
   delay_checksym    =update_symbol(bi_module,"delay_check");
   eval_argsym       =update_symbol(bi_module,"non_strict");
   inputfilesym      =update_symbol(bi_module,"input_file");
   call_handlersym   =update_symbol(bi_module,"call_handler");
   xf_sym        =update_symbol(bi_module,"xf");
   yf_sym        =update_symbol(bi_module,"yf");
   fx_sym        =update_symbol(bi_module,"fx");
   fy_sym        =update_symbol(bi_module,"fy");
   xfx_sym       =update_symbol(bi_module,"xfx");
   xfy_sym       =update_symbol(bi_module,"xfy");
   yfx_sym       =update_symbol(bi_module,"yfx");
   nullsym       =update_symbol(bi_module,"<NULL PSI TERM>");
   null_psi_term     =heap_psi_term(4);
   null_psi_term->type   =nullsym;
 
 
   (void)set_current_module(no_module); /*  RM: Feb  3 1993  */
   t=update_symbol(no_module,"1");
   one=t->keyword->symbol;
   t=update_symbol(no_module,"2");
   two=t->keyword->symbol;
   t=update_symbol(no_module,"3");
   three=t->keyword->symbol;
   (void)set_current_module(bi_module); /*  RM: Feb  3 1993  */
   t=update_symbol(bi_module,"year");
   year_attr=t->keyword->symbol;
   t=update_symbol(bi_module,"month");
   month_attr=t->keyword->symbol;
   t=update_symbol(bi_module,"day");
   day_attr=t->keyword->symbol;
   t=update_symbol(bi_module,"hour");
   hour_attr=t->keyword->symbol;
   t=update_symbol(bi_module,"minute");
   minute_attr=t->keyword->symbol;
   t=update_symbol(bi_module,"second");
   second_attr=t->keyword->symbol;
   t=update_symbol(bi_module,"weekday");
   weekday_attr=t->keyword->symbol;
   
   nothing->type_def=(def_type)type_it;
   top->type_def=(def_type)type_it;
 
   /* Built-in routines */
   //  bi_list = fopen("bi_list.txt","w");
 
   /* Program database */
   new_built_in(bi_module,"dynamic",(def_type)predicate_it,c_dynamic);
   new_built_in(bi_module,"static",(def_type)predicate_it,c_static);
   new_built_in(bi_module,"assert",(def_type)predicate_it,c_assert_last);
   new_built_in(bi_module,"asserta",(def_type)predicate_it,c_assert_first);
   new_built_in(bi_module,"clause",(def_type)predicate_it,c_clause);
   new_built_in(bi_module,"retract",(def_type)predicate_it,c_retract);
   new_built_in(bi_module,"setq",(def_type)predicate_it,c_setq);
   new_built_in(bi_module,"c_listing",(def_type)predicate_it,c_listing);
   new_built_in(bi_module,"print_codes",(def_type)predicate_it,c_print_codes);
 
   /* File I/O */
   new_built_in(bi_module,"get",(def_type)predicate_it,c_get);
   new_built_in(bi_module,"put",(def_type)predicate_it,c_put);
   new_built_in(bi_module,"open_in",(def_type)predicate_it,c_open_in);
   new_built_in(bi_module,"open_out",(def_type)predicate_it,c_open_out);
   new_built_in(bi_module,"set_input",(def_type)predicate_it,c_set_input);
   new_built_in(bi_module,"set_output",(def_type)predicate_it,c_set_output);
   new_built_in(bi_module,"exists_file",(def_type)predicate_it,c_exists);
   new_built_in(bi_module,"close",(def_type)predicate_it,c_close);
   new_built_in(bi_module,"simple_load",(def_type)predicate_it,c_load);
   new_built_in(bi_module,"put_err",(def_type)predicate_it,c_put_err);
   new_built_in(bi_module,"chdir",(def_type)predicate_it,c_chdir);
 
   /* Term I/O */
   new_built_in(bi_module,"write",(def_type)predicate_it,c_write);
   new_built_in(bi_module,"writeq",(def_type)predicate_it,c_writeq);
   new_built_in(bi_module,"pretty_write",(def_type)predicate_it,c_pwrite);
   new_built_in(bi_module,"pretty_writeq",(def_type)predicate_it,c_pwriteq);
   new_built_in(bi_module,"write_canonical",(def_type)predicate_it,c_write_canonical);
   new_built_in(bi_module,"page_width",(def_type)predicate_it,c_page_width);
   new_built_in(bi_module,"print_depth",(def_type)predicate_it,c_print_depth);
   new_built_in(bi_module,"put_err",(def_type)predicate_it,c_put_err);
   new_built_in(bi_module,"parse",(def_type)function_it,c_parse);
   new_built_in(bi_module,"read",(def_type)predicate_it,c_read_psi);
   new_built_in(bi_module,"read_token",(def_type)predicate_it,c_read_token);
   new_built_in(bi_module,"c_op",(def_type)predicate_it,c_op); /*  RM: Jan 13 1993  */
   new_built_in(bi_module,"ops",(def_type)function_it,c_ops);
   new_built_in(bi_module,"write_err",(def_type)predicate_it,c_write_err);
   new_built_in(bi_module,"writeq_err",(def_type)predicate_it,c_writeq_err);
 
   /* Type checks */
   new_built_in(bi_module,"nonvar",(def_type)function_it,c_nonvar);
   new_built_in(bi_module,"var",(def_type)function_it,c_var);
   new_built_in(bi_module,"is_function",(def_type)function_it,c_is_function);
   new_built_in(bi_module,"is_predicate",(def_type)function_it,c_is_predicate);
   new_built_in(bi_module,"is_sort",(def_type)function_it,c_is_sort);
   
   new_built_in(bi_module,
            disjunction->keyword->symbol,
            (def_type)function_it,
            c_eval_disjunction);
   
   /*  RM: Dec 16 1992  So the symbol can be changed easily */
 
   
   /* Arithmetic */
   insert_math_builtins();
 
   /* Comparison */
   new_built_in(syntax_module,"<",(def_type)function_it,c_lt);  
   new_built_in(syntax_module,"=<",(def_type)function_it,c_ltoe);  
   new_built_in(syntax_module,">",(def_type)function_it,c_gt);  
   new_built_in(syntax_module,">=",(def_type)function_it,c_gtoe);  
   new_built_in(syntax_module,"=\\=",(def_type)function_it,c_diff);
   new_built_in(syntax_module,"=:=",(def_type)function_it,c_equal);
   new_built_in(syntax_module,"and",(def_type)function_it,c_and);
   new_built_in(syntax_module,"or",(def_type)function_it,c_or);
   new_built_in(syntax_module,"not",(def_type)function_it,c_not);
   new_built_in(syntax_module,"xor",(def_type)function_it,c_xor);
   new_built_in(syntax_module,"===",(def_type)function_it,c_same_address);
   
   /* RM: Nov 22 1993  */
   new_built_in(syntax_module,"\\===",(def_type)function_it,c_diff_address); 
 
   /* Psi-term navigation */
   new_built_in(bi_module,"features",(def_type)function_it,c_features);
   new_built_in(bi_module,"feature_values",(def_type)function_it,c_feature_values); /* RM: Mar  3 1994  */
 
   /*  RM: Jul 20 1993  */
   
   new_built_in(syntax_module,".",(def_type)function_it,c_project);/*  RM: Jul  7 1993  */
   new_built_in(bi_module,"root_sort",(def_type)function_it,c_rootsort);
   new_built_in(bi_module,"strip",(def_type)function_it,c_strip);
   new_built_in(bi_module,"copy_pointer",(def_type)function_it,c_copy_pointer); /* PVR: Dec 17 1992 */
   new_built_in(bi_module,"has_feature",(def_type)function_it,c_exist_feature); /* PVR: Dec 17 1992 */
 
   /* Unification and assignment */
   new_built_in(syntax_module,"<-",(def_type)predicate_it,c_bk_assign);
   /* new_built_in(syntax_module,"<<-",(def_type)predicate_it,c_assign);  RM: Feb 24 1993  */
   
   /*  RM: Feb 24 1993  */
   new_built_in(syntax_module,"<<-",(def_type)predicate_it,c_global_assign);
   /* new_built_in(syntax_module,"<<<-",(def_type)predicate_it,c_global_assign); */
   
   /*  RM: Feb  8 1993  */
   new_built_in(syntax_module,"{}",(def_type)function_it,c_fail); /*  RM: Feb 16 1993  */
   new_built_in(syntax_module,"=",(def_type)predicate_it,c_unify_pred);
   new_built_in(syntax_module,"&",(def_type)function_it,c_unify_func);
   new_built_in(bi_module,"copy_term",(def_type)function_it,c_copy_term);
   /* UNI new_built_in(syntax_module,":",(def_type)function_it,c_unify_func); */
 
   /* Type hierarchy navigation */
   insert_type_builtins();
 
   /* String and character utilities */
   new_built_in(bi_module,"str2psi",(def_type)function_it,c_string2psi);
   new_built_in(bi_module,"psi2str",(def_type)function_it,c_psi2string);
   new_built_in(bi_module,"int2str",(def_type)function_it,c_int2string);
   new_built_in(bi_module,"asc",(def_type)function_it,c_ascii);
   new_built_in(bi_module,"chr",(def_type)function_it,c_char);
 
   /* Control */
   new_built_in(syntax_module,"|",(def_type)function_it,c_such_that);
   new_built_in(bi_module,"cond",(def_type)function_it,c_cond);
   new_built_in(bi_module,"if",(def_type)function_it,c_cond);
   new_built_in(bi_module,"eval",(def_type)function_it,c_eval);
   new_built_in(bi_module,"evalin",(def_type)function_it,c_eval_inplace);
   /* new_built_in(bi_module,"quote",(def_type)function_it,c_quote); */
   /*new_built_in(bi_module,"call_once",(def_type)function_it,c_call_once);*/ /* DENYS: Jan 25 1995 */
   /* new_built_in(bi_module,"call",(def_type)function_it,c_call); */
   /* new_built_in(bi_module,"undefined",(def_type)function_it,c_fail); */ /* RM: Jan 13 1993 */
   new_built_in(bi_module,"print_variables",(def_type)predicate_it,c_print_variables);
   new_built_in(bi_module,"get_choice",(def_type)function_it,c_get_choice);
   new_built_in(bi_module,"set_choice",(def_type)predicate_it,c_set_choice);
   new_built_in(bi_module,"exists_choice",(def_type)function_it,c_exists_choice);
   new_built_in(bi_module,"apply",(def_type)function_it,c_apply);
   new_built_in(bi_module,"bool_pred",(def_type)predicate_it,c_boolpred);
 
   new_built_in(syntax_module,":-",(def_type)predicate_it,c_declaration);
   new_built_in(syntax_module,"->",(def_type)predicate_it,c_declaration);
   /* new_built_in(syntax_module,"::",(def_type)predicate_it,c_declaration); */
   new_built_in(syntax_module,"<|",(def_type)predicate_it,c_declaration);
   new_built_in(syntax_module,":=",(def_type)predicate_it,c_declaration);
   new_built_in(syntax_module,";",(def_type)predicate_it,c_disj);
   new_built_in(syntax_module,"!",(def_type)predicate_it,c_not_implemented);
   new_built_in(syntax_module,",",(def_type)predicate_it,c_succeed);
   new_built_in(bi_module,"abort",(def_type)predicate_it,c_abort);
   new_built_in(bi_module,"halt",(def_type)predicate_it,c_halt);
   new_built_in(bi_module,"succeed",(def_type)predicate_it,c_succeed);
   new_built_in(bi_module,"repeat",(def_type)predicate_it,c_repeat);
   new_built_in(bi_module,"fail",(def_type)predicate_it,c_fail);
   /* new_built_in(bi_module,"freeze",(def_type)predicate_it,c_freeze); PVR 16.9.93 */
   new_built_in(bi_module,"implies",(def_type)predicate_it,c_implies);
   new_built_in(bi_module,"undo",(def_type)predicate_it,c_undo);
   new_built_in(bi_module,"delay_check",(def_type)predicate_it,c_delay_check);
   new_built_in(bi_module,"non_strict",(def_type)predicate_it,c_non_strict);
   
   /* System */
   insert_system_builtins();
 
   new_built_in(bi_module,"strcon",(def_type)function_it,c_concatenate);
   new_built_in(bi_module,"strlen",(def_type)function_it,c_string_length);
   new_built_in(bi_module,"substr",(def_type)function_it,c_sub_string);
   new_built_in(bi_module,"append_file",(def_type)predicate_it,c_append_file);
   new_built_in(bi_module,"random",(def_type)function_it,c_random);
   new_built_in(bi_module,"initrandom",(def_type)predicate_it,c_initrandom);
 
   /*  RM: Jan  8 1993  */
   new_built_in(bi_module,"set_module",(def_type)predicate_it,c_set_module);
   new_built_in(bi_module,"open_module",(def_type)predicate_it,c_open_module);
   new_built_in(bi_module,"public",(def_type)predicate_it,c_public);
   new_built_in(bi_module,"private",(def_type)predicate_it,c_private);
   new_built_in(bi_module,"display_modules",(def_type)predicate_it,c_display_modules);
   new_built_in(bi_module,"trace_input",(def_type)predicate_it,c_trace_input);
   new_built_in(bi_module,"substitute",(def_type)predicate_it,c_replace);
   new_built_in(bi_module,"current_module",(def_type)function_it,c_current_module);
   new_built_in(bi_module,"module_name",(def_type)function_it,c_module_name);
   new_built_in(bi_module,"combined_name",(def_type)function_it,c_combined_name);
   /* new_built_in(bi_module,"#",(def_type)function_it,c_module_access); */
   
   /* Hack so '.set_up' doesn't issue a Warning message */
   /*  RM: Feb  3 1993  */
   hash_lookup(bi_module->symbol_table,"set_module")->public=TRUE;
   hash_lookup(bi_module->symbol_table,"built_in")->public=TRUE;
 
   /*  RM: Jan 29 1993  */
   abortsym=update_symbol(bi_module,"abort"); /* 26.1 */
   aborthooksym=update_symbol(bi_module,"aborthook"); /* 26.1 */
   tracesym=update_symbol(bi_module,"trace"); /* 26.1 */
 
   
   /*  RM: Feb  9 1993  */
   new_built_in(bi_module,"global",(def_type)predicate_it,c_global);
   new_built_in(bi_module,"persistent",(def_type)predicate_it,c_persistent);
   new_built_in(bi_module,"display_persistent",(def_type)predicate_it,c_display_persistent);
   new_built_in(bi_module,"alias",(def_type)predicate_it,c_alias);
 
   /*  RM: Mar 11 1993  */
   new_built_in(bi_module,"private_feature",(def_type)predicate_it,c_private_feature);
   add_module1=update_symbol(bi_module,"features");
   add_module2=update_symbol(bi_module,"str2psi");
   add_module3=update_symbol(bi_module,"feature_values"); /* RM: Mar  3 1994  */
 
   /*  RM: Jun 29 1993  */
   new_built_in(bi_module,"split_double",(def_type)function_it,c_split_double);
   new_built_in(bi_module,"string_address",(def_type)function_it,c_string_address);
 
   /*  RM: Jul 15 1993  */
   new_built_in(bi_module,"deref_length",(def_type)function_it,c_deref_length);
 
 
   /*  RM: Sep 20 1993  */
   new_built_in(bi_module,"argv",(def_type)function_it,c_args);
 
   /* RM: Jan 28 1994  */
   new_built_in(bi_module,"public_symbols",(def_type)function_it,all_public_symbols);
            
 #ifdef CLIFE
   life_reals();
 #endif /* CLIFE */
 
   insert_sys_builtins();
   //  fclose(bi_list);
 }

void init_copy ( )

init_copy

INIT_COPY() Execute once upon startup of Wild_Life.

Definition at line 32 of file copy.c.

References HASHSIZE, hashtable, hashtime, numbuckets, and NUMBUCKETS.

 {
   long i;
 
   /* for(i=0; i<HASHSTATS; i++) hashstats[i]=0; 20.8 */
 
   for(i=0; i<HASHSIZE; i++) hashtable[i].timestamp = 0;
   hashtime = 0;
   numbuckets = NUMBUCKETS;
   hashbuckets = (struct hashbucket *)
     malloc(NUMBUCKETS * sizeof(struct hashbucket));
 }

void init_global_vars ( )

init_global_vars

INIT_GLOBAL_VARS() Initialize all non-persistent global variables.

Definition at line 1484 of file lefun.c.

References first_definition, wl_definition::global_value, heap_pointer, wl_definition::next, and NULL.

 {
   ptr_definition def;
 
   /* printf("initializing global vars...\n"); */
   
   /*
     for(def=first_definition;def;def=def->next) {
     if(def->type==global_it && ((GENERIC)def->global_value<heap_pointer)) {
     clear_copy();
     def->global_value=eval_copy(def->init_value,STACK); 
     }
     }
     */
 
   for(def=first_definition;def;def=def->next)
     if((GENERIC)(def->global_value)<(GENERIC)heap_pointer)
       def->global_value=NULL;
 }

void init_interrupt ( )

INIT_INTERRUPT.

This initialises interrupts by trapping the interrupt signal and sending it to INTERRUPT.

Definition at line 36 of file interrupt.c.

References interrupt().

 {
   void (*f)(); /*  RM: Apr  7 1993   Weird problem in GCC and C89 */
   f=interrupt;
   if (signal(SIGINT,SIG_IGN)!=SIG_IGN)
     (void)signal(SIGINT,f);
 }

void init_io ( )

void init_io

I/O initialization

Definition at line 69 of file lib.c.

References input_state, NULL, output_stream, stdin_state, stdin_terminal, and TRUE.

 {
   stdin_terminal=TRUE ;
   input_state=NULL;
   stdin_state=NULL;
   output_stream=stdout;
 }

void init_memory ( )

init_memory ()

INIT_MEMORY() Get two big blocks of memory to work in. The second is only used for the half-space garbage collector. The start and end addresses of the blocks are re-aligned correctly. to allocate.

Definition at line 1671 of file memory.c.

References ALIGNUP, ALLOC_WORDS, alloc_words, buffer, delta, Errorline(), GetIntOption(), heap_pointer, mem_base, mem_limit, mem_size, other_base, other_limit, other_pointer, PRINT_BUFFER, stack_pointer, and WORD.

 {
   alloc_words=GetIntOption("memory",ALLOC_WORDS);
   mem_size=alloc_words * WORD;
   
   mem_base   = (GENERIC) malloc(mem_size);
   other_base = (GENERIC) malloc(mem_size);
 
   if (mem_base && other_base) {
     /* Rewrote some rather poor code... RM: Mar  1 1994  */
     ALIGNUP(mem_base);
     stack_pointer = mem_base;
     
     mem_limit=mem_base+alloc_words-2;
     ALIGNUP(mem_limit);
     heap_pointer = mem_limit;
 
     ALIGNUP(other_base);
     other_pointer = other_base;
 
     other_limit=other_base+alloc_words-2;
     ALIGNUP(other_limit);
     
     delta = other_base - mem_base;
     buffer = (char *) malloc (PRINT_BUFFER); /* The printing buffer */
 
     /*  RM: Oct 22 1993  */
     /* Fill the memory with rubbish data */
     /*
     {
       int i;
       
       for(i=0;i<alloc_words;i++) {
     mem_base[i]= -1234;
     other_base[i]= -1234;
       }
     }
     */
   }
   else
     Errorline("Wild_life could not allocate sufficient memory to run.\n\n");
 }

void init_modules ( )

init_modules

INIT_MODULES() Initialize the module system.

Definition at line 34 of file modules.c.

References create_module(), and set_current_module().

 {
   bi_module=create_module("built_ins");
   no_module=create_module("no_module");
   x_module=create_module("x");
   syntax_module=create_module("syntax");
   user_module=create_module("user"); /*  RM: Jan 27 1993  */
   sys_module=create_module("sys");
   
   (void)set_current_module(syntax_module);
 }

void init_parse_state ( )

init_parse_state

Initialize the parser/tokenizer state variables.

Definition at line 464 of file token.c.

References eof_flag, FALSE, line_count, NULL, old_saved_char, old_saved_psi_term, saved_char, saved_psi_term, start_of_line, stringparse, and TRUE.

 {
   line_count=0;
   start_of_line=TRUE;
   saved_char=0;
   old_saved_char=0;
   saved_psi_term=NULL;
   old_saved_psi_term=NULL;
   eof_flag=FALSE;
   stringparse=FALSE;
 }

void init_print ( )

init_print

Initialize size of single segment of split printing. Wild_Life integers are represented as REALS, and therefore can have higher precision than the machine integers. They will be printed in segments.

Definition at line 52 of file print.c.

References PRINT_POWER, and seg_format.

 {
   (void)snprintf(seg_format,PRINT_POWER+4,"%%0%ldd",PRINT_POWER);
 }

void init_system ( )

init_system

Initial state of system to begin a query

Definition at line 83 of file lib.c.

References choice_stack, current_module, exit_if_true(), FALSE, goal_stack, init_global_vars(), mem_base, memory_check(), wl_module::module_name, NULL, PROMPT, prompt, PROMPT_BUFFER, prompt_buffer, resid_aim, stack_nil(), stack_pointer, undo_stack, user_module, var_tree, x_window_creation, and xevent_list.

 {
 #ifdef X11
   x_window_creation=FALSE;
 #endif
   stack_pointer=mem_base;
   goal_stack=NULL;
   choice_stack=NULL;
   undo_stack=NULL; /* 7.8 */
   var_tree=NULL;
 
   /*  RM: Oct 13 1993  */
   if(current_module==user_module)
     prompt=PROMPT;
   else {
     prompt=prompt_buffer;
     (void)snprintf(prompt_buffer,PROMPT_BUFFER,"%s%s",current_module->module_name,PROMPT);
   }
     
   resid_aim=NULL;
   exit_if_true(!memory_check());
   
 #ifdef X11
   /*  RM: Dec 15 1992  */
   xevent_list=stack_nil();
 #endif
   
   init_global_vars(); /*  RM: Feb 15 1993  */
 }

void init_trace ( )

init_trace

Initialize all tracing variables

Definition at line 651 of file error.c.

References FALSE, stepcount, stepflag, and trace.

 {
   trace=FALSE;
   stepflag=FALSE;
   stepcount=0;
 }

void insert_dbm_builtins ( )

void insert_math_builtins ( )

insert math builtins into table

insert functions into table

Definition at line 1346 of file bi_math.c.

References bi_module, c_add(), c_bit_and(), c_bit_not(), c_bit_or(), c_ceiling(), c_cos(), c_div(), c_exp(), c_floor(), c_intdiv(), c_log(), c_mod(), c_mult(), c_shift_left(), c_shift_right(), c_sin(), c_sqrt(), c_sub(), c_tan(), function_it, new_built_in(), and syntax_module.

 {
   new_built_in(syntax_module,"*",(def_type)function_it,c_mult);
   new_built_in(syntax_module,"+",(def_type)function_it,c_add);
   new_built_in(syntax_module,"-",(def_type)function_it,c_sub);
   new_built_in(syntax_module,"/",(def_type)function_it,c_div);  
   new_built_in(syntax_module,"//",(def_type)function_it,c_intdiv);  
   new_built_in(syntax_module,"mod",(def_type)function_it,c_mod); /* PVR 24.2.94 */
   new_built_in(syntax_module,"/\\",(def_type)function_it,c_bit_and);
   new_built_in(syntax_module,"\\/",(def_type)function_it,c_bit_or);
   new_built_in(syntax_module,"\\",(def_type)function_it,c_bit_not);
   new_built_in(syntax_module,">>",(def_type)function_it,c_shift_right);
   new_built_in(syntax_module,"<<",(def_type)function_it,c_shift_left);
   new_built_in(bi_module,"floor",(def_type)function_it,c_floor);
   new_built_in(bi_module,"ceiling",(def_type)function_it,c_ceiling);
   new_built_in(bi_module,"exp",(def_type)function_it,c_exp);
   new_built_in(bi_module,"log",(def_type)function_it,c_log);
   new_built_in(bi_module,"cos",(def_type)function_it,c_cos);
   new_built_in(bi_module,"sin",(def_type)function_it,c_sin);
   new_built_in(bi_module,"tan",(def_type)function_it,c_tan);
   new_built_in(bi_module,"sqrt",(def_type)function_it,c_sqrt);
 }

void insert_own_prop ( ptr_definition d )

insert_own_prop

Parameters

d	- ptr_definition d

INSERT_OWN_PROP(definition) Append a type's "rules" (i.e. its own attr. & constr.) to its property list. The property list also contains the type's code. A type's attributes and constraints are stored in the 'rule' field of the definition.

Definition at line 575 of file types.c.

References wl_pair_list::aaaa_2, wl_pair_list::bbbb_2, children, FALSE, HEAP_ALLOC, wl_int_list::next, wl_definition::next, wl_pair_list::next, NULL, wl_definition::properties, wl_definition::rule, TRUE, and wl_int_list::value_1.

 {
   ptr_int_list l;
   ptr_pair_list rule;
   ptr_triple_list *t;
   long flag;
 
   l=HEAP_ALLOC(int_list);
   l->value_1=(GENERIC)d;
   l->next=children;
   children=l;
 
   rule = d->rule;
   while (rule) {
     t= &(d->properties);
     flag=TRUE;
     
     while (flag) {
       if (*t)
         if ((*t)->aaaa_4==rule->aaaa_2 && (*t)->bbbb_4==rule->bbbb_2 && (*t)->cccc_4==d)
           flag=FALSE;
         else
           t= &((*t)->next);
       else {
         *t = HEAP_ALLOC(triple_list);
         (*t)->aaaa_4=rule->aaaa_2;
         (*t)->bbbb_4=rule->bbbb_2;
         (*t)->cccc_4=d;
         (*t)->next=NULL;
         flag=FALSE;
       }
     } 
     rule=rule->next;
   }
 }

void insert_prop	(	ptr_definition	d,
		ptr_triple_list	prop
	)

insert_prop

Parameters

d	- ptr_definition d
prop	- ptr_triple_list prop

INSERT_PROP(definition,prop) Append the properties to the definition if they aren't already present.

Definition at line 620 of file types.c.

References wl_triple_list::aaaa_4, wl_triple_list::bbbb_4, wl_triple_list::cccc_4, children, FALSE, HEAP_ALLOC, wl_int_list::next, wl_definition::next, wl_triple_list::next, NULL, wl_definition::properties, TRUE, and wl_int_list::value_1.

 {
   ptr_int_list l;
   ptr_triple_list *t;
   long flag;
 
   l=HEAP_ALLOC(int_list);
   l->value_1=(GENERIC)d;
   l->next=children;
   children=l;
 
   while (prop) {
     t= &(d->properties);
     flag=TRUE;
     
     while (flag) {
       if (*t)
         if ((*t)->aaaa_4==prop->aaaa_4 && (*t)->bbbb_4==prop->bbbb_4 && (*t)->cccc_4==prop->cccc_4)
           flag=FALSE;
         else
           t= &((*t)->next);
       else {
         *t = HEAP_ALLOC(triple_list);
         (*t)->aaaa_4=prop->aaaa_4;
         (*t)->bbbb_4=prop->bbbb_4;
         (*t)->cccc_4=prop->cccc_4;
         (*t)->next=NULL;
         flag=FALSE;
       }
     } 
     prop=prop->next;
   }
 }

void insert_sys_builtins ( )

insert_sys_builtins

Definition at line 2209 of file sys.c.

References bi_module, c_accept(), c_apply1(), c_bind(), c_bitvector_and(), c_bitvector_clear(), c_bitvector_count(), c_bitvector_get(), c_bitvector_not(), c_bitvector_or(), c_bitvector_set(), c_bitvector_xor(), c_call_once(), c_connect(), c_cuserid(), c_errmsg(), c_errno(), c_fclose(), c_fflush(), c_fopen(), c_fork(), c_fseek(), c_ftell(), c_fwrite(), c_get_buffer(), c_get_code(), c_get_record(), c_gethostname(), c_getpid(), c_import_symbol(), c_int2stream(), c_kill(), c_lazy_project(), c_listen(), c_make_bitvector(), c_my_wait_on_feature(), c_regexp_compile(), c_regexp_execute(), c_socket(), c_stream2sys_stream(), c_sys_stream2stream(), c_wait(), c_wait_on_feature(), c_waitpid(), current_module, function_it, insert_dbm_builtins(), new_built_in(), predicate_it, set_current_module(), sys_bitvector, sys_bytedata, sys_file_stream, sys_module, sys_process_continued, sys_process_exited, sys_process_no_children, sys_process_signaled, sys_process_stopped, sys_regexp, sys_socket_stream, sys_stream, and update_symbol().

 {
   ptr_module curmod = current_module;
   (void)set_current_module(sys_module);
 
   sys_bytedata      =update_symbol(sys_module,"bytedata"); /* DENYS: BYTEDATA */
   sys_bitvector     =update_symbol(sys_module,"bitvector");
   sys_regexp        =update_symbol(sys_module,"regexp");
   sys_stream        =update_symbol(sys_module,"stream");
   sys_file_stream   =update_symbol(sys_module,"file_stream");
   sys_socket_stream =update_symbol(sys_module,"socket_stream");
   sys_process_no_children=update_symbol(sys_module,"process_no_children");
   sys_process_exited    =update_symbol(sys_module,"process_exited");
   sys_process_signaled  =update_symbol(sys_module,"process_signaled");
   sys_process_stopped   =update_symbol(sys_module,"process_stopped");
   sys_process_continued =update_symbol(sys_module,"process_continued");
 
   /* DENYS: BYTEDATA */
   /* purely for illustration
      new_built_in(sys_module,"string_to_bytedata",(def_type)function_it,c_string_to_bytedata);
      new_built_in(sys_module,"bytedata_to_string",(def_type)function_it,c_bytedata_to_string);
   */
   new_built_in(sys_module,"make_bitvector"  ,(def_type)function_it ,c_make_bitvector);
   new_built_in(sys_module,"bitvector_and"   ,(def_type)function_it ,c_bitvector_and);
   new_built_in(sys_module,"bitvector_or"    ,(def_type)function_it ,c_bitvector_or);
   new_built_in(sys_module,"bitvector_xor"   ,(def_type)function_it ,c_bitvector_xor);
   new_built_in(sys_module,"bitvector_not"   ,(def_type)function_it ,c_bitvector_not);
   new_built_in(sys_module,"bitvector_count" ,(def_type)function_it ,c_bitvector_count);
   new_built_in(sys_module,"bitvector_get"   ,(def_type)function_it ,c_bitvector_get);
   new_built_in(sys_module,"bitvector_set"   ,(def_type)function_it ,c_bitvector_set);
   new_built_in(sys_module,"bitvector_clear" ,(def_type)function_it ,c_bitvector_clear);
   new_built_in(sys_module,"regexp_compile"  ,(def_type)function_it ,c_regexp_compile);
   new_built_in(sys_module,"regexp_execute"  ,(def_type)function_it ,c_regexp_execute);
   new_built_in(sys_module,"int2stream"      ,(def_type)function_it ,c_int2stream);
   new_built_in(sys_module,"fopen"       ,(def_type)function_it ,c_fopen);
   new_built_in(sys_module,"fclose"      ,(def_type)function_it ,c_fclose);
   new_built_in(sys_module,"get_buffer"      ,(def_type)function_it ,c_get_buffer);
   new_built_in(sys_module,"get_record"      ,(def_type)function_it ,c_get_record);
   new_built_in(sys_module,"get_code"        ,(def_type)function_it ,c_get_code);
   new_built_in(sys_module,"ftell"       ,(def_type)function_it ,c_ftell);
   new_built_in(sys_module,"fseek"       ,(def_type)predicate_it,c_fseek);
   new_built_in(sys_module,"socket"      ,(def_type)function_it ,c_socket);
   new_built_in(sys_module,"bind"        ,(def_type)predicate_it,c_bind);
   new_built_in(sys_module,"connect"     ,(def_type)predicate_it,c_connect);
   new_built_in(sys_module,"fwrite"      ,(def_type)predicate_it,c_fwrite);
   new_built_in(sys_module,"fflush"      ,(def_type)predicate_it,c_fflush);
   new_built_in(sys_module,"listen"      ,(def_type)predicate_it,c_listen);
   new_built_in(sys_module,"accept"      ,(def_type)function_it ,c_accept);
   new_built_in(sys_module,"errno"       ,(def_type)function_it ,c_errno);
   new_built_in(sys_module,"errmsg"      ,(def_type)function_it ,c_errmsg);
   new_built_in(sys_module,"import_symbol"   ,(def_type)predicate_it,c_import_symbol);
   new_built_in(sys_module,"fork"        ,(def_type)function_it ,c_fork);
   new_built_in(sys_module,"wait"        ,(def_type)function_it ,c_wait);
   new_built_in(sys_module,"waitpid"     ,(def_type)function_it ,c_waitpid);
   new_built_in(sys_module,"kill"        ,(def_type)predicate_it,c_kill);
   new_built_in(sys_module,"cuserid"     ,(def_type)function_it ,c_cuserid);
   new_built_in(sys_module,"gethostname"     ,(def_type)function_it ,c_gethostname);
   new_built_in(sys_module,"lazy_project"    ,(def_type)function_it ,c_lazy_project);
   new_built_in(sys_module,"wait_on_feature" ,(def_type)predicate_it,c_wait_on_feature);
   new_built_in(sys_module,"my_wait_on_feature"  ,(def_type)function_it ,c_my_wait_on_feature);
   new_built_in(sys_module,"apply1"      ,(def_type)function_it ,c_apply1);
   new_built_in(sys_module,"getpid"      ,(def_type)function_it ,c_getpid);
   new_built_in(sys_module,"stream2sys_stream"   ,(def_type)function_it ,c_stream2sys_stream);
   new_built_in(sys_module,"sys_stream2stream"   ,(def_type)function_it ,c_sys_stream2stream);
 #ifdef LIFE_DBM
   insert_dbm_builtins();
 #endif
 #ifdef LIFE_NDBM
   insert_ndbm_builtins();
 #endif
   (void)set_current_module(bi_module);
   new_built_in(bi_module ,"call_once"       ,(def_type)function_it ,c_call_once);
   (void)set_current_module(curmod);
 }

void insert_system_builtins ( )

insert_system_builtins

Definition at line 746 of file bi_sys.c.

References bi_module, c_cputime(), c_encode(), c_garbage(), c_getenv(), c_localtime(), c_maxint(), c_mresiduate(), c_quiet(), c_realtime(), c_residList(), c_residuate(), c_statistics(), c_step(), c_system(), c_tprove(), c_trace(), c_verbose(), c_warning(), function_it, new_built_in(), and predicate_it.

 {
   new_built_in(bi_module,"trace",(def_type)predicate_it,c_trace);
   new_built_in(bi_module,"step",(def_type)predicate_it,c_step);
   new_built_in(bi_module,"verbose",(def_type)predicate_it,c_verbose);
   new_built_in(bi_module,"warning",(def_type)predicate_it,c_warning);
   new_built_in(bi_module,"maxint",(def_type)function_it,c_maxint);
   new_built_in(bi_module,"cpu_time",(def_type)function_it,c_cputime);
   new_built_in(bi_module,"quiet",(def_type)function_it,c_quiet); /* 21.1 */
   new_built_in(bi_module,"real_time",(def_type)function_it,c_realtime);
   new_built_in(bi_module,"local_time",(def_type)function_it,c_localtime);
   new_built_in(bi_module,"statistics",(def_type)predicate_it,c_statistics);
   new_built_in(bi_module,"gc",(def_type)predicate_it,c_garbage);
   new_built_in(bi_module,"system",(def_type)function_it,c_system);
   new_built_in(bi_module,"getenv",(def_type)function_it,c_getenv);
   new_built_in(bi_module,"encode",(def_type)predicate_it,c_encode);
   new_built_in(bi_module,"rlist",(def_type)function_it,c_residList);
   new_built_in(bi_module,"residuate",(def_type)predicate_it,c_residuate);
   new_built_in(bi_module,"mresiduate",(def_type)predicate_it,c_mresiduate);
   new_built_in(bi_module,"tprove",(def_type)predicate_it,c_tprove);
 }

void insert_translation	(	ptr_psi_term	a,
		ptr_psi_term	b,
		long	info
	)

insert_translation

void insert_translation(ptr_psi_term a,ptr_psi_term b,long info) INSERT_TRANSLATION(a,b,info) Add the translation of address A to address B in the translation table. Also add an info field.

Definition at line 67 of file copy.c.

References hashentry::bucketindex, HASH, hashbuckets, HASHEND, hashfree, hashtable, hashtime, hashbucket::info, hashbucket::new_value, hashbucket::next, numbuckets, hashbucket::old_value, hashentry::timestamp, and traceline().

 {
   long index;
   long lastbucket;
   
   /* Ensure there are free buckets by doubling their number if necessary */
   if (hashfree >= numbuckets) {
     numbuckets *= 2;
     hashbuckets = (struct hashbucket *) 
       realloc((void *) hashbuckets, numbuckets * sizeof(struct hashbucket));
     /* *** Do error handling here *** */
     traceline("doubled the number of hashbuckets to %d\n", numbuckets);
   }
 
   /* Add a bucket to the beginning of the list */
   index = HASH(a);
   if (hashtable[index].timestamp == hashtime)
     lastbucket = hashtable[index].bucketindex;
   else {
     lastbucket = HASHEND;
     hashtable[index].timestamp = hashtime;
   }
   hashtable[index].bucketindex = hashfree;
   hashbuckets[hashfree].old_value = a;
   hashbuckets[hashfree].new_value = b;
   hashbuckets[hashfree].info = info;
   hashbuckets[hashfree].next = lastbucket;
   hashfree++;
 }

void insert_type_builtins ( )

void insert_type_builtins

Definition at line 817 of file bi_type.c.

References bi_module, c_children(), c_glb(), c_is_function(), c_is_number(), c_is_persistent(), c_is_predicate(), c_is_sort(), c_is_value(), c_isa_cmp(), c_isa_eq(), c_isa_ge(), c_isa_gt(), c_isa_le(), c_isa_lt(), c_isa_ncmp(), c_isa_neq(), c_isa_nge(), c_isa_ngt(), c_isa_nle(), c_isa_nlt(), c_isa_subsort(), c_lub(), c_parents(), c_smallest(), function_it, new_built_in(), predicate_it, and syntax_module.

 {
   /* Sort comparisons */
   new_built_in(syntax_module,":=<",(def_type)function_it,c_isa_le);
   new_built_in(syntax_module,":<",(def_type)function_it,c_isa_lt);
   new_built_in(syntax_module,":>=",(def_type)function_it,c_isa_ge);
   new_built_in(syntax_module,":>",(def_type)function_it,c_isa_gt);
   new_built_in(syntax_module,":==",(def_type)function_it,c_isa_eq);
   new_built_in(syntax_module,":><",(def_type)function_it,c_isa_cmp);
   new_built_in(syntax_module,":\\=<",(def_type)function_it,c_isa_nle);
   new_built_in(syntax_module,":\\<",(def_type)function_it,c_isa_nlt);
   new_built_in(syntax_module,":\\>=",(def_type)function_it,c_isa_nge);
   new_built_in(syntax_module,":\\>",(def_type)function_it,c_isa_ngt);
   new_built_in(syntax_module,":\\==",(def_type)function_it,c_isa_neq);
   new_built_in(syntax_module,":\\><",(def_type)function_it,c_isa_ncmp);
 
   /* Type checks */
   new_built_in(bi_module,"is_value",(def_type)function_it,c_is_value);
   new_built_in(bi_module,"is_number",(def_type)function_it,c_is_number);
   new_built_in(bi_module,"is_function",(def_type)function_it,c_is_function);
   new_built_in(bi_module,"is_predicate",(def_type)function_it,c_is_predicate);
   new_built_in(bi_module,"is_sort",(def_type)function_it,c_is_sort);
   new_built_in(bi_module,"is_persistent",(def_type)function_it,c_is_persistent);
   
   /* Sort hierarchy maneuvering */
   new_built_in(bi_module,"children",(def_type)function_it,c_children);
   new_built_in(bi_module,"parents",(def_type)function_it,c_parents);
   new_built_in(bi_module,"least_sorts",(def_type)function_it,c_smallest);
   new_built_in(bi_module,"subsort",(def_type)predicate_it,c_isa_subsort);
   new_built_in(bi_module,"glb",(def_type)function_it,c_glb);
   new_built_in(bi_module,"lub",(def_type)function_it,c_lub);
 }

void insert_variables	(	ptr_node	vars,
		long	force
	)

insert_variables

Parameters

vars	- ptr_node vars
force	- long force

INSERT_VARIABLES(vars,force) This routine gives the name of the query variable to the corresponding pointer in the POINTER_NAMES. If FORCE is TRUE then variables will be printed as TAGS, even if not referred to elsewhere.

Definition at line 308 of file print.c.

References wl_node::data, deref_ptr, find(), INTCMP, wl_node::key, wl_node::left, pointer_names, and wl_node::right.

 {
   ptr_psi_term p;
   ptr_node n;
   
   if(vars) {
     insert_variables(vars->right,force);
     p=(ptr_psi_term )vars->data;
     deref_ptr(p);
     n=find(INTCMP,(char *)p,pointer_names);
     if (n)
       if (n->data || force)
     n->data=(GENERIC)vars->key;
     insert_variables(vars->left,force);
   }
 }

long int_div_warning	(	ptr_psi_term	arg,
		REAL	val
	)

int_div_warning

Parameters

arg	- ptr_psi_term arg
val	- REAL val

Definition at line 1028 of file error.c.

References nonint_warning().

 {
   return nonint_warning(arg,val,"of integer division is not an integer");
 }

long intcmp	(	long	a,
		long	b
	)

intcmp

Parameters

a	- long a
b	- long b

INTCMP(a,b) Compares two integers, for use in FIND or INSERT.

Definition at line 21 of file trees.c.

 {
 #ifdef CMPDBG
     printf("intcmp a = %ld b = %ld a - b = %ld\n", a ,b  , a - b);
 #endif
        return a - b;
 }

void interrupt ( )

INTERRUPT()

This routine is called whenever the user types CONTROL C which generates an interrupt. The interrupt is dealt with later, when convenient, or ignored.

Definition at line 21 of file interrupt.c.

References interrupted, and TRUE.

 {
   void (*f)(); /*  RM: Apr  7 1993   Weird problem in GCC and C89 */
   
   interrupted=TRUE;
   f=interrupt;
   (void)signal(SIGINT,f);/*  RM: Feb 15 1993  */
 }

GENERIC intListNext ( ptr_int_list p )

intListNext

Parameters

p	- ptr_int_list p

not sure purpose (DJD ???)

Definition at line 515 of file bi_sys.c.

References wl_int_list::next.

 {
   return (GENERIC )(p->next);
 }

ptr_psi_term intListValue ( ptr_int_list p )

ptr_psi_term intListValue

Parameters

p	- ptr_int_list p

not sure purpose (DJD ???)

Definition at line 503 of file bi_sys.c.

References makePsiTerm(), and wl_int_list::value_1.

 {
   return makePsiTerm((void *)p->value_1);
 }

long is_built_in ( ptr_pair_list r )

is_built_in

Parameters

r	- ptr_pair_list r

Return TRUE if rules r are for a built-in

Definition at line 5118 of file built_ins.c.

References MAX_BUILT_INS.

 {
   return ((unsigned long)r>0 && (unsigned long)r<MAX_BUILT_INS);
 }

long is_int	(	char **	s,
		long *	len,
		long *	sgn
	)

is_int

Parameters

s	= char **s
len	- long *len
sgn	- long *sgn

Return TRUE iff the string s represents an integer. Modify s to point to first non-zero digit. Return number of significant digits in the integer and its sign.

Definition at line 41 of file trees.c.

References FALSE, and TRUE.

 {
   char *sint; /* Ptr to first non-zero digit */
   char *stmp; /* Scratchpad for string ptr */
 #ifdef CMPDBG
   printf("is_int *s = %s\n",*s);
 #endif
   /*
     { register char *p= *s;
     register char c= *p;
     if(c>'0' && c<='9' && *(p+1)==0) return TRUE;
     }
   */
   
   stmp=(*s);
   if ((*sgn=(*stmp=='-'))) { 
     stmp++;
     if (!*stmp)
       {
 #ifdef CMPDBG
     printf("is_int = FALSE\n");
 #endif
     return   FALSE;
       }
   }
   if (!*stmp)
     { 
 #ifdef CMPDBG
       printf("is_int = FALSE\n");
 #endif
       return FALSE; /* 6.10 */
     }
   while (*stmp=='0') stmp++;
   sint=stmp;
   while (*stmp) {
     if (*stmp<'0' || *stmp>'9') 
       {
 #ifdef CMPDBG
     printf("is_int = FALSE\n"); 
 #endif
     return FALSE;
       }
     stmp++;
   }
   *len=stmp-sint;
   *s=sint;
 #ifdef CMPDBG
   printf("is_int = TRUE *len = %ld *sgn = %ld *s = %s\n",*len,*sgn,*s);
 #endif
   return TRUE;
 }

long is_integer ( char * s )

is_integer

Parameters

s - char *s

Return TRUE if s represents an integer.

Definition at line 450 of file print.c.

References DIGIT, FALSE, and TRUE.

 {
   if (!*s) return FALSE;
   if (*s=='-') s++;
   while (*s) {
     if (!DIGIT(*s)) return FALSE;
     s++;
   }
   return TRUE;
 }

int is_ipaddr ( char * s )

is_ipaddr

Parameters

s - char *s

Definition at line 1333 of file sys.c.

References NULL.

 {
   if (s==NULL) return 0;
   while (*s)
     if (!isdigit(*s) && *s!='.') return 0;
     else s++;
   return 1;
 }

int isSubTypeValue	(	ptr_psi_term	arg1,
		ptr_psi_term	arg2
	)

isSubTypeValue

Parameters

arg1	- ptr_psi_term arg1
arg2	- ptr_psi_term arg2

Definition at line 180 of file bi_type.c.

References FALSE, integer, quoted_string, REAL, real, TRUE, wl_psi_term::type, and wl_psi_term::value_3.

 {
   long ans=TRUE;
   
   /* we already know that either arg1->type == arg2->type or that at both
    * of the two are either long or real
    */
   
   if (arg2->value_3) {
     if (arg1->value_3) {
       if (arg1->type==real || arg1->type==integer) {
         ans=( *(REAL *)arg1->value_3 == *(REAL *)arg2->value_3);
       }
       else if (arg1->type==quoted_string) {
         ans=(strcmp((char *)arg1->value_3,(char *)arg2->value_3)==0);
       }
     }
     else
       ans=FALSE;
   }
   else {
     if (arg1->value_3 && (arg1->type==real || arg1->type==integer)) {
       if (arg2->type==integer)
         ans=(*(REAL *)arg1->value_3 == floor(*(REAL *)arg1->value_3));
       else
         ans=TRUE;
     }
   }
   return ans;
 }

long isValue ( ptr_psi_term p )

isValue(p)

Parameters

p	- ptr_psi_term p

Definition at line 694 of file bi_type.c.

References NULL, and wl_psi_term::value_3.

 {
   return (p->value_3 != NULL);
 }

void least_sorts ( )

void least_sorts()

LEAST_SORTS() Build the list of terminals (i.e. sorts with no children) in nothing->parents.

Definition at line 743 of file types.c.

References wl_definition::children, cons(), first_definition, wl_definition::next, nothing, NULL, wl_definition::parents, wl_definition::type_def, and type_it.

 {
   ptr_definition d;
 
   for(d=first_definition;d;d=d->next)
     if (d->type_def==(def_type)type_it && d->children==NULL && d!=nothing)
       nothing->parents=cons((GENERIC)d,nothing->parents);
 }

long legal_in_name ( long c )

legal_in_name

Parameters

c - long c

LEGAL_IN_NAME(character) Tests if character is legal in a name or a variable (see macros).

Definition at line 980 of file token.c.

References DIGIT, LOWER, and UPPER.

 {
   return
     UPPER(c) ||
       LOWER(c) ||
     DIGIT(c);
 
   /* || c=='\'' RM: Dec 16 1992  */ ;
 }

void List_Append	(	RefListHeader	header,
		Ref	atom
	)

void List_Append

Parameters

header	- RefListHeader header
atom	- Ref atom

Definition at line 71 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, wl_ListHeader::Last, and NULL.

 {
     RefListGetLinksProc  getLinks = header->GetLinks;
 
             /* Link to the end of list */
 
     if (header->Last != NULL)
       (*getLinks)(header->Last)->Next = atom;
 
     else    /* The list is empty */
       header->First = atom;
 
             /* Update links of atom to insert */
 
     (*getLinks)(atom)->Prev = header->Last;
     (*getLinks)(atom)->Next = NULL;
 
         /* Update last element of header */
 
     header->Last  = atom;
 }

long List_Card ( RefListHeader header )

List_Card.

Parameters

header - RefListHeader header

Definition at line 461 of file list.c.

References List_CountAtom(), and List_Enum().

 {
     long n = 0;
     
     (void)List_Enum (header,(RefListEnumProc) List_CountAtom, &n);
     return n;
 }

void List_Concat	(	RefListHeader	header1,
		RefListHeader	header2
	)

List_Concat.

Parameters

header1	- RefListHeader header1
header2	- RefListHeader header2

Definition at line 308 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, wl_ListHeader::Last, and NULL.

 {
     RefListGetLinksProc  getLinks = header1->GetLinks;
 
     if (header1->GetLinks == header2->GetLinks)
     {
 #ifdef prlDEBUG
     OS_PrintMessage ("List_Concat: ERROR concat different lists\n");
 #endif
     return;
     }
 
     /* Concatenate only if the second list is not empty */
 
     if (header2->First != NULL)
     {
     /* Obvious concatenate when the first list is empty */
 
         if (header1->First == NULL)
             header1->First = header2->First;
 
         else    /* Concatenate the two non empty lists */
         {
             (*getLinks)(header1->Last)->Next  = header2->First;
             (*getLinks)(header2->First)->Prev = header1->Last;
         }
         header1->Last = header2->Last;
     }
 } 

void List_Cut	(	RefListHeader	header,
		Ref	atom,
		RefListHeader	newHeader
	)

List_Cut.

Parameters

header	- RefListHeader header
atom	- Ref atom
newHeader	- RefListHeader newHeader

Definition at line 488 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, wl_ListHeader::Last, List_Last, List_Next, and NULL.

 {
     RefListGetLinksProc  getLinks = header->GetLinks;
 
     if (atom != List_Last (header))
     {
     newHeader->First = List_Next (header, atom);
     newHeader->Last  = header->Last;
 
     header->Last = atom;
 
     /* Update the links */
     (*getLinks)(atom)->Next = NULL;
     (*getLinks)(newHeader->First)->Prev = NULL;
     }
 }

long List_Enum	(	RefListHeader	header,
		RefListEnumProc	proc,
		Ref	closure
	)

List_Enum.

Parameters

header	- RefListHeader header
proc	- RefListEnumProc proc
closure	- Ref closure

Definition at line 379 of file list.c.

References wl_ListHeader::First, and List_EnumFrom().

 {
     return (List_EnumFrom (header, header->First, proc, closure));
 }

long List_EnumBack	(	RefListHeader	header,
		RefListEnumProc	proc,
		Ref	closure
	)

List_EnumBack.

Parameters

header	- RefListHeader header
proc	- RefListEnumProc proc
closure	- Ref closure

Definition at line 433 of file list.c.

References wl_ListHeader::Last, and List_EnumBackFrom().

 {
     return (List_EnumBackFrom (header, header->Last, proc, closure));
 }

long List_EnumBackFrom	(	RefListHeader	header,
		Ref	atom,
		RefListEnumProc	proc,
		Ref	closure
	)

List_EnumBackFrom.

Parameters

header	- RefListHeader header
atom	- Ref atom
proc	- RefListEnumProc proc
closure	- Ref closure)

Definition at line 401 of file list.c.

References List_Prev, NULL, and TRUE.

 {
     Ref cur, prev;
     int notInterrupted = TRUE;
 
 #ifdef prlDEBUG
     header->Lock += 1;
 #endif
 
     cur = atom;
     while (cur != NULL && notInterrupted)
     {
     prev = List_Prev (header, cur);
     notInterrupted = (*proc)(cur, closure);
     cur = prev;
     }
 
 #ifdef prlDEBUG
     header->Lock -=1;
 #endif
     
     return (notInterrupted);
 }

long List_EnumFrom	(	RefListHeader	header,
		Ref	atom,
		RefListEnumProc	proc,
		Ref	closure
	)

List_EnumFrom.

Parameters

header	- RefListHeader header
atom	- Ref atom
proc	- RefListEnumProc proc
closure	- Ref closure

Definition at line 347 of file list.c.

References List_Next, text_buffer::next, NULL, and TRUE.

 {
     Ref cur, next;
     int notInterrupted = TRUE;
 
 #ifdef prlDEBUG
     header->Lock += 1;
 #endif
 
     cur = atom;
     while (cur != NULL && notInterrupted)
     {
     next = List_Next (header, cur);
     notInterrupted = (*proc)(cur, closure);
     cur = next;
     }
 
 #ifdef prlDEBUG
     header->Lock -=1;
 #endif
     
     return (notInterrupted);
 }

void List_InsertAfter	(	RefListHeader	header,
		Ref	atom,
		Ref	mark
	)

List_InsertAfter.

Parameters

header	- RefListHeader header
atom	- Ref atom
mark	- Ref mark)

Definition at line 134 of file list.c.

References wl_ListHeader::GetLinks, wl_ListHeader::Last, List_InsertAhead(), and NULL.

 {
     RefListGetLinksProc  getLinks = header->GetLinks;
 
 #ifdef prlDEBUG
     if (header->Lock > 1)
       OS_PrintMessage ("List_InsertAfter: Warning insert after on recursive List_Enum call !!\n");
 #endif
 
     if (mark != NULL)
     {
         (*getLinks)(atom)->Prev = mark;
 
         if (mark != header->Last)
         {
             (*getLinks)(atom)->Next = (*getLinks)(mark)->Next;
             (*getLinks)((*getLinks)(mark)->Next)->Prev = atom;
         }
         else    /* Insert at the end of the list */
         {
             (*getLinks)(atom)->Next = NULL;
             header->Last = atom;
         }
 
         (*getLinks)(mark)->Next = atom;
     }
     else        /* Insert ahead the list */
       List_InsertAhead (header, atom);
 } 

void List_InsertAhead	(	RefListHeader	header,
		Ref	atom
	)

List_InsertAhead.

Parameters

header	- RefListHeader header
atom	- Ref atom

List functions

Definition at line 44 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, wl_ListHeader::Last, and NULL.

 {
     RefListGetLinksProc  getLinks = header->GetLinks;
 
         /* Update links of atom to insert */
 
     (*getLinks)(atom)->Next = header->First;
     (*getLinks)(atom)->Prev = NULL;
 
         /* Link to the head of list */
 
     if (header->First != NULL)
       (*getLinks)(header->First)->Prev = atom;
 
     else    /* The list is empty */
       header->Last  = atom;
 
     header->First = atom;
 }

void List_InsertBefore	(	RefListHeader	header,
		Ref	atom,
		Ref	mark
	)

List_InsertBefore.

Parameters

header	- RefListHeader header
atom	- Ref atom
mark	- Ref mark

Definition at line 101 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, List_Append(), and NULL.

 {
     RefListGetLinksProc  getLinks = header->GetLinks;
 
     if (mark != NULL)
     {
         (*getLinks)(atom)->Next = mark;
 
         if (mark != header->First)
         {
             (*getLinks)(atom)->Prev = (*getLinks)(mark)->Prev;
             (*getLinks)((*getLinks)(mark)->Prev)->Next = atom;
         }
         else    /* Insert ahead the list */
         {
             (*getLinks)(atom)->Prev = NULL;
             header->First = atom;
         }
 
         (*getLinks)(mark)->Prev = atom;
     }
     else        /* Append to the list */
       List_Append (header, atom);
 } 

long List_IsUnlink ( RefListLinks links )

List_IsUnlink.

Parameters

links - RefListLinks links

Definition at line 475 of file list.c.

References wl_ListLinks::Next, NULL, and wl_ListLinks::Prev.

 {
     return (links->Next == NULL && links->Prev == NULL);
 }

psi_term list_nil ( ptr_definition type )

list_nil

Parameters

type	- ptr_definition type

LIST_NIL(type) Returns the atom NIL to mark the end of a list.

Definition at line 278 of file parser.c.

References wl_psi_term::attr_list, wl_psi_term::coref, disj_nil, disjunction, FALSE, wl_psi_term::flags, nil, NULL, wl_psi_term::resid, wl_psi_term::status, wl_psi_term::type, and wl_psi_term::value_3.

 {
   psi_term nihil;
 
   if(type==disjunction) /*  RM: Feb  1 1993  */
     nihil.type=disj_nil;
   else
     nihil.type=nil;
   
   nihil.status=0;
   nihil.flags=FALSE; /* 14.9 */
   nihil.attr_list=NULL;
   nihil.resid=NULL;
   nihil.value_3=NULL;
   nihil.coref=NULL;
 
   return nihil;
 }

void List_Remove	(	RefListHeader	header,
		Ref	atom
	)

List_Remove.

Parameters

header	- RefListHeader header
atom	- Ref atom)

Definition at line 258 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, wl_ListHeader::Last, and NULL.

 {
 /*-----------------------------------------------------------------------------
 
 WARNING
     - The container is 'updated' two times if the first and last atom
       of list is the only one to remove.
 
 -----------------------------------------------------------------------------*/
 
     RefListGetLinksProc  getLinks = header->GetLinks;
 
 #ifdef prlDEBUG
     if (header->Lock > 1)
       OS_PrintMessage ("List_Remove: Warning remove on recursive List_Enum call !!\n");
 #endif
 
         /* Update the DownStream links */
 
     if ((*getLinks)(atom)->Prev != NULL)
     {
         (*getLinks)((*getLinks)(atom)->Prev)->Next = 
             (*getLinks)(atom)->Next;
     }
     else            /* Atom is the first of list */
       header->First = (*getLinks)(atom)->Next;
 
         /* Update the UpStream links */
 
     if ((*getLinks)(atom)->Next != NULL)
     {
         (*getLinks)((*getLinks)(atom)->Next)->Prev = 
             (*getLinks)(atom)->Prev;
     }
     else            /* Atom is the last of list */
       header->Last = (*getLinks)(atom)->Prev;
 
         /* Reset the atom links */
 
     (*getLinks)(atom)->Prev = NULL;
     (*getLinks)(atom)->Next = NULL;
 } 

void List_Reverse ( RefListHeader header )

List_Reverse.

Parameters

header - RefListHeader header

Definition at line 230 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, wl_ListHeader::Last, List_SwapLinks(), text_buffer::next, and NULL.

 {
     Ref         cur, next;
     RefListGetLinksProc getLinks = header->GetLinks;
 
     /* This traverse cannot be done with function List_Enum() */
 
     cur = header->First;
 
     /* Swap the headers */
     header->First = header->Last;
     header->Last  = cur;
 
     while (cur != NULL)
     {
     next = (*getLinks)(cur)->Next;
     (void)List_SwapLinks (header, cur);
     cur = next;
     }
 }

void List_SetLinkProc	(	RefListHeader	header,
		RefListGetLinksProc	getLinks
	)

List_SetLinkProc.

Parameters

header	- RefListHeader header
getLinks	- RefListGetLinksProc getLinks

Set functions

Definition at line 24 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, wl_ListHeader::Last, and NULL.

 {
     header->First = NULL;
     header->Last = NULL;
 
 #ifdef prlDEBUG
     header->Lock = 0;
 #endif
 
     header->GetLinks = getLinks;
 }

void list_special ( ptr_psi_term t )

list_special

Parameters

t	- ptr_psi_term t

List the characteristics (delay_check, dynamic/static, non_strict) in such a way that they can be immediately read in.

Definition at line 5131 of file built_ins.c.

References wl_definition::always_check, display_psi_stream(), wl_definition::evaluate_args, FALSE, is_built_in(), output_stream, wl_definition::protected, wl_definition::rule, TRUE, wl_psi_term::type, wl_definition::type_def, and type_it.

 {
   ptr_definition d = t->type;
   ptr_pair_list r = t->type->rule;
   long prflag=FALSE;
 
   if (t->type->type_def==(def_type)type_it) {
     if (!d->always_check) {
       if (is_built_in(r)) fprintf(output_stream,"%% ");
       fprintf(output_stream,"delay_check(");
       display_psi_stream(t);
       fprintf(output_stream,")?\n");
       prflag=TRUE;
     }
   } else {
     if (!d->protected) {
       if (is_built_in(r)) fprintf(output_stream,"%% ");
       fprintf(output_stream,"%s(",(d->protected?"static":"dynamic"));
       display_psi_stream(t);
       fprintf(output_stream,")?\n");
       prflag=TRUE;
     } 
   }
   if (!d->evaluate_args) {
     if (is_built_in(r)) fprintf(output_stream,"%% ");
     fprintf(output_stream,"non_strict(");
     display_psi_stream(t);
     fprintf(output_stream,")?\n");
     prflag=TRUE;
   }
   /* if (prflag) fprintf(output_stream,"\n"); */
 }

void List_Swap	(	RefListHeader	header,
		Ref	first,
		Ref	second
	)

List_Swap.

Parameters

header	- RefListHeader header
first	- Ref first
second	- Ref second)

Definition at line 172 of file list.c.

References wl_ListHeader::First, wl_ListHeader::GetLinks, and wl_ListHeader::Last.

 {
     RefListGetLinksProc getLinks = header->GetLinks;
 
     /* Don't swap if the input is wrong */
 
     if ((*getLinks)(first)->Next != second)
     {
 #ifdef prlDEBUG
     OS_PrintMessage ("List_Swap: WARNING wrong input data, swap not done..\n");
 #endif
     return;
     }
 
         /* Special Cases */
 
     if (header->First == first)
       header->First = second;
     else
       (*getLinks)((*getLinks)(first)->Prev)->Next = second;
     
     if (header->Last == second)
       header->Last = first;
     else
       (*getLinks)((*getLinks)(second)->Next)->Prev = first;
 
         /* Swap the atoms */
 
     (*getLinks)(second)->Prev = (*getLinks)(first)->Prev;
     (*getLinks)(first)->Next  = (*getLinks)(second)->Next;
     (*getLinks)(first)->Prev  = second;
     (*getLinks)(second)->Next = first;
 }

void listing_pred_write	(	ptr_node	n,
		long	fflag
	)

listing_pred_write

Parameters

n	- ptr_node n
fflag	- long fflag

For the listing built-in

Definition at line 1438 of file print.c.

References const_quote, FALSE, func_flag, indent, listing_flag, main_pred_write(), outfile, output_stream, print_depth, PRINT_DEPTH, TRUE, write_canon, write_corefs, write_resids, and write_stderr.

 {
   long old_print_depth;
 
   listing_flag=TRUE;
   func_flag=fflag;
   indent=TRUE;
   const_quote=TRUE;
   write_corefs=TRUE;
   write_stderr=FALSE;
   write_resids=FALSE;
   write_canon=FALSE;
   outfile=output_stream;
   old_print_depth=print_depth;
   print_depth=PRINT_DEPTH;
   main_pred_write(n);
   print_depth=old_print_depth;
   (void)fflush(outfile);
 }

long load_aim ( )

load_aim

LOAD_AIM() Continue loading a file from the current psi-term up to the next query. Files are loaded in blocks of assertions that end with a query. Such a chunk is loaded by a 'load' goal on the goal_stack. This goal contains the input file state information. This guarantees that all queries in the input file are executed in the order they are encountered (which includes load operations).

Definition at line 2232 of file login.c.

References wl_goal::aaaa_1, abort_life(), aim, assert_clause(), assert_first, wl_goal::bbbb_1, wl_goal::cccc_1, choice_stack, CURRENT_MODULE, DEFRULES, encode_types(), eof, FACT, FALSE, file_date, find_module(), general_cut, get_attr(), input_state, input_stream, load, noisy, NULL, open_input_file(), parse(), prove, push_choice_point(), push_goal(), QUERY, restore_state(), save_state(), set_current_module(), stack_copy_psi_term(), TRUE, wl_psi_term::type, var_occurred, and var_tree.

 {
   long success=TRUE,exitloop;
   ptr_psi_term s;
   long sort;
   char *fn;
   long old_noisy,old_file_date;
   ptr_node old_var_tree;
   ptr_choice_point cutpt;
   long old_var_occurred; /* 18.8 */
   int end_of_file=FALSE; /*  RM: Jan 27 1993  */
 
   
   save_state(input_state);
   input_state=(ptr_psi_term)aim->aaaa_1;
   restore_state(input_state);
   old_file_date=file_date;
   file_date=(unsigned long)aim->bbbb_1;
   old_noisy=noisy;
   noisy=FALSE;
   fn=(char*)aim->cccc_1;
   exitloop=FALSE;
   
   do {
     /* Variables in queries in files are *completely independent* of top- */
     /* level variables.  I.e.: top-level variables are *not* recognized   */
     /* while loading files and variables in file queries are *not* added. */
     old_var_occurred=var_occurred; /* 18.8 */
     old_var_tree=var_tree;
     var_tree=NULL;
     s=stack_copy_psi_term(parse(&sort));
     var_tree=old_var_tree;
     var_occurred=old_var_occurred; /* 18.8 */
 
     if (s->type==eof) {
       encode_types();
       if (input_stream!=stdin) (void)fclose(input_stream);
       exitloop=TRUE;
       end_of_file=TRUE; /*  RM: Jan 27 1993  */
     }
     else if (sort==FACT) {
       assert_first=FALSE;
       assert_clause(s);
     }
     else if (sort==QUERY) {
       encode_types();
       save_state(input_state);
       /* Handle both successful and failing queries correctly. */
       cutpt=choice_stack;
       push_choice_point(load,input_state,(ptr_psi_term)file_date,(GENERIC) fn);
       push_goal(load,(ptr_psi_term)input_state,(ptr_psi_term)file_date,(GENERIC)fn);
       push_goal(general_cut,(ptr_psi_term)cutpt,(ptr_psi_term)NULL,(GENERIC)NULL);
       push_goal(prove,(ptr_psi_term)s,(ptr_psi_term)DEFRULES,(GENERIC)NULL);
       exitloop=TRUE;
     }
     else {
       /* fprintf(stderr,"*** Error: in input file %c%s%c.\n",34,fn,34); */
       /* success=FALSE; */
       /* fail_all(); */
       if (input_stream!=stdin) (void)fclose(input_stream);
       (void)abort_life(TRUE);
       /* printf("\n*** Abort\n"); */
       /* main_loop_ok=FALSE; */
     }
   } while (success && !exitloop);
 
 
   /*  RM: Jan 27 1993 */
   if(end_of_file || !success) {
     /*
       printf("END OF FILE %s, setting module to %s\n",
       ((ptr_psi_term)get_attr(input_state,
       INPUT_FILE_NAME))->value,
       ((ptr_psi_term)get_attr(input_state,
       CURRENT_MODULE))->value);
       */
        
     (void)set_current_module(
                find_module((char *)((ptr_psi_term)get_attr(input_state,
        CURRENT_MODULE))->value_3));
   }
 
   
   noisy=old_noisy;
   file_date=old_file_date;
   (void)open_input_file("stdin");
 
   
   return success;
 }

long look ( )

look

LOOK() This function returns the precedence of the stack top.

Definition at line 163 of file parser.c.

References int_stack, and parser_stack_index.

 {
   return int_stack[parser_stack_index];
 }

ptr_int_list lub	(	ptr_psi_term	a,
		ptr_psi_term	b,
		ptr_psi_term *	pp
	)

Definition at line 173 of file lub.c.

References bfs(), wl_definition::code, copyTypeCode(), decode(), isSubTypeValue(), isValue(), makeUnitList(), NULL, or_codes(), stack_alloc(), sub_type(), top, wl_psi_term::type, and type_count.

 {
   ptr_definition ta;            /* type of psi term a */
   ptr_definition tb;            /* type of psi term b */
   long *flags;                  /* set to 1 if this type has been checked in
                          * the lub search.
                          */
   ptr_int_list ans;
   ptr_int_list pattern;
   long found;
     
   ta = a->type;
   tb = b->type;
     
   /* special cases first */
     
   if (isValue(a) && isValue(b) && sub_type(ta,tb) && sub_type(tb,ta))
     {
       /* special case of two values being of same type.  Check that they
        * might actually be same value before returning the type
        */
       if (isSubTypeValue(a, b))
     {
       /* since we alreadyuu know they are both values, isSubTypeValue
        * returns TRUE if they are same value, else false
        */
             
       *pp = a;
       return NULL;
     }
     }
     
   if (sub_type(ta, tb)) return makeUnitList(tb);
   if (sub_type(tb, ta)) return makeUnitList(ta);
 
   /* ta has the lub of tb&ta without the high bit set, search upwards for a
    * type that has the same lower bits as ta
    */
 
   /* get the pattern to search for */
     
   pattern = copyTypeCode(ta->code);
   or_codes(pattern, tb->code);      /* pattern to search for */
   ans = copyTypeCode(pattern);      /* resulting pattern */
     
   /* initialize the table to be non-searched */
     
   flags = (long *)stack_alloc(sizeof(unsigned long) * type_count);
   memset(flags, 0, sizeof(unsigned long) * type_count);
 
   /* now do a breadth first search for each of arg1 and arg2 */
 
   found  = bfs(ta, ans, pattern, flags);
   found += bfs(tb, ans, pattern, flags);
 
   if (found)
     ans = decode(ans);
   else
     ans = makeUnitList(top);
     
   return ans;
 }

int main	(	int	argc,
		char *	argv[]
	)

main

int main(int argc,char *argv[])

Parameters

argc	- int argc
argv	- char *argv[]

MAIN(argc,argv) This routine contains the Read-Solve-Print loop.

Definition at line 34 of file life.c.

References arg_c, arg_v, assert, assert_clause(), assert_first, assert_ok, begin_terminal_io(), DEFRULES, encode_types(), end_terminal_io(), env, eof, Errorline(), exit_if_true(), exit_life(), FACT, FALSE, file_date, GetBoolOption(), goal_count, heap_copy_string(), ignore_eff, infoline(), init_built_in_types(), init_copy(), init_interrupt(), init_io(), init_memory(), init_modules(), init_print(), init_system(), init_trace(), input_state, life_start, load, main_prove(), mem_base, noisy, NULL, open_input_file(), other_base, parse(), prove, push_goal(), put_back_char(), QUERY, quietflag, rand_array, read_char(), reset_step(), set_current_module(), stack_copy_psi_term(), stack_pointer, start_chrono(), stdin_cleareof(), title(), TRUE, wl_psi_term::type, undo(), undo_stack, user_module, var_occurred, what_next, and x_setup_builtins().

 {
   ptr_psi_term s;  
   ptr_stack save_undo_stack;
   long sort,exitflag;
   long c; /* 21.12 (prev. char) */ 
 
   int i;
 #ifdef SOLARIS
   for(i=0;i<256;i++)
     rand_array[i]=rand_r(&lifeseed);
 #else
   for(i=0;i<256;i++)
     rand_array[i]=random();
 #endif
 
   
   arg_c=argc;
   if (argc < 10)
     {
       for (i = 0; i < argc;i++)
     {
       arg_v[i]=argv[i];
     } 
     }
   else
     Errorline("Too many command line arguments\n");
    
   //  arg_v=argv;
   quietflag = GetBoolOption("q");
   init_io();
   init_memory();
   exit_if_true(!mem_base || !other_base);
   assert(stack_pointer==mem_base); /* 8.10 */
   init_copy();
   assert(stack_pointer==mem_base); /* 8.10 */
   init_print();
   assert(stack_pointer==mem_base); /* 8.10 */
 
   /* Timekeeping initialization */
   tzset();
   (void)times(&life_start);
   assert(stack_pointer==mem_base); /* 8.10 */
 
   init_modules(); /*  RM: Jan  8 1993  */
   
   init_built_in_types();
   assert(stack_pointer==mem_base); /* 8.10 */
 #ifdef X11
   x_setup_builtins();
   assert(stack_pointer==mem_base); /* 8.10 */
 #endif
   init_interrupt();
 
   assert(stack_pointer==mem_base); /* 8.10 */
   title();
   assert(stack_pointer==mem_base); /* 8.10 */
   init_trace();
   noisy=FALSE;
 
   assert(stack_pointer==mem_base); /* 8.10 */
 
 
   (void)set_current_module(user_module); /*  RM: Jan 27 1993  */
   
   /* Read in the .set_up file */
   init_system();
   
 #ifdef ARITY  /*  RM: Mar 29 1993  */
   arity_init();
 #endif
 
   
   (void)open_input_file("+SETUP+");
   push_goal(load,input_state,(ptr_psi_term)file_date,(GENERIC)heap_copy_string("+SETUP+"));
   file_date+=2;
   main_prove();
 
 
   /* Main loop of interpreter */
   do {
     (void)setjmp(env);
     /* printf("%ld\n",(long)(stack_pointer-mem_base)); */ /* 8.10 */
     init_system(); 
     init_trace();
 
     begin_terminal_io();
     var_occurred=FALSE;
     save_undo_stack=undo_stack;
     stdin_cleareof();
     c=read_char();
     /* Wait until an EOF or a good character */
     while (c!=EOF && !(c>32 && c!='.' && c!=';')) c=read_char();
     if (c==EOF)
       exitflag=TRUE;
     else {
       put_back_char(c);
       s=stack_copy_psi_term(parse(&sort));
       exitflag=(s->type==eof);
     }
     end_terminal_io();
 
     if (!exitflag) {
       if (sort==QUERY) {
 
     // clear_already_loaded(symbol_table);     RM: Feb  3 1993  
     
         push_goal(what_next,(ptr_psi_term)TRUE,(ptr_psi_term)var_occurred,(GENERIC)1);
 
         ignore_eff=TRUE;
         goal_count=0;
         push_goal(prove,s,(ptr_psi_term)DEFRULES,NULL);
         reset_step();
         start_chrono();
         main_prove();
         /* assert(goal_stack==NULL); */
         /* assert(choice_stack==NULL); */
     if (undo_stack) {
       undo(NULL);
           Errorline("non-NULL undo stack.\n");
     }
         /* assert(undo_stack==NULL); */
       }
       else if (sort==FACT) {
         assert_first=FALSE;
         assert_clause(s);
         undo(save_undo_stack); /* 17.8 */
         var_occurred=FALSE; /* 18.8 */
         encode_types();
 
         infoline(assert_ok?"\n*** Yes\n":"\n*** No\n"); /* 21.1 */
      }
     }
   } while (!exitflag);
 
   /* hash_display(x_module->symbol_table); */
   
   exit_life(TRUE);
   return 0;
 }

void main_display_psi_term ( ptr_psi_term t )

main_display_psi_term

Parameters

t	- ptr_psi_term t

Main loop for previous two entry points

Definition at line 1593 of file print.c.

References buffer, const_quote, deref_ptr, end_tab(), FALSE, gen_sym_counter, go_through(), heap_pointer, indent, indx, insert_variables(), listing_flag, mark_tab(), MAX_PRECEDENCE, new_tab(), NULL, pointer_names, pretty_output(), pretty_tag_or_psi_term(), pretty_things, printed_pointers, TRUE, var_tree, work_out_length(), write_canon, and write_resids.

 {
   GENERIC old_heap_pointer;
   ptr_tab_brk new;
 
   listing_flag=FALSE;
   if(t) {
 
     deref_ptr(t);
     
     old_heap_pointer=heap_pointer;
     pointer_names=NULL;
     printed_pointers=NULL;
     gen_sym_counter=0;
     go_through(t);
     insert_variables(var_tree,FALSE);
     
     indent=FALSE;
     const_quote=TRUE;
     write_resids=FALSE;
     write_canon=FALSE;
     *buffer=0;
     indx=pretty_things;
 
     new_tab(&new);
     mark_tab(new);
     pretty_tag_or_psi_term(t,MAX_PRECEDENCE+1,0);
     end_tab();
     if (indent) {
       work_out_length();
       pretty_output();
     }
     
     heap_pointer=old_heap_pointer;
   }
   else
     printf("*null psi_term*");
 }

void main_pred_write ( ptr_node n )

main_pred_write

Parameters

n	- ptr_node n

Definition at line 1484 of file print.c.

References buffer, check_pointer(), wl_node::data, end_tab(), FALSE, gen_sym_counter, go_through_tree(), heap_pointer, indent, indx, insert_variables(), wl_node::left, mark_tab(), MAX_PRECEDENCE, new_tab(), NULL, pointer_names, pretty_output(), pretty_tag_or_psi_term(), pretty_things, printed_pointers, wl_node::right, var_tree, work_out_length(), write_attributes(), and write_corefs.

 {
   if (n) {
     GENERIC old_heap_pointer;
     ptr_tab_brk new;
  
     if (!write_corefs) main_pred_write(n->left);
 
     old_heap_pointer=heap_pointer;
     pointer_names=NULL;
     printed_pointers=NULL;
     gen_sym_counter=0;
     if (write_corefs)
       go_through_tree(n);
     else
       check_pointer((ptr_psi_term)n->data);
     insert_variables(var_tree,FALSE);
 
     *buffer=0;
     
     indx=pretty_things;
     new_tab(&new);
 
     if (write_corefs) {
       write_attributes(n,new);
     }
     else {
       mark_tab(new);
       pretty_tag_or_psi_term((ptr_psi_term)n->data,MAX_PRECEDENCE+1,0);
     }
 
     end_tab();
 
     if (indent) {
       work_out_length();
       pretty_output();
     }
     
     heap_pointer=old_heap_pointer;
 
     if (!write_corefs) main_pred_write(n->right);
   }
 }

void main_prove ( )

main_prove

MAIN_PROVE() This is the inference engine. It distributes sub-goals to the appropriate routines. It deals with backtracking. It fails if there is not enough memory available or if there is an interrupt that causes the current query to be aborted.

Definition at line 2333 of file login.c.

References wl_goal::aaaa_1, aim, backtrack(), wl_goal::bbbb_1, c_what_next, wl_goal::cccc_1, choice_stack, clause, clause_aim(), clean_trail(), curried, cut_to, del_clause, disj, disjunct_aim(), do_currying(), do_residuation_user(), Errorline(), eval, eval_aim(), eval_cut, fail, FALSE, freeze_cut, function_it, GC_THRESHOLD, general_cut, goal_count, goal_stack, handle_interrupt(), heap_pointer, i_check_out(), implies_cut, infoline(), interrupted, load, load_aim(), main_loop_ok, match, match_aim(), memory_check(), wl_goal::next, NULL, prove, prove_aim(), release_resid(), resid_aim, resid_vars, restore_resid(), retract, show_count(), stack_pointer, stepcount, stepflag, steptrace, traceline(), TRUE, wl_goal::type, type_disj, type_disj_aim(), undo(), unify, unify_aim(), unify_aim_noeval(), unify_noeval, warningline(), what_next, what_next_aim(), x_exist_event(), xcount, xevent_existing, XEVENTDELAY, and xeventdelay.

 {
   long success=TRUE;
   ptr_pair_list *p;
   ptr_psi_term unused_match_date; /* 13.6 */
     
   xcount=0;
   xeventdelay=XEVENTDELAY;
   interrupted=FALSE;
   main_loop_ok=TRUE;
   
   while (main_loop_ok && goal_stack) {
 
     /*  RM: Oct 28 1993  For debugging a horrible mess.
     { 
       ptr_choice_point c=choice_stack;
       while(c) {
     if((ptr_psi_term)stack_pointer<(ptr_psi_term)c) {
       printf("########### Choice stack corrupted! %x\n",c);
       trace=TRUE;
       c=NULL;
     }
     else
       c=c->next;
       }
     }
     */
 
     
     aim=goal_stack;
     switch(aim->type) {
       
     case unify:
       goal_stack=aim->next;
       goal_count++;
       success=unify_aim();
       break;
       
     /* Same as above, but do not evaluate top level */
     /* Used to bind with unbound variables */
     case unify_noeval:
       goal_stack=aim->next;
       goal_count++;
       success=unify_aim_noeval();
       break;
       
     case prove:
       success=prove_aim();
       break;
       
     case eval:
       goal_stack=aim->next;
       goal_count++;
       success=eval_aim();
       break;
 
     case load:
       goal_stack=aim->next;
       goal_count++;
       success=load_aim();
       break;
       
     case match:
       goal_stack=aim->next;
       goal_count++;
       success=match_aim();
       break;
       
     case disj:
       goal_stack=aim->next;
       goal_count++;
       success=disjunct_aim();
       break;
 
     case general_cut:
       goal_stack=aim->next;
       goal_count++;
       /* assert((ptr_choice_point)aim->aaaa_1 <= choice_stack); 12.7 */
       /* choice_stack=(ptr_choice_point)aim->aaaa_1; */
       cut_to(aim->aaaa_1); /* 12.7 */
 #ifdef CLEAN_TRAIL
       clean_trail(choice_stack);
 #endif
 #ifdef TS
       /* RESTORE_TIME_STAMP; */ /* 9.6 */
 #endif
       break;
       
     case eval_cut:
       /* RESID */ restore_resid((ptr_resid_block)aim->cccc_1, &unused_match_date);
       if (curried)
     do_currying();
       else if (resid_vars) {
     success=do_residuation_user(); /* 21.9 */ /* PVR 9.2.94 */
       } else {
         if (resid_aim)
           traceline("result of %P is %P\n", resid_aim->aaaa_1, aim->aaaa_1);
         goal_stack=aim->next;
         goal_count++;
         /* resid_aim=NULL; 21.9 */
         /* PVR 5.11 choice_stack=(ptr_choice_point)aim->bbbb_1; */
         (void)i_check_out(aim->aaaa_1);
       }
       resid_aim=NULL; /* 21.9 */
       resid_vars=NULL; /* 22.9 */
       /* assert((ptr_choice_point)aim->bbbb_1<=choice_stack); 12.7 */
       /* PVR 5.11 */ /* choice_stack=(ptr_choice_point)aim->bbbb_1; */
       if (success) { /* 21.9 */
         cut_to(aim->bbbb_1); /* 12.7 */
 #ifdef CLEAN_TRAIL
         clean_trail(choice_stack);
 #endif
         /* match_date=NULL; */ /* 13.6 */
 #ifdef TS
         /* RESTORE_TIME_STAMP; */ /* 9.6 */
 #endif
       }
       break;
       
     case freeze_cut:
       /* RESID */ restore_resid((ptr_resid_block)aim->cccc_1, &unused_match_date);
       if (curried) {
         warningline("frozen goal has a missing parameter '%P' and fails.\n",aim->aaaa_1);
     success=FALSE;
       }
       else if (resid_vars) {
     success=do_residuation_user(); /* 21.9 */ /* PVR 9.2.94 */
       } else {
         if (resid_aim) traceline("releasing frozen goal: %P\n", aim->aaaa_1);
     /* resid_aim=NULL; 21.9 */
     /* PVR 5.12 choice_stack=(ptr_choice_point)aim->bbbb_1; */
     goal_stack=aim->next;
     goal_count++;
       }
       resid_aim=NULL; /* 21.9 */
       resid_vars=NULL; /* 22.9 */
       if (success) { /* 21.9 */
         /* assert((ptr_choice_point)aim->bbbb_1<=choice_stack); 12.7 */
         /* PVR 5.12 */ /* choice_stack=(ptr_choice_point)aim->bbbb_1; */
         cut_to(aim->bbbb_1); /* 12.7 */
 #ifdef CLEAN_TRAIL
         clean_trail(choice_stack);
 #endif
         /* match_date=NULL; */ /* 13.6 */
 #ifdef TS
         /* RESTORE_TIME_STAMP; */ /* 9.6 */
 #endif
       }
       break;
       
     case implies_cut: /* 12.10 */
       /* This 'cut' is actually more like a no-op! */
       restore_resid((ptr_resid_block)aim->cccc_1, &unused_match_date);
       if (curried) {
         warningline("implied goal has a missing parameter '%P' and fails.\n",aim->aaaa_1);
     success=FALSE;
       }
       else if (resid_vars)
     success=FALSE;
       else {
         if (resid_aim) traceline("executing implied goal: %P\n", aim->aaaa_1);
     goal_stack=aim->next;
     goal_count++;
       }
       resid_aim=NULL; /* 21.9 */
       resid_vars=NULL; /* 22.9 */
       break;
 
     case fail:
       goal_stack=aim->next;
       success=FALSE;
       break;
       
     case what_next:
       goal_stack=aim->next;
       success=what_next_aim();
       break;
       
     case type_disj:
       goal_stack=aim->next;
       goal_count++;
       type_disj_aim();
       break;
       
     case clause:
       goal_stack=aim->next;
       goal_count++;
       success=clause_aim(0);
       break;
       
     case del_clause:
       goal_stack=aim->next;
       goal_count++;
       success=clause_aim(1);
       break;
       
     case retract:
       goal_stack=aim->next;
       goal_count++;
       p=(ptr_pair_list*)aim->aaaa_1;
       traceline("deleting clause (%P%s%P)\n",
                 (*p)->aaaa_2,((*p)->aaaa_2->type->type_def==(def_type)function_it?"->":":-"),(*p)->bbbb_2);
       (*p)->aaaa_2=NULL;
       (*p)->bbbb_2=NULL;
       (*p)=(*p)->next; /* Remove retracted element from pairlist */
       break;
 
     case c_what_next: /*  RM: Mar 31 1993  */
       main_loop_ok=FALSE; /* Exit the main loop */
       break;
       
     default:
       Errorline("bad goal on stack %d.\n",goal_stack->type);
       goal_stack=aim->next;
     }
 
     if (main_loop_ok) {
     
       if (success) {
 
 #ifdef X11
     /* Polling on external events */
     if (xcount<=0 && aim->type==prove) {
       if (x_exist_event()) {
         /* printf("At event, xeventdelay = %ld.\n",xeventdelay); */
         xeventdelay=0;
         release_resid(xevent_existing);
       } else {
         if (xeventdelay<XEVENTDELAY)
           /* If XEVENTDELAY=1000 it takes 90000 goals to get back */
           /* from 100 at the pace of 1%. */
           xeventdelay=(xeventdelay*101)/100+2;
         else
           xeventdelay=XEVENTDELAY;
       }
       xcount=xeventdelay;
     }
     else
       xcount--;
 #endif
     
       }
       else {
         if (choice_stack) {
       backtrack();
           traceline("backtracking\n");
       success=TRUE;
         }
         else /* if (goal_stack) */ {
           undo(NULL); /* 8.10 */
       infoline("\n*** No");
       /* printf("\n*** No (in main_prove)."); */
           show_count();
 #ifdef TS
       /* global_time_stamp=INIT_TIME_STAMP; */ /* 9.6 */
 #endif
       main_loop_ok=FALSE;
         }
       }
       
       if (heap_pointer-stack_pointer < GC_THRESHOLD)
         (void)memory_check();
       
       if (interrupted || (stepflag && steptrace))
         handle_interrupt();
       else if (stepcount>0) {
         stepcount--;
         if (stepcount==0 && !stepflag) {
           stepflag=TRUE;
           handle_interrupt();
         }
       }
     }
   }
 }

ptr_psi_term make_feature_list	(	ptr_node	tree,
		ptr_psi_term	tail,
		ptr_module	module,
		int	val
	)

make_feature_list

Parameters

tree	- ptr_node tree
tail	- ptr_psi_term tail
module	- ptr_module module
val	- int val

Definition at line 175 of file built_ins.c.

References wl_node::data, heap_alloc(), integer, wl_node::key, wl_node::left, make_feature_list(), REAL, real, wl_node::right, stack_cons(), stack_psi_term(), str_to_int(), and update_feature().

 {
   ptr_psi_term new;
   ptr_definition def;
   double d; // strtod();
   
   
   if(tree) {
     if(tree->right)
       tail=make_feature_list(tree->right,tail,module,val);
 
     /* Insert the feature name into the list */
     
     d=str_to_int(tree->key);
     if (d== -1) { /* Feature is not a number */
       def=update_feature(module,tree->key); /* Extract module RM: Feb 3 1993 */
       if(def) {
     if(val) /* RM: Mar  3 1994 Distinguish between features & values */
       tail=stack_cons((ptr_psi_term)tree->data,(ptr_psi_term)tail);
     else {
       new=stack_psi_term(4);      
       new->type=def;
       tail=stack_cons((ptr_psi_term)new,(ptr_psi_term)tail);
     }
       }
     }
     else { /* Feature is a number */
       if(val) /* RM: Mar  3 1994 Distinguish between features & values */
     tail=stack_cons((ptr_psi_term)tree->data,(ptr_psi_term)tail);
       else {
     new=stack_psi_term(4);      
     new->type=(d==floor(d))?integer:real;
     new->value_3=heap_alloc(sizeof(REAL));
     *(REAL *)new->value_3=(REAL)d;
     tail=stack_cons((ptr_psi_term)new,(ptr_psi_term)tail);
       }
     }
     
     if(tree->left)
       tail=make_feature_list(tree->left,tail,module,val);
   }
   
   return tail;
 }

int make_feature_private ( ptr_psi_term term )

make_feature_private

Parameters

term	- ptr_psi_term term

MAKE_FEATURE_PRIVATE(feature) Make a feature private.

Definition at line 1256 of file modules.c.

References wl_keyword::combined_name, wl_keyword::definition, deref_ptr, hash_lookup(), wl_definition::keyword, wl_keyword::private_feature, wl_keyword::public, wl_keyword::symbol, wl_module::symbol_table, TRUE, wl_psi_term::type, update_symbol(), and warningline().

 {
   int ok=TRUE;
   ptr_keyword key;
   ptr_definition def;
 
   deref_ptr(term);
 
   key=hash_lookup(current_module->symbol_table,term->type->keyword->symbol);
   
   if(key) {
     /*
       if(key->definition->keyword->module!=current_module) {
       warningline("local definition of '%s' overrides '%s'\n",
       key->definition->keyword->symbol,
       key->definition->keyword->combined_name);
       
       new_definition(key);
       }
     */
     
     key->private_feature=TRUE;
     def=key->definition;
   }
   else {
     def=update_symbol(current_module,term->type->keyword->symbol);
     def->keyword->private_feature=TRUE;
   }
 
   
   if(ok && def->keyword->public) {
     warningline("feature '%s' is now private, but was also declared public\n",
         def->keyword->combined_name);
   }
   
   return ok;
 }

psi_term make_life_form	(	ptr_psi_term	tok,
		ptr_psi_term	arg1,
		ptr_psi_term	arg2
	)

make_life_form

Parameters

tok	- ptr_psi_term tok
arg1	- ptr_psi_term arg1
arg2	- ptr_psi_term arg2

MAKE_LIFE_FORM(tok,arg1,arg2) This routine inserts ARG1 and ARG2 as the first and second attributes of psi_term TOK, thus creating the term TOK(1=>arg1,2=>arg2).

If TOK is ':' then a conjunction is created if necessary. Example: a:V:b:5:long => V: <a,b,5,int> (= conjunction list).

Definition at line 571 of file parser.c.

References wl_psi_term::attr_list, wl_psi_term::coref, deref_ptr, equ_tokch, error_psi_term, FEATCMP, heap_alloc(), integer, minus_symbol, NULL, one, push_psi_ptr_value(), REAL, real, wl_psi_term::resid, stack_copy_psi_term(), stack_insert(), Syntaxerrorline(), top, two, wl_psi_term::type, and wl_psi_term::value_3.

 {  
   ptr_psi_term a1,a2;
 
   deref_ptr(tok);
   tok->attr_list=NULL;
   tok->resid=NULL;
     
   /* Here beginneth a terrible FIX,
      I will have to rewrite the tokeniser and the parser to handle
      POINTERS to psi-terms instead of PSI_TERMS !!!
      */
   
   a1=arg1;
   a2=arg2;
 
   if (a1)
     deref_ptr(a1);
   if (a2)
     deref_ptr(a2);
   
   /* End of extremely ugly fix. */
   
   if (/* UNI FALSE */ equ_tokch((*tok),':') && arg1 && arg2) {
     
     if (a1!=a2) {
       if (a1->type==top && 
      !a1->attr_list &&
      !a1->resid) {
     if (a1!=arg1)
       /* push_ptr_value(psi_term_ptr,&(a1->coref)); 9.6 */
       push_psi_ptr_value(a1,(GENERIC *)&(a1->coref));
     a1->coref=stack_copy_psi_term(*arg2);
     tok=arg1;
       }
       else
     if(a2->type==top && 
        !a2->attr_list &&
        !a2->resid) {
       if(a2!=arg2)
         /* push_ptr_value(psi_term_ptr,&(a2->coref)); 9.6 */
         push_psi_ptr_value(a2,(GENERIC *)&(a2->coref));
       a2->coref=stack_copy_psi_term(*arg1);
       tok=arg2;
     }
     else { /*  RM: Feb 22 1993  Now reports an error */
       Syntaxerrorline("':' occurs where '&' required (%E)\n");
       *tok= *error_psi_term;
       /* make_unify_pair(tok,arg1,arg2); Old code */
     }
     }
     else
       tok=arg1;
   }
   else {
 
     /*  RM: Jun 21 1993  */
     /* And now for another nasty hack: reading negative numbers */
     if(tok->type==minus_symbol &&
        a1 &&
        !a2 &&
        a1->value_3 &&
        (a1->type==integer || a1->type==real))  {
       
       tok->type=a1->type;
       tok->value_3=(GENERIC)heap_alloc(sizeof(REAL));
       *(REAL *)tok->value_3 = - *(REAL *)a1->value_3;
       
       return *tok;
     }
     /* End of other nasty hack */
     
     (void)stack_insert(FEATCMP,one,&(tok->attr_list),(GENERIC)stack_copy_psi_term(*arg1));
     if (arg2)
       (void)stack_insert(FEATCMP,two,&(tok->attr_list),(GENERIC)stack_copy_psi_term(*arg2));
   }
   
   return *tok;
 }

char * make_module_token	(	ptr_module	module,
		char *	str
	)

make_module_token

Parameters

module	- ptr_module module
str	- char *str

MAKE_MODULE_TOKEN(module,string) Write 'module::string' in module_buffer. If string is a qualified reference to a given module, then modify the calling module variable to reflect this.

The result must be immediately stored in a newly allocated string.

Definition at line 191 of file modules.c.

References extract_module_from_name(), module_buffer, and wl_module::module_name.

 {
   ptr_module explicit;
 
 
   /* Check if the string already contains a module */
   explicit=extract_module_from_name(str);
   if(explicit)
     strcpy(module_buffer,str);
   else
     if(module!=no_module) {
       strcpy(module_buffer,module->module_name);
       strcat(module_buffer,"#");
       strcat(module_buffer,str);
     }
     else
       strcpy(module_buffer,str);
   
   return module_buffer;
 }

long make_public	(	ptr_psi_term	term,
		long	bool
	)

make_public

Parameters

term	- ptr_psi_term term
bool	- long bool

MAKE_PUBLIC(term,bool) Make a term public.

Definition at line 613 of file modules.c.

References wl_keyword::combined_name, wl_keyword::definition, deref_ptr, hash_lookup(), wl_definition::keyword, wl_keyword::module, new_definition(), wl_keyword::public, wl_keyword::symbol, wl_module::symbol_table, TRUE, wl_psi_term::type, update_symbol(), and warningline().

 {
   int ok=TRUE;
   ptr_keyword key;
   ptr_definition def;
   
   deref_ptr(term);
 
   key=hash_lookup(current_module->symbol_table,term->type->keyword->symbol);
   if(key) {
     
     if(key->definition->keyword->module!=current_module && !bool) {
       warningline("local definition of '%s' overrides '%s'\n",
            key->definition->keyword->symbol,
            key->definition->keyword->combined_name);
       
       (void)new_definition(key);
     }
     
     key->public=bool;
   }
   else {
     def=update_symbol(current_module,term->type->keyword->symbol);
     def->keyword->public=bool;
   }
   
   return ok;
 }

void make_sys_type_links ( )

make_sys_type_links

INITIALIZATION FUNCTIONS

Definition at line 2168 of file sys.c.

References built_in, make_type_link(), sys_bitvector, sys_bytedata, sys_file_stream, sys_regexp, sys_socket_stream, and sys_stream.

 {
 #ifdef LIFE_NDBM
   make_ndbm_type_links();
 #endif
   make_type_link(sys_bitvector    ,sys_bytedata);
   make_type_link(sys_regexp       ,sys_bytedata);
   make_type_link(sys_stream       ,sys_bytedata);
   make_type_link(sys_file_stream  ,sys_stream);
   make_type_link(sys_socket_stream,sys_stream);
   make_type_link(sys_bytedata     ,built_in); /* DENYS: BYTEDATA */
 }

void make_type_link	(	ptr_definition	t1,
		ptr_definition	t2
	)

make_type_link

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2

MAKE_TYPE_LINK(t1,t2) Assert that T1 <| T2, this is used to initialise the built_in type relations so that nothing really horrible happens if the user modifies built-in types such as INT or LIST. This routine also makes sure that top has no links.

Definition at line 901 of file types.c.

References wl_definition::children, cons(), wl_definition::parents, top, and type_member().

 {
   if (t2!=top && !type_member(t2,t1->parents))
     t1->parents=cons((GENERIC)t2,t1->parents);
   if (t2!=top && !type_member(t1,t2->children))
     t2->children=cons((GENERIC)t1,t2->children);
 }

ptr_goal makeGoal ( ptr_psi_term p )

makeGoal

Parameters

p	- ptr_psi_term p

Definition at line 646 of file bi_sys.c.

References DEFRULES, goal_stack, wl_goal::next, NULL, prove, and push_goal().

 {
   ptr_goal old = goal_stack;
   ptr_goal g;
     
   push_goal(prove, p,(ptr_psi_term) DEFRULES,(GENERIC) NULL);
   g = goal_stack;
   g->next=NULL;
   goal_stack = old;
   return g;
 }

ptr_psi_term makePsiList	(	GENERIC	head,
		ptr_psi_term(*)()	valueFunc,
		GENERIC(*)()	nextFunc
	)

makePsiList

Parameters

head	- GENERIC head
*valueFunc	- ptr_psi_term (*valueFunc)()
nextFunc	- GENERIC (*nextFunc)()

Definition at line 590 of file bi_sys.c.

References stack_cons(), and stack_nil().

 {
   ptr_psi_term result;
 
   
   /*  RM: Dec 14 1992: Added the new list representation  */
   result=stack_nil();
   
   while (head) {
     result=stack_cons((*valueFunc)(head),result);
     head=(*nextFunc)(head);
   }
   return result;
 }

ptr_psi_term makePsiTerm ( ptr_definition x )

ptr_psi_term makePsiTerm

Parameters

x	- ptr_definition x

Definition at line 573 of file bi_sys.c.

References stack_psi_term(), and wl_psi_term::type.

 {
   ptr_psi_term p;
     
   p = stack_psi_term(4);
   p->type = x;
   return p;
 }

void mark_ancestors	(	ptr_definition	def,
		long *	flags
	)

mark_ancestors

Parameters

def	- ptr_definition def
flags	- long *flags

Set flags bit for all ancestors (i.e., higher up) of head

Definition at line 60 of file lub.c.

References bit_length(), wl_definition::code, wl_int_list::next, wl_definition::parents, and wl_int_list::value_1.

 {
   ptr_int_list par;
   
   par=def->parents;
   while (par) {
     ptr_definition p;
     long len;
   
     p=(ptr_definition)par->value_1;
     len=bit_length(p->code);
     if (!flags[len]) {
       flags[len]=1;
       mark_ancestors(p, flags);
     }
     par=par->next;
   }
 }

void mark_eval ( ptr_psi_term t )

mark_eval

Parameters

t	- ptr_psi_term t

A (possibly) correct mark_eval and its companion mark_quote.

The translation table is used to record whether a subgraph has already been quoted or not. Mark a psi-term as to be evaluated (i.e. strict), except for arguments of a nonstrict term, which are marked quoted. Set status correctly and propagate zero status upwards. Avoid doing superfluous work: non-shared terms are traversed once; shared terms are traversed at most twice (this only occurs if the first occurrence encountered is strict and a later occurrence is nonstrict). The translation table is used to indicate (1) whether a term has already been traversed, and if so, (2) whether there was a nonstrict traversal (in that case, the info field is FALSE).

Definition at line 498 of file copy.c.

References clear_copy(), FALSE, mark_eval_new(), and mark_nonstrict_flag.

 {
   clear_copy();
   mark_nonstrict_flag=FALSE;
   mark_eval_new(t);
 }

void mark_eval_new ( ptr_psi_term t )

mark_eval_new

Parameters

t	- ptr_psi_term t

Definition at line 540 of file copy.c.

References wl_psi_term::attr_list, curr_status, deref_ptr, wl_definition::evaluate_args, FALSE, wl_psi_term::flags, function_it, global_it, insert_translation(), mark_eval_tree_new(), mark_nonstrict_flag, mark_quote_new(), mark_quote_tree_new(), wl_definition::properties, QUOTED_TRUE, wl_psi_term::status, translate(), TRUE, wl_psi_term::type, wl_definition::type_def, and type_it.

 {
   long *infoptr,flag;
   ptr_psi_term u;
   long old_status;
 
   if (t) {
     deref_ptr(t);
     flag = t->type->evaluate_args;
     u=translate(t,&infoptr);
     if (u) {
       /* Quote the subgraph if it was already copied as to be evaluated. */
       if (!flag && *infoptr) {
         mark_quote_new(t);
         *infoptr=FALSE;
       }
       /* If any subterm has zero curr_status (i.e., if t->status==0),
      then so does the whole term: PVR 14.2.94 */
       old_status=curr_status;
       curr_status=(long)t->status;
       if (curr_status) curr_status=old_status;
     }
     else {
       insert_translation(t,(ptr_psi_term)TRUE,flag);
       old_status=curr_status;
       curr_status=4;
 
       if (flag) /* 16.9 */
         mark_eval_tree_new(t->attr_list);
       else
     mark_quote_tree_new(t->attr_list);
 
       switch((long)t->type->type_def) {
       case type_it:
         if (t->type->properties)
           curr_status=0;
         break;
     
       case function_it:
         curr_status=0;
         break;
 
       case global_it: /*  RM: Feb  8 1993  */
         curr_status=0;
         break;
 
       default:
     break;
       }
       if (mark_nonstrict_flag) { /* 25.8 */
         if (curr_status) {
           /* Only increase the status, never decrease it: */
           t->status=curr_status;
         }
       }
       else {
         t->status=curr_status;
         t->flags=curr_status?QUOTED_TRUE:FALSE; /* 14.9 */
       }
       /* If any subterm has zero curr_status, then so does the whole term: */
       if (curr_status) curr_status=old_status;
     }
   }
 }

void mark_eval_tree_new ( ptr_node n )

mark_eval_tree_new

Parameters

n	- ptr_node n

Definition at line 611 of file copy.c.

References wl_node::data, wl_node::left, mark_eval_new(), mark_eval_tree_new(), and wl_node::right.

 {
   if (n) {
     mark_eval_tree_new(n->left);
     mark_eval_new((ptr_psi_term) (n->data));
     mark_eval_tree_new(n->right);
   }
 }

void mark_nonstrict ( ptr_psi_term t )

mark_nonstrict

Parameters

t	- ptr_psi_term t

Same as above, except that the status is only changed from 0 to 4 when needed; it is never changed from 4 to 0.

Definition at line 513 of file copy.c.

References clear_copy(), mark_eval_new(), mark_nonstrict_flag, and TRUE.

 {
   clear_copy();
   mark_nonstrict_flag=TRUE;
   mark_eval_new(t);
 }

void mark_quote ( ptr_psi_term t )

mark_quote

Parameters

t	- ptr_psi_term t

A more efficient version of mark_quote This version avoids using the translation table by setting a 'visited' in the status field. Mark a psi-term as completely evaluated.

Definition at line 674 of file copy.c.

References wl_psi_term::attr_list, wl_psi_term::coref, wl_psi_term::flags, mark_quote(), mark_quote_tree(), QUOTED_TRUE, RMASK, and wl_psi_term::status.

 {
   if (t && !(t->status&RMASK)) {
     t->status = 4;
     t->flags=QUOTED_TRUE; /* 14.9 */
     t->status |= RMASK;
     mark_quote(t->coref);
     mark_quote_tree(t->attr_list);
     t->status &= ~RMASK;
   }
 }

void mark_quote_c	(	ptr_psi_term	t,
		long	heap_flag
	)

mark_quote_c

Parameters

t	- ptr_psi_term t
heap_flag	- long heap_flag

The new mark_quote to be used from copy.

Meaning of the info field in the translation table: With u=translate(t,&infoptr): If infoptr==QUOTE_FLAG then the whole subgraph from u is quoted. If infoptr==EVAL_FLAG then anything is possible. If infoptr==QUOTE_STUB then the term does not exist yet, e.g., there is a cycle in the term & copy(...) has not created it yet, for example X:s(L,t(X),R), where non_strict(t), in which R does not exist when the call to mark_quote_c is done. When the term is later created, it must be created as quoted.

Mark a psi-term u (which is a copy of t) as completely evaluated. Only t is given as the argument. Assumes the psi-term is a copy of another psi-term t, which is made through eval_copy. Therefore the copy is accessible through the translation table. Assumes all translation table entries already exist. The infoptr field is updated so that each subgraph is only traversed once. This routine is called only from the main copy routine.

Definition at line 434 of file copy.c.

References wl_psi_term::attr_list, deref_ptr, EVAL_FLAG, wl_psi_term::flags, insert_translation(), mark_quote_tree_c(), NEW, QUOTE_FLAG, QUOTE_STUB, QUOTED_TRUE, wl_psi_term::status, and translate().

 {
   //  ptr_list l;
   long *infoptr;
   ptr_psi_term u;
 
   if (t) {
     deref_ptr(t);
     u=translate(t,&infoptr);
     /* assert(u!=NULL); 15.9 */
     if (u) {
       if (*infoptr==EVAL_FLAG) {
         *infoptr=QUOTE_FLAG;
         u->status=4;
         u->flags=QUOTED_TRUE; /* 14.9 */
         mark_quote_tree_c(t->attr_list,heap_flag);
       }
     }
     else { /* u does not exist yet */ /* 15.9 */
       /* Create a stub & mark it as to-be-quoted. */
       u=NEW(t,psi_term);
       insert_translation(t,u,QUOTE_STUB);
     }
   }
 }

void mark_quote_new ( ptr_psi_term t )

mark_quote_new

Parameters

t	- ptr_psi_term t

Definition at line 626 of file copy.c.

References wl_psi_term::attr_list, deref_ptr, FALSE, wl_psi_term::flags, insert_translation(), mark_quote_tree_new(), QUOTED_TRUE, wl_psi_term::status, translate(), and TRUE.

 {
   long *infoptr;
   ptr_psi_term u;
 
   if (t) {
     deref_ptr(t);
     u=translate(t,&infoptr);
 
     /* Return if the subgraph is already quoted. */
     if (u && !*infoptr) return;
 
     /* Otherwise quote the subgraph */
     if (!u) insert_translation(t,(ptr_psi_term)TRUE,FALSE);
     else *infoptr = FALSE;  /* sanjay */
     t->status= 4;
     t->flags=QUOTED_TRUE; /* 14.9 */
     mark_quote_tree_new(t->attr_list);
   }
 }

void mark_quote_new2 ( ptr_psi_term t )

mark_quote_new2

Parameters

t	- ptr_psi_term t

Mark a term as quoted.

Definition at line 527 of file copy.c.

References clear_copy(), FALSE, mark_nonstrict_flag, and mark_quote_new().

 {
   clear_copy();
   mark_nonstrict_flag=FALSE;
   mark_quote_new(t);
 }

void mark_quote_tree ( ptr_node t )

mark_quote_tree

Parameters

t	- ptr_node t

Definition at line 692 of file copy.c.

References wl_node::data, wl_node::left, mark_quote(), mark_quote_tree(), and wl_node::right.

 {
   if (t) {
     mark_quote_tree(t->left);
     mark_quote((ptr_psi_term) (t->data));
     mark_quote_tree(t->right);
   }
 }

void mark_quote_tree_c	(	ptr_node	n,
		long	heap_flag
	)

mark_quote_tree_c

Parameters

n	- ptr_node n
heap_flag	- long heap_flag

Definition at line 467 of file copy.c.

References wl_node::data, wl_node::left, mark_quote_c(), mark_quote_tree_c(), and wl_node::right.

 {
   if (n) {
     mark_quote_tree_c(n->left,heap_flag);
     mark_quote_c((ptr_psi_term) (n->data),heap_flag);
     mark_quote_tree_c(n->right,heap_flag);
   }
 }

void mark_quote_tree_new ( ptr_node n )

mark_quote_tree_new

void mark_quote_tree_new(ptr_node n)

Parameters

n	- ptr_node n

Definition at line 653 of file copy.c.

References wl_node::data, wl_node::left, mark_quote_new(), mark_quote_tree_new(), and wl_node::right.

 {
   if (n) {
     mark_quote_tree_new(n->left);
     mark_quote_new((ptr_psi_term) (n->data));
     mark_quote_tree_new(n->right);
   }
 }

void mark_tab ( ptr_tab_brk t )

mark_tab

Parameters

t	- ptr_tab_brk t

MARK_TAB(t) Mark a tabbing position T. Make the current item point to tabbing position T.

Definition at line 573 of file print.c.

References end_tab(), indx, and wl_item::tab.

 {
   end_tab();
   indx->tab=t;
 }

long match_aim ( )

match_aim

long match_aim() MATCH_AIM() This is very similar to UNIFY_AIM, only matching cannot modify the calling psi_term. The first argument is the calling term (which may not be changed) and the second argument is the function definition (which may be changed). Residuate the expression if the calling term is more general than the function definition.

Definition at line 770 of file lefun.c.

References wl_goal::aaaa_1, aim, wl_psi_term::attr_list, attr_missing, wl_goal::bbbb_1, can_curry, wl_goal::cccc_1, wl_psi_term::coref, curried, cut, deref_ptr, FALSE, FUNC_ARG, integer, match_attr(), matches(), NULL, overlap_type(), quoted_string, REAL, real, resid_aim, residuate_double(), restore_resid(), save_resid(), sys_bytedata, TRUE, wl_psi_term::type, and wl_psi_term::value_3.

 {
   long success=TRUE;
   ptr_psi_term u,v; // ,tmp;
   REAL r;
   long /* less, */ lesseq;
   ptr_resid_block rb;
   ptr_psi_term match_date;
   
   u=(ptr_psi_term )aim->aaaa_1;
   v=(ptr_psi_term )aim->bbbb_1;
   deref_ptr(u);
   deref_ptr(v);
   rb=(ptr_resid_block)aim->cccc_1;
   restore_resid(rb,&match_date);
   
   if (u!=v) {
     if ((success=matches(u->type,v->type,&lesseq))) {
       if (lesseq) {
         if (u->type!=cut || v->type!=cut) { /* Ignore value field for cut! */
           if (v->value_3) {
             if (u->value_3) {
               if (overlap_type(v->type,real))
                 success=(*((REAL *)u->value_3)==(*((REAL *)v->value_3)));
               else if (overlap_type(v->type,quoted_string))
                 success=(strcmp((char *)u->value_3,(char *)v->value_3)==0);
           /* DENYS: BYTEDATA */
               else if (overlap_type(v->type,sys_bytedata)) {
         unsigned long ulen = *((unsigned long *) u->value_3);
         unsigned long vlen = *((unsigned long *) v->value_3);
                 success=(ulen==vlen && bcmp((char *)u->value_3,(char *)v->value_3,ulen)==0);
           }
             }
             else
               residuate_double(u,v);
           }
         }
       }
       else if (u->value_3) {
         /* Here we have U <| V but U and V have values which cannot match. */
         success=TRUE;
           
         if (v->value_3) {
           if (overlap_type(v->type,real))
             success=(*((REAL *)u->value_3)==(*((REAL *)v->value_3)));
         }
         else if (overlap_type(u->type,integer)) {
           r= *((REAL *)u->value_3);
           success=(r==floor(r));
         }
           
         if (success) residuate_double(u,v);
       } 
       else
         residuate_double(u,v);
                   
       if (success) {
         if (FUNC_ARG(u) && FUNC_ARG(v)) { /*  RM: Feb 10 1993  */
           /* residuate2(u,v); 21.9 */
           residuate_double(u,v); /* 21.9 */
           residuate_double(v,u); /* 21.9 */
     }
         else if (FUNC_ARG(v)) {  /*  RM: Feb 10 1993  */
           residuate_double(v,u); /* 21.9 */
         }
         else {
           v->coref=u;
         } /* 21.9 */
       attr_missing=FALSE;
       match_attr(&(u->attr_list),v->attr_list,rb);
       if (attr_missing) {
             if (can_curry)
               curried=TRUE;
             else
               residuate_double(u,v);
           }
         /* } 21.9 */
       }
     }
   }
 
   can_curry=FALSE;
   save_resid(rb,match_date); /* updated resid_block */
   /* This should be a useless statement: */
   resid_aim = NULL;
   
   return success;
 }

void match_attr	(	ptr_node *	u,
		ptr_node	v,
		ptr_resid_block	rb
	)

match_attr

Parameters

u	- ptr_node *u
v	- ptr_node v
rb	- ptr_resid_block rb

MATCH_ATTR(u,v) Match the attribute trees of psi_terms U and V. If V has an attribute that U doesn't then curry. U is the calling term, V is the definition. This routine is careful to push nested eval and match goals in descending order of feature names.

Definition at line 752 of file lefun.c.

References match_attr1(), match_attr2(), and match_attr3().

 {
   match_attr1(u,v,rb); /* Match corresponding arguments (third) */
   match_attr2(u,v,rb); /* Evaluate lone arguments (second) */
   match_attr3(u,v,rb); /* Evaluate corresponding arguments (first) */
 }

void match_attr1	(	ptr_node *	u,
		ptr_node	v,
		ptr_resid_block	rb
	)

void match_attr1

Parameters

u	- ptr_node *u
v	- ptr_node v
rb	- ptr_resid_block rb

Match the corresponding arguments

Definition at line 599 of file lefun.c.

References attr_missing, wl_node::data, featcmp(), wl_node::key, wl_node::left, match, NULL, push_goal(), wl_node::right, and TRUE.

 {
   long cmp;
   ptr_node temp;
   
   if (v) {
     if (*u==NULL)
       attr_missing=TRUE;
     else {
       cmp=featcmp((*u)->key,v->key);
       if(cmp==0) {
         ptr_psi_term t;
     /* RESID */ match_attr1(&((*u)->right),v->right,rb);
         t = (ptr_psi_term) (*u)->data;
     /* RESID */ push_goal(match,(ptr_psi_term)(*u)->data,(ptr_psi_term)v->data,(GENERIC)rb);
         /* deref2_eval(t); */
     /* RESID */ match_attr1(&((*u)->left),v->left,rb);
       }
       else if (cmp>0) {
         temp=v->right;
         v->right=NULL;
     /* RESID */ match_attr1(u,temp,rb);
     /* RESID */ match_attr1(&((*u)->left),v,rb);
     v->right=temp;
       }
       else {
     temp=v->left;
     v->left=NULL;
     /* RESID */ match_attr1(&((*u)->right),v,rb);
     /* RESID */ match_attr1(u,temp,rb);
     v->left=temp;
       }
     }
   }
 }

void match_attr2	(	ptr_node *	u,
		ptr_node	v,
		ptr_resid_block	rb
	)

match_attr2

Parameters

u	- ptr_node *u
v	- ptr_node v
rb	- ptr_resid_block rb

Evaluate the lone arguments (for lazy failure + eager success)

Definition at line 644 of file lefun.c.

References wl_node::data, deref2_rec_eval(), featcmp(), wl_node::key, wl_node::left, match_attr1(), NULL, and wl_node::right.

 {
   long cmp;
   ptr_node temp;
   
   if (v) {
     if (*u==NULL) { /* PVR 12.03 */
       ptr_psi_term t;
       match_attr1(u,v->right,rb);
       t = (ptr_psi_term) v->data;
       deref2_rec_eval(t);
       match_attr1(u,v->left,rb);
     }
     else {
       cmp=featcmp((*u)->key,v->key);
       if(cmp==0) {
     /* RESID */ match_attr2(&((*u)->right),v->right,rb);
     /* RESID */ match_attr2(&((*u)->left),v->left,rb);
       }
       else if (cmp>0) {
         temp=v->right;
         v->right=NULL;
     /* RESID */ match_attr2(u,temp,rb);
     /* RESID */ match_attr2(&((*u)->left),v,rb);
     v->right=temp;
       }
       else {
     temp=v->left;
     v->left=NULL;
     /* RESID */ match_attr2(&((*u)->right),v,rb);
     /* RESID */ match_attr2(u,temp,rb);
     v->left=temp;
       }
     }
   }
   else if (*u!=NULL) {
     ptr_psi_term t /* , empty */ ;
     match_attr1(&((*u)->right),v,rb);
     t = (ptr_psi_term) (*u)->data;
     /* Create a new psi-term to put the (useless) result: */
     /* This is needed so that *all* arguments of a function call */
     /* are evaluated, which avoids incorrect 'Yes' answers.      */
     deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
     match_attr1(&((*u)->left),v,rb);
   }
 }

void match_attr3	(	ptr_node *	u,
		ptr_node	v,
		ptr_resid_block	rb
	)

match_attr3

Parameters

u	- ptr_node *u
v	- ptr_node v
rb	- ptr_resid_block rb

Evaluate the corresponding arguments

Definition at line 700 of file lefun.c.

References attr_missing, wl_node::data, deref2_eval(), featcmp(), wl_node::key, wl_node::left, NULL, wl_node::right, and TRUE.

 {
   long cmp;
   ptr_node temp;
   
   if (v) {
     if (*u==NULL)
       attr_missing=TRUE;
     else {
       cmp=featcmp((*u)->key,v->key);
       if(cmp==0) {
         ptr_psi_term t1,t2;
     /* RESID */ match_attr3(&((*u)->right),v->right,rb);
         t1 = (ptr_psi_term) (*u)->data;
         t2 = (ptr_psi_term) v->data;
     /* RESID */ /* push_goal(match,(*u)->data,v->data,rb); */
         deref2_eval(t1); /* Assumes goal_stack is already restored. */
         deref2_eval(t2); /* PVR 12.03 */
     /* RESID */ match_attr3(&((*u)->left),v->left,rb);
       }
       else if (cmp>0) {
         temp=v->right;
         v->right=NULL;
     /* RESID */ match_attr3(u,temp,rb);
     /* RESID */ match_attr3(&((*u)->left),v,rb);
     v->right=temp;
       }
       else {
     temp=v->left;
     v->left=NULL;
     /* RESID */ match_attr3(&((*u)->right),v,rb);
     /* RESID */ match_attr3(u,temp,rb);
     v->left=temp;
       }
     }
   }
 }

long matches	(	ptr_definition	t1,
		ptr_definition	t2,
		long *	smaller
	)

matches

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2
smaller	- long *smaller

MATCHES(t1,t2,s) Returns TRUE if GLB(t1,t2)!=bottom. Sets S to TRUE if type T1 is <| than type T2, that is if T1 matches T2.

Definition at line 1666 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, top, TRUE, and wl_int_list::value_1.

 {
   ptr_int_list c1,c2;
   long result=TRUE;
   
   *smaller=TRUE;
   
   if (t1!=t2)
     if (t2!=top)
       if (t1==top)
         *smaller=FALSE;
       else {
         c1=t1->code;
         c2=t2->code;
         result=FALSE;
         
         if (c1!=NOT_CODED && c2!=NOT_CODED) {          
           while (c1 && c2) {          
             if ((unsigned long)c1->value_1 &  (unsigned long)c2->value_1) result=TRUE;
             if ((unsigned long)c1->value_1 & ~(unsigned long)c2->value_1) *smaller=FALSE;
             c1=c1->next;
             c2=c2->next;
           }
         }
         else
           *smaller=FALSE;
       }
   
   return result;
 }

long memory_check ( )

memory_check

MEMORY_CHECK() This function tests to see whether enough memory is available to allow execution to continue. It causes a garbage collection if not, and if that fails to release enough memory it returns FALSE.

Definition at line 1723 of file memory.c.

References fail_all(), FALSE, garbage(), GC_THRESHOLD, heap_pointer, stack_pointer, TRUE, and verbose.

 {
   long success=TRUE;
   
   if (heap_pointer-stack_pointer < GC_THRESHOLD) {
     if(verbose) fprintf(stderr,"\n"); /*  RM: Feb  1 1993  */
     garbage();
     /* Abort if didn't recover at least GC_THRESHOLD/10 of memory */
     if (heap_pointer-stack_pointer < GC_THRESHOLD+GC_THRESHOLD/10) {
       fprintf(stderr,"*********************\n");
       fprintf(stderr,"*** OUT OF MEMORY ***\n");
       fprintf(stderr,"*********************\n");
       fail_all();
       success=FALSE;
     }
   }
   return success;
 }

void merge	(	ptr_node *	u,
		ptr_node	v
	)

merge

Parameters

u	- ptr_node *u
v	- ptr_node v

MERGE(u,v) U and V are two binary trees containing the attributes fields of psi-terms. U and V are merged together, that is U becomes the union of U and V: For each label L in V and L->Vpsi_term: If L is in U Then With L->Upsi_term Do unify(Upsi_term,Vpsi_term) Else merge L->Vpsi_term in U. Unification is simply done by appending the 2 psi_terms to the unification stack. All effects must be recorded in the trail so that they can be undone on backtracking.

Definition at line 1131 of file login.c.

References merge1(), merge2(), and merge3().

 {
   merge1(u,v); /* Unify corresponding arguments */
   merge2(u,v); /* Evaluate lone arguments (lazy failure + eager success) */
   merge3(u,v); /* Merge v's loners into u & evaluate corresponding arguments */
 }

void merge1	(	ptr_node *	u,
		ptr_node	v
	)

merge1

Parameters

u	- ptr_node *u
v	- ptr_node v

Unify the corresponding arguments

Definition at line 893 of file login.c.

References wl_node::data, featcmp(), wl_node::key, wl_node::left, NULL, push_goal(), wl_node::right, and unify.

 {
   long cmp;
   ptr_node temp;
   
   if (v) {
     if (*u==NULL) {
       /* push_ptr_value(int_ptr,u); */
       /* (*u)=STACK_ALLOC(node); */
       /* **u= *v; */
       /* more_v_attr=TRUE; */
     }
     else {
       cmp=featcmp((*u)->key,v->key);
       if (cmp==0) {
     if (v->right)
       merge1(&((*u)->right),v->right);
     
     push_goal(unify,(ptr_psi_term)(*u)->data,(ptr_psi_term)v->data,NULL);
     
     if (v->left)
       merge1(&((*u)->left),v->left);
       }
       else if (cmp>0) {
     temp=v->right;
     v->right=NULL;
     merge1(&((*u)->left),v);
     merge1(u,temp);
     v->right=temp;
       }
       else {
         temp=v->left;
         v->left=NULL;
         merge1(&((*u)->right),v);
         merge1(u,temp);
         v->left=temp;
       }
     }
   }
   else if (*u!=NULL) {
     /* more_u_attr=TRUE; */
   }
 }

merge2	(	ptr_node *	u,
		ptr_node	v
	)

merge2

Parameters

u	- ptr_node *u
v	- ptr_node v

Evaluate the lone arguments (For LAZY failure + EAGER success) Evaluate low numbered lone arguments first. For each lone argument in either u or v, create a new psi-term to put the (useless) result: This is needed so that all arguments of a uni- unified psi-term are evaluated, which avoids incorrect 'Yes' answers.

Definition at line 949 of file login.c.

References wl_node::data, deref2_rec_eval(), featcmp(), wl_node::key, wl_node::left, NULL, and wl_node::right.

 {
   long cmp;
   ptr_node temp;
   
   if (v) {
     if (*u==NULL) {
       ptr_psi_term t;
       merge2(u,v->right);
       t = (ptr_psi_term) v->data;
       deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
       merge2(u,v->left);
     }
     else {
       cmp=featcmp((*u)->key,v->key);
       if (cmp==0) {
     /* if (v->right) */
     merge2(&((*u)->right),v->right);
     
     /* if (v->left) */
     merge2(&((*u)->left),v->left);
       }
       else if (cmp>0) {
     temp=v->right;
     v->right=NULL;
     merge2(&((*u)->left),v);
     merge2(u,temp);
     v->right=temp;
       }
       else {
         temp=v->left;
         v->left=NULL;
         merge2(&((*u)->right),v);
         merge2(u,temp);
         v->left=temp;
       }
     }
   }
   else if (*u!=NULL) {
     ptr_psi_term t;
     merge2(&((*u)->right),v);
     t = (ptr_psi_term) (*u)->data;
     deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
     merge2(&((*u)->left),v);
   }
 }

void merge3	(	ptr_node *	u,
		ptr_node	v
	)

merge3

Parameters

u	- ptr_node *u
v	- ptr_node v

Merge v's loners into u and evaluate the corresponding arguments

Definition at line 1004 of file login.c.

References deref2_eval(), featcmp(), int_ptr, wl_node::key, wl_node::left, more_u_attr, more_v_attr, NULL, push_ptr_value(), wl_node::right, STACK_ALLOC, and TRUE.

 {
   long cmp;
   ptr_node temp;
   
   if (v) {
     if (*u==NULL) {
       push_ptr_value(int_ptr,(GENERIC *)u);
       (*u)=STACK_ALLOC(node);
       **u= *v;
       more_v_attr=TRUE;
     }
     else {
       ptr_psi_term t1; // ,t2;
       
       cmp=featcmp((*u)->key,v->key);
       if (cmp==0) {
     if (v->right)
       merge3(&((*u)->right),v->right);
     
         t1 = (ptr_psi_term) (*u)->data;
         /* t2 = (ptr_psi_term) v->data; */
         deref2_eval(t1);
         /* deref2_eval(t2); */
     /* push_goal(unify,(ptr_psi_term)(*u)->data,(ptr_psi_term)v->data,NULL); */
     
     if (v->left)
       merge3(&((*u)->left),v->left);
       }
       else if (cmp>0) {
     temp=v->right;
     v->right=NULL;
     merge3(&((*u)->left),v);
     merge3(u,temp);
     v->right=temp;
       }
       else {
         temp=v->left;
         v->left=NULL;
         merge3(&((*u)->right),v);
         merge3(u,temp);
         v->left=temp;
       }
     }
   }
   else if (*u!=NULL) {
     more_u_attr=TRUE;
   }
 }

void merge_unify	(	ptr_node *	u,
		ptr_node	v
	)

merge_unify

Parameters

u	- ptr_node *u
v	- ptr_node v

For built-ins.c

Definition at line 1146 of file login.c.

References merge1(), and merge3().

 {
   merge1(u,v); /* Unify corresponding arguments */
   merge3(u,v); /* Merge v's loners into u & evaluate corresponding arguments */
 }

long mod_warning	(	ptr_psi_term	arg,
		REAL	val,
		int	zero
	)

mod_warning

Parameters

arg	- ptr_psi_term arg
val	- REAL val
zero	- int zero

Definition at line 1041 of file error.c.

References Errorline(), nonint_warning(), and TRUE.

 {
   int err;
 
   err=nonint_warning(arg,val,"of modulo operation is not an integer");
   if(!err && zero && val==0) {
     Errorline("division by 0 in modulo operation\n");
     err=TRUE;
   }
   return err;
 }

void new_built_in	(	ptr_module	m,
		char *	s,
		def_type	t,
		long(*)()	r
	)

new_built_in

Parameters

m	- ptr_module m
s	- char *s
t	- def_type t
r	- long (*r)()

NEW_BUILT_IN(m,s,t,r) Add a new built-in predicate or function. Used also in x_pred.c

M=module. S=string. T=type (function or predicate). R=address of C routine to call.

Definition at line 5375 of file built_ins.c.

References built_in_index, c_rule, current_module, MAX_BUILT_INS, wl_definition::rule, set_current_module(), wl_definition::type_def, and update_symbol().

 {
   ptr_definition d;
   if (built_in_index >= MAX_BUILT_INS) {
     fprintf(stderr,"Too many primitives, increase MAX_BUILT_INS in extern.h\n");
     exit(EXIT_FAILURE);
   }
 
   if(m!=current_module)  /*  RM: Jan 13 1993  */
     (void)set_current_module(m);
   
   d=update_symbol(m,s); /* RM: Jan  8 1993 */
   d->type_def=t;
   built_in_index++;
   d->rule=(ptr_pair_list )built_in_index;
   c_rule[built_in_index]=r;
 }

ptr_definition new_definition ( ptr_keyword key )

new_definition

Parameters

key	- ptr_keyword key

NEW_DEFINITION(key) Create a definition for a key.

Definition at line 220 of file modules.c.

References wl_definition::already_loaded, wl_definition::always_check, wl_definition::children, wl_definition::code, wl_definition::date, wl_keyword::definition, wl_definition::evaluate_args, FALSE, first_definition, wl_definition::global_value, HEAP_ALLOC, wl_definition::init_value, wl_definition::keyword, wl_definition::next, NOT_CODED, NULL, wl_definition::op_data, wl_definition::parents, wl_definition::properties, wl_definition::protected, wl_definition::rule, TRUE, wl_definition::type_def, and undef_it.

 {
   ptr_definition result;
 
   
   /* printf("*** New definition: %s\n",key->combined_name); */
   
   /* Create a new definition */
   result=HEAP_ALLOC(struct wl_definition);
   
   /*  RM: Feb  3 1993  */
   result->next=first_definition; /* Linked list of all definitions */
   first_definition=result;
         
   result->keyword=key;
   result->rule=NULL;
   result->properties=NULL;
   result->date=0;
   result->type_def=(def_type)undef_it;
   result->always_check=TRUE;
   result->protected=TRUE;
   result->evaluate_args=TRUE;
   result->already_loaded=FALSE;
   result->children=NULL;
   result->parents=NULL;
   result->code=NOT_CODED;
   result->op_data=NULL;
   result->global_value=NULL; /*  RM: Feb  8 1993  */
   result->init_value=NULL;   /*  RM: Mar 23 1993  */
   key->definition=result;
 
   return result;
 }

ptr_psi_term new_psi_term	(	long	numargs,
		ptr_definition	typ,
		ptr_psi_term **	a1,
		ptr_psi_term **	a2
	)

new_psi_term

Parameters

numargs	- long numargs
typ	- ptr_definition typ
a1	- ptr_psi_term **a1
a2	- ptr_psi_term **a2

Return a psi term with one or two args, and the addresses of the args

Definition at line 5064 of file built_ins.c.

References wl_psi_term::attr_list, wl_node::data, wl_node::key, wl_node::left, NULL, one, wl_node::right, STACK_ALLOC, stack_psi_term(), two, and wl_psi_term::type.

 {
   ptr_psi_term t;
   ptr_node n1, n2;
 
   if (numargs==2) {
     n2 = STACK_ALLOC(node);
     n2->key = two;
     *a2 = (ptr_psi_term *) &(n2->data);
     n2->left = NULL;
     n2->right = NULL;
   }
   else
     n2=NULL;
 
   n1 = STACK_ALLOC(node);
   n1->key = one;
   *a1 = (ptr_psi_term *) &(n1->data);
   n1->left = NULL;
   n1->right = n2;
 
   t=stack_psi_term(4);
   t->type = typ;
   t->attr_list = n1;
 
   return t;
 }

void new_state ( ptr_psi_term * t )

new_state

Parameters

t	- ptr_psi_term *t

Create a new file state psi-term that reflects the current global state

Definition at line 372 of file token.c.

References current_module, CURRENT_MODULE, eof_flag, EOF_FLAG, heap_add_int_attr(), heap_add_psi_attr(), heap_add_str_attr(), heap_psi_term(), INPUT_FILE_NAME, input_file_name, input_stream, inputfilesym, lf_false, lf_true, LINE_COUNT, line_count, wl_module::module_name, null_psi_term, old_saved_char, OLD_SAVED_CHAR, old_saved_psi_term, OLD_SAVED_PSI_TERM, saved_char, SAVED_CHAR, saved_psi_term, SAVED_PSI_TERM, start_of_line, START_OF_LINE, stream, STREAM, wl_psi_term::type, and wl_psi_term::value_3.

 {
   ptr_psi_term t1;
 
   *t=heap_psi_term(4);
   (*t)->type=inputfilesym;
 
   t1=heap_psi_term(4);
   t1->type=stream;
   t1->value_3=(GENERIC)input_stream;
   heap_add_psi_attr(*t,STREAM,t1);
 
   /*  RM: Jan 27 1993  */
   heap_add_str_attr(*t,CURRENT_MODULE,current_module->module_name);
   
   /*
     printf("Creating new state for file '%s', module '%s'\n",
     input_file_name,
     current_module->module_name);
     */
   
   heap_add_str_attr(*t,INPUT_FILE_NAME,input_file_name);
   heap_add_int_attr(*t,LINE_COUNT,line_count);
   heap_add_int_attr(*t,SAVED_CHAR,saved_char);
   heap_add_int_attr(*t,OLD_SAVED_CHAR,old_saved_char);
 
   t1=saved_psi_term?saved_psi_term:null_psi_term;
   heap_add_psi_attr(*t,SAVED_PSI_TERM,t1);
 
   t1=old_saved_psi_term?old_saved_psi_term:null_psi_term;
   heap_add_psi_attr(*t,OLD_SAVED_PSI_TERM,t1);
 
   t1=heap_psi_term(4);
   t1->type=(eof_flag?lf_true:lf_false);
   heap_add_psi_attr(*t,EOF_FLAG,t1);
 
   t1=heap_psi_term(4);
   t1->type=(start_of_line?lf_true:lf_false);
   heap_add_psi_attr(*t,START_OF_LINE,t1);
 }

void new_step ( long newstep )

new_step

long newstep

Definition at line 713 of file error.c.

References FALSE, new_trace(), stepflag, and steptrace.

 {
   stepflag = newstep;
   printf("*** Single stepping is turned ");
   printf(stepflag?"on.\n":"off.\n");
   new_trace(stepflag);
   steptrace=FALSE;
 }

void new_tab ( ptr_tab_brk * t )

new_tab

Parameters

t	- ptr_tab_brk *t

NEW_TAB(t) Create a new tabulation mark T.

Definition at line 587 of file print.c.

References FALSE, and HEAP_ALLOC.

 {
   (*t)=HEAP_ALLOC(tab_brk);
   (*t)->broken=FALSE;
   (*t)->printed=FALSE;
   (*t)->column=0;
 }

void new_trace ( long newtrace )

new_trace

Parameters

newtrace - long newtrace

Definition at line 698 of file error.c.

References trace.

 {
   trace = newtrace;
   printf("*** Tracing is turned ");
   printf(trace?"on.":"off.");
   if (trace == 2) printf(" Only for Proves");
   printf("\n");
 }

long no_choices ( )

no_choices

Return TRUE iff the top choice point is a what_next choice point or if there are no choice points.

Definition at line 1945 of file login.c.

References choice_stack, wl_choice_point::goal_stack, NULL, wl_goal::type, and what_next.

 {
   return (choice_stack==NULL) || (choice_stack->goal_stack->type==what_next);
 }

long no_quote ( char * s )

no_quote

Parameters

s - char *s

Return TRUE if s does not have to be quoted, i.e., s starts with '_' or a lowercase symbol and contains all digits, letters, and '_'.

Definition at line 470 of file print.c.

References all_symbol(), FALSE, ISALPHA, LOWER, SINGLE, and TRUE.

 {
   if (!s[0]) return FALSE;
 
   if (s[0]=='%') return FALSE;
   if (SINGLE(s[0]) && s[1]==0) return TRUE;
   if (s[0]=='_'    && s[1]==0) return FALSE;
   if (all_symbol(s)) return TRUE;
 
   if (!LOWER(s[0])) return FALSE;
   s++;
   while (*s) {
     if (!ISALPHA(*s)) return FALSE;
     s++;
   }
   return TRUE;
 }

long nonint_warning	(	ptr_psi_term	arg,
		REAL	val,
		char *	msg
	)

nonint_warning

Parameters

arg	- ptr_psi_term arg
val	- REAL val
msg	- char *msg

Definition at line 974 of file error.c.

References FALSE, report_warning2(), and TRUE.

 {
   long err=FALSE;
 
   if (val!=floor(val)) {
     report_warning2(arg, msg);
     err=TRUE;
   }
   return err;
 }

void nonnum_warning	(	ptr_psi_term	t,
		ptr_psi_term	arg1,
		ptr_psi_term	arg2
	)

nonnum_warning

Parameters

t	- ptr_psi_term t
arg1	- ptr_psi_term arg1
arg2	- ptr_psi_term arg2

Give error message if there is an argument which cannot unify with/ a real number.

Definition at line 953 of file error.c.

References curried, overlap_type(), real, report_warning(), and wl_psi_term::type.

 {
   if (!curried && /* PVR 15.9.93 */
       ((arg1 && !overlap_type(arg1->type,real)) ||
        (arg2 && !overlap_type(arg2->type,real)))) {
     report_warning(t,"non-numeric argument(s)");
   }
 }

long num_choices ( )

num_choices

Return the number of choice points on the choice point stack

Definition at line 1956 of file login.c.

References choice_stack, and wl_choice_point::next.

 {
   long num;
   ptr_choice_point cp;
   
   num=0;
   cp=choice_stack;
   while (cp) {
     num++;
     cp=cp->next;
   }
   return num;
 }

long num_vars ( ptr_node vt )

num_vars

Parameters

vt	- ptr_node vt

Return the number of variables in the variable tree.

Definition at line 1976 of file login.c.

References wl_node::left, and wl_node::right.

 {
   return (vt?(num_vars(vt->left)+1+num_vars(vt->right)):0);
 }

ptr_node one_attr ( )

one_attr

Return an attr_list with one argument

Definition at line 5042 of file built_ins.c.

References wl_node::data, wl_node::key, wl_node::left, NULL, one, wl_node::right, and STACK_ALLOC.

 {
   ptr_node n;
 
   n = STACK_ALLOC(node);
   n->key = one;
   n->data = NULL; /* To be filled in later */
   n->left = NULL;
   n->right = NULL;
 
   return n;
 }

void one_pass_always_check ( long * ch )

one_pass_always_check

Parameters

ch	- long *ch ONE_PASS_ALWAYS_CHECK(ch) Go through the symbol table & propagate all FALSE always_check flags of all sorts to their children. Return a TRUE flag if a change was made somewhere (for the closure calculation).

Definition at line 1049 of file types.c.

References wl_definition::always_check, first_definition, wl_definition::next, propagate_always_check(), wl_definition::type_def, and type_it.

 {
   ptr_definition d;
   
   
   for(d=first_definition;d;d=d->next)
     if (d->type_def==(def_type)type_it && !d->always_check)
       propagate_always_check(d,ch);
 }

long only_arg1	(	ptr_psi_term	t,
		ptr_psi_term *	arg1
	)

only_arg1

Parameters

t	- ptr_psi_term t
arg1	- ptr_psi_term * arg1

Return TRUE iff t has only argument "1", and return the argument.

Definition at line 1605 of file built_ins.c.

References wl_psi_term::attr_list, wl_node::data, FALSE, featcmp(), wl_node::key, wl_node::left, NULL, one, wl_node::right, and TRUE.

 {
   ptr_node n=t->attr_list;
 
   if (n && n->left==NULL && n->right==NULL && !featcmp(n->key,one)) {
     *arg1=(ptr_psi_term)n->data;
     return TRUE;
   }
   else
     return FALSE;
 }

long opcheck	(	ptr_psi_term	t,
		long *	prec,
		long *	type
	)

opcheck

Parameters

t	- ptr_psi_term t
prec	- long *prec
type	- long *type)

Get information about an operator. If t is an operator with the correct arguments, return one of {INFIX, PREFIX, POSTFIX} and also its precedence and type. If t is not an operator, or it has wrong arguments, return NOTOP and prec=0.

Definition at line 913 of file print.c.

References wl_psi_term::attr_list, check_opargs(), fx, fy, INFIX, wl_operator_data::next, NOTOP, NULL, wl_definition::op_data, POSTFIX, wl_operator_data::precedence, PREFIX, wl_psi_term::type, xf, xfx, xfy, yf, and yfx.

 {
   long op;
   long result=NOTOP;
   long numarg=check_opargs(t->attr_list);
   ptr_operator_data opdat=t->type->op_data;
 
   *prec=0;
   if (numarg!=1 && numarg!=3) return NOTOP;
   while (opdat) {
     op=opdat->type;
     if (numarg==1) {
       if (op==xf || op==yf) { result=POSTFIX; break; }
       if (op==fx || op==fy) { result=PREFIX; break; }
     }
     if (numarg==3)
       if (op==xfx || op==xfy || op==yfx) { result=INFIX; break; }
     opdat=opdat->next;
   }
   if (opdat==NULL) return NOTOP;
   *prec=opdat->precedence;
   *type=op;
   return result;
 }

long open_input_file ( char * file )

open_input_file

Parameters

file	- char *file

OPEN_INPUT_FILE(file) Open the input file specified by the string FILE. If the file is "stdin", restore the stdin state. Otherwise, open the file and create a new global state for it. If the file can't be opened, print an error and open "stdin" instead.

Definition at line 594 of file token.c.

References Errorline(), expand_file_name(), FALSE, init_parse_state(), input_file_name, input_state, input_stream, new_state(), noisy, NULL, restore_state(), save_state(), stdin_state, and TRUE.

 {
   long ok=TRUE;
   long stdin_flag;
 
   /* Save global input file state */
   if (input_state!=NULL) save_state(input_state);
 
   file=expand_file_name(file);
   
   if ((stdin_flag=(!strcmp(file,"stdin")))) {
     input_stream=stdin;
     noisy=TRUE;
   }
   else {
     input_stream=fopen(file,"r");
     noisy=FALSE;
   }
   
   if (input_stream==NULL) {
     Errorline("file '%s' does not exist.\n",file);
     file="stdin";
     input_stream=stdin;
     noisy=TRUE;
     ok=FALSE;
   }
 
   if (!stdin_flag || stdin_state==NULL) {
     /* Initialize a new global input file state */
     strcpy(input_file_name,file);
     init_parse_state();
     /* Create a new state containing the new global values */
     new_state(&input_state);
     if (stdin_flag) stdin_state=input_state;
   }
   else {
     input_state=stdin_state;
     restore_state(input_state);
   }
 
   return ok;
 }

void open_module_one	(	ptr_psi_term	t,
		int *	onefailed
	)

open_module_one

Parameters

t	= ptr_psi_term t
onefailed	- int *onefailed

Definition at line 562 of file modules.c.

References wl_keyword::combined_name, wl_keyword::definition, Errorline(), FALSE, find_module(), hash_lookup(), HEAP_ALLOC, wl_int_list::next, wl_module::open_modules, wl_keyword::public, string_val(), wl_keyword::symbol, wl_module::symbol_table, TRUE, and wl_int_list::value_1.

 {
   ptr_module open_module;
   ptr_int_list opens;
   ptr_keyword key1,key2;
   int i;
   int found=FALSE;
 
   open_module=find_module(string_val(t));
   if (open_module) {
     
     for (opens=current_module->open_modules;opens;opens=opens->next)
     if (opens->value_1 == (GENERIC)open_module) {
       /* warningline("module \"%s\" is already open\n",
          open_module->module_name); */ /*  RM: Jan 27 1993  */
       found=TRUE;
     }
     
     if (!found) {
     opens=HEAP_ALLOC(struct wl_int_list);
     opens->value_1=(GENERIC)open_module;
     opens->next=current_module->open_modules;
     current_module->open_modules=opens;
 
     /* Check for name conflicts */
     /*  RM: Feb 23 1993  */
     for (i=0;i<open_module->symbol_table->size;i++)
       if ((key1=open_module->symbol_table->data[i]) && key1->public) {
         key2=hash_lookup(current_module->symbol_table,key1->symbol);
         if (key2 && key1->definition!=key2->definition)
           Errorline("symbol clash '%s' and '%s'\n",
             key1->combined_name,
             key2->combined_name);
       }
     }
   }
   else {
     Errorline("module \"%s\" not found\n",string_val(t));
     *onefailed=TRUE;
   }
 }

void open_module_tree	(	ptr_node	n,
		int *	onefailed
	)

open_module_tree

Parameters

n	- ptr_node n
onefailed	- int *onefailed

Definition at line 542 of file modules.c.

References wl_node::data, wl_node::left, open_module_one(), and wl_node::right.

 {
   if (n) {
     ptr_psi_term t;
     open_module_tree(n->left,onefailed);
 
     t=(ptr_psi_term)n->data;
     open_module_one(t,onefailed);
 
     open_module_tree(n->right,onefailed);
   }
 }

long open_output_file ( char * file )

void or_codes	(	ptr_int_list	u,
		ptr_int_list	v
	)

or_codes

Parameters

u	- ptr_int_list u
v	- ptr_int_list v

OR_CODES(code1,code2) Performs CODE1 := CODE1 or CODE2, 'or' being the binary logical operator on bits.

Definition at line 831 of file types.c.

References HEAP_ALLOC, wl_int_list::next, NULL, and wl_int_list::value_1.

 {
   while (v) {
     u->value_1= (GENERIC)(((unsigned long)(u->value_1)) | ((unsigned long)(v->value_1)));
     v=v->next;
     if (u->next==NULL && v) {
       u->next=HEAP_ALLOC(int_list);
       u=u->next;
       u->value_1=0;
       u->next=NULL;
     }
     else
       u=u->next;
   }
 }

void outputline	(	char *	format,
			...
	)

void outputline(char *format,...)

outputline

Parameters

format	- char *format
...

Definition at line 101 of file error.c.

References assert, display_psi(), FALSE, input_file_name, output_stream, parse_ok, perr_i(), perr_s(), print_code(), print_def_type(), print_operator_kind(), and psi_term_line_number.

 {
   va_list VarArg;
   // int l;     
   char buffer_loc[5];   
   char *p; 
   unsigned long lng2; 
   char *cptr; 
   ptr_int_list pil;  
   ptr_psi_term psi;  
   operator kind; 
   def_type t ; 
   va_start(VarArg,format);
   //  vinfoline(format,output_stream, VarArg);
   //  #define vinfoline(format, outfile, xxxx)  {   
   for (p=format;p &&  *p; p++) 
     { 
       if (*p == '%') 
     { 
       p++; 
       switch (*p) 
         { 
         case 'd': 
         case 'x': 
           buffer_loc[0] = '%'; 
           buffer_loc[1] = 'l'; 
           buffer_loc[2] = *p; 
           buffer_loc[3] = 0; 
           lng2 = va_arg(VarArg, long); 
           fprintf(output_stream, buffer_loc, lng2); 
           break; 
         case 's': 
           buffer_loc[0] = '%'; 
           buffer_loc[1] = *p; 
           buffer_loc[2] = 0; 
           cptr = va_arg(VarArg,char *); 
           fprintf(output_stream, buffer_loc, cptr); 
           break; 
         case 'C': 
           /* type coding as bin string */ 
           pil = va_arg(VarArg,ptr_int_list); 
           print_code(output_stream,pil); 
           break; 
         case 'P': 
           psi = va_arg(VarArg,ptr_psi_term); 
           display_psi(output_stream,psi); 
           break; 
         case 'O': 
           kind = va_arg(VarArg,operator); 
           print_operator_kind(output_stream,kind); 
           break; 
         case 'T': 
           assert(output_stream==stderr); 
           t = va_arg(VarArg,def_type); 
           print_def_type(t); 
           break; 
         case 'E': 
           assert(output_stream==stderr); 
           perr_i("near line %ld",psi_term_line_number); 
           if (strcmp(input_file_name,"stdin")) {       
         perr_s(" in file \042%s\042",input_file_name); 
           }                        
           parse_ok=FALSE;                      
           break;                           
         case '%':                          
           (void)putc(*p,output_stream);                
           break;                           
         default: 
           fprintf(output_stream,"<%c follows %% : report bug >", *p); 
           break; 
         } 
     } 
       else 
     (void)putc(*p,output_stream); 
     } 
   va_end(VarArg); 
 } 

long overlap_type	(	ptr_definition	t1,
		ptr_definition	t2
	)

overlap_type

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2

OVERLAP_TYPE(t1,t2) This function returns TRUE if GLB(t1,t2)!=bottom. This is essentially the same thing as GLB, only it's faster 'cause we don't care about the resulting code.

Definition at line 1579 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, top, TRUE, and wl_int_list::value_1.

 {
   ptr_int_list c1,c2;
   long result=TRUE;
   
   if (t1!=t2 && t1!=top && t2!=top) {
     
     c1=t1->code;
     c2=t2->code;
     result=FALSE;
 
     if (c1!=NOT_CODED && c2!=NOT_CODED) {     
       while (!result && c1 && c2) {          
         result=(((unsigned long)(c1->value_1)) & ((unsigned long)(c2->value_1)));
         c1=c1->next;
         c2=c2->next;
       }
     }
   }
   
   /*
   printf("overlap_type(%s,%s) => %ld\n",t1->def->keyword->symbol,t2->def->keyword->symbol,result);
   */
   
   return result;
 }

psi_term parse ( long * q )

parse

Parameters

q - long *q

PARSE(is_it_a_clause) This returns one clause or query from the input stream. It also indicates the type psi-term read, that is whether it was a clause or a query in the IS_IT_A_CLAUSE variable. This is the top level of the parser.

The whole parser is, rather like the psi_termiser, not too well written. It handles psi_terms rather than pointers which causes a lot of messy code and is somewhat slower.

Definition at line 907 of file parser.c.

References eof, EOLN, ERROR, FACT, FALSE, final_dot, final_question, mark_nonstrict(), NULL, parse_ok, parser_stack_index, prompt, put_back_char(), QUERY, read_char(), read_life_form(), read_token(), saved_char, saved_psi_term, stringparse, Syntaxerrorline(), TRUE, and wl_psi_term::type.

 {
   psi_term s,t,u;
   long c;
 
   parser_stack_index=0;
   parse_ok=TRUE;
 
   /*s=read_life_form('.','?');*/
   s=read_life_form(0,0);
 
   if (parse_ok) {
     if (s.type!=eof) {
       read_token(&t);
      
       /*
       if (equ_tokch(t,'?'))
     *q=QUERY;
       else if (equ_tokch(t,'.'))
     *q=FACT;
     */
 
       /*  RM: Jul  7 1993  */
       if (t.type==final_question)
     {
       *q=QUERY;
     }
       else if (t.type==final_dot)
     {      
       *q=FACT;
     }
       else 
     {
       if (stringparse) parse_ok=FALSE;
       else {
 
         /*
           perr("*** Syntax error ");psi_term_error();perr(": ");
           display_psi_stderr(&t);
           perr(".\n");
         */
         
         /*  RM: Feb  1 1993  */
         Syntaxerrorline("'%P' (%E)\n",&t);
         
       }
       *q=ERROR;
     }
     }
   }
   
   
   if (!parse_ok) {
     
     while (saved_psi_term!=NULL) read_token(&u);
 
     prompt="error>";
     while((c=read_char()) && c!=EOF && c!='.' && c!='?' && c!=EOLN) {}
 
     *q=ERROR;
   }
   else if (saved_char)
     do {
       c=read_char();
       if (c==EOLN)
         c=0;
       else if (c<0 || c>32) {
         put_back_char(c);
         c=0;
       }
     } while(c && c!=EOF);
 
   /* Make sure arguments of nonstrict terms are marked quoted. */
   if (parse_ok) mark_nonstrict(&s); /* 25.8 */
 
   /* mark_eval(&s); 24.8 XXX */
 
   /* Mark all the psi-terms corresponding to variables in the var_tree as    */
   /* quoted.  This is needed for correct parsing of inputs; otherwise vars   */
   /* that occur in an increment of a query are marked to be evaluated again! */
   /* mark_quote_tree(var_tree); 24.8 XXX */
 
   
   return s;
 }

psi_term parse_list	(	ptr_definition	typ,
		char	e,
		char	s
	)

parse_list

Parameters

typ	- ptr_definition typ
e	- char e
s	- char s

PARSE_LIST(type,end,separator)

This function provides a replacement for the function 'read_list'. It does not create the old (slightly more compact and a lot more complicated) list structure, but instead creates a generic psi-term with 2 features. The list is terminated by the atom 'nil'.

Example:

[a,b,c|d] -> cons(a,cons(b,cons(c,d))). [] -> nil {a;b;c} -> disj(a,disj(b,disj(c,{}))). {} -> {} = bottom

Example: TYP=disjunction, END="}", SEPARATOR=";" will read in disjunctions.

Example: TYP=list, END="]", SEPARATOR="," will read lists such as [1,2,a,b,c|d]

Definition at line 329 of file parser.c.

References wl_psi_term::attr_list, display_psi_stderr(), equ_tokc, equ_tokch, FALSE, FEATCMP, list_nil(), NULL, one, parse_ok, perr(), psi_term_error(), put_back_token(), read_life_form(), read_token(), stack_copy_psi_term(), stack_insert(), stringparse, two, and wl_psi_term::type.

 {
   ptr_psi_term car=NULL;
   ptr_psi_term cdr=NULL;
   psi_term result;
   psi_term t;
   char a;
 
   result=list_nil(typ); /*  RM: Feb  1 1993  */
   
   if (parse_ok) {
 
     /* Character used for building cons pairs */
     a='|'; /*  RM: Jan 11 1993  */
     
 
     read_token(&t);
 
     if(!equ_tokc(t,e)) {
 
       /* Read the CAR of the list */
       put_back_token(t);
       car=stack_copy_psi_term(read_life_form(s,a));
 
       /* Read the CDR of the list */
       read_token(&t);
       if(equ_tokch(t,s))
     cdr=stack_copy_psi_term(parse_list(typ,e,s));
       else if(equ_tokch(t,e))
     cdr=stack_copy_psi_term(list_nil(typ));
       else if(equ_tokch(t,'|')) {
     cdr=stack_copy_psi_term(read_life_form(e,0));
     read_token(&t);
     if(!equ_tokch(t,e)) {
       if (stringparse) parse_ok=FALSE;
       else {
         perr("*** Syntax error ");psi_term_error();
         perr(": bad symbol for end of list '");
         display_psi_stderr(&t);
         perr("'.\n");
         put_back_token(t);
       }
     }
       }
       else 
     if (stringparse) parse_ok=FALSE;
     else {
       perr("*** Syntax error ");psi_term_error();
       perr(": bad symbol in list '");
       display_psi_stderr(&t);
       perr("'.\n");
       put_back_token(t);
     }
 
       result.type=typ;
       if(car)
     (void)stack_insert(FEATCMP,one,&(result.attr_list),(GENERIC)car);
       if(cdr)
     (void)stack_insert(FEATCMP,two,&(result.attr_list),(GENERIC)cdr);
     }
   }
   
   return result;
 }

void pchoices ( )

pchoices

for debugging

Definition at line 94 of file memory.c.

References choice_stack, wl_choice_point::next, stack_pointer, and wl_choice_point::stack_top.

 {
   ptr_choice_point c;
   printf("stack pointer is: %lx\n",(unsigned long)stack_pointer);
   for(c=choice_stack;c;c=c->next)
     printf("\tc=%lx\ts=%lx\tg=%lx\tu=%lx\n",(unsigned long)c,(unsigned long)c->stack_top,(unsigned long)c->goal_stack,(unsigned long)c->undo_point);
 }

void perr ( char * str )

perr

Parameters

str	- char *str

Definition at line 763 of file error.c.

 {
   (void)fputs(str, stderr);
 }

void perr_i	(	char *	str,
		long	i
	)

perr_i

Parameters

str	- char *str
i	- long i

Definition at line 800 of file error.c.

 {
   fprintf(stderr,str,i);
 }

void perr_s	(	char *	s1,
		char *	s2
	)

perr_s

Parameters

s1	- char *s1
s2	- char *s2

Definition at line 775 of file error.c.

 {
   fprintf(stderr,s1,s2);
 }

void perr_s2	(	char *	s1,
		char *	s2,
		char *	s3
	)

perr_s2

Parameters

s1	- char *s1
s2	- char *s2
s3	- char *s3

Definition at line 788 of file error.c.

 {
   fprintf(stderr,s1,s2,s3);
 }

void perr_sort ( ptr_definition d )

perr_sort

Parameters

d	- ptr_definition d

Definition at line 933 of file types.c.

References wl_definition::keyword, perr_s(), and wl_keyword::symbol.

 {
   perr_s("%s",d->keyword->symbol);
 }

void perr_sort_cycle ( ptr_int_list anc )

perr_sort_cycle

Parameters

anc	- ptr_int_list anc

Definition at line 959 of file types.c.

References perr(), perr_sort(), perr_sort_list(), and wl_int_list::value_1.

 {
   perr_sort((ptr_definition)anc->value_1);
   perr(" <| ");
   perr_sort_list(anc);
 }

void perr_sort_list ( ptr_int_list anc )

perr_sort_list

Parameters

anc	- ptr_int_list anc

Definition at line 944 of file types.c.

References wl_int_list::next, perr(), perr_sort(), and wl_int_list::value_1.

 {
   if (anc) {
     perr_sort_list(anc->next);
     if (anc->next) perr(" <| ");
     perr_sort((ptr_definition)anc->value_1);
   }
 }

void persistent_error_check	(	ptr_node	n,
		int *	error
	)

persistent_error_check

Parameters

n	- ptr_node n
error	- int *error

Definition at line 2714 of file built_ins.c.

References wl_node::data, deref_ptr, error_psi_term, Errorline(), global_it, wl_node::left, persistent_error_check(), wl_node::right, TRUE, wl_psi_term::type, wl_definition::type_def, and undef_it.

 {
   if (n) {
     ptr_psi_term t;
     persistent_error_check(n->left, error);
 
     t=(ptr_psi_term)n->data;
     deref_ptr(t);
     if (t->type->type_def!=(def_type)undef_it && t->type->type_def!=(def_type)global_it) {
       Errorline("%T %P cannot be redeclared persistent (%E).\n",
         t->type->type_def,
         t);
       t->type=error_psi_term->type;
       *error=TRUE;
     }
 
     persistent_error_check(n->right, error);
   }
 }

void persistent_one ( ptr_psi_term t )

persistent_one

Parameters

t	- ptr_psi_term t

Definition at line 2759 of file built_ins.c.

References global_it, wl_definition::global_value, heap_pointer, heap_psi_term(), wl_psi_term::type, and wl_definition::type_def.

 {
   t->type->type_def=(def_type)global_it;
   if ((GENERIC)t->type->global_value<(GENERIC)heap_pointer)
     t->type->global_value=heap_psi_term(4);
 }

void persistent_tree ( ptr_node n )

persistent_tree

Parameters

n	- ptr_node n

Definition at line 2739 of file built_ins.c.

References wl_node::data, deref_ptr, wl_node::left, persistent_one(), persistent_tree(), and wl_node::right.

 {
   if (n) {
     ptr_psi_term t;
     persistent_tree(n->left);
 
     t=(ptr_psi_term)n->data;
     deref_ptr(t);
     persistent_one(t);
 
     persistent_tree(n->right);
   }
 }

long pop	(	ptr_psi_term	tok,
		long *	op
	)

pop

Parameters

tok	- ptr_psi_term tok
op	- long *op

POP(psi_term,op); This function pops PSI_TERM and OP off the parser stack and returns its precedence.

Definition at line 132 of file parser.c.

References error_psi_term, FALSE, int_stack, parse_ok, parser_stack_index, and psi_term_stack.

 {
   long r=0;
   
   if (parser_stack_index==0) {
     /*
       perr("*** Parser error ");
       psi_term_error();
       perr(": stack empty.\n");
     */
 
     (*tok)= *error_psi_term;
     parse_ok=FALSE;
   }
   else {
     (*tok)=psi_term_stack[parser_stack_index];
     (*op)=op_stack[parser_stack_index];
     r=int_stack[parser_stack_index];
     parser_stack_index--;
   }
   
   return r;
 }

long precedence	(	psi_term	tok,
		long	typ
	)

precedence

Parameters

tok	- psi_term tok
typ	- long typ

PRECEDENCE(tok,typ) This function returns the precedence of TOK if it is an operator of type TYP where TYP is FX XFX XF etc... Note that this allows both a binary and unary minus. The result is NOP if tok is not an operator.

Definition at line 180 of file parser.c.

References wl_operator_data::next, NOP, wl_definition::op_data, wl_operator_data::precedence, and wl_psi_term::type.

 {
   long r=NOP;
   ptr_operator_data o;
 
   o=tok.type->op_data;
   while(o && r==NOP) {
     if(typ==o->type)
       r=o->precedence;
     else
       o=o->next;
   }
   
   return r;
 }

long pred_clause	(	ptr_psi_term	t,
		long	r,
		ptr_psi_term	g
	)

pred_clause

Parameters

t	- ptr_psi_term t
r	- long r
g	- ptr_psi_term g

PRED_CLAUSE(ptr_psi_term t,long r,ptr_psi_term g) Set about finding a clause that unifies with psi_term T. This routine is used both for CLAUSE and RETRACT. If R==TRUE then delete the first clause which unifies with T.

Definition at line 2451 of file built_ins.c.

References wl_psi_term::attr_list, bk_mark_quote(), clause, del_clause, deref_ptr, Errorline(), FALSE, function_it, get_two_args(), wl_definition::keyword, predicate_it, push_goal(), redefine(), wl_definition::rule, stack_psi_term(), succeed, wl_keyword::symbol, TRUE, wl_psi_term::type, wl_definition::type_def, and undef_it.

 {
   long success=FALSE;
   ptr_psi_term head,body;
   
   bk_mark_quote(g); /*  RM: Apr  7 1993  */
   if (t) {
     deref_ptr(t);
     
     if (!strcmp(t->type->keyword->symbol,"->")) {
       get_two_args(t->attr_list,&head,&body);
       if (head) {
     deref_ptr(head);
     if (head && body &&
             (head->type->type_def==(def_type)function_it || head->type->type_def==(def_type)undef_it))
       success=TRUE;
       }
     }
     else if (!strcmp(t->type->keyword->symbol,":-")) {
       get_two_args(t->attr_list,&head,&body);
       if (head) {
         deref_ptr(head);
         if (head &&
             (head->type->type_def==(def_type)predicate_it || head->type->type_def==(def_type)undef_it)) {
           success=TRUE;
           if (!body) {
             body=stack_psi_term(4);
             body->type=succeed;
           }
         }
       }
     }
     /* There is no body, so t is a fact */
     else if (t->type->type_def==(def_type)predicate_it || t->type->type_def==(def_type)undef_it) {
       head=t;
       body=stack_psi_term(4);
       body->type=succeed;
       success=TRUE;
     }
   }
   
   if (success) {
     if (r) {
       if (redefine(head))
         push_goal(del_clause,head,body,(GENERIC)&(head->type->rule));
       else
         success=FALSE;
     }
     else
       push_goal(clause,head,body,(GENERIC)&(head->type->rule));
   }
   else
     Errorline("bad argument in %s.\n", (r?"retract":"clause"));
   
   return success;
 }

void pred_write ( ptr_node n )

pred_write

Parameters

n	- ptr_node n

PRED_WRITE(n) N is an attribute tree to be printed in one lump. This is called by WRITE.

For all write builtins I.e: write, writeq, pretty_write, pretty_writeq, write_err, writeq_err.

Definition at line 1469 of file print.c.

References FALSE, listing_flag, main_pred_write(), outfile, output_stream, and write_stderr.

 {
   listing_flag=FALSE;
   /* write_stderr=FALSE; */
   outfile=(write_stderr?stderr:output_stream);
   main_pred_write(n);
   (void)fflush(outfile);
 }

void pretty_attr	(	ptr_node	t,
		long	depth
	)

pretty_attr

Parameters

t	- ptr_node t
depth	- long depth

PRETTY_ATTR(t,depth) Pretty print the attributes. This calls DO_PRETTY_ATTR which does the real work.

Definition at line 1273 of file print.c.

References do_pretty_attr(), new_tab(), prettyf(), and two_or_more().

 {
   ptr_tab_brk new;
   long cnt=1;
 
   prettyf("(");
   new_tab(&new);
 
   do_pretty_attr(t,new,&cnt,two_or_more(t),depth);
 
   prettyf(")");
 }

void pretty_list	(	ptr_psi_term	t,
		long	depth
	)

pretty_list

Parameters

t	- ptr_psi_term t
depth	- long depth

PRETTY_LIST(t,depth) Pretty print a list. On entry we know that T is a legal CONS pair, so we can immediately print the opening bracket etc...

Definition at line 734 of file print.c.

References alist, wl_psi_term::attr_list, check_legal_cons(), COMMA_PREC, wl_node::data, deref_ptr, disj_nil, disjunction, DOTDOT, equal_types, FALSE, find(), get_two_args(), INTCMP, wl_definition::keyword, mark_tab(), MAX_PRECEDENCE, new_tab(), nil, overlap_type(), pointer_names, pretty_symbol(), pretty_tag_or_psi_term(), prettyf(), print_depth, TRUE, and wl_psi_term::type.

 {
   ptr_tab_brk new;
   ptr_definition t_type;
   ptr_psi_term car,cdr;
   ptr_node n; 
   char sep[4],end[3];
   long list_depth; /* 20.8 */
   long done=FALSE; /* RM: Dec 11 1992 */
   
   strcpy(sep,"ab");
   strcpy(end,"cd");
   t_type=t->type;
   
   if (overlap_type(t_type,alist)) {
     if (!equal_types(t_type,alist)) {
       pretty_symbol(t_type->keyword);  /*  RM: Jan 13 1993  */
       prettyf(DOTDOT);
     }
     prettyf("[");
     strcpy(sep,",");
     strcpy(end,"]");
   }
 
   /*
     else if (equal_types(t_type,conjunction)) {
       prettyf("(");
       strcpy(sep,DOTDOT);
       strcpy(end,")");
       }
       */
   
   else if (equal_types(t_type,disjunction)) {
     prettyf("{");
     strcpy(sep,";");
     strcpy(end,"}");
   }
 
   
   /* RM: Dec 11 1992  New code for printing lists */
   
   new_tab(&new);
   list_depth=0; /* 20.8 */
   while(!done) {
     mark_tab(new);
     if(list_depth==print_depth)
       prettyf("...");
 
     get_two_args(t->attr_list,&car,&cdr);
     deref_ptr(car);
     deref_ptr(cdr);
 
     
     if(list_depth<print_depth)
       pretty_tag_or_psi_term(car,COMMA_PREC,depth);
     
     /* Determine how to print the CDR */
     n=find(INTCMP,(char *)cdr,pointer_names);
     
     if(n && n->data) {
       prettyf("|");
       pretty_tag_or_psi_term(cdr,MAX_PRECEDENCE+1,depth);
       done=TRUE;
     }
     else
       if(( /*  RM: Feb  1 1993  */
       (cdr->type==nil && overlap_type(t_type,alist)) ||
       (cdr->type==disj_nil && t_type==disjunction)
       )
       && !cdr->attr_list)
     done=TRUE;
       else
     if(!check_legal_cons(cdr,t_type)) {
       prettyf("|");
       pretty_tag_or_psi_term(cdr,MAX_PRECEDENCE+1,depth);
       done=TRUE;
     }
     else {
       if(list_depth<print_depth)
         prettyf(sep);
       t=cdr;
     }
     
     list_depth++;
   }
   
   prettyf(end);
 }

void pretty_output ( )

pretty_output

PRETTY_OUTPUT() Final output of all these pretty things which have been built up.

Definition at line 1293 of file print.c.

References wl_tab_brk::broken, wl_tab_brk::column, indx, outfile, wl_tab_brk::printed, wl_item::str, wl_item::tab, and TRUE.

 {
   ptr_item i;
   long j;
   
   for(i=pretty_things+1;(unsigned long)i<(unsigned long)indx;i++) {
     if(i->tab->broken && i->tab->printed) {
       fprintf(outfile,"\n");
       for(j=0;j<i->tab->column;j++)
     fprintf(outfile," ");
     }
     fprintf(outfile,"%s",i->str);
     i->tab->printed=TRUE;
   }
 }

void pretty_psi_term	(	ptr_psi_term	t,
		long	sprec,
		long	depth
	)

pretty_psi_term

Parameters

t	- ptr_psi_term t
sprec	- long sprec
depth	- long depth

PRETTY_PSI_TERM(t,sprec,depth) Pretty print a psi_term T with sugar for lists.

Definition at line 1058 of file print.c.

References wl_goal::aaaa_1, alist, wl_psi_term::attr_list, check_legal_cons(), cut, deref_ptr, disj_nil, disjunction, display_persistent, DOTDOT, eof, equal_types, FALSE, wl_residuation::goal, heap_pointer, integer, wl_definition::keyword, wl_residuation::next, nil, wl_goal::pending, pretty_attr(), pretty_list(), pretty_psi_with_ops(), pretty_quote_symbol(), pretty_symbol(), prettyf(), prettyf_quoted_string(), print_depth, PRINT_POWER, PRINT_SPLIT, quoted_string, REAL, real, wl_psi_term::resid, seg_format, stream, STRLEN, sub_type(), sys_bytedata, wl_psi_term::type, wl_psi_term::value_3, WL_MAXINT, and write_canon.

 {
   char buf[STRLEN]; /* Big enough for a long number */
   ptr_residuation r;
   long argswritten;
   //  double fmod();
   
   if (t) {
     deref_ptr(t); /* PVR */
 
     /* if (trace) printf("<%ld>",t->status); For brunobug.lf PVR 14.2.94 */
 
     /*  RM: Feb 12 1993  */
     if(display_persistent &&
        (GENERIC)t>heap_pointer)
       prettyf(" $");
     
     if((t->type==alist || t->type==disjunction) && check_legal_cons(t,t->type))
       pretty_list(t,depth+1); /*  RM: Dec 11 1992  */
     else
       if(t->type==nil && !t->attr_list)
     prettyf("[]");
       else
     if(t->type==disj_nil && !t->attr_list) /*  RM: Feb  1 1993  */
       prettyf("{}");
     else {
     argswritten=FALSE;
     if (t->value_3) {
 #ifdef CLIFE
       if(t->type->type==block) {  /* RM 20 Jan 1993 */
             pretty_block(t);          /* AA 21 Jan 1993 */
       }
       else
 #endif /* CLIFE */
       if (sub_type(t->type,integer)) {
         /* Print integers in chunks up to the full precision of the REAL */
         long seg,neg,i;
         REAL val;
         char segbuf[100][PRINT_POWER+3];
         
         val = *(REAL *)t->value_3;
         neg = (val<0.0);
         if (neg) val = -val;
         if (val>WL_MAXINT) goto PrintReal;
         seg=0;
         while (val>=(double)PRINT_SPLIT) {
           double tmp;
           tmp=(REAL)fmod((double)val,(double)PRINT_SPLIT);
           (void)snprintf(segbuf[seg],100,seg_format,(unsigned long)tmp);
           val=floor(val/(double)PRINT_SPLIT);
           seg++;
         }
         (void)snprintf(segbuf[seg],100,"%s%ld",(neg?"-":""),(unsigned long)val);
         for (i=seg; i>=0; i--) prettyf(segbuf[i]);
         if (!equal_types(t->type,integer)) {
           prettyf(DOTDOT);
           pretty_symbol(t->type->keyword); /*  RM: Jan 13 1993  */
         }
       }
       else if (sub_type(t->type,real)) {
       PrintReal:
         (void)snprintf(buf,STRLEN,"%lg",*(REAL *)t->value_3);
         prettyf(buf);
         if (!equal_types(t->type,real) &&
         !equal_types(t->type,integer)) {
           prettyf(DOTDOT);
           pretty_symbol(t->type->keyword); /*  RM: Jan 13 1993  */
         }
       }
       else if (sub_type(t->type,quoted_string)) {
         prettyf_quoted_string((char *)t->value_3);
         if(!equal_types(t->type,quoted_string)) {
           prettyf(DOTDOT);
           pretty_quote_symbol(t->type->keyword); /*  RM: Jan 13 1993  */
         }
       }
       /* DENYS: BYTEDATA */
       else if (sub_type(t->type,sys_bytedata)) {
         pretty_quote_symbol(t->type->keyword);
       }
       else if (equal_types(t->type,stream)) {
         (void)snprintf(buf,STRLEN,"stream(%ld)",(long)t->value_3);
         prettyf(buf);
       }
       else if (equal_types(t->type,eof))
         pretty_quote_symbol(eof->keyword); /*  RM: Jan 13 1993  */
       else if (equal_types(t->type,cut))
         pretty_quote_symbol(cut->keyword); /*  RM: Jan 13 1993  */
       else {
         prettyf("*** bad object '");
         pretty_symbol(t->type->keyword); /*  RM: Jan 13 1993  */
         prettyf("'***");
       }
     }
     else {
       if (depth<print_depth) /* 20.8 */
         argswritten=pretty_psi_with_ops(t,sprec,depth+1);
       /*  RM: Jan 13 1993  */
       if (!argswritten) pretty_quote_symbol(t->type->keyword);
     }
     
     /* write_canon -- PVR 24.2.94 */
     if (!argswritten && t->attr_list &&
         (depth<print_depth || write_canon)) /* 20.8 */
       pretty_attr(t->attr_list,depth+1);
     
     if (depth>=print_depth && !write_canon && t->attr_list) /* 20.8 */
       prettyf("(...)");
       }
     if ((r=t->resid))
       while (r) {
     if (r->goal->pending) {
           if (FALSE /* write_resids 11.8 */) {
         prettyf("\\");
         pretty_psi_term(r->goal->aaaa_1,0,depth);
           }
           else
         prettyf("~");
     }
     r=r->next;
       }
   }
 }

long pretty_psi_with_ops	(	ptr_psi_term	t,
		long	sprec,
		long	depth
	)

pretty_psi_with_ops

Parameters

t	- ptr_psi_term t
sprec	- long sprec
depth	- long depth

Write an expression with its operators. Return TRUE iff the arguments of t are written here (i.e. t was indeed a valid operator, and is therefore taken care of here).

Definition at line 949 of file print.c.

References wl_psi_term::attr_list, deref_ptr, FALSE, func_flag, fx, fy, get_two_args(), INFIX, wl_definition::keyword, listing_flag, MAX_PRECEDENCE, opcheck(), POSTFIX, PREFIX, pretty_quote_symbol(), pretty_tag_or_psi_term(), prettyf(), wl_keyword::symbol, TRUE, wl_psi_term::type, write_canon, xf, xfx, xfy, yf, and yfx.

 {
   // ptr_tab_brk new;
   ptr_psi_term arg1, arg2;
   long ttype, a1type, a2type;
   long tprec, a1prec, a2prec;
   long tkind, a1kind, a2kind;
   long p1, p2, argswritten;
   long sp; /* surrounding parentheses */
 
   if (write_canon) return FALSE; /* PVR 24.2.94 */
 
   argswritten=TRUE;
   tkind=opcheck(t, &tprec, &ttype);
   sp=(tkind==INFIX||tkind==PREFIX||tkind==POSTFIX) && tprec>=sprec;
   if (sp) prettyf("(");
   if (tkind==INFIX) {
     get_two_args(t->attr_list, &arg1, &arg2);
     deref_ptr(arg1); /* 16.9 */
     deref_ptr(arg2); /* 16.9 */
     a1kind = opcheck(arg1, &a1prec, &a1type);
     a2kind = opcheck(arg2, &a2prec, &a2type);
 
     /* The p1 and p2 flags tell whether to put parens around t's args */
     /* Calculate p1 flag: */
     if      (a1prec>tprec) p1=TRUE;
     else if (a1prec<tprec) p1=FALSE;
     else /* equal priority */
       if (ttype==xfy || ttype==xfx) p1=TRUE;
       else /* yfx */
         if (a1type==yfx || a1type==fx || a1type==fy) p1=FALSE;
         else p1=TRUE;
 
     /* Calculate p2 flag: */
     if      (a2prec>tprec) p2=TRUE;
     else if (a2prec<tprec) p2=FALSE;
     else /* equal priority */
       if (ttype==yfx || ttype==xfx) p2=TRUE;
       else /* xfy */
         if (a2type==xfy || a2type==xf || a2type==yf) p2=FALSE;
         else p2=TRUE;
 
     /* Write the expression */
     if (p1) prettyf("(");
     pretty_tag_or_psi_term(arg1,MAX_PRECEDENCE+1,depth);
     if (p1) prettyf(")");
     if (!p1 && strcmp(t->type->keyword->symbol,",")) {
       prettyf(" ");
     }
     pretty_quote_symbol(t->type->keyword); /*  RM: Jan 13 1993  */
     if (listing_flag && !func_flag &&
         (!strcmp(t->type->keyword->symbol,",") ||
          !strcmp(t->type->keyword->symbol,":-"))) {
       prettyf("\n        ");
     }
     else {
       if (!p2 && strcmp(t->type->keyword->symbol,".")) prettyf(" ");
     }
     if (p2) prettyf("(");
     pretty_tag_or_psi_term(arg2,MAX_PRECEDENCE+1,depth);
     if (p2) prettyf(")");
   }
   else if (tkind==PREFIX) {
     get_two_args(t->attr_list, &arg1, &arg2); /* arg2 does not exist */
     a1kind = opcheck(arg1, &a1prec, &a1type);
 
     /* Calculate p1 flag: */
     if (a1type==fx || a1type==fy) p1=FALSE;
     else p1=(tprec<=a1prec);
 
     pretty_quote_symbol(t->type->keyword);  /*  RM: Jan 13 1993  */
     if (!p1) prettyf(" ");
     if (p1) prettyf("(");
     pretty_tag_or_psi_term(arg1,MAX_PRECEDENCE+1,depth);
     if (p1) prettyf(")");
   }
   else if (tkind==POSTFIX) {
     get_two_args(t->attr_list, &arg1, &arg2); /* arg2 does not exist */
     a1kind = opcheck(arg1, &a1prec, &a1type);
 
     /* Calculate p1 flag: */
     if (a1type==xf || a1type==yf) p1=FALSE;
     else p1=(tprec<=a1prec);
 
     if (p1) prettyf("(");
     pretty_tag_or_psi_term(arg1,MAX_PRECEDENCE+1,depth);
     if (p1) prettyf(")");
     if (!p1) prettyf(" ");
     pretty_quote_symbol(t->type->keyword); /*  RM: Jan 13 1993  */
   }
   else {
     argswritten=FALSE;
   }
   if (sp) prettyf(")");
   return argswritten;
 }

void pretty_quote_symbol ( ptr_keyword k )

pretty_quote_symbol

Parameters

k	- ptr_keyword k

PRETTY_QUOTE_SYMBOL(k) Prints the string to be used to display keyword K, with quotes if required.

Definition at line 470 of file modules.c.

References wl_keyword::definition, display_modules, wl_definition::keyword, wl_keyword::module, wl_module::module_name, prettyf(), prettyf_quote(), and wl_keyword::symbol.

 {
   k=k->definition->keyword;
   if(display_modules) {
     prettyf(k->module->module_name);
     prettyf("#");
   }
   prettyf_quote(k->symbol);
 }

void pretty_symbol ( ptr_keyword k )

pretty_symbol

Parameters

k	- ptr_keyword k

PRETTY_SYMBOL(k) Prints the string to be used to display keyword K.

Definition at line 452 of file modules.c.

References wl_keyword::definition, display_modules, wl_definition::keyword, wl_keyword::module, wl_module::module_name, prettyf(), and wl_keyword::symbol.

 {
   k=k->definition->keyword;
   if(display_modules) {
     prettyf(k->module->module_name);
     prettyf("#");
   }
   prettyf(k->symbol);
 }

void pretty_tag_or_psi_term	(	ptr_psi_term	p,
		long	sprec,
		long	depth
	)

pretty_tag_or_psi_term

Parameters

p	- ptr_psi_term p
sprec	- long sprec
depth	- long depth

PRETTY_TAG_OR_PSI_TERM(p,depth) Print a psi-term, but first precede it with the appropriate TAG. Don't reprint the same psi-term twice.

Definition at line 834 of file print.c.

References COLON_PREC, wl_node::data, deref_ptr, DOTDOT, FALSE, find(), heap_insert(), INTCMP, is_top, no_name, NULL, pointer_names, pretty_psi_term(), prettyf(), printed_pointers, and unique_name().

 {
   ptr_node n,n2;
 
   if (p==NULL) {
     prettyf("<VOID>");
     return;
   }
   if (FALSE /*depth>=print_depth*/) { /* 20.8 */
     prettyf("...");
     return;
   }
   deref_ptr(p);
   
   n=find(INTCMP,(char *)p,pointer_names);
   
   if (n && n->data) {
     if (n->data==(GENERIC)no_name) {
       n->data=(GENERIC)unique_name();
       /* sprintf(name,"_%ld%c",++gen_sym_counter,0); */
       /* n->data=(GENERIC)heap_copy_string(name); */
     }
     n2=find(INTCMP,(char *)p,printed_pointers);
     if(n2==NULL) {
       prettyf((char *)n->data);
       (void)heap_insert(INTCMP,(char *)p,&printed_pointers,(GENERIC)n->data);
       if (!is_top(p)) {
         prettyf(DOTDOT);
         pretty_psi_term(p,COLON_PREC,depth);
       }
     }
     else
       prettyf((char *)n2->data);
   }
   else
     pretty_psi_term(p,sprec,depth);
 }

void pretty_variables	(	ptr_node	n,
		ptr_tab_brk	tab
	)

pretty_variables

Parameters

n	- ptr_node n
tab	- ptr_tab_brk tab

PRETTY_VARIABLES(n,tab) Pretty print the variables at position TAB.

Definition at line 1318 of file print.c.

References wl_node::data, deref_ptr, eqsym, find(), INTCMP, wl_node::key, wl_node::left, mark_tab(), MAX_PRECEDENCE, wl_definition::op_data, opcheck(), wl_operator_data::precedence, pretty_psi_term(), prettyf(), printed_pointers, and wl_node::right.

 {
   ptr_psi_term tok;
   ptr_node n2;
   
   if(n->left) {
     pretty_variables(n->left,tab);
     prettyf(", ");
   }
 
   mark_tab(tab);
   prettyf(n->key);
   prettyf(" = ");
 
   tok=(ptr_psi_term )n->data;
   deref_ptr(tok);
   n2=find(INTCMP,(char *)tok,printed_pointers);
   if(strcmp((char *)n2->data,n->key)<0)
     /* Reference to previously printed variable */
     prettyf((char *)n2->data);
   else {
     if (eqsym->op_data) {
       long tkind, tprec, ttype, eqprec;
       eqprec=eqsym->op_data->precedence;
       tkind=opcheck(tok, &tprec, &ttype);
       if (tprec>=eqprec) prettyf("(");
       pretty_psi_term(tok,MAX_PRECEDENCE+1,0);
       if (tprec>=eqprec) prettyf(")");
     }
     else
       pretty_psi_term(tok,MAX_PRECEDENCE+1,0);
   }
   
   if(n->right) {
     prettyf(", ");
     pretty_variables(n->right,tab);
   }
 }

void prettyf ( char * s )

prettyf

Parameters

s - char *s

PRETTYF(s) This prints the string S into the BUFFER.

Definition at line 496 of file print.c.

References FALSE, and prettyf_inner().

 {
   prettyf_inner(s,FALSE,'\'');
 }

void prettyf_inner	(	char *	s,
		long	q,
		char	c
	)

prettyf_inner

Parameters

s	- char *s
q	- long q
c	- char c the quote character

PRINTING ROUTINES.

These routines allow the correct printing in minimal form of a set of possibly cyclic psi-terms with coreferences from one to another.

First the term to be printed is explored to locate any cyclic terms or coreferences. Then is printed into memory where is it formatted to fit within PAGE_WIDTH of the output page. Then it is effectively printed to the output stream.

Printing into memory involves the use of an array containing a TAB position on which to align things then a string to print. The routine WORK_OUT_LENGTH tries (by trial and error) to print the psi_term into PAGE_WIDTH columns by inserting line feeds whereever possible

Does the work of prettyf and prettyf_quote The q argument is a flag telling whether to quote or not.

Definition at line 374 of file print.c.

References buffer, indent, and outfile.

 {
   char *sb=buffer;
 
   if (indent) {
     while (*sb) sb++;
     if (q) { *sb = c; sb++; }
     while (*s) {
       if (q && *s==c) { *sb = *s; sb++; }
       *sb = *s; sb++; s++;
     }
     if (q) { *sb = c; sb++; }
     *sb=0;
   }
   else {
     if (q) (void)putc(c,outfile);
     while (*s) {
       if (q && *s==c) { (void)putc(*s,outfile); }
       (void)putc(*s,outfile);
       s++;
     }
     if (q) (void)putc(c,outfile);
   }
 }

void prettyf_quote ( char * s )

prettyf_quote

Parameters

s - char *s

PRETTYF_QUOTE(s) This prints the string S into the buffer. S is surrounded by quotes if: (1) const_quote==TRUE, and (2) S does not represent an integer, and (2) S contains a non-alphanumeric character or starts with a non-lowercase character, and (3) if S is longer than one character, it is not true that S has only non-SINGLE SYMBOL characters (in that case, S does not need quotes),and (4) if S has only one character, it is a single space or underscore. When S is surrounded by quotes, a quote inside S is printed as two quotes.

Definition at line 529 of file print.c.

References const_quote, no_quote(), and prettyf_inner().

 {
   prettyf_inner(s, const_quote && !no_quote(s), '\'');
 }

void prettyf_quoted_string ( char * s )

prettyf_quoted_string

Parameters

s - char *s

Definition at line 507 of file print.c.

References const_quote, and prettyf_inner().

 {
   prettyf_inner((char *)s,const_quote,'"');
 }

void print_bin ( long b )

print_bin

Parameters

b - long b

PRINT_BIN(b) Print the integer B under binary format (currently 26 is printed **-*-). This is used to print the binary codes used in type encryption.

Definition at line 147 of file print.c.

References INT_SIZE, and outfile.

 {
   long p;
 
   for (p=INT_SIZE;p--;p>0) 
   {
     fprintf(outfile,(b&1?"X":" "));
     b = b>>1;
   }
 }

void print_code	(	FILE *	s,
		ptr_int_list	c
	)

print_code

Parameters

s	- FILE *s
c	- ptr_int_list c

PRINT_CODE(s,c) Print a binary code C to a stream s (as used in type encoding).

Definition at line 167 of file print.c.

References wl_int_list::next, NOT_CODED, outfile, print_bin(), and wl_int_list::value_1.

 {
   outfile=s;
 
   if (c==NOT_CODED)
     fprintf(outfile,"  (not coded) ");
   else {
     fprintf(outfile,"  [");
     while (c) {
       print_bin((long)c->value_1);
       c=c->next;
     }
     fprintf(outfile,"]");
   }
 }

void print_codes ( )

print_codes

PRINT_CODES() Print all the codes.

Definition at line 1256 of file types.c.

References outputline(), and type_count.

 {
   long i;
 
   for (i=0; i<type_count; i++) {
     outputline("%C = %s\n",
            gamma_table[i]->code,
            gamma_table[i]->keyword->combined_name);
   }
 }

void print_def_type ( def_type t )

print_def_type

Parameters

t	- def_type t

PRINT_DEF_TYPE(t) This prints type T to stderr, where T=predicate, function or type.

Definition at line 24 of file types.c.

References function_it, global_it, perr(), predicate_it, and type_it.

 {
   switch ((long)t) {
   case (long)predicate_it:
     perr("predicate");
     break;
   case (long)function_it:
     perr("function");
     break;
   case (long)type_it:
     perr("sort");
     break;
   case (long)global_it: /*  RM: Feb  8 1993  */
     perr("global variable");
     break;
   default:
     perr("undefined");
   }
 }

void print_gc_info ( long timeflag )

print_gc_info

Parameters

timeflag - long timeflag

Definition at line 1493 of file memory.c.

References gc_time, heap_pointer, life_time, mem_base, mem_limit, mem_size, and stack_pointer.

 {
   fprintf(stderr," [%ld%% free (%ldK), %ld%% heap, %ld%% stack",
           (100*((unsigned long)heap_pointer-(unsigned long)stack_pointer)+mem_size/2)/mem_size,
           ((unsigned long)heap_pointer-(unsigned long)stack_pointer+512)/1024,
           (100*((unsigned long)mem_limit-(unsigned long)heap_pointer)+mem_size/2)/mem_size,
           (100*((unsigned long)stack_pointer-(unsigned long)mem_base)+mem_size/2)/mem_size);
   if (timeflag) {
     fprintf(stderr,", %1.3fs cpu (%ld%%)",
             gc_time,
             (unsigned long)(0.5+100*gc_time/(life_time+gc_time)));
   }
   fprintf(stderr,"]\n");
 }

void print_operator_kind	(	FILE *	s,
		long	kind
	)

print_operator_kind

Parameters

s	- FILE *s
kind	- long kind

PRINT_OPERATOR_KIND(s,kind) Print the kind of an operator.

Definition at line 192 of file print.c.

References fx, fy, xf, xfx, xfy, yf, and yfx.

 {
   switch (kind) {
   case xf:
     fprintf(s,"xf");
     break;
   case fx:
     fprintf(s,"fx");
     break;
   case yf:
     fprintf(s,"yf");
     break;
   case fy:
     fprintf(s,"fy");
     break;
   case xfx:
     fprintf(s,"xfx");
     break;
   case xfy:
     fprintf(s,"xfy");
     break;
   case yfx:
     fprintf(s,"yfx");
     break;
   default:
     fprintf(s,"illegal");
     break;
   }
 }

void print_resid_message	(	ptr_psi_term	t,
		ptr_resid_list	r
	)

print_resid_message

Parameters

t	- ptr_psi_term t
r	- ptr_resid_list r

PRINT_RESID_MESSAGE This is called in trace mode to print the residuated goal along with the RV set.

Definition at line 1690 of file print.c.

References buffer, check_pointer(), const_quote, end_tab(), FALSE, gen_sym_counter, heap_pointer, indent, indx, insert_variables(), listing_flag, mark_tab(), MAX_PRECEDENCE, new_tab(), wl_resid_list::next, NULL, outfile, pointer_names, pretty_tag_or_psi_term(), pretty_things, prettyf(), printed_pointers, TRUE, wl_resid_list::var, var_tree, write_canon, and write_resids.

 {
   GENERIC old_heap_pointer;
   ptr_tab_brk new;
   ptr_resid_list r2; /* 21.9 */
   
   outfile=stdout;
   listing_flag=FALSE;
   old_heap_pointer=heap_pointer;
   
   pointer_names=NULL;
   printed_pointers=NULL;
   gen_sym_counter=0;
 
   check_pointer(t);
 
   r2=r;
   while(r2) {
     check_pointer(r2->var);
     r2=r2->next;
   }
   
   insert_variables(var_tree,TRUE);
   
   indent=FALSE;
   const_quote=TRUE;
   write_resids=FALSE;
   write_canon=FALSE;
   *buffer=0;
   indx=pretty_things;
   new_tab(&new);
   mark_tab(new);
 
   prettyf("residuating ");
   pretty_tag_or_psi_term(t,MAX_PRECEDENCE+1,0);
   prettyf(" on variable(s) {");
 
   r2=r;
   while(r2) {
     pretty_tag_or_psi_term(r2->var,MAX_PRECEDENCE+1,0);
     r2=r2->next;
     if(r2)
       prettyf(",");
   }
 
   prettyf("}\n");
   end_tab();
   
   heap_pointer=old_heap_pointer;
 }

char * print_symbol ( ptr_keyword k )

print_symbol

OBSOLETE ptr_psi_term get_function_value(module,symbol)

ptr_module module; char *symbol;

{ ptr_node n; ptr_definition def; ptr_psi_term result=NULL; ptr_pair_list rule;

n=find(STRCMP,make_module_token(module,symbol),symbol_table); if(n) def=(ptr_definition)n->data; if(def && def->type==function) { rule=def->rule; while (rule && (!rule->aaaa_1 || !rule->bbbb_1)) rule=rule->next; if(rule) { result=(ptr_psi_term)rule->bbbb_1; deref_ptr(result); } } }

if(!result) Errorline("error in definition of '%s'\n",module_buffer);

return result; }

Parameters

k	- ptr_keyword k

PRINT_SYMBOL(k) Returns the string to be used to display keyword K.

Definition at line 435 of file modules.c.

References wl_keyword::combined_name, wl_keyword::definition, display_modules, wl_definition::keyword, and wl_keyword::symbol.

 {
   k=k->definition->keyword;
   if(display_modules)
     return k->combined_name;
   else
     return k->symbol;
 }

void print_undo_stack ( )

print_undo_stack

Definition at line 122 of file memory.c.

References wl_stack::aaaa_3, wl_stack::bbbb_3, mem_base, mem_limit, wl_stack::next, wl_stack::type, and undo_stack.

 {
   ptr_stack u=undo_stack;
 
   while (u) {
     if ((GENERIC)u->aaaa_3<mem_base || (GENERIC)u->aaaa_3>mem_limit ||
         (GENERIC)u->next<mem_base || (GENERIC)u->next>mem_limit) {
       printf("UNDO: type:%ld a:%lx b:%lx next:%lx\n",u->type,(unsigned long)u->aaaa_3,(unsigned long)u->bbbb_3,(unsigned long)u->next);
       (void)fflush(stdout);
     }
     u=u->next;
   }
 }

long print_variables ( long printflag )

print_variables

Parameters

printflag - long printflag

PRINT_VARIABLES This prints all the query variables. Symbols generated to print one variable are coherent with those used in other variables. Returns TRUE iff the set of query variables is nonempty.

Definition at line 1368 of file print.c.

References buffer, const_quote, end_tab(), FALSE, forbid_variables(), gen_sym_counter, go_through_tree(), heap_pointer, indent, indx, insert_variables(), listing_flag, mark_tab(), new_tab(), NULL, outfile, output_stream, pointer_names, pretty_output(), pretty_things, pretty_variables(), prettyf(), printed_pointers, TRUE, var_tree, work_out_length(), write_canon, and write_resids.

 {
   ptr_tab_brk new;
   GENERIC old_heap_pointer;
   if (!printflag) return FALSE; /* 21.1 */
   
   outfile=output_stream;
   listing_flag=FALSE;
   old_heap_pointer=heap_pointer;
   
   pointer_names=NULL;
   printed_pointers=NULL;
   gen_sym_counter=0;
   go_through_tree(var_tree);
   insert_variables(var_tree,TRUE);
   forbid_variables(var_tree);
   
   indent=TRUE;
   const_quote=TRUE;
   write_resids=TRUE;
   write_canon=FALSE;
   *buffer=0;
   indx=pretty_things;
 
   if (var_tree) {
     new_tab(&new);
     pretty_variables(var_tree,new);
     prettyf(".");
     mark_tab(new);
     prettyf("\n");
     end_tab();
 
     if (indent) {
       work_out_length();
       pretty_output();
     }
   }
   heap_pointer=old_heap_pointer;
   return (var_tree!=NULL);
 }

void propagate_always_check	(	ptr_definition	d,
		long *	ch
	)

propagate_always_check

Parameters

d	- ptr_definition d
ch	- long *ch

PROPAGATE_ALWAYS_CHECK(d,ch) Recursively set the always_check flag to 'FALSE' for all d's children. Continue until encountering only 'FALSE' values. Return a TRUE flag if a change was made somewhere (for the closure calculation).

Definition at line 1022 of file types.c.

References wl_definition::always_check, wl_definition::children, FALSE, wl_int_list::next, TRUE, and wl_int_list::value_1.

 {
   ptr_int_list child_list;
   ptr_definition child;
   
   child_list = d->children;
   while (child_list) {
     child = (ptr_definition)child_list->value_1;
     if (child->always_check) {
       child->always_check = FALSE;
       *ch = TRUE;
       propagate_always_check(child,ch);
     }
     child_list = child_list->next;
   }
 }

void propagate_definitions ( )

propagate_definitions

PROPAGATE_DEFINITIONS() This routine propagates the definition (attributes,predicates) of a type to all its sons.

Definition at line 662 of file types.c.

References adults, wl_definition::children, children, find_adults(), insert_own_prop(), insert_prop(), wl_int_list::next, NULL, wl_definition::properties, and wl_int_list::value_1.

 {
   ptr_int_list kids;
   ptr_definition d;
   
   adults=NULL;
   find_adults();
   
   while (adults) {
     
     children=NULL;
     
     while (adults) {
       d=(ptr_definition)adults->value_1;
       
       insert_own_prop(d);
       children=children->next;
       
       kids=d->children;
       
       while(kids) {
         insert_prop((ptr_definition)kids->value_1,d->properties);
         /* if (d->always_check && kids->value_1)
           ((ptr_definition)kids->value_1)->always_check=TRUE; */
         kids=kids->next;
       }
       adults=adults->next;
     }
     adults=children;
   }
 }

long prove_aim ( )

prove_aim

PROVE_AIM() This is the proving routine. It performs one proof step, that is: finding the definition to use to prove AIM, and unifying the HEAD with the GOAL before proving. It all works by pushing sub-goals onto the goal_stack. Special cases are CUT and AND (","). Built-in predicates written in C are called.

Definition at line 1645 of file login.c.

References wl_goal::aaaa_1, wl_pair_list::aaaa_2, aim, and, wl_psi_term::attr_list, wl_goal::bbbb_1, wl_pair_list::bbbb_2, boolpredsym, c_rule, call_handlersym, can_curry, choice_stack, clean_trail(), clear_copy(), wl_psi_term::coref, curried, cut, cut_to, wl_node::data, DEFRULES, deref_args, deref_ptr, do_currying(), do_residuation_user(), eval_copy(), FALSE, function_it, get_two_args(), goal_count, goal_stack, i_check_out(), i_eval_args(), wl_node::key, wl_node::left, lf_false, lf_true, life_or, MAX_BUILT_INS, merge(), wl_pair_list::next, wl_goal::next, NULL, one, predicate_it, wl_definition::protected, prove, push_choice_point(), push_goal(), push_psi_ptr_value(), quote_copy(), resid_aim, resid_vars, wl_node::right, wl_definition::rule, set_empty, STACK, stack_add_psi_attr(), STACK_ALLOC, stack_psi_term(), wl_psi_term::status, sub_type(), succeed, traceline(), tracesym, TRUE, wl_psi_term::type, wl_definition::type_def, type_it, undef_it, and wl_psi_term::value_3.

 {
   long success=TRUE;
   ptr_psi_term thegoal,head,body,arg1,arg2;
   ptr_pair_list rule;
   
   thegoal=(ptr_psi_term )aim->aaaa_1;
   rule=(ptr_pair_list )aim->bbbb_1;
   
   if (thegoal && rule) {
     
     deref_ptr(thegoal); /* Evaluation is explicitly handled later. */
     
     if (thegoal->type!=and) {
       if (thegoal->type!=cut)
     if(thegoal->type!=life_or) {
       /* User-defined predicates with unevaluated arguments */
       /* Built-ins do this themselves (see built_ins.c). */
       /* if (!thegoal->type->evaluate_args) mark_quote(thegoal); 24.8 25.8 */
       
       if(i_check_out(thegoal)) { /* RM: Apr  6 1993  */
         
         goal_stack=aim->next;
         goal_count++;
         
         if ((unsigned long)rule==DEFRULES) {
           rule=(ptr_pair_list)thegoal->type->rule;
           if (thegoal->type->type_def==(def_type)predicate_it) {
         if (!rule) /* This can happen when RETRACT is used */
           success=FALSE;
           }
           else if ( thegoal->type->type_def==(def_type)function_it
               || ( thegoal->type->type_def==(def_type)type_it
              && sub_type(boolean,thegoal->type)
              )
                   ) {
         if (thegoal->type->type_def==(def_type)function_it && !rule)
           /* This can happen when RETRACT is used */
           success=FALSE;
         else {
           ptr_psi_term bool_pred;
           ptr_node a;
           /* A function F in pred. position is called as */
           /* '*bool_pred*'(F), which succeeds if F returns true */
           /* and fails if it returns false.  It can residuate too. */
           bool_pred=stack_psi_term(0);
           bool_pred->type=boolpredsym;
           bool_pred->attr_list=(a=STACK_ALLOC(node));
           a->key=one;
           a->left=a->right=NULL;
           a->data=(GENERIC) thegoal;
           push_goal(prove,(ptr_psi_term)bool_pred,(ptr_psi_term)DEFRULES,NULL);
           return success; /* We're done! */
         }
           }
           else if (!thegoal->type->protected && thegoal->type->type_def==(def_type)undef_it) {
         /* Don't give an error message for undefined dynamic objects */
         /* that do not yet have a definition */
         success=FALSE;
           }
           else if (thegoal->type==lf_true || thegoal->type==lf_false) {
         /* What if the 'lf_true' or 'lf_false' have arguments? */
         success=(thegoal->type==lf_true);
         return success; /* We're done! */
           }
           else {
         /* Error: undefined predicate. */
         /* Call the call_handler (which may do an auto-load). */
         ptr_psi_term call_handler;
         /* mark_quote(thegoal); */
         
         /*  RM: Jan 27 1993 */
         /* warningline("call handler invoked for %P\n",thegoal); */
         
         call_handler=stack_psi_term(0);
         call_handler->type=call_handlersym;
         stack_add_psi_attr(call_handler,"1",thegoal);
         push_goal(prove,(ptr_psi_term)call_handler,(ptr_psi_term)DEFRULES,NULL);
         return success; /* We're done! */
           }
         }
         
         if (success) {
           
           if ((unsigned long)rule<=MAX_BUILT_INS) {
         
         /* For residuation (RESPRED) */
         curried=FALSE;
         can_curry=TRUE;
         resid_vars=NULL;
         /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
         
         if (thegoal->type!=tracesym) /* 26.1 */
           traceline("prove built-in %P\n", thegoal);
         
         /* RESPRED */ resid_aim=aim;
         /* Residuated predicate must return success=TRUE */
         success=c_rule[(unsigned long)rule]();
         
         /* RESPRED */ if (curried)
         /* RESPRED */   do_currying();
         /* RESPRED */ else if (resid_vars)
         /* RESPRED */   success=do_residuation_user(); /* 21.9 */ /* PVR 9.2.94 */
           }
           else {
         
         /* Evaluate arguments of a predicate call before the call. */
         deref_args(thegoal,set_empty);
         
         traceline("prove %P\n", thegoal);
         
         /* For residuation (RESPRED) */
         curried=FALSE;
         can_curry=TRUE;
         resid_vars=NULL;
         /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
         
         while (rule && (rule->aaaa_2==NULL || rule->bbbb_2==NULL)) {
           rule=rule->next;
           traceline("alternative clause has been retracted\n");
         }
         if (rule) {
           
           clear_copy();
           if (TRUE) /* 8.9 */
             /* if (thegoal->type->evaluate_args) 8.9 */
             head=eval_copy(rule->aaaa_2,STACK);
           else
             head=quote_copy(rule->aaaa_2,STACK);
 
           body=eval_copy(rule->bbbb_2,STACK);
 
           /* What does this do?? */
           /* if (body->type==built_in) */
           /*   body->coref=head; */
           
           if (rule->next)
             push_choice_point(prove,thegoal,(ptr_psi_term)rule->next,NULL);
           
           if (body->type!=succeed)
             push_goal(prove,(ptr_psi_term)body,(ptr_psi_term)DEFRULES,NULL);
           
           /* push_ptr_value(psi_term_ptr,&(head->coref)); 9.6 */
           push_psi_ptr_value(head,(GENERIC *)&(head->coref));
           head->coref=thegoal;
           merge(&(thegoal->attr_list),head->attr_list);
           if (!head->status) {
             (void)i_eval_args(head->attr_list);
           }
         }
         else {
           success=FALSE;
         }
           }
         }
       }
     }
     else { /* ';' built-in */
       /*  RM: Apr  6 1993  */
       goal_stack=aim->next;
       goal_count++;
       get_two_args(thegoal->attr_list,&arg1,&arg2);
       push_choice_point(prove,arg2,(ptr_psi_term)DEFRULES,NULL);
       push_goal(prove,(ptr_psi_term)arg1,(ptr_psi_term)DEFRULES,NULL);
     }
       else { /* 'Cut' built-in*/
     goal_stack=aim->next;
     goal_count++;
     /* assert((ptr_choice_point)(thegoal->value)<=choice_stack); 12.7 */
     cut_to(thegoal->value_3); /* 12.7 */
 #ifdef CLEAN_TRAIL
         clean_trail(choice_stack);
 #endif
         traceline("cut all choice points back to %x\n",choice_stack);
       }
     }
     else { /* 'And' built-in */
       goal_stack=aim->next;
       goal_count++;
       get_two_args(thegoal->attr_list,&arg1,&arg2);
       push_goal(prove,(ptr_psi_term)arg2,(ptr_psi_term)DEFRULES,NULL);
       push_goal(prove,(ptr_psi_term)arg1,(ptr_psi_term)DEFRULES,NULL);
     }
   }
   else
     success=FALSE;
   
   /* RESPRED */ resid_aim=NULL;
   return success;
 }

void psi_term_error ( )

psi_term_error

PSI_TERM_ERROR Print the line number at which the current psi_term started.

Definition at line 761 of file token.c.

References FALSE, input_file_name, parse_ok, perr_i(), perr_s(), and psi_term_line_number.

 {
   perr_i("near line %ld",psi_term_line_number);
   if (strcmp(input_file_name,"stdin")) {
     perr_s(" in file \042%s\042",input_file_name);
   }
   /* prompt="error>"; 20.8 */
   parse_ok=FALSE;
 }

long psi_to_string	(	ptr_psi_term	t,
		char **	fn
	)

psi_to_string

Parameters

t	- ptr_psi_term t
fn	- char ** fn

PSI_TO_STRING(t,fn) Get the value of a Life string, or the name of a non-string psi-term. Return TRUE iff a valid string is found.

Definition at line 146 of file built_ins.c.

References equal_types, wl_definition::keyword, quoted_string, wl_keyword::symbol, TRUE, wl_psi_term::type, and wl_psi_term::value_3.

 {
   if (equal_types(t->type,quoted_string)) {
     if (t->value_3) {
       *fn = (char *) t->value_3;
       return TRUE;
     }
     else {
       *fn = quoted_string->keyword->symbol;
       return TRUE;
     }
   }
   else {
     *fn = t->type->keyword->symbol;
     return TRUE;
   }
 }

void push	(	psi_term	tok,
		long	prec,
		long	op
	)

push

Parameters

tok	- psi_term tok
prec	- long prec
op	- long op

PUSH(tok,prec,op) Push psi_term and precedence and operator onto parser stack.

Definition at line 107 of file parser.c.

References int_stack, parser_stack_index, PARSER_STACK_SIZE, perr(), psi_term_error(), and psi_term_stack.

 {
   if (parser_stack_index==PARSER_STACK_SIZE) {
     perr("*** Parser error ");
     psi_term_error();
     perr(": stack full.\n");
   }
   else {
     parser_stack_index++;
     psi_term_stack[parser_stack_index]=tok;
     int_stack[parser_stack_index]=prec;
     op_stack[parser_stack_index]=op;
   }
 }

void push2_ptr_value	(	type_ptr	t,
		GENERIC *	p,
		GENERIC	v
	)

push2_ptr_value

Parameters

t	- type_ptr t
p	- GENERIC *p
v	- GENERIC v

PUSH2_PTR_VALUE(t,*p,v) Push the pair (P,V) onto the stack of things to be undone (trail). It needn't be done if P is greater than the latest choice point because in that case memory is reclaimed.

Definition at line 573 of file login.c.

References wl_stack::aaaa_3, wl_stack::bbbb_3, choice_stack, wl_stack::next, STACK_ALLOC, stack_pointer, wl_stack::type, and undo_stack.

 {
   ptr_stack n;
   
   if (p<(GENERIC *)choice_stack || p>(GENERIC *)stack_pointer) {
     n=STACK_ALLOC(stack);
     n->type=t;
     n->aaaa_3= (GENERIC *)p;
     n->bbbb_3= (GENERIC *)v;
     n->next=undo_stack;
     undo_stack=n;
   }
 }

void push_choice_point	(	goals	t,
		ptr_psi_term	aaaa_6,
		ptr_psi_term	bbbb_6,
		GENERIC	cccc_6
	)

push_choice_point

Parameters

t	- goals t
aaaa_6	ptr_psi_term aaaa_6
bbbb_6	ptr_psi_term bbbb_6
cccc_6	GENERIC cccc_6

PUSH_CHOICE_POINT(t,a,b,c) T,A,B,C is an alternative goal to try. T is the type of the goal: unify or prove.

If T=prove then a=goal to prove b=definition to use if b=DEFRULES then that means it's a first call.

If T=unify then a and b are the terms to unify.

etc...

Definition at line 638 of file login.c.

References wl_goal::aaaa_1, wl_goal::bbbb_1, wl_goal::cccc_1, choice_stack, FALSE, global_time_stamp, wl_choice_point::goal_stack, goal_stack, wl_goal::next, wl_choice_point::next, wl_goal::pending, STACK_ALLOC, stack_pointer, wl_choice_point::stack_top, wl_choice_point::time_stamp, wl_goal::type, wl_choice_point::undo_point, and undo_stack.

 {
   ptr_goal alternative;
   ptr_choice_point choice;
   GENERIC top_loc;
   
   alternative=STACK_ALLOC(goal);
   
   alternative->type=t;
   alternative->aaaa_1=aaaa_6;
   alternative->bbbb_1=bbbb_6;
   alternative->cccc_1=cccc_6;
   alternative->next=goal_stack;
   alternative->pending=FALSE;
   
   top_loc=stack_pointer;
   
   choice=STACK_ALLOC(choice_point);
   
   choice->undo_point=undo_stack;
   choice->goal_stack=alternative;
   choice->next=choice_stack;
   choice->stack_top=top_loc;
   
 #ifdef TS
   choice->time_stamp=global_time_stamp; /* 9.6 */
   global_time_stamp++; /* 9.6 */
 #endif
   
   choice_stack=choice;  
 }

void push_def_ptr_value	(	ptr_psi_term	q,
		GENERIC *	p
	)

push_def_ptr_value

Parameters

q	- ptr_psi_term q
p	- GENERIC *p

PUSH_DEF_PTR_VALUE(q,p) (9.6) Same as push_ptr_value, but only for psi-terms whose definition field is being modified. (If another field is modified, use push_ptr_value.) This routine implements the time-stamp technique of only trailing once between choice point creations, even on multiple bindings. q is address of psi-term, p is address of field inside psi-term that is modified. Both the definition and the time_stamp must be trailed.

Definition at line 416 of file login.c.

References wl_stack::aaaa_3, assert, wl_stack::bbbb_3, choice_stack, def_ptr, global_time_stamp, heap_pointer, int_ptr, wl_stack::next, push_ptr_value(), STACK_ALLOC, stack_pointer, trail_condition(), wl_stack::type, undo_stack, and VALID_ADDRESS.

 {
   ptr_stack m,n;
   
   assert(VALID_ADDRESS(q));
   assert(VALID_ADDRESS(p));
 #ifdef TS
   if (trail_condition(q) &&
       /* (q->time_stamp != global_time_stamp) && */
       (p < (GENERIC *)choice_stack || p > (GENERIC *)stack_pointer))
     {
 #define TRAIL_TS
 #ifdef TRAIL_TS
       
       assert((GENERIC)q<heap_pointer); /*  RM: Feb 15 1993  */
       
       m=STACK_ALLOC(stack); /* Trail time_stamp */
       m->type=int_ptr;
       m->aaaa_3= (GENERIC *) &(q->time_stamp);
       m->bbbb_3= (GENERIC *) (q->time_stamp);
       m->next=undo_stack;
       n=STACK_ALLOC(stack); /* Trail definition field (top of undo_stack) */
       n->type=def_ptr;
       n->aaaa_3=  p;
       n->bbbb_3= (GENERIC *)*p;
       n->next=m;
       undo_stack=n;
 #else
       n=STACK_ALLOC(stack); /* Trail definition field (top of undo_stack) */
       n->type=def_ptr;
       n->aaaa_3= p;
       n->bbbb_3= (GENERIC *) *p;
       n->next=undo_stack;
       undo_stack=n;
 #endif
       q->time_stamp=global_time_stamp;
     }
 #else
   push_ptr_value(def_ptr,p);
 #endif
 }

void push_goal	(	goals	t,
		ptr_psi_term	aaaa_5,
		ptr_psi_term	bbbb_5,
		GENERIC	cccc_5
	)

push_goal

Parameters

t	- goals t
aaaa_5	ptr_psi_term aaaa_5
bbbb_5	ptr_psi_term bbbb_5
cccc_5	GENERIC cccc_5

PUSH_GOAL(t,a,b,c) Push a goal onto the goal stack. T is the type of the goal, A,B and C are various parameters. See PUSH_CHOICE_POINT(t,a,b,c).

Definition at line 600 of file login.c.

References wl_goal::aaaa_1, wl_goal::bbbb_1, wl_goal::cccc_1, FALSE, goal_stack, wl_goal::next, wl_goal::pending, STACK_ALLOC, and wl_goal::type.

 {
   ptr_goal thegoal;
   
   thegoal=STACK_ALLOC(goal);
   
   thegoal->type=t;
   thegoal->aaaa_1=aaaa_5;
   thegoal->bbbb_1=bbbb_5;
   thegoal->cccc_1=cccc_5;
   thegoal->next=goal_stack;
   thegoal->pending=FALSE;
   
   goal_stack=thegoal;
 }

void push_psi_ptr_value	(	ptr_psi_term	q,
		GENERIC *	p
	)

push_psi_ptr_value

Parameters

q	- ptr_psi_term q
p	- GENERIC *p

PUSH_PSI_PTR_VALUE(q,p) (9.6) Same as push_ptr_value, but only for psi-terms whose coref field is being modified. (If another field is modified, use push_ptr_value.) This routine implements the time-stamp technique of only trailing once between choice point creations, even on multiple bindings. q is address of psi-term, p is address of field inside psi-term that is modified. Both the coref and the time_stamp must be trailed.

Definition at line 474 of file login.c.

References wl_stack::aaaa_3, assert, wl_stack::bbbb_3, choice_stack, global_time_stamp, int_ptr, wl_stack::next, psi_term_ptr, push_ptr_value(), STACK_ALLOC, stack_pointer, trail_condition(), wl_stack::type, undo_stack, and VALID_ADDRESS.

 {
   ptr_stack m,n;
   
   assert(VALID_ADDRESS(q));
   assert(VALID_ADDRESS(p));
 #ifdef TS
   if (trail_condition(q) &&
       /* (q->time_stamp != global_time_stamp) && */
       (p < (GENERIC *)choice_stack || p > (GENERIC *)stack_pointer))
     {
 #define TRAIL_TS
 #ifdef TRAIL_TS
       m=STACK_ALLOC(stack); /* Trail time_stamp */
       m->type=int_ptr;
       m->aaaa_3= (GENERIC *) &(q->time_stamp);
       m->bbbb_3= (GENERIC *) (q->time_stamp);
       m->next=undo_stack;
       n=STACK_ALLOC(stack); /* Trail coref field (top of undo_stack) */
       n->type=psi_term_ptr;
       n->aaaa_3= (GENERIC *) p;
       n->bbbb_3= (GENERIC *) *p;
       n->next=m;
       undo_stack=n;
 #else
       n=STACK_ALLOC(stack); /* Trail coref field (top of undo_stack) */
       n->type=psi_term_ptr;
       n->aaaa_3= (ptr_psi_term)p;
       n->bbbb_3= *p;
       n->next=undo_stack;
       undo_stack=n;
 #endif
       q->time_stamp=global_time_stamp;
     }
 #else
   push_ptr_value(psi_term_ptr,(ptr_psi_term *)p);
 #endif
 }

push_ptr_value	(	type_ptr	t,
		GENERIC *	p
	)

push_ptr_value

Parameters

t	- type_ptr t
p	- GENERIC *p

PUSH_PTR_VALUE(t,*p) Push the pair (P,*P) onto the stack of things to be undone (trail). It needn't be done if P is greater than the latest choice point because in that case memory is reclaimed.

Definition at line 383 of file login.c.

References wl_stack::aaaa_3, assert, wl_stack::bbbb_3, choice_stack, heap_pointer, wl_stack::next, STACK_ALLOC, stack_pointer, wl_stack::type, undo_stack, and VALID_ADDRESS.

 {
   ptr_stack n;
   
   assert(p<(GENERIC *)heap_pointer); /*  RM: Feb 15 1993  */
   
   assert(VALID_ADDRESS(p));
   if (p < (GENERIC *)choice_stack || p > (GENERIC *)stack_pointer) 
     {
       n=STACK_ALLOC(stack);
       n->type=t;
       n->aaaa_3= (GENERIC *) p;
       n->bbbb_3= (GENERIC *) *p;
       n->next=undo_stack;
       undo_stack=n;
     }
 }

void push_ptr_value_global	(	type_ptr	t,
		GENERIC *	p
	)

push_ptr_value_global

Parameters

t	- type_ptr t
p	- GENERIC *p

Same as push_ptr_value, but for objects that must always be trailed. This includes objects outside of the Life data space and entries in the var_tree.

Definition at line 523 of file login.c.

References wl_stack::aaaa_3, assert, wl_stack::bbbb_3, wl_stack::next, STACK_ALLOC, wl_stack::type, undo_stack, and VALID_ADDRESS.

 {
   ptr_stack n;
   
   assert(VALID_ADDRESS(p)); /* 17.8 */
   n=STACK_ALLOC(stack);
   n->type=t;
   n->aaaa_3= (GENERIC *) p;
   n->bbbb_3= (GENERIC *) *p;
   n->next=undo_stack;
   undo_stack=n;
 }

void push_window	(	long	type,
		long	disp,
		long	wind
	)

push_window

Parameters

type	- long type
disp	- long disp
wind	- long wind

PUSH_WINDOW(type,disp,wind) Push the window information (operation, display and window identifiers) on the undo_stack (trail) so that the window can be destroyed, redrawn, or hidden on backtracking.

Definition at line 548 of file login.c.

References wl_stack::aaaa_3, assert, wl_stack::bbbb_3, wl_stack::next, STACK_ALLOC, wl_stack::type, undo_action, and undo_stack.

 {
   ptr_stack n;
   
   assert(type & undo_action);
   n=STACK_ALLOC(stack);
   n->type=type;
   n->aaaa_3=(GENERIC *)disp;
   n->bbbb_3=(GENERIC *)wind;
   n->next=undo_stack;
   undo_stack=n;
 }

void put_back_char ( long c )

put_back_char

Parameters

c - long c

PUT_BACK_CHAR Put back one character, if there already are 2 saved characters then report an error (= bug).

Definition at line 729 of file token.c.

References Errorline(), old_saved_char, and saved_char.

 {
   if (old_saved_char)
     Errorline("in tokenizer, put_back_char three times (last=%d).\n",c);
   old_saved_char=saved_char;
   saved_char=c;
 }

void put_back_token ( psi_term t )

put_back_token

Parameters

t	- psi_term t

PUT_BACK_TOKEN Put back a psi_term, if there already are two saved then report an error (= bug).

Definition at line 746 of file token.c.

References Errorline(), NULL, old_saved_psi_term, saved_psi_term, and stack_copy_psi_term().

 {  
   if (old_saved_psi_term!=NULL)
     Errorline("in parser, put_back_token three times (last=%P).\n",t);
   old_saved_psi_term=saved_psi_term;
   saved_psi_term=stack_copy_psi_term(t);
 }

ptr_psi_term quote_copy	(	ptr_psi_term	t,
		long	heap_flag
	)

quote_copy

Parameters

t	- ptr_psi_term t
heap_flag	- long heap_flag

Definition at line 186 of file copy.c.

References copy(), FALSE, QUOTE_FLAG, and to_heap.

187 { to_heap=FALSE; return (copy(t, QUOTE_FLAG, heap_flag)); }

ptr_psi_term copy(ptr_psi_term t, long copy_flag, long heap_flag)

copy

Definition: copy.c:248

long to_heap

Definition: def_glob.h:905

#define FALSE

Standard boolean.

Definition: def_const.h:275

QUOTE_FLAG

#define QUOTE_FLAG

flag to copy function in copy.c to indicate kind of copy

Definition: def_const.h:1313

ptr_psi_term quotedStackCopy ( psi_term p )

Definition at line 528 of file bi_sys.c.

References mark_quote(), and stack_copy_psi_term().

 {
   ptr_psi_term q;
 
   q = (ptr_psi_term) stack_copy_psi_term(p); 
   mark_quote(q);
   return q;
 }

void raw_setup_builtins ( )

raw_setup_builtins

set up the built-ins for the mode raw

Definition at line 303 of file raw.c.

References bi_module, c_begin_raw(), c_end_raw(), c_get_raw(), c_in_raw(), c_put_raw(), c_reset_window_flag(), c_window_flag(), function_it, and new_built_in().

 {
 #ifndef NORAW  
     new_built_in(bi_module,"begin_raw",         predicate, c_begin_raw);
     new_built_in(bi_module,"get_raw",           predicate, c_get_raw);
     new_built_in(bi_module,"put_raw",           predicate, c_put_raw);
     new_built_in(bi_module,"end_raw",           predicate, c_end_raw);
     new_built_in(bi_module,"in_raw",            function_it,  c_in_raw);
     new_built_in(bi_module,"window_flag",       function_it,  c_window_flag);
     new_built_in(bi_module,"reset_window_flag", predicate, c_reset_window_flag);
 #endif
 }

long read_char ( )

read_char

READ_CHAR Return the char read from the input stream, if end of file reached then return EOF. If stringparse==TRUE then read characters from the input string instead of from a file.

Definition at line 680 of file token.c.

References EOLN, FALSE, infoline(), input_stream, line_count, NULL, old_saved_char, prompt, saved_char, start_of_line, stringinput, stringparse, trace_input, and TRUE.

 {
   int c=0;
   
   if ((c=saved_char)) {
     saved_char=old_saved_char;
     old_saved_char=0;
   }
   else if (stringparse) {
     if ((c=(*stringinput)))
       stringinput++;
     else
       c=EOF;
   }
   else if (input_stream == NULL || feof(input_stream))
       c=EOF;
   else {
     if (start_of_line) {
       start_of_line=FALSE;
       line_count++;
       if (input_stream==stdin) infoline("%s",prompt); /* 21.1 */
     }
      
     c=fgetc(input_stream);
     
     if(trace_input)   /*  RM: Jan 13 1993  */
       if(c!=EOF)
     printf("%c",c);
       else
     printf(" <EOF>\n");
     
     if (c==EOLN)
       start_of_line=TRUE;
   }
 
   /* printf("%c\n",c); RM: Jan  5 1993  Just to trace the parser */
   
   return c;
 }

void read_comment ( ptr_psi_term tok )

read_comment

Parameters

tok	- ptr_psi_term tok

READ_COMMENT Read a comment starting with '' to the end of the line.

Definition at line 779 of file token.c.

References comment, EOLN, read_char(), and wl_psi_term::type.

 {
   long c;
   
   do {
     c=read_char();
   } while (c!=EOF && c!=EOLN);
   
   tok->type=comment;
 }

psi_term read_life_form	(	char	ch1,
		char	ch2
	)

read_life_form

Parameters

ch1	- char ch1
ch2	- char ch2

READ_LIFE_FORM(str1,str2) This reads in one life-form from the input stream which finishes with the psi_term whose name is STR1 or STR2, typically if we're reading a list [A,4*5,b-4!] then STR1="," and STR2="|" . It would be incorrect if "," were taken as an operator.

This routine implements the two state expression parser as described in the implementation guide. It deals with all the various types of operators, precedence is dealt with by the CRUNCH function. Each time an opening parenthesis is encountered a new expression is started.

Definition at line 728 of file parser.c.

References wl_psi_term::attr_list, bad_psi_term(), crunch(), equ_tokc, equ_tokch, error_psi_term, FALSE, fx, fy, line_count, MAX_PRECEDENCE, nop, NOP, parse_ok, parser_stack_index, pop(), precedence(), push(), put_back_token(), read_psi_term(), read_token(), stringparse, Syntaxerrorline(), TRUE, xf, xfx, xfy, yf, and yfx.

 {
   psi_term t,t2;
   long limit,pr_op,pr_1,pr_2,start=0;
   long fin=FALSE;
   long state=0;
   long prec=0;
   
   long op;
   
   limit=parser_stack_index+1;
   
   if (parse_ok)
     do {
       if (state)
     read_token(&t);
       else
     t=read_psi_term();
       
       if (!start)
     start=line_count;
       
       if (!fin)
     if (state) {
       if (equ_tokc(t,ch1) || equ_tokc(t,ch2)) {
         fin=TRUE;
         put_back_token(t);
       }
       else {
         pr_op=precedence(t,xf);
         pr_1=pr_op-1;
         
         if(pr_op==NOP) {
           pr_op=precedence(t,yf);
           pr_1=pr_op;
         }
         
         if(pr_op==NOP) {
           
           pr_op=precedence(t,xfx);
           pr_1=pr_op-1;
           pr_2=pr_op-1;
           
           if(pr_op==NOP) {
         pr_op=precedence(t,xfy);
         pr_1=pr_op-1;
         pr_2=pr_op;
           }
           
           if(pr_op==NOP) {
         pr_op=precedence(t,yfx);
         pr_1=pr_op;
         pr_2=pr_op-1;
           }
           
           /* if(pr_op==NOP) {
         pr_op=precedence(t,yfy);
         pr_1=pr_op;
         pr_2=pr_op-1;
           }
               */
           
           if(pr_op==NOP) {
         fin=TRUE;
         put_back_token(t);
           }
           else
         {
           crunch(pr_1,limit);
           push(t,pr_2,xfx);
           prec=pr_2;
           state=0;
         }
         }
         else {
           crunch(pr_1,limit);
           push(t,pr_1,xf);
           prec=pr_1;
         }
       }
     }
     else {
 
       if(t.attr_list)
         pr_op=NOP;
       else {
         pr_op=precedence(t,fx);
         pr_2=pr_op-1;
           
         if(pr_op==NOP) {
           pr_op=precedence(t,fy);
           pr_2=pr_op;
         }
       }
 
       if(pr_op==NOP) {
         if(equ_tokch(t,'(')) {
           t2=read_life_form(')',0);
           if(parse_ok) {
         push(t2,prec,nop);
         read_token(&t2);
         if(!equ_tokch(t2,')')) {
                   if (stringparse) parse_ok=FALSE;
                   else {
             /*
               perr("*** Syntax error ");psi_term_error();
               perr(": ')' missing.\n");
               */
 
             /*  RM: Feb  1 1993  */
             Syntaxerrorline("')' missing (%E)\n");
 
             put_back_token(t2);
           }
         }
         state=1;
           }
         }
         else 
           if(bad_psi_term(&t)) {
         put_back_token(t);
         /* psi_term_error(); */
         fin=TRUE;
           }
           else {
         push(t,prec,nop);
         state=1;
           }
       }
       else {
         push(t,pr_2,fx);
         prec=pr_2;
       }
       
     }
       
     } while (!fin && parse_ok);
   
   if (state)
     crunch(MAX_PRECEDENCE,limit);
   
   if (parse_ok && parser_stack_index!=limit) {
     if (stringparse) parse_ok=FALSE;
     else {
       /*
     perr("*** Syntax error ");psi_term_error();
     perr(": bad expression.\n");
     */
       
       /*  RM: Feb  1 1993  */
       Syntaxerrorline("bad expression (%E)\n");
     }
   }
   else
     (void)pop(&t,&op);
   
   if (!parse_ok)
     t= *error_psi_term;
 
   parser_stack_index=limit-1;
   
   return t;
 }

void read_name	(	ptr_psi_term	tok,
		long	ch,
		long(*)()	f,
		ptr_definition	typ
	)

void read_number	(	ptr_psi_term	tok,
		long	c
	)

read_number

Parameters

tok	- ptr_psi_term tok
c	- long c

READ_NUMBER(c) Read in the number whose first character is c. Accepted syntax: digit+ [ . digit+ ] [ {e|E} {+|-|empty} digit* ] Negative numbers are dealt with in the parser.

Definition at line 1110 of file token.c.

References DIGIT, heap_alloc(), integer, put_back_char(), read_char(), REAL, real, wl_psi_term::type, and wl_psi_term::value_3.

 {
   long c2;
   REAL f,p;
   long /* sgn, */ pwr,posflag;
 
   /* if (sgn=(c=='-')) c=read_char(); */
 
   /* tok->type=integer;   RM: Mar  8 1993  */
 
   f=0.0;
   do { f=f*10.0+(c-'0'); c=read_char(); } while (DIGIT(c));
 
   if (c=='.') {
     c2=read_char();
     if DIGIT(c2) {
       /* tok->type=real;     RM: Mar  8 1993  */
       p=10.0;
       while (DIGIT(c2)) { f=f+(c2-'0')/p; p=p*10.0; c2=read_char(); }
       put_back_char(c2);
     }
     else {
       put_back_char(c2);
       put_back_char(c);
     }
   }
   else
     put_back_char(c);
 
   c=read_char();
   if (c=='e' || c=='E') {
     c2=read_char();
     if (c2=='+' || c2=='-' || DIGIT(c2)) {
       tok->type=real;
       posflag = (c2=='+' || DIGIT(c2));
       if (!DIGIT(c2)) c2=read_char();
       pwr=0;
       while (DIGIT(c2)) { pwr=pwr*10+(c2-'0'); c2=read_char(); }
       put_back_char(c2);
       p=1.0;
       while (pwr>=100) { pwr-=100; if (posflag) p*=1e100; else p/=1e100; }
       while (pwr>=10 ) { pwr-=10;  if (posflag) p*=1e10;  else p/=1e10;  }
       while (pwr>0   ) { pwr-=1;   if (posflag) p*=1e1;   else p/=1e1;   }
       f*=p;
     }
     else {
       put_back_char(c2);
       put_back_char(c);
     }
   }
   else
     put_back_char(c);
 
   /* if (sgn) f = -f; */
   tok->value_3=heap_alloc(sizeof(REAL)); /* 12.5 */
   *(REAL *)tok->value_3=f;
 
   /*  RM: Mar  8 1993  */
   if(f==floor(f))
     tok->type=integer;
   else
     tok->type=real;
 }

psi_term read_psi_term ( )

read_psi_term

READ_PSI_TERM() This reads in a complex object from the input stream, that is, a whole psi-term.

Examples:

[A,B,C]

{0;1;2+A}

<a,b,c> death(victim => V,murderer => M)

which(x,y,z)

A:g(f)

I have allowed mixing labelled with unlabelled attributes.

Example:

f(x=>A,B,y=>K,"hklk",D) is parsed as f(1=>B,2=>"hklk",3=>D,x=>A,y=>K).

Definition at line 421 of file parser.c.

References add_module1, add_module2, add_module3, alist, apply, wl_psi_term::attr_list, bad_psi_term(), wl_keyword::combined_name, wl_psi_term::coref, current_module, disjunction, eof, equ_tok, equ_tokch, equal_types, error_psi_term, FALSE, FEATCMP, feature_insert(), find(), functor, heap_copy_string(), integer, wl_definition::keyword, wl_module::module_name, NULL, parse_list(), parse_ok, wl_keyword::private_feature, put_back_token(), quoted_string, read_life_form(), read_token(), REAL, wl_psi_term::resid, stack_copy_psi_term(), stack_insert(), stack_psi_term(), stringparse, wl_keyword::symbol, Syntaxerrorline(), TRUE, two, wl_psi_term::type, wl_psi_term::value_3, variable, and wl_const_3.

 {
   psi_term t,t2,t3;
   char s[10];
   long count=0,f=TRUE,f2,v;
   ptr_psi_term module;
   
   if(parse_ok) {
     
     read_token(&t);
     
     if(equ_tokch(t,'['))
       t=parse_list(alist,']',','); /*** RICHARD Nov_4 ***/
     else
       if(equ_tokch(t,'{')) 
     t=parse_list(disjunction,'}',';'); /*** RICHARD Nov_4 ***/
 
       /* The syntax <a,b,c> for conjunctions has been abandoned.
     else
     if(equ_tokch(t,'<'))
     t=parse_list(conjunction,'>',',');
     */
   
     if(parse_ok 
        && t.type!=eof
        && !bad_psi_term(&t)
        /* && (precedence(t,fx)==NOP)
       && (precedence(t,fy)==NOP) */
        ) {
       read_token(&t2);
       if(equ_tokch(t2,'(')) {
     
     do {
       
       f2=TRUE;
       read_token(&t2);
       
       if(wl_const_3(t2) && !bad_psi_term(&t2)) {
         read_token(&t3);
         if(equ_tok(t3,"=>")) {
           t3=read_life_form(',',')');
           
           if(t2.type->keyword->private_feature) /*  RM: Mar 11 1993  */
         feature_insert(t2.type->keyword->combined_name,
                    /*  RM: Jan 13 1993  */
                    &(t.attr_list),
                    &t3);
           else
         feature_insert(t2.type->keyword->symbol,
                    /*  RM: Jan 13 1993  */
                    &(t.attr_list),
                    &t3);
           
           f2=FALSE;
         }
         else 
           put_back_token(t3);
       }
       
       if(parse_ok && equal_types(t2.type,integer)) {
         read_token(&t3);
         if(equ_tok(t3,"=>")) {
           t3=read_life_form(',',')');
           v= *(REAL *)t2.value_3;
           (void)snprintf(s,10,"%ld",v);
               feature_insert(s,&(t.attr_list),&t3);
           f2=FALSE;
         }
         else 
           put_back_token(t3);
       }
       
       if(f2) {
         put_back_token(t2);
         t2=read_life_form(',',')');
         ++count;
         (void)snprintf(s,10,"%ld",count);
             feature_insert(s,&(t.attr_list),&t2);
       }
       
       read_token(&t2);
       
       if(equ_tokch(t2,')'))
         f=FALSE;
       else
         if(!equ_tokch(t2,',')) {
               if (stringparse) parse_ok=FALSE;
               else {
         /*
           perr("*** Syntax error ");psi_term_error();
           perr(": ',' expected in argument list.\n");
           */
 
         /*  RM: Feb  1 1993  */
         Syntaxerrorline("',' expected in argument list (%E)\n");
 
             f=FALSE;
               }
         }
       
     } while(f && parse_ok);
       }
       else
     put_back_token(t2);
     }
   }
   else
     t= *error_psi_term;
 
   if(t.type==variable && t.attr_list) {
     t2=t;
     t.type=apply;
     t.value_3=NULL;
     t.coref=NULL;
     t.resid=NULL;
     (void)stack_insert(FEATCMP,(char *)functor->keyword->symbol,
          &(t.attr_list),
          (GENERIC)stack_copy_psi_term(t2));
   }
 
 
   /*  RM: Mar 12 1993  Nasty hack for Bruno's features in modules */
   if((t.type==add_module1 || t.type==add_module2 || t.type==add_module3) &&
      !find(FEATCMP,two,t.attr_list)) {
 
     module=stack_psi_term(4);
     module->type=quoted_string;
     module->value_3=(GENERIC)heap_copy_string(current_module->module_name);
     
     (void)stack_insert(FEATCMP,two,&(t.attr_list),(GENERIC)module);
   }
   
   return t;
 }

void read_string	(	ptr_psi_term	tok,
		long	e
	)

read_string

Parameters

tok	- ptr_psi_term tok
e	- long e

READ_STRING(e) Read a string ending with character E, where E=" or '. Transform a double occurrence into a single one so that 'ab""cd' is the string 'ab"cd'.

Definition at line 859 of file token.c.

References base2int(), FALSE, heap_copy_string(), isoctal, NULL, put_back_char(), read_char(), read_string_error(), STRLEN, TOKEN_ERROR(), TRUE, wl_psi_term::type, update_symbol(), wl_psi_term::value_3, and warningline().

 {
   long c;
   string str;
   long len=0;
   long store=TRUE;
   long flag=TRUE;
   
   str[len]=0;
   
   do {
     c=read_char();
     if (c==EOF) {
       store=FALSE;
       flag=FALSE;
       read_string_error(0);
     }
     else if (e=='"' && c=='\\') {
       c=read_char();
       if (c==EOF) {
     store=FALSE;
     flag=FALSE;
     put_back_char('\\');
     read_string_error(0);
       }
       else {
     switch (c) {
     case 'a': c='\a'; break;
     case 'b': c='\b'; break;
     case 'f': c='\f'; break;
     case 'n': c='\n'; break;
     case 'r': c='\r'; break;
     case 't': c='\t'; break;
     case 'v': c='\v'; break;
       /* missing \ooo and \xhh */
     case 'x':
       {
         int n;
         c=read_char();
         if (c==EOF) {
           store=flag=FALSE;
           read_string_error(0);
           break;
         }
         else if (!isxdigit(c)) {
           store=flag=FALSE;
           read_string_error(1);
           break;
         }
         else {
           n = base2int(c);
         }
         c=read_char();
         if (isxdigit(c)) n = 16*n+base2int(c);
         else put_back_char(c);
         c=n;
         break;
       }
     default: 
       if (isoctal(c)) {
         int n,i;
         for(i=n=0;i<3&&isoctal(c);i++,c=read_char())
           n = n*8 + base2int(c);
         if (c!=EOF) put_back_char(c);
         c=n;
         break;
       }
       else break;
     }
       }
     }
     else
       if (c==e) {
     c=read_char();
     if (c!=e) {
       store=FALSE;
       flag=FALSE;
       put_back_char(c);
     }
       }
     if (store)
       if (len==STRLEN) {
     warningline("string too long, extra ignored (%E).\n");
     store=FALSE;
       }
       else {
     str[len++]=c;
     str[len]=0;
       }
   } while(flag);
   
   if (e=='"')
     tok->value_3=(GENERIC)heap_copy_string(str);
   else {
     tok->type=update_symbol(NULL,str); /* Maybe no_module would be better */
     tok->value_3=NULL;
     TOKEN_ERROR(tok);       /*  RM: Feb  1 1993  */
   }
 }

void read_string_error ( int n )

read_string_error

Parameters

n - int n

Definition at line 796 of file token.c.

References FALSE, parse_ok, stringparse, and Syntaxerrorline().

 {
   if (stringparse) parse_ok=FALSE;
   else
     switch (n) {
     case 0:
       Syntaxerrorline("end of file reached before end of string (%E).\n");
       break;
     case 1:
       Syntaxerrorline("Hexadecimal digit expected (%E).\n");
       break;
     }
 }

void read_token ( ptr_psi_term tok )

read_token

Parameters

tok	- ptr_psi_term tok

READ_TOKEN Read in one token from the input stream, represented as a psi_term. Return the psi_term 'end_of_file' if that is the case.

Used in the parser Set prompt to the 'partial input' prompt

Definition at line 1186 of file token.c.

References read_token_main(), and TRUE.

1187 { read_token_main(tok, TRUE); }

read_token_main

void read_token_main(ptr_psi_term tok, long for_parser)

read_token_main

Definition: token.c:1207

TRUE

#define TRUE

Standard boolean.

Definition: def_const.h:268

void read_token_b ( ptr_psi_term tok )

read_token_b

Parameters

tok	- ptr_psi_term tok

Used as a built-in Prompt is unchanged

Definition at line 1197 of file token.c.

References FALSE, and read_token_main().

1198 { read_token_main(tok, FALSE); }

read_token_main

void read_token_main(ptr_psi_term tok, long for_parser)

read_token_main

Definition: token.c:1207