Wild Life  2.29
 All Data Structures Files Functions Variables Typedefs Macros
login.c
Go to the documentation of this file.
1 /* Copyright 1991 Digital Equipment Corporation.
2  ** All Rights Reserved.
3  *****************************************************************/
4 /* $Id: login.c,v 1.4 1995/01/14 00:25:33 duchier Exp $ */
5 
6 #include "defs.h"
7 
8 /* Clean trail toggle */
9 /* Removed temporarily because of comb bug 1.6 */
10 #define CLEAN_TRAIL
11 
12 /* Statistics on trail cleaning */
13 long clean_iter = 0;
14 long clean_succ = 0;
15 
16 #ifdef TS
17 /* Should never wrap (32 bit is enough) 9.6 */
18 /* Rate of incrementing: One per choice point */
19 unsigned long global_time_stamp=INIT_TIME_STAMP; /* 9.6 */
20 #endif
21 
22 
23 /******************************************************************************
24 
25  What follows are the functions which assert facts in their correct places:
26  function definitions, rule definitions or type definitions.
27 
28  ****************************************************************************/
29 
30 
31 
32 /******** GET_TWO_ARGS(attr_list,arg1,arg2)
33  Get the arguments labelled '1' and '2' as quickly as possible from the
34  binary tree ATTR_LIST, place them in ARG1 and ARG2. This routine nearly
35  always makes a direct hit.
36  */
37 void get_two_args(t,a,b)
38  ptr_node t;
39  ptr_psi_term *a;
40  ptr_psi_term *b;
41 {
42  ptr_node n;
43 
44  *a=NULL;
45  *b=NULL;
46  if (t) {
47  if (t->key==one) {
48  *a=(ptr_psi_term )t->data;
49  n=t->right;
50  if (n)
51  if (n->key==two)
52  *b=(ptr_psi_term )n->data;
53  else {
54  n=find(FEATCMP,two,t);
55  if(n==NULL)
56  *b=NULL;
57  else
58  *b=(ptr_psi_term )n->data;
59  }
60  else
61  *b=NULL;
62  }
63  else {
64  n=find(FEATCMP,one,t);
65  if (n==NULL)
66  *a=NULL;
67  else
68  *a=(ptr_psi_term )n->data;
69  n=find(FEATCMP,two,t);
70  if (n==NULL)
71  *b=NULL;
72  else
73  *b=(ptr_psi_term )n->data;
74  }
75  }
76 }
77 
78 
79 
80 
81 /******** GET_ONE_ARG(attr_list,arg1)
82  Get the argument labelled '1' as quickly as possible from the
83  binary tree ATTR_LIST, place it in ARG1. This routine nearly
84  always makes a direct hit.
85  */
86 void get_one_arg(t,a)
87  ptr_node t;
88  ptr_psi_term *a;
89 {
90  ptr_node n;
91 
92  *a=NULL;
93  if (t) {
94  if (t->key==one) {
95  *a=(ptr_psi_term)t->data;
96  }
97  else {
98  n=find(FEATCMP,one,t);
99  if (n==NULL)
100  *a=NULL;
101  else
102  *a=(ptr_psi_term)n->data;
103  }
104  }
105 }
106 
107 
108 
109 
110 /******** GET_ONE_ARG_ADDR(attr_list,arg1addr)
111  Get address of slot in the attr_list that points to the argument labelled
112  '1' as quickly as possible from the binary tree ATTR_LIST.
113  This routine nearly always makes a direct hit.
114  */
116  ptr_node t;
117  ptr_psi_term **a;
118 {
119  ptr_node n;
120  // ptr_psi_term *b;
121 
122  *a=NULL;
123  if (t) {
124  if (t->key==one)
125  *a= (ptr_psi_term *)(&t->data);
126  else {
127  n=find(FEATCMP,one,t);
128  if (n==NULL)
129  *a=NULL;
130  else
131  *a= (ptr_psi_term *)(&n->data);
132  }
133  }
134 }
135 
136 
137 
138 
139 /******** ADD_RULE(head,body,typ)
140  The TYP argument is either 'predicate', 'function', or 'type'.
141  For predicates or functions, insert the clause 'HEAD :- BODY' or the rule
142  'HEAD -> BODY' into the definition of HEAD.
143  For types, insert HEAD as a term of type attributes and BODY as a type
144  constraint.
145  The global flag ASSERT_FIRST indicates whether to do the insertion at the
146  head or the tail of the existing list.
147  */
148 void add_rule(head,body,typ)
149  ptr_psi_term head;
150  ptr_psi_term body;
151  def_type typ;
152 {
153  psi_term succ;
154  ptr_psi_term head2;
155  ptr_definition def;
156  ptr_pair_list p, *p2;
157 
158  if (!body && typ==(def_type)predicate) {
159  succ.type=succeed;
160  succ.value_3=NULL;
161  succ.coref=NULL;
162  succ.resid=NULL;
163  succ.attr_list=NULL;
164  body= ≻
165  }
166 
167  deref_ptr(head);
168  head2=head;
169 
170  /* assert(head->resid==NULL); 10.8 */
171  /* assert(body->resid==NULL); 10.8 */
172 
173  if (redefine(head)) {
174 
175  def=head->type;
176 
177  if (def->type_def==(def_type)undef || def->type_def==typ)
178 
179  /* RM: Jan 27 1993 */
180  if(TRUE
181  /* def->type==undef ||
182  def->keyword->module==current_module */
183  /* RM: Feb 2 1993 Commented out */
184  ) {
185  if (def->rule && (unsigned long)def->rule<=MAX_BUILT_INS) {
186  Errorline("the built-in %T '%s' may not be redefined.\n",
187  def->type_def, def->keyword->symbol);
188  }
189  else {
190  def->type_def=typ;
191 
192  /* PVR single allocation in source */
194  clear_copy();
195  /* p->aaaa_3=exact_copy(head2,HEAP); 24.8 25.8 */
196  /* p->bbbb_3=exact_copy(body,HEAP); 24.8 25.8 */
197 
198  p->aaaa_2=quote_copy(head2,HEAP); /* 24.8 25.8 */
199  p->bbbb_2=quote_copy(body,HEAP); /* 24.8 25.8 */
200 
201  if (assert_first) {
202  p->next=def->rule;
203  def->rule=p;
204  }
205  else {
206  p->next=NULL;
207  p2= &(def->rule);
208  while (*p2) {
209  p2= &((*p2)->next);
210  }
211  *p2=p;
212  }
213  assert_ok=TRUE;
214  }
215  }
216  else { /* RM: Jan 27 1993 */
217  Errorline("the %T '%s' may not be redefined from within module %s.\n",
218  def->type_def,
219  def->keyword->combined_name,
221  }
222  else {
223  Errorline("the %T '%s' may not be redefined as a %T.\n",
224  def->type_def, def->keyword->symbol, typ);
225  }
226  }
227 }
228 
229 
230 
231 /******** ASSERT_RULE(t,typ)
232  Add a rule to the rule tree.
233  It may be either a predicate or a function.
234  The psi_term T is of the form 'H :- B' or 'H -> B', but it may be incorrect
235  (report errors). TYP is the type, function or predicate.
236  */
237 void assert_rule(t,typ)
238  psi_term t;
239  def_type typ;
240 {
241  ptr_psi_term head;
242  ptr_psi_term body;
243 
244  get_two_args(t.attr_list,&head,&body);
245  if (head)
246  if (body)
247  add_rule(head,body,typ);
248  else {
249  Syntaxerrorline("body missing in definition of %T '%P'.\n", typ, head);
250  }
251  else {
252  Syntaxerrorline("head missing in definition of %T.\n",typ);
253  }
254 }
255 
256 
257 
258 /******** ASSERT_CLAUSE(t)
259  Assert the clause T.
260  Cope with various syntaxes for predicates.
261 
262  ASSERT_FIRST is a flag indicating the position:
263  1= insert before existing rules (asserta),
264  0= insert after existing rules (assert),
265  */
266 
268  ptr_psi_term t;
269 {
270  // ptr_psi_term arg1,arg2;
271  // char *str;
272 
273  assert_ok=FALSE;
274  deref_ptr(t);
275 
276  /* RM: Feb 22 1993 defined c_alias in modules.c
277  if (equ_tok((*t),"alias")) {
278  get_two_args(t->attr_list,&arg1,&arg2);
279  if (arg1 && arg2) {
280  warningline("'%s' has taken the meaning of '%s'.\n",
281  arg2->type->keyword->symbol, arg1->type->keyword->symbol);
282  str=arg2->type->keyword->symbol;
283  assert_ok=TRUE;
284  deref_ptr(arg1);
285  deref_ptr(arg2);
286  *(arg2->type)= *(arg1->type);
287  arg2->type->keyword->symbol=str;
288  }
289  else
290  Errorline("arguments missing in %P.\n",t);
291  }
292  else
293  */
294 
295  if (equ_tok((*t),":-"))
297  else
298  if (equ_tok((*t),"->"))
300  else
301  if (equ_tok((*t),"::"))
303  else
304 
305 #ifdef CLIFE
306  if (equ_tok((*t),"block_struct"))
307  define_block(t);
308  else
309 #endif /* CLIFE */
310  /* if (equ_tok((*t),"<<<-")) { RM: Feb 10 1993
311  declare T as global. To do... maybe.
312  }
313  else
314  */
315 
316  if (equ_tok((*t),"<|") || equ_tok((*t),":="))
318  else
319  add_rule(t,NULL,(def_type)predicate);
320 
321  /* if (!assert_ok && warning()) perr("the declaration is ignored.\n"); */
322 }
323 
324 
325 
326 /******** START_CHRONO()
327  This initialises the CPU time counter.
328  */
329 
331 {
332  (void)times(&start_time);
333 }
334 
335 
336 
337 /******************************************************************************
338 
339  PROOF and UNIFICATION routines.
340 
341  These two different functions are written without using explicit recursion
342  so that backtracking can easily take place between the two. PROVE can call
343  UNIFY and vice-versa.
344 
345  The argument to PROVE is the adress of a PSI_TERM (psi-term) which represents
346  a goal to prove.
347 
348  Prove then passes that on the goal stack to MAIN_PROVE() which does
349  the real work, involving calls to UNIFY_AIM, PROVE_AIM and backtracking.
350 
351  ****************************************************************************/
352 
353 
354 
355 /******* PUSH_PTR_VALUE(p)
356  Push the pair (P,*P) onto the stack of things to be undone (trail).
357  It needn't be done if P is greater than the latest choice point because in
358  that case memory is reclaimed.
359  */
360 void push_ptr_value(t,p)
361  type_ptr t;
362  GENERIC *p;
363 {
364  ptr_stack n;
365 
366  assert(p<(GENERIC *)heap_pointer); /* RM: Feb 15 1993 */
367 
368  assert(VALID_ADDRESS(p));
369  if (p < (GENERIC *)choice_stack || p > (GENERIC *)stack_pointer)
370  {
371  n=STACK_ALLOC(stack);
372  n->type=t;
373  n->aaaa_3= (GENERIC *) p;
374  n->bbbb_3= (GENERIC *) *p;
375  n->next=undo_stack;
376  undo_stack=n;
377  }
378 }
379 
380 
381 /******** PUSH_DEF_PTR_VALUE(q,p) (9.6)
382  Same as push_ptr_value, but only for psi-terms whose definition field is
383  being modified. (If another field is modified, use push_ptr_value.)
384  This routine implements the time-stamp technique of only trailing
385  once between choice point creations, even on multiple bindings.
386  q is address of psi-term, p is address of field inside psi-term
387  that is modified. Both the definition and the time_stamp must be trailed.
388  */
390  ptr_psi_term q;
391  GENERIC *p;
392 {
393  ptr_stack m,n;
394 
395  assert(VALID_ADDRESS(q));
396  assert(VALID_ADDRESS(p));
397 #ifdef TS
398  if (trail_condition(q) &&
399  /* (q->time_stamp != global_time_stamp) && */
400  (p < (GENERIC *)choice_stack || p > (GENERIC *)stack_pointer))
401  {
402 #define TRAIL_TS
403 #ifdef TRAIL_TS
404 
405  assert((GENERIC)q<heap_pointer); /* RM: Feb 15 1993 */
406 
407  m=STACK_ALLOC(stack); /* Trail time_stamp */
408  m->type=int_ptr;
409  m->aaaa_3= (GENERIC *) &(q->time_stamp);
410  m->bbbb_3= (GENERIC *) (q->time_stamp);
411  m->next=undo_stack;
412  n=STACK_ALLOC(stack); /* Trail definition field (top of undo_stack) */
413  n->type=def_ptr;
414  n->aaaa_3= p;
415  n->bbbb_3= (GENERIC *)*p;
416  n->next=m;
417  undo_stack=n;
418 #else
419  n=STACK_ALLOC(stack); /* Trail definition field (top of undo_stack) */
420  n->type=def_ptr;
421  n->aaaa_3= p;
422  n->bbbb_3= (GENERIC *) *p;
423  n->next=undo_stack;
424  undo_stack=n;
425 #endif
426  q->time_stamp=global_time_stamp;
427  }
428 #else
430 #endif
431 }
432 
433 
434 
435 /******** PUSH_PSI_PTR_VALUE(q,p) (9.6)
436  Same as push_ptr_value, but only for psi-terms whose coref field is being
437  modified. (If another field is modified, use push_ptr_value.)
438  This routine implements the time-stamp technique of only trailing
439  once between choice point creations, even on multiple bindings.
440  q is address of psi-term, p is address of field inside psi-term
441  that is modified. Both the coref and the time_stamp must be trailed.
442  */
444  ptr_psi_term q;
445  GENERIC *p;
446 {
447  ptr_stack m,n;
448 
449  assert(VALID_ADDRESS(q));
450  assert(VALID_ADDRESS(p));
451 #ifdef TS
452  if (trail_condition(q) &&
453  /* (q->time_stamp != global_time_stamp) && */
454  (p < (GENERIC *)choice_stack || p > (GENERIC *)stack_pointer))
455  {
456 #define TRAIL_TS
457 #ifdef TRAIL_TS
458  m=STACK_ALLOC(stack); /* Trail time_stamp */
459  m->type=int_ptr;
460  m->aaaa_3= (GENERIC *) &(q->time_stamp);
461  m->bbbb_3= (GENERIC *) (q->time_stamp);
462  m->next=undo_stack;
463  n=STACK_ALLOC(stack); /* Trail coref field (top of undo_stack) */
464  n->type=psi_term_ptr;
465  n->aaaa_3= (GENERIC *) p;
466  n->bbbb_3= (GENERIC *) *p;
467  n->next=m;
468  undo_stack=n;
469 #else
470  n=STACK_ALLOC(stack); /* Trail coref field (top of undo_stack) */
471  n->type=psi_term_ptr;
472  n->aaaa_3= (ptr_psi_term)p;
473  n->bbbb_3= *p;
474  n->next=undo_stack;
475  undo_stack=n;
476 #endif
477  q->time_stamp=global_time_stamp;
478  }
479 #else
481 #endif
482 }
483 
484 
485 /* Same as push_ptr_value, but for objects that must always be trailed. */
486 /* This includes objects outside of the Life data space and entries in */
487 /* the var_tree. */
489  type_ptr t;
490  GENERIC *p;
491 {
492  ptr_stack n;
493 
494  assert(VALID_ADDRESS(p)); /* 17.8 */
495  n=STACK_ALLOC(stack);
496  n->type=t;
497  n->aaaa_3= (GENERIC *) p;
498  n->bbbb_3= (GENERIC *) *p;
499  n->next=undo_stack;
500  undo_stack=n;
501 }
502 
503 
504 
505 /******* PUSH_WINDOW(type,disp,wind)
506  Push the window information (operation, display and window identifiers) on
507  the undo_stack (trail) so that the window can be destroyed, redrawn, or
508  hidden on backtracking.
509  */
510 void push_window(type,disp,wind)
511  long type,disp,wind;
512 {
513  ptr_stack n;
514 
515  assert(type & undo_action);
516  n=STACK_ALLOC(stack);
517  n->type=type;
518  n->aaaa_3=(GENERIC *)disp;
519  n->bbbb_3=(GENERIC *)wind;
520  n->next=undo_stack;
521  undo_stack=n;
522 }
523 
524 
525 
526 /******* PUSH2_PTR_VALUE(p)
527  Push the pair (P,V) onto the stack of things to be undone (trail).
528  It needn't be done if P is greater than the latest choice point because in
529  that case memory is reclaimed.
530  */
531 void push2_ptr_value(t,p,v)
532  type_ptr t;
533  GENERIC *p;
534  GENERIC v;
535 {
536  ptr_stack n;
537 
538  if (p<(GENERIC *)choice_stack || p>(GENERIC *)stack_pointer) {
539  n=STACK_ALLOC(stack);
540  n->type=t;
541  n->aaaa_3= (GENERIC *)p;
542  n->bbbb_3= (GENERIC *)v;
543  n->next=undo_stack;
544  undo_stack=n;
545  }
546 }
547 
548 
549 
550 /******** PUSH_GOAL(t,a,b,c)
551  Push a goal onto the goal stack.
552  T is the type of the goal, A,B and C are various parameters.
553  See PUSH_CHOICE_POINT(t,a,b,c).
554  */
555 void push_goal(t,aaaa_5,bbbb_5,cccc_5)
556  goals t;
557  ptr_psi_term aaaa_5;
558  ptr_psi_term bbbb_5;
559  GENERIC cccc_5;
560 {
561  ptr_goal thegoal;
562 
563  thegoal=STACK_ALLOC(goal);
564 
565  thegoal->type=t;
566  thegoal->aaaa_1=aaaa_5;
567  thegoal->bbbb_1=bbbb_5;
568  thegoal->cccc_1=cccc_5;
569  thegoal->next=goal_stack;
570  thegoal->pending=FALSE;
571 
572  goal_stack=thegoal;
573 }
574 
575 
576 
577 /******** PUSH_CHOICE_POINT(t,a,b,c)
578  T,A,B,C is an alternative goal to try.
579  T is the type of the goal: unify or prove.
580 
581  If T=prove then
582  a=goal to prove
583  b=definition to use
584  if b=DEFRULES then that means it's a first call.
585 
586  If T=unify then
587  a and b are the terms to unify.
588 
589  etc...
590  */
591 void push_choice_point(t,aaaa_6,bbbb_6,cccc_6)
592  goals t;
593  ptr_psi_term aaaa_6;
594  ptr_psi_term bbbb_6;
595  GENERIC cccc_6;
596 {
597  ptr_goal alternative;
598  ptr_choice_point choice;
599  GENERIC top_loc;
600 
601  alternative=STACK_ALLOC(goal);
602 
603  alternative->type=t;
604  alternative->aaaa_1=aaaa_6;
605  alternative->bbbb_1=bbbb_6;
606  alternative->cccc_1=cccc_6;
607  alternative->next=goal_stack;
608  alternative->pending=FALSE;
609 
610  top_loc=stack_pointer;
611 
612  choice=STACK_ALLOC(choice_point);
613 
614  choice->undo_point=undo_stack;
615  choice->goal_stack=alternative;
616  choice->next=choice_stack;
617  choice->stack_top=top_loc;
618 
619 #ifdef TS
620  choice->time_stamp=global_time_stamp; /* 9.6 */
621  global_time_stamp++; /* 9.6 */
622 #endif
623 
624  choice_stack=choice;
625 }
626 
627 
628 #define RESTORE_TIME_STAMP global_time_stamp=\
629 choice_stack?choice_stack->time_stamp:INIT_TIME_STAMP;
630 
631 
632 
633 /******** UNDO(limit)
634  Undoes any side-effects up to LIMIT. Limit being the adress of the stack of
635  side-effects you wish to return to.
636 
637  Possible improvement:
638  LIMIT is a useless parameter because GOAL_STACK is equivalent if one takes
639  care when stacking UNDO actions. Namely, anything to be undone must be
640  stacked LATER (=after) the goal which caused these things to be done, so that
641  when the goal fails, everything done after it can be undone and the memory
642  used can be reclaimed.
643  This routine could be modified in order to cope with goals to be proved
644  on backtracking: undo(goal).
645  */
646 void undo(limit)
647  ptr_stack limit;
648 {
649  /*
650  while((unsigned long)undo_stack>(unsigned long)goal_stack)
651  */
652 
653  while ((unsigned long)undo_stack>(unsigned long)limit) {
654 #ifdef X11
655  if (undo_stack->type & undo_action) {
656  /* Window operation on backtracking */
657  switch(undo_stack->type) { /*** RM 8/12/92 ***/
658  case destroy_window:
659  x_destroy_window((Display *)undo_stack->aaaa_3,(Window)undo_stack->bbbb_3);
660  break;
661  case show_window:
662  x_show_window((Display *)undo_stack->aaaa_3,(Window)undo_stack->bbbb_3);
663  break;
664  case hide_window:
665  x_hide_window((Display *)undo_stack->aaaa_3,(Window)undo_stack->bbbb_3);
666  break;
667  case show_subwindow:
668  x_show_subwindow((Display *)undo_stack->aaaa_3,(Window)undo_stack->bbbb_3);
669  break;
670  case hide_subwindow:
671  x_hide_subwindow((Display *)undo_stack->aaaa_3,(Window)undo_stack->bbbb_3);
672  break;
673  }
674  }
675  else
676 #endif
677  /* Restoring variable value on backtracking */
680  }
681 }
682 
683 
684 
685 /******** UNDO_ACTIONS()
686  A subset of undo(limit) (the detrailing routine) that does all undo
687  actions on the undo_stack, but does not undo any variable bindings,
688  nor does it change the value of undo_stack.
689  */
691 {
692  // ptr_stack u=undo_stack;
693 
694  Errorline("undo_actions should not be called.\n");
695  undo(NULL); /* 8.10 */
696  return;
697  /*
698  #ifdef X11
699  while ((unsigned long)u) {
700  if (u->type & undo_action) {
701  if (u->type==destroy_window) {
702  x_destroy_window((unsigned long)u->aaaa_3,(unsigned long)u->bbbb_3);
703  }
704  else if (u->type==show_window) {
705  x_show_window((unsigned long)u->aaaa_3,(unsigned long)u->bbbb_3);
706  }
707  else if (u->type==hide_window) {
708  x_hide_window((unsigned long)u->aaaa_3,(unsigned long)u->bbbb_3);
709  }
710  }
711  u=u->next;
712  }
713  #endif
714  */
715 }
716 
717 
718 
719 /******** BACKTRACK()
720  Undo everything back to the previous choice-point and take the alternative
721  decision. This routine would have to be modified, along with UNDO to cope
722  with goals to be proved on backtracking.
723  */
724 void backtrack()
725 {
726  // long gts;
727 
730 #ifdef TS
731  /* global_time_stamp=choice_stack->time_stamp; */ /* 9.6 */
732 #endif
735  resid_aim=NULL;
736 
737 
738  /* assert((unsigned long)stack_pointer>=(unsigned long)cut_point); 13.6 */
739  /* This situation occurs frequently in some benchmarks (e.g comb) */
740  /* printf("*** Possible GC error: cut_point is dangling\n"); */
741  /* fflush(stdout); */
742 
743  /* assert((unsigned long)stack_pointer>=(unsigned long)match_date); 13.6 */
744 }
745 
746 
747 
748 /******** CLEAN_TRAIL(cutpt)
749  This routine removes all trail entries between the top of the undo_stack
750  and the cutpt, whose addresses are between the cutpt and stack_pointer.
751  (The cutpt is the choice point that will become the most recent
752  one after the cut.)
753  This routine should be called when a cut built-in is done.
754  This routine is careful not to remove any trailed entries that are
755  on the heap or outside of Life space.
756  */
757 static void clean_trail(cutpt)
758  ptr_choice_point cutpt;
759 {
760  ptr_stack *prev,u,cut_limit;
761  GENERIC cut_sp;
762 
763  u = undo_stack;
764  prev = &undo_stack;
765  if (cutpt) {
766  cut_sp = cutpt->stack_top;
767  cut_limit = cutpt->undo_point;
768  }
769  else {
770  cut_sp = mem_base; /* Empty stack */
771  cut_limit = NULL; /* Empty undo_stack */
772  }
773 
774  while ((unsigned long)u > (unsigned long)cut_limit) {
775  clean_iter++;
776  if (!(u->type & undo_action) && VALID_RANGE(u->aaaa_3) &&
777  (unsigned long)u->aaaa_3>(unsigned long)cut_sp && (unsigned long)u->aaaa_3<=(unsigned long)stack_pointer) {
778  *prev = u->next;
779  clean_succ++;
780  }
781  prev = &(u->next);
782  u = u->next;
783  }
784 }
785 
786 
787 
788 /******* CLEAN_UNDO_WINDOW(disp,wind)
789  Remove all trail entries that reference a given window.
790  This is called when the window is destroyed.
791  */
792 void clean_undo_window(disp,wind)
793  long disp,wind;
794 {
795  // ptr_stack *prev,u;
796  // ptr_choice_point c;
797 
798 #ifdef X11
799  /* Remove entries on the trail */
800  u = undo_stack;
801  prev = &undo_stack;
802  while (u) {
803  if ((u->type & undo_action) &&
804  ((unsigned long)u->aaaa_3==disp) && ((unsigned long)u->bbbb_3==wind)) {
805  *prev = u->next;
806  }
807  prev = &(u->next);
808  u = u->next;
809  }
810 
811  /* Remove entries at the *tops* of trail entry points from the */
812  /* choice point stack. It's only necessary to look at the tops, */
813  /* since those are the only ones that haven't been touched by */
814  /* the previous while loop. */
815  c = choice_stack;
816  while (c) {
817  u = c->undo_point;
818  prev = &(c->undo_point);
819  while (u && (u->type & undo_action) &&
820  ((unsigned long)u->aaaa_3==disp) && ((unsigned long)u->bbbb_3==wind)) {
821  *prev = u->next;
822  prev = &(u->next);
823  u = u->next;
824  }
825  c = c->next;
826  }
827 #endif
828 }
829 
830 
831 
832 /* Unify the corresponding arguments */
833 void merge1(u,v)
834  ptr_node *u,v;
835 {
836  long cmp;
837  ptr_node temp;
838 
839  if (v) {
840  if (*u==NULL) {
841  /* push_ptr_value(int_ptr,u); */
842  /* (*u)=STACK_ALLOC(node); */
843  /* **u= *v; */
844  /* more_v_attr=TRUE; */
845  }
846  else {
847  cmp=featcmp((*u)->key,v->key);
848  if (cmp==0) {
849  if (v->right)
850  merge1(&((*u)->right),v->right);
851 
852  push_goal(unify,(ptr_psi_term)(*u)->data,(ptr_psi_term)v->data,NULL);
853 
854  if (v->left)
855  merge1(&((*u)->left),v->left);
856  }
857  else if (cmp>0) {
858  temp=v->right;
859  v->right=NULL;
860  merge1(&((*u)->left),v);
861  merge1(u,temp);
862  v->right=temp;
863  }
864  else {
865  temp=v->left;
866  v->left=NULL;
867  merge1(&((*u)->right),v);
868  merge1(u,temp);
869  v->left=temp;
870  }
871  }
872  }
873  else if (*u!=NULL) {
874  /* more_u_attr=TRUE; */
875  }
876 }
877 
878 
879 /* Evaluate the lone arguments (For LAZY failure + EAGER success) */
880 /* Evaluate low numbered lone arguments first. */
881 /* For each lone argument in either u or v, create a new psi-term to put */
882 /* the (useless) result: This is needed so that *all* arguments of a uni-*/
883 /* unified psi-term are evaluated, which avoids incorrect 'Yes' answers. */
884 void merge2(u,v)
885  ptr_node *u,v;
886 {
887  long cmp;
888  ptr_node temp;
889 
890  if (v) {
891  if (*u==NULL) {
892  ptr_psi_term t;
893  merge2(u,v->right);
894  t = (ptr_psi_term) v->data;
895  deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
896  merge2(u,v->left);
897  }
898  else {
899  cmp=featcmp((*u)->key,v->key);
900  if (cmp==0) {
901  /* if (v->right) */
902  merge2(&((*u)->right),v->right);
903 
904  /* if (v->left) */
905  merge2(&((*u)->left),v->left);
906  }
907  else if (cmp>0) {
908  temp=v->right;
909  v->right=NULL;
910  merge2(&((*u)->left),v);
911  merge2(u,temp);
912  v->right=temp;
913  }
914  else {
915  temp=v->left;
916  v->left=NULL;
917  merge2(&((*u)->right),v);
918  merge2(u,temp);
919  v->left=temp;
920  }
921  }
922  }
923  else if (*u!=NULL) {
924  ptr_psi_term t;
925  merge2(&((*u)->right),v);
926  t = (ptr_psi_term) (*u)->data;
927  deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
928  merge2(&((*u)->left),v);
929  }
930 }
931 
932 
933 /* Merge v's loners into u and evaluate the corresponding arguments */
934 void merge3(u,v)
935  ptr_node *u,v;
936 {
937  long cmp;
938  ptr_node temp;
939 
940  if (v) {
941  if (*u==NULL) {
943  (*u)=STACK_ALLOC(node);
944  **u= *v;
946  }
947  else {
948  ptr_psi_term t1; // ,t2;
949 
950  cmp=featcmp((*u)->key,v->key);
951  if (cmp==0) {
952  if (v->right)
953  merge3(&((*u)->right),v->right);
954 
955  t1 = (ptr_psi_term) (*u)->data;
956  /* t2 = (ptr_psi_term) v->data; */
957  deref2_eval(t1);
958  /* deref2_eval(t2); */
959  /* push_goal(unify,(ptr_psi_term)(*u)->data,(ptr_psi_term)v->data,NULL); */
960 
961  if (v->left)
962  merge3(&((*u)->left),v->left);
963  }
964  else if (cmp>0) {
965  temp=v->right;
966  v->right=NULL;
967  merge3(&((*u)->left),v);
968  merge3(u,temp);
969  v->right=temp;
970  }
971  else {
972  temp=v->left;
973  v->left=NULL;
974  merge3(&((*u)->right),v);
975  merge3(u,temp);
976  v->left=temp;
977  }
978  }
979  }
980  else if (*u!=NULL) {
982  }
983 }
984 
985 
986 
987 
988 /******** MERGE(u,v)
989  U and V are two binary trees containing the
990  attributes fields of psi-terms. U and V are merged together, that is U
991  becomes the union of U and V:
992  For each label L in V and L->Vpsi_term:
993  If L is in U Then With L->Upsi_term Do unify(Upsi_term,Vpsi_term)
994  Else merge L->Vpsi_term in U.
995  Unification is simply done by appending the 2 psi_terms to the unification
996  stack. All effects must be recorded in the trail so that they can be
997  undone on backtracking.
998  */
999 
1000 #if FALSE
1001 /* This version is not quite right */
1002 void merge(u,v)
1003  ptr_node *u,v;
1004 {
1005  long cmp;
1006  ptr_node temp;
1007 
1008  if (v) {
1009  if (*u==NULL) {
1010  ptr_psi_term t;
1011  merge(u,v->right);
1012 
1014  (*u)=STACK_ALLOC(node);
1015  **u= *v;
1016  more_v_attr=TRUE;
1017 
1018  t = (ptr_psi_term) v->data;
1019  deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
1020  merge(u,v->left);
1021  }
1022  else {
1023  cmp=featcmp((*u)->key,v->key);
1024  if (cmp==0) {
1025  /* if (v->right) */
1026  merge(&((*u)->right),v->right);
1027 
1028  push_goal(unify,(ptr_psi_term)(*u)->data,(ptr_psi_term)v->data,NULL);
1029 
1030  /* if (v->left) */
1031  merge(&((*u)->left),v->left);
1032  }
1033  else if (cmp>0) {
1034  temp=v->right;
1035  v->right=NULL;
1036  merge(&((*u)->left),v);
1037  merge(u,temp);
1038  v->right=temp;
1039  }
1040  else {
1041  temp=v->left;
1042  v->left=NULL;
1043  merge(&((*u)->right),v);
1044  merge(u,temp);
1045  v->left=temp;
1046  }
1047  }
1048  }
1049  else if (*u!=NULL) {
1050  ptr_psi_term t;
1051  merge(&((*u)->right),v);
1052  t = (ptr_psi_term) (*u)->data;
1053  deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
1054  merge(&((*u)->left),v);
1055 
1056  more_u_attr=TRUE;
1057  }
1058 }
1059 #endif
1060 
1061 void merge(u,v)
1062  ptr_node *u,v;
1063 {
1064  merge1(u,v); /* Unify corresponding arguments */
1065  merge2(u,v); /* Evaluate lone arguments (lazy failure + eager success) */
1066  merge3(u,v); /* Merge v's loners into u & evaluate corresponding arguments */
1067 }
1068 
1069 /* For built-ins.c */
1070 void merge_unify(u,v)
1071  ptr_node *u,v;
1072 {
1073  merge1(u,v); /* Unify corresponding arguments */
1074  merge3(u,v); /* Merge v's loners into u & evaluate corresponding arguments */
1075 }
1076 
1077 
1078 
1079 
1080 /******** SHOW_COUNT()
1081  This routine doesn't do anything if not in verbose mode.
1082  It prints the number of of sub-goals attempted, along with cpu-time
1083  spent during the proof etc...
1084  */
1086 {
1087  float t;
1088 
1089  if (verbose) {
1090  printf(" [");
1091 
1092  (void)times(&end_time);
1093  t = (end_time.tms_utime - start_time.tms_utime)/60.0;
1094 
1095  printf("%1.3fs cpu, %ld goal%s",t,goal_count,(goal_count!=1?"s":""));
1096 
1097  if (t!=0.0) printf(" (%0.0f/s)",goal_count/t);
1098 
1099  printf(", %ld stack",sizeof(mem_base)*(stack_pointer-mem_base));
1100  printf(", %ld heap",sizeof(mem_base)*(mem_limit-heap_pointer));
1101 
1102  printf("]");
1103  }
1104 
1105  if(NOTQUIET) {
1106  printf("\n");
1107  stack_info(stdout);
1108  }
1109 
1110  goal_count=0;
1111 }
1112 
1113 
1114 
1115 /******** FETCH_DEF(psi_term)
1116  Fetch the type definition of a psi_term and execute it.
1117  That is, get the list of (term,predicate) pairs that define the type.
1118  Unify the psi_term with the term, then prove the predicate.
1119 
1120  This routine only gets the pairs that are defined in the type itself,
1121  not those defined in any types above it. This is the correct behavior
1122  for enumerating type disjunctions--all higher constraints have already
1123  been checked.
1124 
1125  The above is true if allflag==FALSE. If allflag==TRUE then all constraints
1126  are executed, not just those defined in the type itself.
1127  */
1128 void fetch_def(u, allflag)
1129  ptr_psi_term u;
1130  long allflag;
1131 {
1132  ptr_triple_list prop;
1133  ptr_psi_term v,w;
1134  ptr_definition utype;
1135 
1136  /* Uses SMASK because called from check_out */
1137  push2_ptr_value(int_ptr,(GENERIC *)&(u->status),(GENERIC)(u->status & SMASK));
1138  u->status=(4 & SMASK) | (u->status & RMASK);
1139 
1140  utype=u->type;
1141  prop=u->type->properties;
1142  if (prop) {
1143 
1144  traceline("fetching definition of %P\n",u);
1145 
1146  while (prop) {
1147  if (allflag || prop->cccc_4==utype) {
1148  clear_copy();
1149  v=eval_copy(prop->aaaa_4,STACK);
1150  w=eval_copy(prop->bbbb_4,STACK);
1151 
1153 
1154  deref_ptr(v);
1155  v->status=4;
1157  (void)i_eval_args(v->attr_list);
1158  }
1159  prop=prop->next;
1160  }
1161  }
1162 }
1163 
1164 
1165 /******** FETCH_DEF_LAZY(psi_term,type1,type2,attr_list1,attr_list2)
1166  Fetch the type definition of a psi_term and execute it.
1167  That is, get the list of (term,pred) pairs that define the type.
1168  'Term' is one of the type's attributes and 'pred' is a constraint.
1169  Unify the psi_term with the term, then prove pred.
1170 
1171  Only those (term,pred) pairs are executed whose original type is
1172  below both type1 and type2, the types of the two psi-terms whose
1173  unification created psi_term. This avoids doing much superfluous work.
1174 
1175  The above behavior is correct for a psi_term when always_check==TRUE for
1176  that psi_term. If always_check==FALSE for a psi_term, then if it does not
1177  have attributes it is not checked, and the addition of an attribute will
1178  force checking to occur.
1179 
1180  Example:
1181 
1182  :: t(a=>one,b=>two,c=> X) | thing(X).
1183 
1184  psi_term = A:t (it can be any psi_term of type t)
1185  term = t(a=>one,b=>two,c=> X)
1186  pred = thing(X)
1187  */
1188 void fetch_def_lazy(u, old1, old2, old1attr, old2attr, old1stat, old2stat)
1189  ptr_psi_term u;
1190  ptr_definition old1, old2;
1191  ptr_node old1attr, old2attr;
1192  long old1stat, old2stat;
1193 {
1194  ptr_triple_list prop;
1195  ptr_psi_term v,w;
1196  long checked1, checked2;
1197  long m1, m2;
1198 
1199  if (!u->type->always_check) if (u->attr_list==NULL) return;
1200 
1201  push_ptr_value(int_ptr,(GENERIC *)&(u->status));
1202  u->status=4;
1203 
1204  prop=u->type->properties;
1205  if (prop) {
1206  traceline("fetching partial definition of %P\n",u);
1207 
1208  checked1 = old1attr || old1->always_check;
1209  checked2 = old2attr || old2->always_check;
1210 
1211  /* checked1 = (old1stat==4); */ /* 18.2.94 */
1212  /* checked2 = (old2stat==4); */
1213 
1214  while (prop) {
1215  /* Only do those constraints that have not yet been done: */
1216  /* In matches, mi is TRUE iff oldi <| prop->cccc_1. */
1217  if (!checked1) m1=FALSE; else (void)matches(old1,prop->cccc_4,&m1);
1218  if (!checked2) m2=FALSE; else (void)matches(old2,prop->cccc_4,&m2);
1219  if (!m1 && !m2) {
1220  /* At this point, prop->cccc_1 is an attribute that has not yet */
1221  /* been checked. */
1222  clear_copy();
1223  v=eval_copy(prop->aaaa_4,STACK);
1224  w=eval_copy(prop->bbbb_4,STACK);
1225 
1227 
1228  deref_ptr(v);
1229  v->status=4;
1231  (void)i_eval_args(v->attr_list);
1232  }
1233  prop=prop->next;
1234  }
1235  }
1236 }
1237 
1238 
1239 
1240 /******** UNIFY_AIM()
1241  This routine performs one unification step.
1242  AIM is the current unification goal.
1243 
1244  U and V are the two psi-terms to unify.
1245 
1246  It swaps the two psi-terms into chronological order.
1247  U is the oldest (smallest stack address).
1248  Calculates their GLB, check their values are unifiable.
1249  It deals with all the messy things like:
1250  curried functions gaining missing arguments,
1251  types which need checking,
1252  residuation variables whose constraints must be released,
1253  disjunctions appearing in the GLB etc...
1254 
1255  It's a rather lengthy routine, only its speed is fairly crucial in the
1256  overall performance of Wild_Life, and the code is not duplicated elsewhere.
1257  */
1258 
1260 {
1261  return unify_body(FALSE);
1262 }
1263 
1265 {
1266  return unify_body(TRUE);
1267 }
1268 
1269 long unify_body(eval_flag)
1270  long eval_flag;
1271 {
1272  long success=TRUE,compare;
1273  ptr_psi_term u,v,tmp;
1274  // ptr_list lu,lv;
1275  REAL r;
1276  ptr_definition new_type,old1,old2;
1277  ptr_node old1attr, old2attr;
1278  ptr_int_list new_code;
1279  ptr_int_list d=NULL;
1280  long old1stat,old2stat; /* 18.2.94 */
1281 
1282  u=(ptr_psi_term )aim->aaaa_1;
1283  v=(ptr_psi_term )aim->bbbb_1;
1284 
1285  deref_ptr(u);
1286  deref_ptr(v);
1287 
1288  traceline("unify %P with %P\n",u,v);
1289 
1290  if (eval_flag) {
1291  deref(u);
1292  deref(v);
1293  }
1294 
1295  if (u!=v) {
1296 
1297  /**** Swap the two psi-terms to get them into chronological order ****/
1298  if (u>v) { tmp=v; v=u; u=tmp; }
1299 
1300  /**** Check for curried functions ****/
1303  old1stat=u->status; /* 18.2.94 */
1304  old2stat=v->status; /* 18.2.94 */
1305 
1306  /* PVR 18.2.94 */
1307  /* if (u_func && !(u->flags&QUOTED_TRUE) && v->attr_list) { */
1308  if (u_func && u->status==4 && !(u->flags&QUOTED_TRUE) && v->attr_list) {
1309  Errorline("attempt to unify with curried function %P\n", u);
1310  return FALSE;
1311  }
1312  /* if (v_func && !(v->flags&QUOTED_TRUE) && u->attr_list) { */
1313  if (v_func && v->status==4 && !(v->flags&QUOTED_TRUE) && u->attr_list) {
1314  Errorline("attempt to unify with curried function %P\n", v);
1315  return FALSE;
1316  }
1317 
1318 
1319 #ifdef ARITY /* RM: Mar 29 1993 */
1320  arity_unify(u,v);
1321 #endif
1322 
1323  /***** Deal with global vars **** RM: Feb 8 1993 */
1324  if((GENERIC) v>=heap_pointer)
1325  return global_unify(u,v);
1326 
1327 
1328  /**** Calculate their Greatest Lower Bound and compare them ****/
1329  success=(compare=glb(u->type,v->type,&new_type,&new_code));
1330 
1331  if (success) {
1332 
1333  /**** Keep the old types for later use in incr. constraint checking ****/
1334  old1 = u->type;
1335  old2 = v->type;
1336  old1attr = u->attr_list;
1337  old2attr = v->attr_list;
1338 
1339  /**** DECODE THE RESULTING TYPE ****/
1340  if (!new_type) {
1341  d=decode(new_code);
1342  if (d) {
1343  new_type=(ptr_definition)d->value_1;
1344  d=d->next;
1345  }
1346  else
1347  Errorline("undecipherable sort code.\n");
1348  }
1349 
1350  /**** Make COMPARE a little more precise ****/
1351  if (compare==1)
1352  if (u->value_3 && !v->value_3)
1353  compare=2;
1354  else
1355  if (v->value_3 && !u->value_3)
1356  compare=3;
1357 
1358  /**** Determine the status of the resulting psi-term ****/
1359  new_stat=4;
1360  switch (compare) {
1361  case 1:
1362  if (u->status <4 && v->status <4)
1363  new_stat=2;
1364  break;
1365  case 2:
1366  if (u->status<4)
1367  new_stat=2;
1368  break;
1369  case 3:
1370  if (v->status<4)
1371  new_stat=2;
1372  break;
1373  case 4:
1374  new_stat=2;
1375  break;
1376  }
1377 
1378  /*
1379  printf("u=%s, v=%s, compare=%ld, u.s=%ld, v.s=%ld, ns=%ld\n",
1380  u->type->keyword->symbol,
1381  v->type->keyword->symbol,
1382  compare,
1383  u->status,
1384  v->status,
1385  new_stat);
1386  */
1387 
1388  /**** Check that integers have no decimals ****/
1389  if (u->value_3 && sub_type(new_type,integer)) {
1390  r= *(REAL *)u->value_3;
1391  success=(r==floor(r));
1392  }
1393  if (success && v->value_3 && sub_type(new_type,integer)) {
1394  r= *(REAL *)v->value_3;
1395  success=(r==floor(r));
1396  }
1397 
1398  /**** Unify the values of INTs REALs STRINGs LISTs etc... ****/
1399  if (success) {
1400  /* LAZY-EAGER */
1401  if (u->value_3!=v->value_3)
1402  if (!u->value_3) {
1403  compare=4;
1405  u->value_3=v->value_3;
1406  }
1407  else if (v->value_3) {
1408  if (overlap_type(new_type,real))
1409  success=(*((REAL *)u->value_3)==(*((REAL *)v->value_3)));
1410  else if (overlap_type(new_type,quoted_string))
1411  success=(strcmp((char *)u->value_3,(char *)v->value_3)==0);
1412  else if (overlap_type(new_type,sys_bytedata)) {
1413  unsigned long ulen = *((unsigned long *)u->value_3);
1414  unsigned long vlen = *((unsigned long *)v->value_3);
1415  success=(ulen==vlen &&
1416  (bcmp((char *)u->value_3,(char *)v->value_3,ulen)==0));
1417  }
1418  else if (u->type==cut && v->type==cut) { /* 22.9 */
1419  ptr_psi_term mincut;
1420  mincut = (ptr_psi_term) (u->value_3 < (GENERIC) v->value_3? u->value_3 : v->value_3);
1421  if (mincut!=(ptr_psi_term)u->value_3) {
1423  u->value_3=(GENERIC)mincut;
1424  }
1425  }
1426  else {
1427  warningline("'%s' may not be unified.\n",new_type->keyword->symbol);
1428  success=FALSE;
1429  }
1430  }
1431  else
1432  compare=4;
1433  }
1434 
1435  /**** Bind the two psi-terms ****/
1436  if (success) {
1437  /* push_ptr_value(psi_term_ptr,(ptr_psi_term *)&(v->coref)); 9.6 */
1438  push_psi_ptr_value(v,(GENERIC *)&(v->coref));
1439  v->coref=u;
1440 
1441  if (!equal_types(u->type,new_type)) {
1442  push_ptr_value(def_ptr,(GENERIC *)&(u->type));
1443  /* This does not seem to work right with cut.lf: */
1444  /* push_def_ptr_value(u,&(u->type_3)); */ /* 14.8 */
1445  u->type=new_type;
1446  }
1447 
1448  if (u->status!=new_stat) {
1450  u->status=new_stat;
1451  }
1452 
1453  /**** Unify the attributes ****/
1456 
1457 
1458 #ifdef ARITY /* RM: Mar 29 1993 */
1459  arity_merge(u->attr_list,v->attr_list);
1460 #endif
1461 
1462 
1463  if (u->attr_list || v->attr_list)
1464  merge(&(u->attr_list),v->attr_list);
1465 
1466  /**** Look after curried functions ****/
1467  /*
1468  if ((u_func && more_v_attr) || (v_func && more_u_attr)) {
1469  if (!(u->flags&QUOTED_TRUE | v->flags&QUOTED_TRUE)) {
1470  traceline("re-evaluating curried expression %P\n", u);
1471  if (u->status!=0) {
1472  push_ptr_value(int_ptr,(ptr_psi_term *)&(u->status));
1473  u->status=0;
1474  }
1475  check_func(u);
1476  }
1477  }
1478  */
1479 
1480  if (v->flags&QUOTED_TRUE && !(u->flags&QUOTED_TRUE)) { /* 16.9 */
1481  push_ptr_value(int_ptr,(GENERIC *)&(u->flags));
1482  u->flags|=QUOTED_TRUE;
1483  }
1484 
1485  /**** RELEASE RESIDUATIONS ****/
1486  /* This version implements the correct semantics. */
1487  if (u->resid)
1488  release_resid(u);
1489  if (v->resid)
1490  release_resid(v);
1491 
1492  /**** Alternatives in a type disjunction ****/
1493  if (d) {
1494  traceline("pushing type disjunction choice point for %P\n",u);
1496  }
1497 
1498  /**** VERIFY CONSTRAINTS ****/
1499  /* if ((old1stat<4 || old2stat<4) &&
1500  (u->type->type==type || v->type->type==type)) { 18.2.94 */
1501  if (new_stat<4 && u->type->type_def==(def_type)type_it) {
1502  /* This does not check the already-checked properties */
1503  /* (i.e. those in types t with t>=old1 or t>=old2), */
1504  /* and it does not check anything if u has no attributes. */
1505  /* It will, however, check the unchecked properties if a */
1506  /* type gains attributes. */
1507  fetch_def_lazy(u, old1, old2,
1508  old1attr, old2attr,
1509  old1stat, old2stat);
1510  }
1511  }
1512  }
1513  }
1514  return success;
1515 }
1516 
1517 
1518 
1519 /******** DISJUNCT_AIM()
1520  This is the disjunction enumeration routine.
1521  If U is the disjunction {H|T} then first bind U to H, then on backtracking
1522  enumerate the disjunction T. U is always passed along so that every choice
1523  of the disjunction can be bound to U.
1524  */
1526 {
1527  // ptr_psi_term u,v;
1528  // ptr_list l;
1529  long success=TRUE;
1530 
1531  printf("Call to disjunct_aim\nThis routine inhibited by RM: Dec 9 1992\n");
1532 
1533  return success;
1534 }
1535 
1536 
1537 
1538 /******** PROVE_AIM()
1539  This is the proving routine. It performs one
1540  proof step, that is: finding the definition to use to prove AIM, and
1541  unifying the HEAD with the GOAL before proving. It all works by pushing
1542  sub-goals onto the goal_stack. Special cases are CUT and AND (","). Built-in
1543  predicates written in C are called.
1544  */
1546 {
1547  long success=TRUE;
1548  ptr_psi_term thegoal,head,body,arg1,arg2;
1549  ptr_pair_list rule;
1550 
1551  thegoal=(ptr_psi_term )aim->aaaa_1;
1552  rule=(ptr_pair_list )aim->bbbb_1;
1553 
1554  if (thegoal && rule) {
1555 
1556  deref_ptr(thegoal); /* Evaluation is explicitly handled later. */
1557 
1558  if (thegoal->type!=and) {
1559  if (thegoal->type!=cut)
1560  if(thegoal->type!=life_or) {
1561  /* User-defined predicates with unevaluated arguments */
1562  /* Built-ins do this themselves (see built_ins.c). */
1563  /* if (!thegoal->type->evaluate_args) mark_quote(thegoal); 24.8 25.8 */
1564 
1565  if(i_check_out(thegoal)) { /* RM: Apr 6 1993 */
1566 
1567  goal_stack=aim->next;
1568  goal_count++;
1569 
1570  if ((unsigned long)rule==DEFRULES) {
1571  rule=(ptr_pair_list)thegoal->type->rule;
1572  if (thegoal->type->type_def==(def_type)predicate) {
1573  if (!rule) /* This can happen when RETRACT is used */
1574  success=FALSE;
1575  }
1576  else if ( thegoal->type->type_def==(def_type)function_it
1577  || ( thegoal->type->type_def==(def_type)type_it
1578  && sub_type(boolean,thegoal->type)
1579  )
1580  ) {
1581  if (thegoal->type->type_def==(def_type)function_it && !rule)
1582  /* This can happen when RETRACT is used */
1583  success=FALSE;
1584  else {
1585  ptr_psi_term bool_pred;
1586  ptr_node a;
1587  /* A function F in pred. position is called as */
1588  /* '*bool_pred*'(F), which succeeds if F returns true */
1589  /* and fails if it returns false. It can residuate too. */
1590  bool_pred=stack_psi_term(0);
1591  bool_pred->type=boolpredsym;
1592  bool_pred->attr_list=(a=STACK_ALLOC(node));
1593  a->key=one;
1594  a->left=a->right=NULL;
1595  a->data=(GENERIC) thegoal;
1597  return success; /* We're done! */
1598  }
1599  }
1600  else if (!thegoal->type->protected && thegoal->type->type_def==(def_type)undef) {
1601  /* Don't give an error message for undefined dynamic objects */
1602  /* that do not yet have a definition */
1603  success=FALSE;
1604  }
1605  else if (thegoal->type==lf_true || thegoal->type==lf_false) {
1606  /* What if the 'lf_true' or 'lf_false' have arguments? */
1607  success=(thegoal->type==lf_true);
1608  return success; /* We're done! */
1609  }
1610  else {
1611  /* Error: undefined predicate. */
1612  /* Call the call_handler (which may do an auto-load). */
1613  ptr_psi_term call_handler;
1614  /* mark_quote(thegoal); */
1615 
1616  /* RM: Jan 27 1993 */
1617  /* warningline("call handler invoked for %P\n",thegoal); */
1618 
1619  call_handler=stack_psi_term(0);
1620  call_handler->type=call_handlersym;
1621  stack_add_psi_attr(call_handler,"1",thegoal);
1623  return success; /* We're done! */
1624  }
1625  }
1626 
1627  if (success) {
1628 
1629  if ((unsigned long)rule<=MAX_BUILT_INS) {
1630 
1631  /* For residuation (RESPRED) */
1632  curried=FALSE;
1633  can_curry=TRUE;
1634  resid_vars=NULL;
1635  /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
1636 
1637  if (thegoal->type!=tracesym) /* 26.1 */
1638  traceline("prove built-in %P\n", thegoal);
1639 
1640  /* RESPRED */ resid_aim=aim;
1641  /* Residuated predicate must return success=TRUE */
1642  success=c_rule[(unsigned long)rule]();
1643 
1644  /* RESPRED */ if (curried)
1645  /* RESPRED */ do_currying();
1646  /* RESPRED */ else if (resid_vars)
1647  /* RESPRED */ success=do_residuation_user(); /* 21.9 */ /* PVR 9.2.94 */
1648  }
1649  else {
1650 
1651  /* Evaluate arguments of a predicate call before the call. */
1652  deref_args(thegoal,set_empty);
1653 
1654  traceline("prove %P\n", thegoal);
1655 
1656  /* For residuation (RESPRED) */
1657  curried=FALSE;
1658  can_curry=TRUE;
1659  resid_vars=NULL;
1660  /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
1661 
1662  while (rule && (rule->aaaa_2==NULL || rule->bbbb_2==NULL)) {
1663  rule=rule->next;
1664  traceline("alternative clause has been retracted\n");
1665  }
1666  if (rule) {
1667 
1668  clear_copy();
1669  if (TRUE) /* 8.9 */
1670  /* if (thegoal->type->evaluate_args) 8.9 */
1671  head=eval_copy(rule->aaaa_2,STACK);
1672  else
1673  head=quote_copy(rule->aaaa_2,STACK);
1674 
1675  body=eval_copy(rule->bbbb_2,STACK);
1676 
1677  /* What does this do?? */
1678  /* if (body->type==built_in) */
1679  /* body->coref=head; */
1680 
1681  if (rule->next)
1682  push_choice_point(prove,thegoal,(ptr_psi_term)rule->next,NULL);
1683 
1684  if (body->type!=succeed)
1686 
1687  /* push_ptr_value(psi_term_ptr,&(head->coref)); 9.6 */
1688  push_psi_ptr_value(head,(GENERIC *)&(head->coref));
1689  head->coref=thegoal;
1690  merge(&(thegoal->attr_list),head->attr_list);
1691  if (!head->status) {
1692  (void)i_eval_args(head->attr_list);
1693  }
1694  }
1695  else {
1696  success=FALSE;
1697  }
1698  }
1699  }
1700  }
1701  }
1702  else { /* ';' built-in */
1703  /* RM: Apr 6 1993 */
1704  goal_stack=aim->next;
1705  goal_count++;
1706  get_two_args(thegoal->attr_list,&arg1,&arg2);
1708  push_goal(prove,(ptr_psi_term)arg1,(ptr_psi_term)DEFRULES,NULL);
1709  }
1710  else { /* 'Cut' built-in*/
1711  goal_stack=aim->next;
1712  goal_count++;
1713  /* assert((ptr_choice_point)(thegoal->value)<=choice_stack); 12.7 */
1714  cut_to(thegoal->value_3); /* 12.7 */
1715 #ifdef CLEAN_TRAIL
1717 #endif
1718  traceline("cut all choice points back to %x\n",choice_stack);
1719  }
1720  }
1721  else { /* 'And' built-in */
1722  goal_stack=aim->next;
1723  goal_count++;
1724  get_two_args(thegoal->attr_list,&arg1,&arg2);
1726  push_goal(prove,(ptr_psi_term)arg1,(ptr_psi_term)DEFRULES,NULL);
1727  }
1728  }
1729  else
1730  success=FALSE;
1731 
1732  /* RESPRED */ resid_aim=NULL;
1733  return success;
1734 }
1735 
1736 
1737 
1738 /******** TYPE_DISJ_AIM()
1739  This routine implements type disjunctions, that is, when a type has been
1740  decoded and found to be a disjunction of types, enumerates the different
1741  values one by one.
1742  */
1743 
1745 {
1746  ptr_psi_term t;
1747  ptr_int_list d;
1748 
1749  t=(ptr_psi_term)aim->aaaa_1;
1750  d=(ptr_int_list)aim->bbbb_1;
1751 
1752  if (d->next) {
1753  traceline("pushing type disjunction choice point for %P\n", t);
1755  }
1756 
1757  push_ptr_value(def_ptr,(GENERIC *)&(t->type));
1758  /* Below makes cut.lf behave incorrectly: */
1759  /* push_def_ptr_value(t,&(t->type)); */ /* 14.8 */
1760  t->type=(ptr_definition)d->value_1;
1761 
1762  traceline("setting type disjunction to %s.\n", t->type->keyword->symbol);
1763 
1764  if ((t->attr_list || t->type->always_check) && t->status<4)
1765  fetch_def(t, FALSE);
1766 }
1767 
1768 
1769 
1770 /******** CLAUSE_AIM(r)
1771  Prove a CLAUSE or RETRACT goal. That is try to
1772  unify the calling argument with the current rule. If this succeeds and
1773  R=TRUE then delete the rule (RETRACT).
1774  */
1775 long clause_aim(r)
1776  long r;
1777 {
1778  long success=FALSE;
1779  ptr_pair_list *p;
1780  ptr_psi_term head,body,rule_head,rule_body;
1781 
1782  head=(ptr_psi_term)aim->aaaa_1;
1783  body=(ptr_psi_term)aim->bbbb_1;
1784  p=(ptr_pair_list *)aim->cccc_1;
1785 
1786  if ((unsigned long)(*p)>MAX_BUILT_INS) {
1787  success=TRUE;
1788  /* deref(head); 17.9 */
1789 
1790  if ((*p)->next) {
1791  if (r) {
1792  traceline("pushing 'retract' choice point for %P\n", head);
1793  push_choice_point(del_clause,head,(ptr_psi_term)body,(GENERIC)&((*p)->next));
1794  /* push_choice_point(del_clause,head,body,p); */
1795  }
1796  else {
1797  traceline("pushing 'clause' choice point for %P\n", head);
1798  push_choice_point(clause,head,(ptr_psi_term)body,(GENERIC)&((*p)->next));
1799  }
1800  }
1801 
1802  if (r)
1804  if ((*p)->aaaa_2) {
1805  clear_copy();
1806  rule_head=quote_copy((*p)->aaaa_2,STACK);
1807  rule_body=quote_copy((*p)->bbbb_2,STACK);
1808 
1809  push_goal(unify,(ptr_psi_term)body,(ptr_psi_term)rule_body,NULL);
1810  push_goal(unify,(ptr_psi_term)head,(ptr_psi_term)rule_head,NULL);
1811 
1812  rule_head->status=4;
1813  rule_body->status=4;
1814 
1815  (void)i_eval_args(rule_body->attr_list);
1816  (void)i_eval_args(rule_head->attr_list);
1817 
1818  traceline("fetching next clause for %s\n", head->type->keyword->symbol);
1819  }
1820  else {
1821  success=FALSE;
1822  traceline("following clause had been retracted\n");
1823  }
1824  }
1825  else if ((unsigned long)(*p)>0) {
1826  if (r)
1827  Errorline("the built-in %P cannot be retracted.\n",head);
1828  else
1829  Errorline("the definition of built-in %P is not accessible.\n",head);
1830  }
1831 
1832  return success;
1833 }
1834 
1835 
1836 /* Return TRUE iff the top choice point is a what_next choice point */
1837 /* or if there are no choice points. */
1839 {
1841 }
1842 
1843 
1844 /* Return the number of choice points on the choice point stack */
1846 {
1847  long num;
1848  ptr_choice_point cp;
1849 
1850  num=0;
1851  cp=choice_stack;
1852  while (cp) {
1853  num++;
1854  cp=cp->next;
1855  }
1856  return num;
1857 }
1858 
1859 
1860 /* Return the number of variables in the variable tree. */
1861 long num_vars(vt)
1862  ptr_node vt;
1863 {
1864  // long num;
1865 
1866  return (vt?(num_vars(vt->left)+1+num_vars(vt->right)):0);
1867 }
1868 
1869 
1870 
1871 /* Cut away up to and including the first 'what_next' choice point. */
1873 {
1874  long flag=TRUE;
1875  long result=FALSE;
1876 
1877  do {
1878  if (choice_stack) {
1879  backtrack();
1880  if (goal_stack->type==what_next) {
1881  flag=FALSE;
1882  result=TRUE;
1883  }
1884  }
1885  else {
1886  /* This undo does the last undo actions before returning to top level. */
1887  /* It is not needed for variable undoing, but for actions (like */
1888  /* closing windows). */
1889  undo(NULL);
1890  /* undo(mem_base); 7.8 */
1891 #ifdef TS
1892  /* global_time_stamp=INIT_TIME_STAMP; */ /* 9.6 */
1893 #endif
1894  flag=FALSE;
1895  }
1896  } while (flag);
1897 
1898  return result;
1899 }
1900 
1901 
1902 /* UNUSED 12.7 */
1903 /* Return the choice point corresponding to the first 'what_next' */
1904 /* choice point in the choice point stack. Return NULL if there is none. */
1905 /* This is used to ensure that cuts don't go below the most recent */
1906 /* 'what_next' choice point. */
1908 {
1910 
1911  while (cp && cp->goal_stack && cp->goal_stack->type!=what_next)
1912  cp=cp->next;
1913 
1914  if (cp && cp->goal_stack && cp->goal_stack->type==what_next)
1915  return cp;
1916  else
1917  return (ptr_choice_point) NULL;
1918 }
1919 
1920 
1921 /* Called when level jumps back to zero. Setting these two pointers to */
1922 /* NULL causes an exit from main_prove and will then reset all other */
1923 /* global information. */
1925 {
1926  undo(NULL); /* 8.10 */
1927  goal_stack=NULL;
1929 #ifdef TS
1930  /* global_time_stamp=INIT_TIME_STAMP; */ /* 9.6 */
1931 #endif
1932 }
1933 
1934 
1935 /******** WHAT_NEXT_AIM()
1936  Find out what the user wants to do:
1937  a) retry current goal -> ';'
1938  b) quit current goal -> RETURN
1939  c) add current goal -> 'new goal ?'
1940  d) return to top level -> '.'
1941  */
1943 {
1944  long result=FALSE;
1945  ptr_psi_term s;
1946  long c, c2; /* 21.12 (prev. char) */
1947  char *pr;
1948  long sort,cut_loc=FALSE;
1949  long level,i;
1950  long eventflag;
1951  ptr_stack save_undo_stack;
1952  long lev1,lev2;
1954 
1955  level=((unsigned long)aim->cccc_1);
1956 
1957  if (aim->aaaa_1) {
1958  /* Must remember var_occurred from the what_next goal and from */
1959  /* execution of previous query (it may have contained a parse) */
1960  var_occurred=var_occurred || ((unsigned long)aim->bbbb_1)&TRUEMASK; /* 18.8 */
1961  eventflag=(((unsigned long)aim->bbbb_1)&(TRUEMASK*2))!=0;
1962  if (
1963  !var_occurred && no_choices() && level>0
1964 #ifdef X11
1965  /* Keep level same if no window & no X event */
1966  && !x_window_creation && !eventflag
1967 #endif
1968  ) {
1969  /* Keep level the same if in a query, the number of choice points */
1970  /* has not increased and there are no variables. */
1971  /* This has to have the same behavior as if an EOLN was typed */
1972  /* and no 'No' message should be given on the lowest level, */
1973  level--;
1974  (void)what_next_cut();
1975  if (level==0) { result=TRUE; }
1976  }
1977  }
1978 
1979 #ifdef X11
1981 #endif
1982 
1983  infoline(aim->aaaa_1?"\n*** Yes":"\n*** No");
1984  show_count();
1985  if (aim->aaaa_1 || level>0 ) (void)print_variables(NOTQUIET); // had commente || ... DJD
1986 
1987  {
1988  if (level > 0 && aborthooksym->type_def != (def_type)function_it )
1989  {
1990  lev1=MAX_LEVEL<level?MAX_LEVEL:(level);
1991  lev2=level;
1992  }
1993  else
1994  {
1995  lev1 = 0;
1996  lev2 = 0;
1997  }
1998 
1999  pr=prompt_buffer;
2000  /* RM: Oct 13 1993 */
2002  *pr='\0';
2003  else
2004  strcpy(pr,current_module->module_name);
2005  pr += strlen(pr);
2006  for(i=1;i<=lev1;i++) { *pr='-'; pr++; *pr='-'; pr++; }
2007  if (lev2>0)
2008  sprintf(pr,"%ld",lev2);
2009  strcat(pr,PROMPT);
2010 
2012  }
2013 
2014  stdin_cleareof();
2015  /* The system waits for either an input command or an X event. */
2016  /* An X event is treated *exactly* like an input command that */
2017  /* has the same effect. */
2018 #ifdef X11
2019  c=x_read_stdin_or_event(&eventflag);
2020  if (eventflag) {
2021  /* Include eventflag info in var_occurred field. */
2022  push_goal(what_next,(ptr_psi_term)TRUE,(ptr_psi_term)(FALSE+2*TRUE),(GENERIC)level /* +1 RM: Jun 22 1993 */);
2024  result=TRUE;
2025  }
2026  else
2027 #else
2028  c=read_char();
2029 #endif
2030  {
2031  while (c!=EOLN && c>0 && c<=32 && c!=EOF) {
2032  c=read_char();
2033  }
2034  if (c==EOF) {
2035  reset_stacks();
2036  }
2037  else if (c==EOLN) {
2038  cut_loc=TRUE;
2039  }
2040  else if (c==';' || c=='.') {
2041  do {
2042  c2=read_char();
2043  } while (c2!=EOLN && c2!=EOF && c2>0 && c2<=32);
2044  if (c=='.') { /* 6.10 */
2045  reset_stacks();
2046  result=TRUE;
2047  }
2048  }
2049  else {
2051 
2052  put_back_char(c);
2054  save_undo_stack=undo_stack;
2055  s=stack_copy_psi_term(parse(&sort));
2056 
2057  if (s->type==eof) {
2058  reset_stacks();
2059  put_back_char(EOF);
2060  } else if (sort==QUERY) {
2063  reset_step();
2064  result=TRUE;
2065  }
2066  else if (sort==FACT) { /* A declaration */
2067  push_goal(what_next,(ptr_psi_term)TRUE,(ptr_psi_term)FALSE,(GENERIC)(level + 1)); /* 18.5 */ // HERE
2069  assert_clause(s);
2070  /* Variables in the query may be used in a declaration, */
2071  /* but the declaration may not add any variables. */
2072  undo(save_undo_stack); /* 17.8 */
2073  encode_types();
2074  result=TRUE;
2075  }
2076  else {
2077  /* Stay at same level on syntax error */
2078  push_goal(what_next,(ptr_psi_term)TRUE,(ptr_psi_term)FALSE,(GENERIC)(level+1)); /* 20.8 */
2079  result=TRUE; /* 20.8 */
2080  }
2081  }
2082  }
2083 
2084  if (cut_loc) result = what_next_cut() || result;
2085 
2086  end_terminal_io();
2087 
2089  start_chrono();
2090 
2091  return result;
2092 }
2093 
2094 
2095 
2096 /******** LOAD_AIM()
2097  Continue loading a file from the current psi-term up to the next query.
2098  Files are loaded in blocks of assertions that end with a query.
2099  Such a chunk is loaded by a 'load' goal on the goal_stack.
2100  This goal contains the input file state information. This guarantees that
2101  all queries in the input file are executed in the order they are encountered
2102  (which includes load operations).
2103 */
2104 long load_aim()
2105 {
2106  long success=TRUE,exitloop;
2107  ptr_psi_term s;
2108  long sort;
2109  char *fn;
2110  long old_noisy,old_file_date;
2111  ptr_node old_var_tree;
2112  ptr_choice_point cutpt;
2113  long old_var_occurred; /* 18.8 */
2114  int end_of_file=FALSE; /* RM: Jan 27 1993 */
2115 
2116 
2120  old_file_date=file_date;
2121  file_date=(unsigned long)aim->bbbb_1;
2122  old_noisy=noisy;
2123  noisy=FALSE;
2124  fn=(char*)aim->cccc_1;
2125  exitloop=FALSE;
2126 
2127 
2128 
2129  do {
2130  /* Variables in queries in files are *completely independent* of top- */
2131  /* level variables. I.e.: top-level variables are *not* recognized */
2132  /* while loading files and variables in file queries are *not* added. */
2133  old_var_occurred=var_occurred; /* 18.8 */
2134  old_var_tree=var_tree;
2135  var_tree=NULL;
2136  s=stack_copy_psi_term(parse(&sort));
2137  var_tree=old_var_tree;
2138  var_occurred=old_var_occurred; /* 18.8 */
2139 
2140  if (s->type==eof) {
2141  encode_types();
2142  if (input_stream!=stdin) (void)fclose(input_stream);
2143  exitloop=TRUE;
2144  end_of_file=TRUE; /* RM: Jan 27 1993 */
2145  }
2146  else if (sort==FACT) {
2148  assert_clause(s);
2149  }
2150  else if (sort==QUERY) {
2151  encode_types();
2153  /* Handle both successful and failing queries correctly. */
2154  cutpt=choice_stack;
2159  exitloop=TRUE;
2160  }
2161  else {
2162  /* fprintf(stderr,"*** Error: in input file %c%s%c.\n",34,fn,34); */
2163  /* success=FALSE; */
2164  /* fail_all(); */
2165  if (input_stream!=stdin) (void)fclose(input_stream);
2166  (void)abort_life(TRUE);
2167  /* printf("\n*** Abort\n"); */
2168  /* main_loop_ok=FALSE; */
2169  }
2170  } while (success && !exitloop);
2171 
2172 
2173  /* RM: Jan 27 1993 */
2174  if(end_of_file || !success) {
2175  /*
2176  printf("END OF FILE %s, setting module to %s\n",
2177  ((ptr_psi_term)get_attr(input_state,
2178  INPUT_FILE_NAME))->value,
2179  ((ptr_psi_term)get_attr(input_state,
2180  CURRENT_MODULE))->value);
2181  */
2182 
2183  (void)set_current_module(
2185  CURRENT_MODULE))->value_3));
2186  }
2187 
2188 
2189  noisy=old_noisy;
2190  file_date=old_file_date;
2191  (void)open_input_file("stdin");
2192 
2193 
2194  return success;
2195 }
2196 
2197 
2198 
2199 /******** MAIN_PROVE()
2200  This is the inference engine. It distributes sub-goals to the appropriate
2201  routines. It deals with backtracking. It fails if there is not enough
2202  memory available or if there is an interrupt that causes the current query
2203  to be aborted.
2204 */
2206 {
2207  long success=TRUE;
2208  ptr_pair_list *p;
2209  ptr_psi_term unused_match_date; /* 13.6 */
2210 
2211  xcount=0;
2215 
2216  while (main_loop_ok && goal_stack) {
2217 
2218  /* RM: Oct 28 1993 For debugging a horrible mess.
2219  {
2220  ptr_choice_point c=choice_stack;
2221  while(c) {
2222  if((ptr_psi_term)stack_pointer<(ptr_psi_term)c) {
2223  printf("########### Choice stack corrupted! %x\n",c);
2224  trace=TRUE;
2225  c=NULL;
2226  }
2227  else
2228  c=c->next;
2229  }
2230  }
2231  */
2232 
2233 
2234  aim=goal_stack;
2235  switch(aim->type) {
2236 
2237  case unify:
2238  goal_stack=aim->next;
2239  goal_count++;
2240  success=unify_aim();
2241  break;
2242 
2243  /* Same as above, but do not evaluate top level */
2244  /* Used to bind with unbound variables */
2245  case unify_noeval:
2246  goal_stack=aim->next;
2247  goal_count++;
2248  success=unify_aim_noeval();
2249  break;
2250 
2251  case prove:
2252  success=prove_aim();
2253  break;
2254 
2255  case eval:
2256  goal_stack=aim->next;
2257  goal_count++;
2258  success=eval_aim();
2259  break;
2260 
2261  case load:
2262  goal_stack=aim->next;
2263  goal_count++;
2264  success=load_aim();
2265  break;
2266 
2267  case match:
2268  goal_stack=aim->next;
2269  goal_count++;
2270  success=match_aim();
2271  break;
2272 
2273  case disj:
2274  goal_stack=aim->next;
2275  goal_count++;
2276  success=disjunct_aim();
2277  break;
2278 
2279  case general_cut:
2280  goal_stack=aim->next;
2281  goal_count++;
2282  /* assert((ptr_choice_point)aim->aaaa_1 <= choice_stack); 12.7 */
2283  /* choice_stack=(ptr_choice_point)aim->aaaa_1; */
2284  cut_to(aim->aaaa_1); /* 12.7 */
2285 #ifdef CLEAN_TRAIL
2287 #endif
2288 #ifdef TS
2289  /* RESTORE_TIME_STAMP; */ /* 9.6 */
2290 #endif
2291  break;
2292 
2293  case eval_cut:
2294  /* RESID */ restore_resid((ptr_resid_block)aim->cccc_1, &unused_match_date);
2295  if (curried)
2296  do_currying();
2297  else if (resid_vars) {
2298  success=do_residuation_user(); /* 21.9 */ /* PVR 9.2.94 */
2299  } else {
2300  if (resid_aim)
2301  traceline("result of %P is %P\n", resid_aim->aaaa_1, aim->aaaa_1);
2302  goal_stack=aim->next;
2303  goal_count++;
2304  /* resid_aim=NULL; 21.9 */
2305  /* PVR 5.11 choice_stack=(ptr_choice_point)aim->bbbb_1; */
2306  (void)i_check_out(aim->aaaa_1);
2307  }
2308  resid_aim=NULL; /* 21.9 */
2309  resid_vars=NULL; /* 22.9 */
2310  /* assert((ptr_choice_point)aim->bbbb_1<=choice_stack); 12.7 */
2311  /* PVR 5.11 */ /* choice_stack=(ptr_choice_point)aim->bbbb_1; */
2312  if (success) { /* 21.9 */
2313  cut_to(aim->bbbb_1); /* 12.7 */
2314 #ifdef CLEAN_TRAIL
2316 #endif
2317  /* match_date=NULL; */ /* 13.6 */
2318 #ifdef TS
2319  /* RESTORE_TIME_STAMP; */ /* 9.6 */
2320 #endif
2321  }
2322  break;
2323 
2324  case freeze_cut:
2325  /* RESID */ restore_resid((ptr_resid_block)aim->cccc_1, &unused_match_date);
2326  if (curried) {
2327  warningline("frozen goal has a missing parameter '%P' and fails.\n",aim->aaaa_1);
2328  success=FALSE;
2329  }
2330  else if (resid_vars) {
2331  success=do_residuation_user(); /* 21.9 */ /* PVR 9.2.94 */
2332  } else {
2333  if (resid_aim) traceline("releasing frozen goal: %P\n", aim->aaaa_1);
2334  /* resid_aim=NULL; 21.9 */
2335  /* PVR 5.12 choice_stack=(ptr_choice_point)aim->bbbb_1; */
2336  goal_stack=aim->next;
2337  goal_count++;
2338  }
2339  resid_aim=NULL; /* 21.9 */
2340  resid_vars=NULL; /* 22.9 */
2341  if (success) { /* 21.9 */
2342  /* assert((ptr_choice_point)aim->bbbb_1<=choice_stack); 12.7 */
2343  /* PVR 5.12 */ /* choice_stack=(ptr_choice_point)aim->bbbb_1; */
2344  cut_to(aim->bbbb_1); /* 12.7 */
2345 #ifdef CLEAN_TRAIL
2347 #endif
2348  /* match_date=NULL; */ /* 13.6 */
2349 #ifdef TS
2350  /* RESTORE_TIME_STAMP; */ /* 9.6 */
2351 #endif
2352  }
2353  break;
2354 
2355  case implies_cut: /* 12.10 */
2356  /* This 'cut' is actually more like a no-op! */
2357  restore_resid((ptr_resid_block)aim->cccc_1, &unused_match_date);
2358  if (curried) {
2359  warningline("implied goal has a missing parameter '%P' and fails.\n",aim->aaaa_1);
2360  success=FALSE;
2361  }
2362  else if (resid_vars)
2363  success=FALSE;
2364  else {
2365  if (resid_aim) traceline("executing implied goal: %P\n", aim->aaaa_1);
2366  goal_stack=aim->next;
2367  goal_count++;
2368  }
2369  resid_aim=NULL; /* 21.9 */
2370  resid_vars=NULL; /* 22.9 */
2371  break;
2372 
2373  case fail:
2374  goal_stack=aim->next;
2375  success=FALSE;
2376  break;
2377 
2378  case what_next:
2379  goal_stack=aim->next;
2380  success=what_next_aim();
2381  break;
2382 
2383  case type_disj:
2384  goal_stack=aim->next;
2385  goal_count++;
2386  type_disj_aim();
2387  break;
2388 
2389  case clause:
2390  goal_stack=aim->next;
2391  goal_count++;
2392  success=clause_aim(0);
2393  break;
2394 
2395  case del_clause:
2396  goal_stack=aim->next;
2397  goal_count++;
2398  success=clause_aim(1);
2399  break;
2400 
2401  case retract:
2402  goal_stack=aim->next;
2403  goal_count++;
2404  p=(ptr_pair_list*)aim->aaaa_1;
2405  traceline("deleting clause (%P%s%P)\n",
2406  (*p)->aaaa_2,((*p)->aaaa_2->type->type_def==(def_type)function_it?"->":":-"),(*p)->bbbb_2);
2407  (*p)->aaaa_2=NULL;
2408  (*p)->bbbb_2=NULL;
2409  (*p)=(*p)->next; /* Remove retracted element from pairlist */
2410  break;
2411 
2412  case c_what_next: /* RM: Mar 31 1993 */
2413  main_loop_ok=FALSE; /* Exit the main loop */
2414  break;
2415 
2416  default:
2417  Errorline("bad goal on stack %d.\n",goal_stack->type);
2418  goal_stack=aim->next;
2419  }
2420 
2421  if (main_loop_ok) {
2422 
2423  if (success) {
2424 
2425 #ifdef X11
2426  /* Polling on external events */
2427  if (xcount<=0 && aim->type==prove) {
2428  if (x_exist_event()) {
2429  /* printf("At event, xeventdelay = %ld.\n",xeventdelay); */
2430  xeventdelay=0;
2432  } else {
2434  /* If XEVENTDELAY=1000 it takes 90000 goals to get back */
2435  /* from 100 at the pace of 1%. */
2436  xeventdelay=(xeventdelay*101)/100+2;
2437  else
2439  }
2441  }
2442  else
2443  xcount--;
2444 #endif
2445 
2446  }
2447  else {
2448  if (choice_stack) {
2449  backtrack();
2450  traceline("backtracking\n");
2451  success=TRUE;
2452  }
2453  else /* if (goal_stack) */ {
2454  undo(NULL); /* 8.10 */
2455  infoline("\n*** No");
2456  /* printf("\n*** No (in main_prove)."); */
2457  show_count();
2458 #ifdef TS
2459  /* global_time_stamp=INIT_TIME_STAMP; */ /* 9.6 */
2460 #endif
2462  }
2463  }
2464 
2466  (void)memory_check();
2467 
2468  if (interrupted || (stepflag && steptrace))
2469  handle_interrupt();
2470  else if (stepcount>0) {
2471  stepcount--;
2472  if (stepcount==0 && !stepflag) {
2473  stepflag=TRUE;
2474  handle_interrupt();
2475  }
2476  }
2477  }
2478  }
2479 }
2480 
2481 
2482 int dummy_printf(f,s,t)
2483 
2484  char *f, *s, *t;
2485 {
2486  return strlen(f);
2487 }
2488 // from login.h
2489 #ifdef TS
2491 {
2492  return (choice_stack && choice_stack->time_stamp>=Q->time_stamp);
2493 }
2494 #endif
#define VALID_ADDRESS(A)
Definition: def_macro.h:132
#define show_subwindow
Definition: def_const.h:186
void assert_clause(ptr_psi_term t)
Definition: login.c:267
#define prove
Definition: def_const.h:273
void get_one_arg_addr(ptr_node t, ptr_psi_term **a)
Definition: login.c:115
long what_next_cut()
Definition: login.c:1872
void reset_stacks()
Definition: login.c:1924
ptr_definition boolpredsym
Definition: def_glob.h:74
ptr_psi_term aaaa_1
Definition: def_struct.h:224
ptr_psi_term aaaa_2
Definition: def_struct.h:189
ptr_residuation resid
Definition: def_struct.h:173
long load_aim()
Definition: login.c:2104
#define hide_subwindow
Definition: def_const.h:187
#define predicate
Definition: def_const.h:361
void push_window(long type, long disp, long wind)
Definition: login.c:510
#define function_it
Definition: def_const.h:362
ptr_choice_point topmost_what_next()
Definition: login.c:1907
#define HEAP
Definition: def_const.h:147
long assert_first
Definition: def_glob.h:58
int global_unify(ptr_psi_term u, ptr_psi_term v)
Definition: modules.c:1035
void push2_ptr_value(type_ptr t, GENERIC *p, GENERIC v)
Definition: login.c:531
#define FEATCMP
Definition: def_const.h:257
void clear_copy()
Definition: copy.c:52
struct wl_definition * def_type
Definition: def_struct.h:32
void put_back_char(long c)
Definition: token.c:633
long main_loop_ok
Definition: def_glob.h:48
long do_residuation_user()
Definition: lefun.c:306
void restore_resid(ptr_resid_block rb, ptr_psi_term *match_date)
Definition: lefun.c:1270
char * combined_name
Definition: def_struct.h:92
long glb(ptr_definition t1, ptr_definition t2, ptr_definition *t3, ptr_int_list *c3)
Definition: types.c:1388
void show_count()
Definition: login.c:1085
ptr_goal goal_stack
Definition: def_glob.h:50
#define show_window
Definition: def_const.h:184
GENERIC mem_limit
Definition: def_glob.h:13
ptr_module current_module
Definition: def_glob.h:161
#define NOTQUIET
Definition: def_macro.h:10
#define VALID_RANGE(A)
Definition: def_macro.h:122
#define def_ptr
Definition: def_const.h:173
psi_term parse(long *q)
Definition: parser.c:877
char prompt_buffer[PROMPT_BUFFER]
Definition: def_glob.h:237
long new_stat
Definition: def_glob.h:307
#define TRUEMASK
Definition: def_const.h:129
void undo(ptr_stack limit)
Definition: login.c:646
void reset_step()
Definition: error.c:596
long unify_aim()
Definition: login.c:1264
long verbose
Definition: def_glob.h:273
ptr_pair_list next
Definition: def_struct.h:191
void push_goal(goals t, ptr_psi_term aaaa_5, ptr_psi_term bbbb_5, GENERIC cccc_5)
Definition: login.c:555
char * two
Definition: def_glob.h:251
GENERIC * bbbb_3
Definition: def_struct.h:218
#define undef
Definition: def_const.h:360
GENERIC cccc_1
Definition: def_struct.h:226
long(* c_rule[MAX_BUILT_INS])()
Definition: def_glob.h:247
ptr_int_list decode(ptr_int_list c)
Definition: types.c:1678
long redefine(ptr_psi_term t)
Definition: types.c:91
#define general_cut
Definition: def_const.h:282
void deref2_rec_eval(ptr_psi_term t)
Definition: lefun.c:1245
void fetch_def_lazy(ptr_psi_term u, ptr_definition old1, ptr_definition old2, ptr_node old1attr, ptr_node old2attr, long old1stat, long old2stat)
Definition: login.c:1188
#define implies_cut
Definition: def_const.h:281
ptr_stack undo_point
Definition: def_struct.h:233
def_type type_def
Definition: def_struct.h:133
long more_u_attr
Definition: def_glob.h:303
void merge_unify(ptr_node *u, ptr_node v)
Definition: login.c:1070
long clean_succ
Definition: login.c:14
#define XEVENTDELAY
Definition: def_const.h:117
long interrupted
Definition: def_glob.h:146
void assert_rule(psi_term t, def_type typ)
Definition: login.c:237
long matches(ptr_definition t1, ptr_definition t2, long *smaller)
Definition: types.c:1565
#define set_empty
Definition: def_const.h:193
long file_date
Definition: def_glob.h:60
#define DEFRULES
Definition: def_const.h:138
#define destroy_window
Definition: def_const.h:183
#define CURRENT_MODULE
Definition: def_const.h:234
ptr_definition aborthooksym
Definition: def_glob.h:65
void deref2_eval(ptr_psi_term t)
Definition: lefun.c:1224
#define FACT
Definition: def_const.h:151
void push_def_ptr_value(ptr_psi_term q, GENERIC *p)
Definition: login.c:389
GENERIC stack_top
Definition: def_struct.h:236
long num_vars(ptr_node vt)
Definition: login.c:1861
void assert_complicated_type(ptr_psi_term t)
Definition: types.c:375
ptr_keyword keyword
Definition: def_struct.h:124
void main_prove()
Definition: login.c:2205
ptr_module user_module
Definition: def_glob.h:156
GENERIC data
Definition: def_struct.h:185
#define cut_ptr
Definition: def_const.h:176
#define NULL
Definition: def_const.h:203
ptr_node var_tree
Definition: def_glob.h:26
ptr_psi_term input_state
Definition: def_glob.h:199
long steptrace
Definition: def_glob.h:274
void type_disj_aim()
Definition: login.c:1744
#define PROMPT
Definition: def_const.h:109
char * symbol
Definition: def_struct.h:91
#define QUERY
Definition: def_const.h:152
unsigned long time_stamp
Definition: def_struct.h:232
ptr_goal resid_aim
Definition: def_glob.h:220
ptr_choice_point next
Definition: def_struct.h:235
void merge(ptr_node *u, ptr_node v)
Definition: login.c:1061
long overlap_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1486
#define c_what_next
Definition: def_const.h:289
#define REAL
Definition: def_const.h:72
ptr_triple_list next
Definition: def_struct.h:199
long x_window_creation
Definition: def_glob.h:217
long noisy
Definition: def_glob.h:35
ptr_definition cccc_4
Definition: def_struct.h:198
ptr_resid_list resid_vars
Definition: def_glob.h:221
long assert_ok
Definition: def_glob.h:59
char always_check
Definition: def_struct.h:134
long abort_life(int nlflag)
Definition: built_ins.c:2124
#define eval
Definition: def_const.h:278
void stack_add_psi_attr(ptr_psi_term t, char *attrname, ptr_psi_term g)
Definition: token.c:192
void release_resid(ptr_psi_term t)
Definition: lefun.c:414
ptr_node left
Definition: def_struct.h:183
long sub_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1544
void traceline(char *format,...)
Definition: error.c:157
long stepcount
Definition: def_glob.h:275
long num_choices()
Definition: login.c:1845
#define type_it
Definition: def_const.h:363
#define hide_window
Definition: def_const.h:185
ptr_stack undo_stack
Definition: def_glob.h:53
ptr_psi_term quote_copy(ptr_psi_term t, long heap_flag)
Definition: copy.c:200
void Errorline(char *format,...)
Definition: error.c:414
#define EOLN
Definition: def_const.h:140
#define MAX_LEVEL
Definition: def_const.h:113
long clause_aim(long r)
Definition: login.c:1775
void end_terminal_io()
Definition: token.c:431
long goal_count
Definition: def_glob.h:152
ptr_definition real
Definition: def_glob.h:102
void push_psi_ptr_value(ptr_psi_term q, GENERIC *p)
Definition: login.c:443
#define deref_ptr(P)
Definition: def_macro.h:95
void infoline(char *format,...)
Definition: error.c:245
goals type
Definition: def_struct.h:223
long unify_body(long eval_flag)
Definition: login.c:1269
long trail_condition(psi_term *Q)
Definition: login.c:2490
type_ptr type
Definition: def_struct.h:216
void do_currying()
Definition: lefun.c:359
void assert_attributes(ptr_psi_term t)
Definition: types.c:468
char * key
Definition: def_struct.h:182
#define freeze_cut
Definition: def_const.h:280
void begin_terminal_io()
Definition: token.c:410
ptr_definition eof
Definition: def_glob.h:86
void Syntaxerrorline(char *format,...)
Definition: error.c:498
#define TRUE
Definition: def_const.h:127
void add_rule(ptr_psi_term head, ptr_psi_term body, def_type typ)
Definition: login.c:148
long v_func
Definition: def_glob.h:306
#define RMASK
Definition: def_const.h:159
static void clean_trail(ptr_choice_point cutpt)
Definition: login.c:757
void merge2(ptr_node *u, ptr_node v)
Definition: login.c:884
#define what_next
Definition: def_const.h:277
ptr_definition integer
Definition: def_glob.h:93
#define match
Definition: def_const.h:283
ptr_definition lf_true
Definition: def_glob.h:107
ptr_pair_list rule
Definition: def_struct.h:126
long u_func
Definition: def_glob.h:306
#define FALSE
Definition: def_const.h:128
#define deref(P)
Definition: def_macro.h:142
long unify_aim_noeval()
Definition: login.c:1259
long var_occurred
Definition: def_glob.h:189
ptr_definition quoted_string
Definition: def_glob.h:101
GENERIC mem_base
Definition: def_glob.h:11
ptr_definition succeed
Definition: def_glob.h:104
#define clause
Definition: def_const.h:285
struct wl_definition * ptr_definition
Definition: def_struct.h:31
ptr_psi_term stack_psi_term(long stat)
Definition: lefun.c:15
ptr_definition and
Definition: def_glob.h:71
FILE * input_stream
Definition: def_glob.h:38
void merge3(ptr_node *u, ptr_node v)
Definition: login.c:934
ptr_definition lf_false
Definition: def_glob.h:89
GENERIC value_3
Definition: def_struct.h:170
struct wl_pair_list * ptr_pair_list
Definition: def_struct.h:36
long stepflag
Definition: def_glob.h:150
#define cut_to(C)
Definition: def_macro.h:80
ptr_psi_term bbbb_2
Definition: def_struct.h:190
int dummy_printf(char *f, char *s, char *t)
Definition: login.c:2482
ptr_psi_term bbbb_4
Definition: def_struct.h:197
#define fail
Definition: def_const.h:272
ptr_goal aim
Definition: def_glob.h:49
char * module_name
Definition: def_struct.h:75
GENERIC heap_pointer
Definition: def_glob.h:12
ptr_psi_term coref
Definition: def_struct.h:172
void get_two_args(ptr_node t, ptr_psi_term *a, ptr_psi_term *b)
Definition: login.c:37
char * one
Definition: def_glob.h:250
long goals
Definition: def_struct.h:21
#define retract
Definition: def_const.h:287
#define equal_types(A, B)
Definition: def_macro.h:106
#define STACK_ALLOC(A)
Definition: def_macro.h:16
void get_one_arg(ptr_node t, ptr_psi_term *a)
Definition: login.c:86
#define unify
Definition: def_const.h:274
GENERIC * aaaa_3
Definition: def_struct.h:217
ptr_node find(long comp, char *keystr, ptr_node tree)
Definition: trees.c:341
long xeventdelay
Definition: def_glob.h:300
long eval_aim()
Definition: lefun.c:456
ptr_psi_term stack_copy_psi_term(psi_term t)
Definition: parser.c:183
long featcmp(char *str1, char *str2)
Definition: trees.c:89
ptr_definition life_or
Definition: def_glob.h:95
void restore_state(ptr_psi_term t)
Definition: token.c:267
void undo_actions()
Definition: login.c:690
#define load
Definition: def_const.h:288
long prove_aim()
Definition: login.c:1545
long can_curry
Definition: def_glob.h:224
void push_ptr_value_global(type_ptr t, GENERIC *p)
Definition: login.c:488
#define unify_noeval
Definition: def_const.h:275
void encode_types()
Definition: types.c:1015
ptr_goal goal_stack
Definition: def_struct.h:234
long i_eval_args(ptr_node n)
Definition: lefun.c:817
ptr_definition sys_bytedata
Definition: def_glob.h:336
ptr_definition tracesym
Definition: def_glob.h:109
long curried
Definition: def_glob.h:223
#define del_clause
Definition: def_const.h:286
#define eval_cut
Definition: def_const.h:279
#define deref_args(P, S)
Definition: def_macro.h:145
long disjunct_aim()
Definition: login.c:1525
void start_chrono()
Definition: login.c:330
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
void handle_interrupt()
Definition: interrupt.c:43
void save_state(ptr_psi_term t)
Definition: token.c:230
char * prompt
Definition: def_glob.h:42
void stack_info(FILE *outfile)
Definition: error.c:58
#define undo_action
Definition: def_const.h:188
ptr_definition cut
Definition: def_glob.h:83
void backtrack()
Definition: login.c:724
long print_variables(long printflag)
Definition: print.c:1272
#define GC_THRESHOLD
Definition: def_const.h:65
long read_char()
Definition: token.c:587
struct tms start_time end_time
Definition: def_glob.h:298
unsigned long global_time_stamp
Definition: login.c:19
#define INIT_TIME_STAMP
Definition: def_const.h:164
long clean_iter
Definition: login.c:13
#define disj
Definition: def_const.h:276
#define MAX_BUILT_INS
Definition: def_const.h:82
#define equ_tok(A, B)
Definition: def_macro.h:62
GENERIC stack_pointer
Definition: def_glob.h:14
GENERIC get_attr(ptr_psi_term t, char *attrname)
Definition: token.c:210
ptr_psi_term eval_copy(ptr_psi_term t, long heap_flag)
Definition: copy.c:205
#define type_disj
Definition: def_const.h:284
void warningline(char *format,...)
Definition: error.c:327
void clean_undo_window(long disp, long wind)
Definition: login.c:792
ptr_module find_module(char *module)
Definition: modules.c:48
long no_choices()
Definition: login.c:1838
ptr_definition type
Definition: def_struct.h:165
long memory_check()
Definition: memory.c:1622
GENERIC value_1
Definition: def_struct.h:54
ptr_psi_term bbbb_1
Definition: def_struct.h:225
void stdin_cleareof()
Definition: token.c:42
unsigned long * GENERIC
Definition: def_struct.h:17
ptr_psi_term xevent_existing
Definition: def_glob.h:208
long xcount
Definition: def_glob.h:301
long match_aim()
Definition: lefun.c:712
void fetch_def(ptr_psi_term u, long allflag)
Definition: login.c:1128
#define QUOTED_TRUE
Definition: def_const.h:123
long type_ptr
Definition: def_const.h:169
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
#define SMASK
Definition: def_const.h:160
ptr_stack next
Definition: def_struct.h:219
ptr_node attr_list
Definition: def_struct.h:171
long open_input_file(char *file)
Definition: token.c:504
void push_ptr_value(type_ptr t, GENERIC *p)
Definition: login.c:360
ptr_definition pending
Definition: def_struct.h:228
ptr_module set_current_module(ptr_module module)
Definition: modules.c:95
ptr_psi_term aaaa_4
Definition: def_struct.h:196
long i_check_out(ptr_psi_term t)
Definition: lefun.c:985
ptr_definition call_handlersym
Definition: def_glob.h:121
void push_choice_point(goals t, ptr_psi_term aaaa_6, ptr_psi_term bbbb_6, GENERIC cccc_6)
Definition: login.c:591
ptr_choice_point choice_stack
Definition: def_glob.h:51
#define STACK
Definition: def_const.h:148
#define assert(N)
Definition: memory.c:104
long more_v_attr
Definition: def_glob.h:304
ptr_node right
Definition: def_struct.h:184
void merge1(ptr_node *u, ptr_node v)
Definition: login.c:833
long what_next_aim()
Definition: login.c:1942
ptr_goal next
Definition: def_struct.h:227
#define psi_term_ptr
Definition: def_const.h:170
ptr_int_list next
Definition: def_struct.h:55
#define int_ptr
Definition: def_const.h:172