Wild Life  2.29
 All Data Structures Files Functions Variables Typedefs Macros
built_ins.c
Go to the documentation of this file.
1 /* Copyright 1991 Digital Equipment Corporation.
2 ** All Rights Reserved.
3 *****************************************************************/
4 /* $Id: built_ins.c,v 1.14 1995/07/27 21:26:28 duchier Exp $ */
5 
6 #include "defs.h"
7 
8 #ifdef SOLARIS
9 #include <stdlib.h>
10 static unsigned int randomseed;
11 #endif
12 
13 static long built_in_index=0;
14 
15 long all_public_symbols(); /* RM: Jan 28 1994 */
16 
17 /* RM: Sep 20 1993 */
18 // int arg_c;
19 // char **arg_v;
20 
21 
22 
23 /*** RM: Dec 9 1992 (START) ***/
24 
25 /********* STACK_NIL
26  Create the NIL object on the stack.
27 */
28 
30 
31 {
32  ptr_psi_term empty;
33 
34 
35  empty=stack_psi_term(4);
36  empty->type=nil;
37 
38  return empty;
39 }
40 
41 
42 
43 /******** STACK_CONS(head,tail)
44  Create a CONS object.
45 */
46 
48  ptr_psi_term head;
49  ptr_psi_term tail;
50 {
52 
53  cons=stack_psi_term(4);
54  cons->type=alist;
55  if(head)
56  (void)stack_insert(FEATCMP,one,&(cons->attr_list),(GENERIC)head);
57  if(tail)
58  (void)stack_insert(FEATCMP,two,&(cons->attr_list),(GENERIC)tail);
59 
60  return cons;
61 }
62 
63 /********* STACK_PAIR(left,right)
64  create a PAIR object.
65 */
66 
68  ptr_psi_term left;
69  ptr_psi_term right;
70 {
71  ptr_psi_term pair;
72 
73  pair=stack_psi_term(4);
74  pair->type=and;
75  if(left)
76  (void)stack_insert(FEATCMP,one,&(pair->attr_list),(GENERIC)left);
77  if(right)
78  (void)stack_insert(FEATCMP,two,&(pair->attr_list),(GENERIC)right);
79 
80  return pair;
81 }
82 
83 /********* STACK_INT(n)
84  create an INT object
85 */
86 
88  long n;
89 {
90  ptr_psi_term m;
91  m=stack_psi_term(4);
92  m->type=integer;
93  m->value_3= heap_alloc(sizeof(REAL));
94  *(REAL *)m->value_3=(REAL)n;
95  return m;
96 }
97 
98 /********* STACK_STRING(s)
99  create a STRING object
100 */
101 
103  char *s;
104 {
106  t->type = quoted_string;
108  return t;
109 }
110 
111 /*** RM: Dec 9 1992 (END) ***/
112 
113 /********* STACK_BYTES(s,n)
114  create a STRING object given a sequence of bytes
115 */
116 
118  char * s;
119  int n;
120 {
122  t->type = quoted_string;
124  return t;
125 }
126 
127 
128 
129 /********* PSI_TO_STRING(t,fn)
130  Get the value of a Life string, or the name of a non-string psi-term.
131  Return TRUE iff a valid string is found.
132 */
133 long psi_to_string(t, fn)
134  ptr_psi_term t;
135  char **fn;
136 {
137  if (equal_types(t->type,quoted_string)) {
138  if (t->value_3) {
139  *fn = (char *) t->value_3;
140  return TRUE;
141  }
142  else {
143  *fn = quoted_string->keyword->symbol;
144  return TRUE;
145  }
146  }
147  else {
148  *fn = t->type->keyword->symbol;
149  return TRUE;
150  }
151 }
152 
153 
154 /*** RM: Dec 9 1992 (START) ***/
155 
156 ptr_psi_term make_feature_list(tree,tail,module,val)
157 
158  ptr_node tree;
159  ptr_psi_term tail;
160  ptr_module module;
161  int val;
162 
163 {
164  ptr_psi_term new;
165  ptr_definition def;
166  double d; // strtod();
167 
168 
169  if(tree) {
170  if(tree->right)
171  tail=make_feature_list(tree->right,tail,module,val);
172 
173  /* Insert the feature name into the list */
174 
175  d=str_to_int(tree->key);
176  if (d== -1) { /* Feature is not a number */
177  def=update_feature(module,tree->key); /* Extract module RM: Feb 3 1993 */
178  if(def) {
179  if(val) /* RM: Mar 3 1994 Distinguish between features & values */
180  tail=stack_cons((ptr_psi_term)tree->data,(ptr_psi_term)tail);
181  else {
182  new=stack_psi_term(4);
183  new->type=def;
184  tail=stack_cons((ptr_psi_term)new,(ptr_psi_term)tail);
185  }
186  }
187  }
188  else { /* Feature is a number */
189  if(val) /* RM: Mar 3 1994 Distinguish between features & values */
190  tail=stack_cons((ptr_psi_term)tree->data,(ptr_psi_term)tail);
191  else {
192  new=stack_psi_term(4);
193  new->type=(d==floor(d))?integer:real;
194  new->value_3=heap_alloc(sizeof(REAL));
195  *(REAL *)new->value_3=(REAL)d;
196  tail=stack_cons((ptr_psi_term)new,(ptr_psi_term)tail);
197  }
198  }
199 
200  if(tree->left)
201  tail=make_feature_list(tree->left,tail,module,val);
202  }
203 
204  return tail;
205 }
206 
207 /*** RM: Dec 9 1992 (END) ***/
208 
209 
210 
211 
212 
213 
214 /******** CHECK_REAL(t,v,n)
215  Like get_real_value, but does not force the type of T to be real.
216 */
217 long check_real(t,v,n)
218  ptr_psi_term t;
219  REAL *v;
220  long *n;
221 {
222  long success=FALSE;
223  long smaller;
224 
225  if (t) {
226  success=matches(t->type,real,&smaller);
227  if (success) {
228  *n=FALSE;
229  if (smaller && t->value_3) {
230  *v= *(REAL *)t->value_3;
231  *n=TRUE;
232  }
233  }
234  }
235  return success;
236 }
237 
238 
239 
240 /******** GET_REAL_VALUE(t,v,n)
241  Check if psi_term T is a real number. Return N=TRUE iff T <| REAL.
242  If T has a real value then set V to that value.
243  Also force the type of T to REAL if REAL <| T.
244  This is used in all the arithmetic built-in functions to get their arguments.
245 */
246 long get_real_value(t,v,n)
247  ptr_psi_term t;
248  REAL *v;
249  long *n;
250 {
251  long success=FALSE;
252  long smaller;
253  if (t) {
254  success=matches(t->type,real,&smaller);
255  if (success) {
256  *n=FALSE;
257  if (smaller) {
258  if (t->value_3) {
259  *v= *(REAL *)t->value_3;
260  *n=TRUE;
261  }
262  }
263  else {
264  if((GENERIC)t<heap_pointer) { /* RM: Jun 8 1993 */
265  push_ptr_value(def_ptr,(GENERIC *)&(t->type));
266  push_ptr_value(int_ptr,(GENERIC *)&(t->status));
267  t->type=real;
268  t->status=0;
269  (void)i_check_out(t);
270  }
271  }
272  }
273  }
274  return success;
275 }
276 
277 
278 
279 /******** GET_BOOL_VALUE(t,v,n)
280  This is identical in nature to
281  GET_REAL_VALUE. The values handled here have to be booleans.
282  Check if psi_term T is a boolean. V <- TRUE or FALSE value of T.
283 */
284 static long get_bool_value(t,v,n)
285  ptr_psi_term t;
286  REAL *v;
287  long *n;
288 {
289  long success=FALSE;
290  long smaller;
291 
292 
293  if(t) {
294  success=matches(t->type,boolean,&smaller);
295  if(success) {
296  *n=FALSE;
297  if(smaller) {
298  if(matches(t->type,lf_false,&smaller) && smaller) {
299  *v= 0;
300  *n=TRUE;
301  }
302  else
303  if(matches(t->type,lf_true,&smaller) && smaller) {
304  *v= 1;
305  *n=TRUE;
306  }
307  }
308  else {
309  if((GENERIC)t<heap_pointer) { /* RM: Jun 8 1993 */
310  push_ptr_value(def_ptr,(GENERIC *)&(t->type));
311  push_ptr_value(int_ptr,(GENERIC *)&(t->status));
312  t->type=boolean;
313  t->status=0;
314  (void)i_check_out(t);
315  }
316  }
317  }
318  }
319 
320  return success;
321 }
322 
323 
324 
325 /******** UNIFY_BOOL_RESULT(t,v)
326  Unify psi_term T to the boolean value V = TRUE or FALSE.
327  This is used by built-in logical functions to return their result.
328 */
330  ptr_psi_term t;
331  long v;
332 {
333  ptr_psi_term u;
334 
335  u=stack_psi_term(4);
336  u->type=v?lf_true:lf_false;
337  push_goal(unify,t,u,NULL);
338 
339  /* Completely commented out by Richard on Nov 25th 1993
340  What's *your* Birthday? Maybe you'd like a Birthday-Bug-Card!
341  tried restoring 2.07 DJD no effect on test suite - removed again 2.14 DJD
342 
343  if((GENERIC)t<heap_pointer) {
344  push_ptr_value(def_ptr,&(t->type));
345  if (v) {
346  t->type=lf_true;
347  t->status=0;
348  }
349  else {
350  t->type=lf_false;
351  t->status=0;
352  }
353 
354  i_check_out(t);
355  if (t->resid)
356  release_resid(t);
357  }
358  else {
359  warningline("the persistent term '%P' appears in a boolean constraint and cannot be refined\n",t);
360  }
361  / */
362 }
363 
364 
365 
366 
367 /******** UNIFY_REAL_RESULT(t,v)
368  Unify psi_term T to the real value V.
369  This is used by built-in arithmetic functions to return their result.
370 */
372  ptr_psi_term t;
373  REAL v;
374 {
375  long smaller;
376  long success=TRUE;
377 
378 #ifdef prlDEBUG
379  if (t->value_3) {
380  printf("*** BUG: value already present in UNIFY_REAL_RESULT\n");
381  }
382 #endif
383 
384  if((GENERIC)t<heap_pointer) { /* RM: Jun 8 1993 */
385  deref_ptr(t);
386  assert(t->value_3==NULL); /* 10.6 */
387  push_ptr_value(int_ptr,(GENERIC *)&(t->value_3));
388  t->value_3=heap_alloc(sizeof(REAL)); /* 12.5 */
389  *(REAL *)t->value_3 = v;
390 
391  (void)matches(t->type,integer,&smaller);
392 
393  if (v==floor(v)){
394  if (!smaller) {
395  push_ptr_value(def_ptr,(GENERIC *)&(t->type));
396  t->type=integer;
397  t->status=0;
398  }
399  }
400  else
401  if (smaller)
402  success=FALSE;
403 
404  if (success) {
405  (void)i_check_out(t);
406  if (t->resid)
407  release_resid(t);
408  }
409  }
410  else {
411  warningline("the persistent term '%P' appears in an arithmetic constraint and cannot be refined\n",t);
412  }
413 
414  return success;
415 }
416 
417 
418 
419 /******** C_GT
420  Greater than.
421 */
422 static long c_gt()
423 {
424  long success=TRUE;
425  ptr_psi_term arg1,arg2,arg3,t;
426  long num1,num2,num3;
427  REAL val1,val2,val3;
428 
429  t=aim->aaaa_1;
430  deref_ptr(t);
431  get_two_args(t->attr_list,&arg1,&arg2);
432  arg3=aim->bbbb_1;
433 
434  if (arg1) {
435  deref(arg1);
436  success=get_real_value(arg1,&val1,&num1);
437  if(success && arg2) {
438  deref(arg2);
439  deref_args(t,set_1_2);
440  success=get_real_value(arg2,&val2,&num2);
441  }
442  }
443 
444  if(success)
445  if(arg1 && arg2) {
446  deref(arg3);
447  success=get_bool_value(arg3,&val3,&num3);
448  if(success)
449  switch(num1+num2*2+num3*4) {
450  case 0:
451  residuate2(arg1,arg2);
452  break;
453  case 1:
454  residuate(arg2);
455  break;
456  case 2:
457  residuate(arg1);
458  break;
459  case 3:
460  unify_bool_result(arg3,(val1>val2));
461  break;
462  case 4:
463  residuate2(arg1,arg2);
464  break;
465  case 5:
466  residuate(arg2);
467  break;
468  case 6:
469  residuate(arg1);
470  break;
471  case 7:
472  success=(val3==(REAL)(val1>val2));
473  break;
474  }
475  }
476  else
477  curry();
478 
479  nonnum_warning(t,arg1,arg2);
480  return success;
481 }
482 
483 
484 
485 /******** C_EQUAL
486  Arithmetic equality.
487 */
488 static long c_equal()
489 {
490  long success=TRUE;
491  ptr_psi_term arg1,arg2,arg3,t;
492  long num1,num2,num3;
493  REAL val1,val2,val3;
494 
495  t=aim->aaaa_1;
496  deref_ptr(t);
497  get_two_args(t->attr_list,&arg1,&arg2);
498  arg3=aim->bbbb_1;
499 
500  if(arg1) {
501  deref(arg1);
502  success=get_real_value(arg1,&val1,&num1);
503  if(success && arg2) {
504  deref(arg2);
505  deref_args(t,set_1_2);
506  success=get_real_value(arg2,&val2,&num2);
507  }
508  }
509 
510  if(success)
511  if(arg1 && arg2) {
512  deref(arg3);
513  success=get_bool_value(arg3,&val3,&num3);
514  if(success)
515  switch(num1+2*num2+4*num3) {
516  case 0:
517  if(arg1==arg2)
518  unify_bool_result(arg3,TRUE);
519  else
520  residuate2(arg1,arg2);
521  break;
522  case 1:
523  residuate2(arg2,arg3);
524  break;
525  case 2:
526  residuate2(arg1,arg3);
527  break;
528  case 3:
529  unify_bool_result(arg3,(val1==val2));
530  break;
531  case 4:
532  if(arg1==arg2 && !val3)
533  success=FALSE;
534  else
535  residuate2(arg1,arg2);
536  break;
537  case 5:
538  if(!val3)
539  residuate(arg2);
540  else
541  success=unify_real_result(arg2,val1);
542  break;
543  case 6:
544  if(!val3)
545  residuate(arg1);
546  else
547  success=unify_real_result(arg1,val2);
548  break;
549  case 7:
550  success=(val3==(REAL)(val1==val2));
551  break;
552  }
553  }
554  else
555  curry();
556 
557  nonnum_warning(t,arg1,arg2);
558  return success;
559 }
560 
561 
562 
563 /*** RM: 9 Dec 1992 (START) ***/
564 
565 /******** C_EVAL_DISJUNCTION
566  Evaluate a disjunction.
567 */
568 
569 static long c_eval_disjunction()
570 
571 {
572  ptr_psi_term arg1,arg2,funct,result;
573 
574 
575  funct=aim->aaaa_1;
576  deref_ptr(funct);
577  result=aim->bbbb_1;
578  get_two_args(funct->attr_list,&arg1,&arg2);
579 
580  /* deref_args(funct,set_1_2); Don't know about this */
581 
582  if (arg1 && arg2) {
583  deref_ptr(arg1);
584  deref_ptr(arg2);
585 
586  resid_aim=NULL; /* Function evaluation is over */
587 
588  if(arg2->type!=disj_nil) /* RM: Feb 1 1993 */
589  /* Create the alternative */
590  push_choice_point(eval,arg2,result,(GENERIC)funct->type->rule);
591 
592  /* Unify the result with the first argument */
593  push_goal(unify,result,arg1,NULL);
594  (void)i_check_out(arg1);
595  }
596  else {
597  Errorline("malformed disjunction '%P'\n",funct);
598  return (c_abort());
599  }
600 
601  return TRUE;
602 }
603 
604 /*** RM: 9 Dec 1992 (END) ***/
605 
606 
607 
608 
609 
610 /******** C_LT
611  Less than.
612 */
613 static long c_lt()
614 {
615  long success=TRUE;
616  ptr_psi_term arg1,arg2,arg3,t;
617  long num1,num2,num3;
618  REAL val1,val2,val3;
619 
620  t=aim->aaaa_1;
621  deref_ptr(t);
622  get_two_args(t->attr_list,&arg1,&arg2);
623  arg3=aim->bbbb_1;
624 
625  if(arg1) {
626  deref(arg1);
627  success=get_real_value(arg1,&val1,&num1);
628  if(success && arg2) {
629  deref(arg2);
630  deref_args(t,set_1_2);
631  success=get_real_value(arg2,&val2,&num2);
632  }
633  }
634 
635  if(success)
636  if(arg1 && arg2) {
637  deref(arg3);
638  success=get_bool_value(arg3,&val3,&num3);
639  if(success)
640  switch(num1+num2*2+num3*4) {
641  case 0:
642  residuate2(arg1,arg2);
643  break;
644  case 1:
645  residuate(arg2);
646  break;
647  case 2:
648  residuate(arg1);
649  break;
650  case 3:
651  unify_bool_result(arg3,(val1<val2));
652  break;
653  case 4:
654  residuate2(arg1,arg2);
655  break;
656  case 5:
657  residuate(arg2);
658  break;
659  case 6:
660  residuate(arg1);
661  break;
662  case 7:
663  success=(val3==(REAL)(val1<val2));
664  break;
665  }
666  }
667  else
668  curry();
669 
670  nonnum_warning(t,arg1,arg2);
671  return success;
672 }
673 
674 
675 
676 
677 /******** C_GTOE
678  Greater than or equal.
679 */
680 static long c_gtoe()
681 {
682  long success=TRUE;
683  ptr_psi_term arg1,arg2,arg3,t;
684  long num1,num2,num3;
685  REAL val1,val2,val3;
686 
687  t=aim->aaaa_1;
688  deref_ptr(t);
689  get_two_args(t->attr_list,&arg1,&arg2);
690  arg3=aim->bbbb_1;
691 
692  if(arg1) {
693  deref(arg1);
694  success=get_real_value(arg1,&val1,&num1);
695  if(success && arg2) {
696  deref(arg2);
697  deref_args(t,set_1_2);
698  success=get_real_value(arg2,&val2,&num2);
699  }
700  }
701 
702  if(success)
703  if(arg1 && arg2) {
704  deref(arg3);
705  success=get_bool_value(arg3,&val3,&num3);
706  if(success)
707  switch(num1+num2*2+num3*4) {
708  case 0:
709  residuate2(arg1,arg2);
710  break;
711  case 1:
712  residuate(arg2);
713  break;
714  case 2:
715  residuate(arg1);
716  break;
717  case 3:
718  unify_bool_result(arg3,(val1>=val2));
719  break;
720  case 4:
721  residuate2(arg1,arg2);
722  break;
723  case 5:
724  residuate(arg2);
725  break;
726  case 6:
727  residuate(arg1);
728  break;
729  case 7:
730  success=(val3==(REAL)(val1>=val2));
731  break;
732  }
733  }
734  else
735  curry();
736 
737  nonnum_warning(t,arg1,arg2);
738  return success;
739 }
740 
741 
742 
743 /******** C_LTOE
744  Less than or equal.
745 */
746 static long c_ltoe()
747 {
748  long success=TRUE;
749  ptr_psi_term arg1,arg2,arg3,t;
750  long num1,num2,num3;
751  REAL val1,val2,val3;
752 
753  t=aim->aaaa_1;
754  deref_ptr(t);
755  get_two_args(t->attr_list,&arg1,&arg2);
756  arg3=aim->bbbb_1;
757 
758  if(arg1) {
759  deref(arg1);
760  success=get_real_value(arg1,&val1,&num1);
761  if(success && arg2) {
762  deref(arg2);
763  deref_args(t,set_1_2);
764  success=get_real_value(arg2,&val2,&num2);
765  }
766  }
767 
768  if(success)
769  if(arg1 && arg2) {
770  deref(arg3);
771  success=get_bool_value(arg3,&val3,&num3);
772  if(success)
773  switch(num1+num2*2+num3*4) {
774  case 0:
775  residuate2(arg1,arg2);
776  break;
777  case 1:
778  residuate(arg2);
779  break;
780  case 2:
781  residuate(arg1);
782  break;
783  case 3:
784  unify_bool_result(arg3,(val1<=val2));
785  break;
786  case 4:
787  residuate2(arg1,arg2);
788  break;
789  case 5:
790  residuate(arg2);
791  break;
792  case 6:
793  residuate(arg1);
794  break;
795  case 7:
796  success=(val3==(REAL)(val1<=val2));
797  break;
798  }
799  }
800  else
801  curry();
802 
803  nonnum_warning(t,arg1,arg2);
804  return success;
805 }
806 
807 
808 
809 
810 /******** C_BOOLPRED
811  Internal built-in predicate that handles functions in predicate positions.
812  This predicate should never be called directly by the user.
813 */
814 
815 static long c_boolpred()
816 {
817  long success=TRUE,succ,lesseq;
818  ptr_psi_term t,arg1;
819 
820  t=aim->aaaa_1;
821  deref_ptr(t);
822  get_one_arg(t->attr_list,&arg1);
823  if (arg1) {
824  deref(arg1);
825  deref_args(t,set_1);
826  if (sub_type(boolean,arg1->type)) {
827  residuate(arg1);
828  }
829  else {
830  succ=matches(arg1->type,lf_true,&lesseq);
831  if (succ) {
832  if (lesseq) {
833  /* Function returns lf_true: success. */
834  }
835  else
836  residuate(arg1);
837  }
838  else {
839  succ=matches(arg1->type,lf_false,&lesseq);
840  if (succ) {
841  if (lesseq) {
842  /* Function returns lf_false: failure. */
843  success=FALSE;
844  }
845  else
846  residuate(arg1);
847  }
848  else {
849  /* Both lf_true and false are disentailed. */
850  if (arg1->type->type_def==(def_type)predicate) {
852  }
853  else {
854  Errorline("function result '%P' should be a boolean or a predicate.\n",
855  arg1);
856  return (c_abort());
857  }
858  }
859  }
860  }
861  }
862  else {
863  Errorline("missing argument to '*boolpred*'.\n");
864  return (c_abort());
865  }
866 
867  return success;
868 }
869 
870 static long get_bool(typ)
871  ptr_definition typ;
872 {
873  if (sub_type(typ,lf_true)) return TRUE;
874  else if (sub_type(typ,lf_false)) return FALSE;
875  else return UNDEF;
876 }
877 
878 static void unify_bool(arg)
879  ptr_psi_term arg;
880 {
881  ptr_psi_term tmp;
882 
883  tmp=stack_psi_term(4);
884  tmp->type=boolean;
885  push_goal(unify,tmp,arg,(GENERIC)NULL);
886 }
887 
888 /* Main routine to handle the and & or functions. */
889 /* sel = TRUE (for and) or FALSE (for or) */
890 static long c_logical_main(sel)
891  long sel;
892 {
893  long success=TRUE;
894  ptr_psi_term funct,arg1,arg2,arg3;
895  long sm1, sm2, sm3;
896  long a1comp, a2comp, a3comp;
897  long a1, a2, a3;
898 
899  funct=aim->aaaa_1;
900  deref_ptr(funct);
901  get_two_args(funct->attr_list,&arg1,&arg2);
902  if (arg1 && arg2) {
903  deref(arg1);
904  deref(arg2);
905  deref_args(funct,set_1_2);
906  arg3=aim->bbbb_1;
907  deref(arg3);
908 
909  a1comp = matches(arg1->type,boolean,&sm1);
910  a2comp = matches(arg2->type,boolean,&sm2);
911  a3comp = matches(arg3->type,boolean,&sm3);
912  if (a1comp && a2comp && a3comp) {
913  a1 = get_bool(arg1->type);
914  a2 = get_bool(arg2->type);
915  a3 = get_bool(arg3->type);
916  if (a1== !sel || a2== !sel) {
917  unify_bool_result(arg3,!sel);
918  } else if (a1==sel) {
919  /* tmp=stack_psi_term(4); */
920  /* tmp->type=boolean; */
921  /* push_goal(unify,tmp,arg3,NULL); */
922  push_goal(unify,arg2,arg3,(GENERIC)NULL);
923  } else if (a2==sel) {
924  /* tmp=stack_psi_term(4); */
925  /* tmp->type=boolean; */
926  /* push_goal(unify,tmp,arg3,NULL); */
927  push_goal(unify,arg1,arg3,(GENERIC)NULL);
928  } else if (a3==sel) {
929  unify_bool_result(arg1,sel);
930  unify_bool_result(arg2,sel);
931  } else if (arg1==arg2) {
932  /* tmp=stack_psi_term(4); */
933  /* tmp->type=boolean; */
934  /* push_goal(unify,tmp,arg3,NULL); */
935  push_goal(unify,arg1,arg3,(GENERIC)NULL);
936  } else {
937  if (a1==UNDEF) residuate(arg1);
938  if (a2==UNDEF) residuate(arg2);
939  if (a3==UNDEF) residuate(arg3);
940  }
941  if (!sm1) unify_bool(arg1);
942  if (!sm2) unify_bool(arg2);
943  if (!sm3) unify_bool(arg3);
944  }
945  else {
946  success=FALSE;
947  Errorline("Non-boolean argument or result in '%P'.\n",funct);
948  }
949  }
950  else
951  curry();
952 
953  return success;
954 }
955 
956 
957 
958 
959 /******** C_AND, C_OR
960  Logical and & or.
961  These functions do all possible local propagations.
962 */
963 static long c_and()
964 {
965  return c_logical_main(TRUE);
966 }
967 
968 static long c_or()
969 {
970  return c_logical_main(FALSE);
971 }
972 
973 
974 
975 
976 /******** C_NOT
977  Logical not.
978  This function does all possible local propagations.
979 */
980 static long c_not()
981 {
982  long success=TRUE;
983  ptr_psi_term funct,arg1,arg2;
984  long sm1, sm2;
985  long a1comp, a2comp;
986  long a1, a2;
987 
988  funct=aim->aaaa_1;
989  deref_ptr(funct);
990  get_one_arg(funct->attr_list,&arg1);
991  if (arg1) {
992  deref(arg1);
993  deref_args(funct,set_1);
994  arg2=aim->bbbb_1;
995  deref(arg2);
996 
997  a1comp = matches(arg1->type,boolean,&sm1);
998  a2comp = matches(arg2->type,boolean,&sm2);
999  if (a1comp && a2comp) {
1000  a1 = get_bool(arg1->type);
1001  a2 = get_bool(arg2->type);
1002  if (a1==TRUE || a1==FALSE) {
1003  unify_bool_result(arg2,!a1);
1004  } else if (a2==TRUE || a2==FALSE) {
1005  unify_bool_result(arg1,!a2);
1006  } else if (arg1==arg2) {
1007  success=FALSE;
1008  } else {
1009  if (a1==UNDEF) residuate(arg1);
1010  if (a2==UNDEF) residuate(arg2);
1011  }
1012  if (!sm1) unify_bool(arg1);
1013  if (!sm2) unify_bool(arg2);
1014  }
1015  else {
1016  success=FALSE;
1017  Errorline("Non-boolean argument or result in '%P'.\n",funct);
1018  }
1019  }
1020  else
1021  curry();
1022 
1023  return success;
1024 }
1025 
1026 
1027 
1028 
1029 /******** C_XOR
1030  Logical exclusive or.
1031  This function does all possible local propagations.
1032 */
1033 static long c_xor()
1034 {
1035  long success=TRUE;
1036  ptr_psi_term funct,arg1,arg2,arg3;
1037  long sm1, sm2, sm3;
1038  long a1comp, a2comp, a3comp;
1039  long a1, a2, a3;
1040 
1041  funct=aim->aaaa_1;
1042  deref_ptr(funct);
1043  get_two_args(funct->attr_list,&arg1,&arg2);
1044  if (arg1 && arg2) {
1045  deref(arg1);
1046  deref(arg2);
1047  deref_args(funct,set_1_2);
1048  arg3=aim->bbbb_1;
1049  deref(arg3);
1050 
1051  a1comp = matches(arg1->type,boolean,&sm1);
1052  a2comp = matches(arg2->type,boolean,&sm2);
1053  a3comp = matches(arg3->type,boolean,&sm3);
1054  if (a1comp && a2comp && a3comp) {
1055  a1 = get_bool(arg1->type);
1056  a2 = get_bool(arg2->type);
1057  a3 = get_bool(arg3->type);
1058  if ((a1==TRUE || a1==FALSE) && (a2==TRUE || a2==FALSE)) {
1059  unify_bool_result(arg3, a1^a2);
1060  } else if ((a1==TRUE || a1==FALSE) && (a3==TRUE || a3==FALSE)) {
1061  unify_bool_result(arg2, a1^a3);
1062  } else if ((a3==TRUE || a3==FALSE) && (a2==TRUE || a2==FALSE)) {
1063  unify_bool_result(arg1, a3^a2);
1064 
1065  } else if (a1==TRUE && arg3==arg2) {
1066  success=FALSE;
1067  } else if (a2==TRUE && arg3==arg2) {
1068  success=FALSE;
1069  } else if (a3==TRUE && arg1==arg2) {
1070  success=FALSE;
1071 
1072  } else if (a1==FALSE) {
1073  push_goal(unify,arg2,arg3,(GENERIC)NULL);
1074  } else if (a2==FALSE) {
1075  push_goal(unify,arg1,arg3,(GENERIC)NULL);
1076  } else if (a3==FALSE) {
1077  push_goal(unify,arg1,arg2,(GENERIC)NULL);
1078 
1079  } else if (arg1==arg2) {
1080  unify_bool_result(arg3,FALSE);
1081  } else if (arg1==arg3) {
1082  unify_bool_result(arg2,FALSE);
1083  } else if (arg3==arg2) {
1084  unify_bool_result(arg1,FALSE);
1085  } else {
1086  if (a1==UNDEF) residuate(arg1);
1087  if (a2==UNDEF) residuate(arg2);
1088  if (a3==UNDEF) residuate(arg3);
1089  }
1090  if (!sm1) unify_bool(arg1);
1091  if (!sm2) unify_bool(arg2);
1092  if (!sm3) unify_bool(arg3);
1093  }
1094  else {
1095  success=FALSE;
1096  Errorline("Non-boolean argument or result in '%P'.\n",funct);
1097  }
1098  }
1099  else
1100  curry();
1101 
1102  return success;
1103 }
1104 
1105 
1106 
1107 
1108 /******** C_APPLY
1109  This evaluates "apply(functor => F,Args)". If F is
1110  a known function, then it builds the psi-term F(Args), and evaluates it.
1111 */
1112 static long c_apply()
1113 {
1114  long success=TRUE;
1115  ptr_psi_term funct,other;
1116  ptr_node n,fattr;
1117 
1118  funct=aim->aaaa_1;
1119  deref_ptr(funct);
1121  if (n) {
1122  other=(ptr_psi_term )n->data;
1123  deref(other);
1124  if (other->type==top)
1125  residuate(other);
1126  else
1127  if(other->type && other->type->type_def!=(def_type)function_it) {
1128  success=FALSE;
1129  Errorline("argument is not a function in %P.\n",funct);
1130  }
1131  else {
1132  /* What we really want here is to merge all attributes in */
1133  /* funct->attr_list, except '*functor*', into other->attr_list. */
1134  clear_copy();
1135  other=distinct_copy(other);
1136  fattr=distinct_tree(funct->attr_list); /* Make distinct copy: PVR */
1137  push_goal(eval,other,aim->bbbb_1,(GENERIC)other->type->rule);
1138  merge_unify(&(other->attr_list),fattr);
1139  /* We don't want to remove anything from funct->attr_list here. */
1141  }
1142  }
1143  else
1144  curry();
1145 
1146  return success;
1147 }
1148 
1149 
1150 
1151 /******** C_PROJECT RM: Jan 7 1993
1152  Here we evaluate "project(Psi-term,Label)". This
1153  returns the psi-term associated to label Label in Psi-term.
1154  It is identical to C_PROJECT except that the order of the arguments is
1155  inversed.
1156 */
1157 static long c_project()
1158 
1159 {
1160  long success=TRUE;
1161  ptr_psi_term arg1,arg2,funct,result;
1162  ptr_node n;
1163  char *label;
1164  double v;
1165 
1166  /* char *thebuffer="integer"; 18.5 */
1167  char thebuffer[20]; /* Maximum number of digits in an integer */
1168 
1169  funct=aim->aaaa_1;
1170  deref_ptr(funct);
1171  result=aim->bbbb_1;
1172  get_two_args(funct->attr_list,&arg1,&arg2);
1173  if (arg2 && arg1) {
1174  deref(arg1);
1175  deref(arg2);
1176  deref_args(funct,set_1_2);
1177 
1178  label=NULL;
1179 
1180  /* RM: Jul 20 1993: Don't residuate on 'string' etc... */
1181  if(arg2->type!=top) {
1182  if(arg2->value_3 && sub_type(arg2->type,quoted_string)) /* 10.8 */
1183  label=(char *)arg2->value_3;
1184  else
1185  if(arg2->value_3 && sub_type(arg2->type,integer)) { /* 10.8 */
1186  v= *(REAL *)arg2->value_3;
1187  if(v==floor(v)) {
1188  (void)snprintf(thebuffer,20,"%ld",(long)v);
1189  label=heap_copy_string(thebuffer); /* A little voracious */
1190  }
1191  else { /* RM: Jul 28 1993 */
1192  Errorline("non-integer numeric feature in %P\n",funct);
1193  return FALSE;
1194  }
1195  }
1196  else {
1197  if(arg2->type->keyword->private_feature) /* RM: Mar 12 1993 */
1198  label=arg2->type->keyword->combined_name;
1199  else
1200  label=arg2->type->keyword->symbol;
1201  }
1202  }
1203 
1204  if (label) {
1205  n=find(FEATCMP,(char *)label,arg1->attr_list);
1206 
1207  if (n)
1209  else if (arg1->type->type_def==(def_type)function_it && !(arg1->flags&QUOTED_TRUE)) {
1210  Errorline("attempt to add a feature to curried function %P\n",
1211  arg1);
1212  return FALSE;
1213  }
1214  else {
1215  deref_ptr(result);
1216  if((GENERIC)arg1>=heap_pointer) { /* RM: Feb 9 1993 */
1217  if((GENERIC)result<heap_pointer)
1218  push_psi_ptr_value(result,(GENERIC *)&(result->coref));
1219  clear_copy();
1220  result->coref=inc_heap_copy(result);
1221  (void)heap_insert(FEATCMP,label,&(arg1->attr_list),(GENERIC)result->coref);
1222  }
1223  else {
1224 
1225 #ifdef ARITY /* RM: Mar 29 1993 */
1226  arity_add(arg1,label);
1227 #endif
1228 
1229  /* RM: Mar 25 1993 */
1230  if(arg1->type->always_check || arg1->attr_list)
1231  (void)bk_stack_insert(FEATCMP,label,&(arg1->attr_list),(GENERIC)result);
1232  else {
1233  (void)bk_stack_insert(FEATCMP,label,&(arg1->attr_list),(GENERIC)result);
1234  fetch_def_lazy(arg1, arg1->type,arg1->type,NULL,NULL,0,0); // djd added zeros
1235  }
1236 
1237  if (arg1->resid)
1238  release_resid(arg1);
1239  }
1240  }
1241  }
1242  else
1243  residuate(arg2);
1244  }
1245  else
1246  curry();
1247 
1248  return success;
1249 }
1250 
1251 
1252 
1253 
1254 /******** C_DIFF
1255  Arithmetic not-equal.
1256 */
1257 static long c_diff()
1258 {
1259  long success=TRUE;
1260  ptr_psi_term arg1,arg2,arg3,t;
1261  long num1,num2,num3;
1262  REAL val1,val2,val3;
1263 
1264  t=aim->aaaa_1;
1265  deref_ptr(t);
1266  get_two_args(t->attr_list,&arg1,&arg2);
1267  arg3=aim->bbbb_1;
1268 
1269  if(arg1) {
1270  deref(arg1);
1271  success=get_real_value(arg1,&val1,&num1);
1272  if(success && arg2) {
1273  deref(arg2);
1274  deref_args(t,set_1_2);
1275  success=get_real_value(arg2,&val2,&num2);
1276  }
1277  }
1278 
1279  if(success)
1280  if(arg1 && arg2) {
1281  deref(arg3);
1282  success=get_bool_value(arg3,&val3,&num3);
1283  if(success)
1284  switch(num1+2*num2+4*num3) {
1285  case 0:
1286  if(arg1==arg2)
1287  unify_bool_result(arg3,FALSE);
1288  else
1289  residuate2(arg1,arg2);
1290  break;
1291  case 1:
1292  residuate2(arg2,arg3);
1293  break;
1294  case 2:
1295  residuate2(arg1,arg3);
1296  break;
1297  case 3:
1298  unify_bool_result(arg3,(val1!=val2));
1299  break;
1300  case 4:
1301  if(arg1==arg2 && val3)
1302  success=FALSE;
1303  else
1304  residuate2(arg1,arg2);
1305  break;
1306  case 5:
1307  if(val3)
1308  residuate(arg2);
1309  else
1310  success=unify_real_result(arg2,val1);
1311  break;
1312  case 6:
1313  if(val3)
1314  residuate(arg1);
1315  else
1316  success=unify_real_result(arg1,val2);
1317  break;
1318  case 7:
1319  success=(val3==(REAL)(val1!=val2));
1320  break;
1321  }
1322  }
1323  else
1324  curry();
1325 
1326  nonnum_warning(t,arg1,arg2);
1327  return success;
1328 }
1329 
1330 
1331 
1332 
1333 /******** C_FAIL
1334  Always fail.
1335 */
1336 static long c_fail()
1337 {
1338  return FALSE;
1339 }
1340 
1341 
1342 
1343 /******** C_SUCCEED
1344  Always succeed.
1345 */
1346 static long c_succeed()
1347 {
1348  ptr_psi_term t;
1349 
1350  t=aim->aaaa_1;
1351  deref_args(t,set_empty);
1352  return TRUE;
1353 }
1354 
1355 
1356 
1357 /******** C_REPEAT
1358  Succeed indefinitely on backtracking.
1359 */
1360 static long c_repeat()
1361 {
1362  ptr_psi_term t;
1363 
1364  t=aim->aaaa_1;
1365  deref_args(t,set_empty);
1367  return TRUE;
1368 }
1369 
1370 
1371 /******** C_VAR
1372  Return lf_true/lf_false iff argument is/is not '@' (top with no attributes).
1373 */
1374 static long c_var()
1375 {
1376  long success=TRUE;
1377  ptr_psi_term arg1,result,g,other;
1378 
1379  g=aim->aaaa_1;
1380  deref_ptr(g);
1381  result=aim->bbbb_1;
1382  deref(result);
1383  get_one_arg(g->attr_list,&arg1);
1384  if (arg1) {
1385  deref(arg1);
1386  deref_args(g,set_1);
1387  other=stack_psi_term(4); /* 19.11 */
1388  other->type=((arg1->type==top)&&(arg1->attr_list==NULL))?lf_true:lf_false;
1389  resid_aim=NULL;
1390  push_goal(unify,result,other,NULL);
1391  }
1392  else {
1393  curry();
1394  /* Errorline("argument missing in %P.\n",t); */
1395  /* return c_abort(); */
1396  }
1397 
1398  return success;
1399 }
1400 
1401 
1402 /******** C_NONVAR
1403  Return lf_true/false iff argument is not/is '@' (top with no attributes).
1404 */
1405 static long c_nonvar()
1406 {
1407  long success=TRUE;
1408  ptr_psi_term arg1,result,g,other;
1409 
1410  g=aim->aaaa_1;
1411  deref_ptr(g);
1412  result=aim->bbbb_1;
1413  deref(result);
1414  get_one_arg(g->attr_list,&arg1);
1415  if (arg1) {
1416  deref(arg1);
1417  deref_args(g,set_1);
1418  other=stack_psi_term(4); /* 19.11 */
1419  other->type=((arg1->type==top)&&(arg1->attr_list==NULL))?lf_false:lf_true;
1420  resid_aim=NULL;
1421  push_goal(unify,result,other,NULL);
1422  }
1423  else {
1424  curry();
1425  /* Errorline("argument missing in %P.\n",t); */
1426  /* return c_abort(); */
1427  }
1428 
1429  return success;
1430 }
1431 
1432 
1433 /******** C_IS_FUNCTION
1434  Succeed iff argument is a function (built-in or user-defined).
1435 */
1436 static long c_is_function()
1437 {
1438  long success=TRUE;
1439  ptr_psi_term arg1,result,g,other;
1440 
1441  g=aim->aaaa_1;
1442  deref_ptr(g);
1443  result=aim->bbbb_1;
1444  deref(result);
1445  get_one_arg(g->attr_list,&arg1);
1446  if (arg1) {
1447  deref(arg1);
1448  deref_args(g,set_1);
1449  other=stack_psi_term(4); /* 19.11 */
1451  resid_aim=NULL;
1452  push_goal(unify,result,other,NULL);
1453  }
1454  else {
1455  curry();
1456  /* Errorline("argument missing in %P.\n",t); */
1457  /* return c_abort(); */
1458  }
1459 
1460  return success;
1461 }
1462 
1463 
1464 /******** C_IS_PREDICATE
1465  Succeed iff argument is a predicate (built-in or user-defined).
1466 */
1467 static long c_is_predicate()
1468 {
1469  long success=TRUE;
1470  ptr_psi_term arg1,result,g,other;
1471 
1472  g=aim->aaaa_1;
1473  deref_ptr(g);
1474  result=aim->bbbb_1;
1475  deref(result);
1476  get_one_arg(g->attr_list,&arg1);
1477  if (arg1) {
1478  deref(arg1);
1479  deref_args(g,set_1);
1480  other=stack_psi_term(4); /* 19.11 */
1481  other->type=(arg1->type->type_def==(def_type)predicate)?lf_true:lf_false;
1482  resid_aim=NULL;
1483  push_goal(unify,result,other,NULL);
1484  }
1485  else {
1486  curry();
1487  /* Errorline("argument missing in %P.\n",t); */
1488  /* return c_abort(); */
1489  }
1490 
1491  return success;
1492 }
1493 
1494 
1495 /******** C_IS_SORT
1496  Succeed iff argument is a sort (built-in or user-defined).
1497 */
1498 static long c_is_sort()
1499 {
1500  long success=TRUE;
1501  ptr_psi_term arg1,result,g,other;
1502 
1503  g=aim->aaaa_1;
1504  deref_ptr(g);
1505  result=aim->bbbb_1;
1506  deref(result);
1507  get_one_arg(g->attr_list,&arg1);
1508  if (arg1) {
1509  deref(arg1);
1510  deref_args(g,set_1);
1511  other=stack_psi_term(4); /* 19.11 */
1512  other->type=(arg1->type->type_def==(def_type)type_it)?lf_true:lf_false;
1513  resid_aim=NULL;
1514  push_goal(unify,result,other,NULL);
1515  }
1516  else {
1517  curry();
1518  /* Errorline("argument missing in %P.\n",t); */
1519  /* return c_abort(); */
1520  }
1521 
1522  return success;
1523 }
1524 
1525 
1526 
1527 /* Return TRUE iff t has only argument "1", and return the argument. */
1528 long only_arg1(t, arg1)
1529  ptr_psi_term t;
1530  ptr_psi_term *arg1;
1531 {
1532  ptr_node n=t->attr_list;
1533 
1534  if (n && n->left==NULL && n->right==NULL && !featcmp(n->key,one)) {
1535  *arg1=(ptr_psi_term)n->data;
1536  return TRUE;
1537  }
1538  else
1539  return FALSE;
1540 }
1541 
1542 
1543 
1544 /******** C_DYNAMIC()
1545  Mark all the arguments as 'unprotected', i.e. they may be changed
1546  by assert/retract/redefinition.
1547 */
1548 static long c_dynamic()
1549 {
1550  ptr_psi_term t=aim->aaaa_1;
1551  deref_ptr(t);
1552  /* mark_quote(t); 14.9 */
1554  return TRUE;
1555 }
1556 
1557 
1558 
1559 /******** C_STATIC()
1560  Mark all the arguments as 'protected', i.e. they may not be changed
1561  by assert/retract/redefinition.
1562 */
1563 static long c_static()
1564 {
1565  ptr_psi_term t=aim->aaaa_1;
1566  deref_ptr(t);
1567  /* mark_quote(t); 14.9 */
1569  return TRUE;
1570 }
1571 
1572 
1573 
1574 /******** C_DELAY_CHECK()
1575  Mark that the properties of the types in the arguments are delay checked
1576  during unification (i.e. they are only checked when the psi-term is
1577  given attributes, and they are not checked as long as the psi-term has
1578  no attributes.)
1579 */
1580 static long c_delay_check()
1581 {
1582  ptr_psi_term t=aim->aaaa_1;
1583 
1584  deref_ptr(t);
1585  /* mark_quote(t); 14.9 */
1588  return TRUE;
1589 }
1590 
1591 
1592 
1593 /******** C_NON_STRICT()
1594  Mark that the function or predicate's arguments are not evaluated when
1595  the function or predicate is called.
1596 */
1597 static long c_non_strict()
1598 {
1599  ptr_psi_term t=aim->aaaa_1;
1600 
1601  deref_ptr(t);
1602  /* mark_quote(t); 14.9 */
1604  return TRUE;
1605 }
1606 
1607 
1608 
1609 /******** C_OP()
1610  Declare an operator.
1611 */
1612 static long c_op()
1613 {
1614  // long declare_operator();
1615  ptr_psi_term t=aim->aaaa_1;
1616 
1617  return declare_operator(t);
1618 }
1619 
1620 
1621 
1623  char *s;
1624 {
1625  FILE *f;
1626  char *e;
1627  long success=FALSE;
1628 
1629  e=expand_file_name(s);
1630  if ((f=fopen(e,"r"))) {
1631  (void)fclose(f);
1632  success=TRUE;
1633  }
1634  return success;
1635 }
1636 
1637 
1638 
1639 /******** C_EXISTS
1640  Succeed iff a file can be read in (i.e. if it exists).
1641 */
1642 static long c_exists()
1643 {
1644  ptr_psi_term g;
1645  ptr_node n;
1646  long success=TRUE;
1647  ptr_psi_term arg1;
1648  char *c_arg1;
1649 
1650  g=aim->aaaa_1;
1651  deref_ptr(g);
1652 
1653  if (success) {
1654  n=find(FEATCMP,one,g->attr_list);
1655  if (n) {
1656  arg1= (ptr_psi_term )n->data;
1657  deref(arg1);
1658  deref_args(g,set_1);
1659  if (!psi_to_string(arg1,&c_arg1)) {
1660  success=FALSE;
1661  Errorline("bad argument in %P.\n",g);
1662  }
1663  }
1664  else {
1665  success=FALSE;
1666  Errorline("bad argument in %P.\n",g);
1667  }
1668  }
1669 
1670  if (success)
1671  success=file_exists(c_arg1);
1672 
1673  return success;
1674 }
1675 
1676 
1677 
1678 /******** C_LOAD
1679  Load a file. This load accepts and executes any queries in the loaded
1680  file, including calls to user-defined predicates and other load predicates.
1681 */
1682 static long c_load()
1683 {
1684  long success=FALSE;
1685  ptr_psi_term arg1,arg2,t;
1686  char *fn;
1687  t=aim->aaaa_1;
1688  deref_ptr(t);
1689  get_two_args(t->attr_list,&arg1,&arg2);
1690  if(arg1) {
1691  deref(arg1);
1692  deref_args(t,set_1);
1693  if (psi_to_string(arg1,&fn)) {
1694  success=open_input_file(fn);
1695  if (success) {
1696  file_date+=2;
1698  file_date+=2;
1699  }
1700  }
1701  else {
1702  Errorline("bad file name in %P.\n",t);
1703  success=FALSE;
1704  }
1705  }
1706  else {
1707  Errorline("no file name in %P.\n",t);
1708  success=FALSE;
1709  }
1710 
1711  return success;
1712 }
1713 
1714 
1715 
1716 /******** C_GET_CHOICE()
1717  Return the current state of the choice point stack (i.e., the time stamp
1718  of the current choice point).
1719 */
1720 static long c_get_choice()
1721 {
1722  long gts,success=TRUE;
1723  ptr_psi_term funct,result;
1724 
1725  funct=aim->aaaa_1;
1726  deref_ptr(funct);
1727  result=aim->bbbb_1;
1728  deref_args(funct,set_empty);
1729  if (choice_stack)
1730  gts=choice_stack->time_stamp;
1731  else
1732  gts=global_time_stamp-1;
1733  /* gts=INIT_TIME_STAMP; PVR 11.2.94 */
1734  push_goal(unify,result,real_stack_psi_term(4,(REAL)gts),NULL);
1735 
1736  return success;
1737 }
1738 
1739 
1740 
1741 /******** C_SET_CHOICE()
1742  Set the choice point stack to a state no later than (i.e. the same or earlier
1743  than) the state of the first argument (i.e., remove all choice points up to
1744  the first one whose time stamp is =< the first argument). This predicate
1745  will remove zero or more choice points, never add them. The first argument
1746  must come from a past call to get_choice.
1747  Together, get_choice and set_choice allow one to implement an "ancestor cut"
1748  that removes all choice points created between the current execution point
1749  and an execution point arbitarily remote in the past.
1750  The built-ins get_choice, set_choice, and exists_choice are implemented
1751  using the timestamping mechanism in the interpreter. The two
1752  relevant properties of the timestamping mechanism are that each choice
1753  point is identified by an integer and that the integers are in increasing
1754  order (but not necessarily consecutive) from the bottom to the top of the
1755  choice point stack.
1756 */
1757 static long c_set_choice()
1758 {
1759  REAL gts_r;
1760  long gts;
1761  long num,success=TRUE;
1762  ptr_psi_term t,arg1;
1763  ptr_choice_point cutpt;
1764 
1765  t=aim->aaaa_1;
1766  deref_ptr(t);
1767  get_one_arg(t->attr_list,&arg1);
1768  if (arg1) {
1769  deref(arg1);
1770  deref_args(t,set_1);
1771  success = get_real_value(arg1,&gts_r,&num);
1772  if (success) {
1773  if (num) {
1774  gts=(unsigned long)gts_r;
1775  if (choice_stack) {
1776  cutpt=choice_stack;
1777  while (cutpt && cutpt->time_stamp>gts) cutpt=cutpt->next;
1778  if (choice_stack!=cutpt) {
1779  choice_stack=cutpt;
1780 #ifdef CLEAN_TRAIL
1782 #endif
1783  }
1784  }
1785  }
1786  else {
1787  Errorline("bad argument to %P.\n",t);
1788  success=FALSE;
1789  }
1790  }
1791  else {
1792  Errorline("bad argument %P.\n",t);
1793  success=FALSE;
1794  }
1795  }
1796  else
1797  curry();
1798 
1799  return success;
1800 }
1801 
1802 
1803 
1804 /******** C_EXISTS_CHOICE()
1805  Return true iff there exists a choice point A such that arg1 < A <= arg2,
1806  i.e. A is more recent than the choice point marked by arg1 and no more
1807  recent than the choice point marked by arg2. The two arguments to
1808  exists_choice must come from past calls to get_choice.
1809  This function allows one to check whether a choice point exists between
1810  any two arbitrary execution points of the program.
1811 */
1812 static long c_exists_choice()
1813 {
1814  REAL gts_r;
1815  long ans,gts1,gts2,num,success=TRUE;
1816  ptr_psi_term funct,result,arg1,arg2,ans_term;
1817  ptr_choice_point cp;
1818 
1819  funct=aim->aaaa_1;
1820  deref_ptr(funct);
1821  result=aim->bbbb_1;
1822  deref_args(funct,set_empty);
1823  get_two_args(funct->attr_list,&arg1,&arg2);
1824  if (arg1 && arg2) {
1825  deref(arg1);
1826  deref(arg2);
1827  deref_args(funct,set_1_2);
1828  success = get_real_value(arg1,&gts_r,&num);
1829  if (success && num) {
1830  gts1 = (unsigned long) gts_r;
1831  success = get_real_value(arg2,&gts_r,&num);
1832  if (success && num) {
1833  gts2 = (unsigned long) gts_r;
1834  cp = choice_stack;
1835  if (cp) {
1836  while (cp && cp->time_stamp>gts2) cp=cp->next;
1837  ans=(cp && cp->time_stamp>gts1);
1838  }
1839  else
1840  ans=FALSE;
1841  ans_term=stack_psi_term(4);
1842  ans_term->type=ans?lf_true:lf_false;
1843  push_goal(unify,result,ans_term,NULL);
1844  }
1845  else {
1846  Errorline("bad second argument to %P.\n",funct);
1847  success=FALSE;
1848  }
1849  }
1850  else {
1851  Errorline("bad first argument %P.\n",funct);
1852  success=FALSE;
1853  }
1854  }
1855  else
1856  curry();
1857 
1858  return success;
1859 }
1860 
1861 
1862 
1863 /******** C_PRINT_VARIABLES
1864  Print the global variables and their values,
1865  in the same way as is done in the user interface.
1866 */
1867 static long c_print_variables()
1868 {
1869  long success=TRUE;
1870 
1871  (void)print_variables(TRUE); /* 21.1 */
1872 
1873  return success;
1874 }
1875 
1876 
1877 static void set_parse_queryflag(thelist, sort)
1878  ptr_node thelist;
1879  long sort;
1880 {
1881  ptr_node n; /* node pointing to argument 2 */
1882  ptr_psi_term arg; /* argumenrt 2 psi-term */
1883  ptr_psi_term queryflag; /* query term created by this function */
1884 
1885  n=find(FEATCMP,two,thelist);
1886  if (n) {
1887  /* there was a second argument */
1888  arg=(ptr_psi_term)n->data;
1889  queryflag=stack_psi_term(4);
1890  queryflag->type =
1892  ((sort==QUERY)?"query":
1893  ((sort==FACT)?"declaration":"error")));
1894  push_goal(unify,queryflag,arg,NULL);
1895  }
1896 }
1897 
1898 
1899 /******** C_PARSE
1900  Parse a string and return a quoted psi-term.
1901  The global variable names are recognized (see the built-in
1902  print_variables). All variables in the parsed string
1903  are added to the set of global variables.
1904 */
1905 static long c_parse()
1906 {
1907  long success=TRUE;
1908  ptr_psi_term arg1,arg2,arg3,funct,result;
1909  long smaller,sort,old_var_occurred;
1910  ptr_node n;
1911  parse_block pb;
1912 
1913  funct=aim->aaaa_1;
1914  deref_ptr(funct);
1915  result=aim->bbbb_1;
1916  get_one_arg(funct->attr_list,&arg1);
1917  if (arg1) {
1918  deref(arg1);
1919  deref_args(funct,set_1);
1920  success=matches(arg1->type,quoted_string,&smaller);
1921  if (success) {
1922  if (arg1->value_3) {
1923  ptr_psi_term t;
1924 
1925  /* Parse the string in its own state */
1926  save_parse_state(&pb);
1927  init_parse_state();
1928  stringparse=TRUE;
1929  stringinput=(char*)arg1->value_3;
1930 
1931  old_var_occurred=var_occurred;
1933  t=stack_copy_psi_term(parse(&sort));
1934 
1935  /* Optional second argument returns 'query', 'declaration', or 'error'. */
1936  n=find(FEATCMP,two,funct->attr_list);
1937  if (n) {
1938  ptr_psi_term queryflag;
1939  arg2=(ptr_psi_term)n->data;
1940  queryflag=stack_psi_term(4);
1941  queryflag->type=
1943  ((sort==QUERY)?"query":((sort==FACT)?"declaration":"error"))
1944  );
1945  push_goal(unify,queryflag,arg2,NULL);
1946  }
1947 
1948  /* Optional third argument returns true or false if the psi-term
1949  contains a variable or not. */
1950  n=find(FEATCMP,three,funct->attr_list);
1951  if (n) {
1952  ptr_psi_term varflag;
1953  arg3=(ptr_psi_term)n->data;
1954  varflag=stack_psi_term(4);
1955  varflag->type=var_occurred?lf_true:lf_false;
1956  push_goal(unify,varflag,arg3,NULL);
1957  }
1958 
1959  var_occurred = var_occurred || old_var_occurred;
1961  restore_parse_state(&pb);
1962 
1963  /* parse_ok flag says whether there was a syntax error. */
1964  if (TRUE /*parse_ok*/) {
1965  mark_quote(t);
1966  push_goal(unify,t,result,NULL);
1967  }
1968  else
1969  success=FALSE;
1970  }
1971  else
1972  residuate(arg1);
1973  }
1974  else
1975  success=FALSE;
1976  }
1977  else
1978  curry();
1979 
1980  return success;
1981 }
1982 
1983 
1984 
1985 
1986 
1987 /******** C_READ
1988  Read a psi_term or a token from the current input stream.
1989  The variables in the object read are not added to the set
1990  of global variables.
1991 */
1992 
1993 static long c_read(long);
1994 
1995 static long c_read_psi() { return (c_read(TRUE)); }
1996 
1997 static long c_read_token() { return (c_read(FALSE)); }
1998 
1999 static long c_read(psi_flag)
2000  long psi_flag;
2001 {
2002  long success=TRUE;
2003  long sort;
2004  ptr_psi_term arg1,arg2,arg3,g,t;
2005  ptr_node old_var_tree;
2006  ptr_node n;
2007  int line=line_count+1;
2008 
2009  g=aim->aaaa_1;
2010  deref_ptr(g);
2011  get_one_arg(g->attr_list,&arg1);
2012  if (arg1) {
2013  deref_args(g,set_1);
2014  if (eof_flag) {
2015  Errorline("attempt to read past end of file (%E).\n");
2016  return (abort_life(TRUE));
2017  }
2018  else {
2019  prompt="";
2020  old_var_tree=var_tree;
2021  var_tree=NULL;
2022  if (psi_flag) {
2023 
2024  t=stack_copy_psi_term(parse(&sort));
2025 
2026 
2027  /* Optional second argument returns 'query', 'declaration', or
2028  'error'. */
2029  n=find(FEATCMP,two,g->attr_list); /* RM: Jun 8 1993 */
2030  if (n) {
2031  ptr_psi_term queryflag;
2032  arg2=(ptr_psi_term)n->data;
2033  queryflag=stack_psi_term(4);
2034  queryflag->type=
2036  ((sort==QUERY)?"query":((sort==FACT)?"declaration":"error"))
2037  );
2038  push_goal(unify,queryflag,arg2,NULL);
2039  }
2040 
2041 
2042  /* Optional third argument returns the starting line number */
2043  /* RM: Oct 11 1993 */
2044  n=find(FEATCMP,three,g->attr_list);
2045  if (n) {
2046  arg3=(ptr_psi_term)n->data;
2047  g=stack_psi_term(4);
2048  g->type=integer;
2049  g->value_3=heap_alloc(sizeof(REAL));
2050  *(REAL *)g->value_3=line;
2051  push_goal(unify,g,arg3,NULL);
2052  }
2053 
2054  }
2055  else {
2056  t=stack_psi_term(0);
2057  read_token_b(t);
2058  /* RM: Jan 5 1993 removed spurious argument: &quot (??) */
2059 
2060  }
2061  if (t->type==eof) eof_flag=TRUE;
2062  var_tree=old_var_tree;
2063  }
2064 
2065  if (success) {
2066  mark_quote(t);
2067  push_goal(unify,t,arg1,NULL);
2068  /* i_check_out(t); */
2069  }
2070  }
2071  else {
2072  Errorline("argument missing in %P.\n",g);
2073  success=FALSE;
2074  }
2075 
2076  return success;
2077 }
2078 
2079 
2080 
2081 /******** C_HALT
2082  Exit the Wild_Life interpreter.
2083 */
2084 long c_halt() /* RM: Jan 8 1993 Used to be 'void' */
2085 {
2086  exit_life(TRUE);
2087 }
2088 
2089 
2090 void exit_life(nl_flag)
2091  long nl_flag;
2092 {
2093  (void)open_input_file("stdin");
2094  (void)times(&life_end);
2095  if (NOTQUIET) { /* 21.1 */
2096  if (nl_flag) printf("\n");
2097  printf("*** Exiting Wild_Life ");
2098  printf("[%1.3fs cpu, %1.3fs gc (%2.1f%%)]\n",
2099  (life_end.tms_utime-life_start.tms_utime)/60.0,
2100  garbage_time,
2101  garbage_time*100 / ((life_end.tms_utime-life_start.tms_utime)/60.0)
2102  );
2103  }
2104 
2105 #ifdef ARITY /* RM: Mar 29 1993 */
2106  arity_end();
2107 #endif
2108 
2109  exit(EXIT_SUCCESS);
2110 }
2111 
2112 
2113 
2114 /******** C_ABORT
2115  Return to the top level of the interpreter.
2116 */
2117 long c_abort() /* RM: Feb 15 1993 */
2118 {
2119  return (abort_life(TRUE));
2120 }
2121 
2122 
2123 /* 26.1 */
2124 long abort_life(nlflag) /* RM: Feb 15 1993 */
2125  int nlflag;
2126 {
2128  !aborthooksym->rule->bbbb_2 ||
2130  /* Do a true abort if aborthook is not a function or is equal to 'abort'.*/
2131  main_loop_ok = FALSE;
2132  undo(NULL); /* 8.10 */
2133  if(NOTQUIET) fprintf(stderr,"\n*** Abort"); /* RM: Feb 17 1993 */
2134  if(NOTQUIET && nlflag) fprintf(stderr,"\n");/* RM: Feb 17 1993 */
2135  } else {
2136  /* Do a 'user-defined abort': initialize the system, then */
2137  /* prove the user-defined abort routine (which is set by */
2138  /* means of 'setq(aborthook,user_defined_abort)'. */
2139  ptr_psi_term aborthook;
2140 
2141  undo(NULL);
2142  init_system();
2144  stdin_cleareof();
2145  if(NOTQUIET) fprintf(stderr,"\n*** Abort"); /* RM: Feb 17 1993 */
2146  if(NOTQUIET && nlflag) fprintf(stderr,"\n");/* RM: Feb 17 1993 */
2147  aborthook=stack_psi_term(0);
2148  aborthook->type=aborthooksym;
2150  }
2151  fprintf(stderr,"\n*** END Abort");
2152  return TRUE;
2153 }
2154 /******** C_NOT_IMPLEMENTED
2155  This function always fails, it is in fact identical to BOTTOM.
2156 */
2157 static long c_not_implemented()
2158 {
2159  ptr_psi_term t;
2160 
2161  t=aim->aaaa_1;
2162  deref_ptr(t);
2163  Errorline("built-in %P is not implemented yet.\n",t);
2164  return FALSE;
2165 }
2166 
2167 
2168 
2169 /******** C_DECLARATION
2170  This function always fails, it is in fact identical to BOTTOM.
2171 */
2172 static long c_declaration()
2173 {
2174  ptr_psi_term t;
2175 
2176  t=aim->aaaa_1;
2177  deref_ptr(t);
2178  Errorline("%P is a declaration, not a query.\n",t);
2179  return FALSE;
2180 }
2181 
2182 
2183 
2184 /******** C_SETQ
2185 
2186  Create a function with one rule F -> X, where F and X are the
2187  arguments of setq. Setq evaluates its first argument and quotes the first.
2188  away any previous definition of F. F must be undefined or a function, there
2189  is an error if F is a sort or a predicate. This gives an error for a static
2190  function, but none for an undefined (i.e. uninterpreted) psi-term, which is
2191  made dynamic. */
2192 
2193 
2194 static long c_setq()
2195 {
2196  long success=FALSE;
2197  ptr_psi_term arg1,arg2,g;
2198  ptr_pair_list p;
2199  ptr_definition d;
2200 
2201  g=aim->aaaa_1;
2202  get_two_args(g->attr_list,&arg1,&arg2);
2203  if (arg1 && arg2) {
2204  deref_rec(arg2); /* RM: Jan 6 1993 */
2205  deref_ptr(arg1);
2206  d=arg1->type;
2207  if (d->type_def==(def_type)function_it || d->type_def==(def_type)undef) {
2208  if (d->type_def==(def_type)undef || !d->protected) {
2209  if (!arg1->attr_list) {
2211  d->protected=FALSE;
2212  p=HEAP_ALLOC(pair_list);
2213  p->aaaa_2=heap_psi_term(4);
2214  p->aaaa_2->type=d;
2215  clear_copy();
2216  p->bbbb_2=quote_copy(arg2,HEAP);
2217  p->next=NULL;
2218  d->rule=p;
2219  success=TRUE;
2220  }
2221  else
2222  Errorline("%P may not have arguments in %P.\n",arg1,g);
2223  }
2224  else
2225  Errorline("%P should be dynamic in %P.\n",arg1,g);
2226  }
2227  else
2228  Errorline("%P should be a function or uninterpreted in %P.\n",arg1,g);
2229  }
2230  else
2231  Errorline("%P is missing one or both arguments.\n",g);
2232 
2233  return success;
2234 }
2235 
2236 
2237 
2238 /******** C_ASSERT_FIRST
2239  Assert a fact, inserting it as the first clause
2240  for that predicate or function.
2241 */
2242 static long c_assert_first()
2243 {
2244  long success=FALSE;
2245  ptr_psi_term arg1,g;
2246 
2247  g=aim->aaaa_1;
2248  bk_mark_quote(g); /* RM: Apr 7 1993 */
2249  get_one_arg(g->attr_list,&arg1);
2251  if (arg1) {
2252  deref_ptr(arg1);
2253  assert_clause(arg1);
2254  encode_types();
2255  success=assert_ok;
2256  }
2257  else {
2258  success=FALSE;
2259  Errorline("bad clause in %P.\n",g);
2260  }
2261 
2262  return success;
2263 }
2264 
2265 
2266 
2267 /******** C_ASSERT_LAST
2268  Assert a fact, inserting as the last clause for that predicate or function.
2269 */
2270 static long c_assert_last()
2271 {
2272  long success=FALSE;
2273  ptr_psi_term arg1,g;
2274 
2275  g=aim->aaaa_1;
2276  bk_mark_quote(g); /* RM: Apr 7 1993 */
2277  get_one_arg(g->attr_list,&arg1);
2279  if (arg1) {
2280  deref_ptr(arg1);
2281  assert_clause(arg1);
2282  encode_types();
2283  success=assert_ok;
2284  }
2285  else {
2286  success=FALSE;
2287  Errorline("bad clause in %P.\n",g);
2288  }
2289 
2290  return success;
2291 }
2292 
2293 
2294 
2295 /******** PRED_CLAUSE(t,r,g)
2296  Set about finding a clause that unifies with psi_term T.
2297  This routine is used both for CLAUSE and RETRACT.
2298  If R==TRUE then delete the first clause which unifies with T.
2299 */
2300 long pred_clause(t,r,g)
2301  ptr_psi_term t, g;
2302  long r;
2303 {
2304  long success=FALSE;
2305  ptr_psi_term head,body;
2306 
2307  bk_mark_quote(g); /* RM: Apr 7 1993 */
2308  if (t) {
2309  deref_ptr(t);
2310 
2311  if (!strcmp(t->type->keyword->symbol,"->")) {
2312  get_two_args(t->attr_list,&head,&body);
2313  if (head) {
2314  deref_ptr(head);
2315  if (head && body &&
2316  (head->type->type_def==(def_type)function_it || head->type->type_def==(def_type)undef))
2317  success=TRUE;
2318  }
2319  }
2320  else if (!strcmp(t->type->keyword->symbol,":-")) {
2321  get_two_args(t->attr_list,&head,&body);
2322  if (head) {
2323  deref_ptr(head);
2324  if (head &&
2325  (head->type->type_def==(def_type)predicate || head->type->type_def==(def_type)undef)) {
2326  success=TRUE;
2327  if (!body) {
2328  body=stack_psi_term(4);
2329  body->type=succeed;
2330  }
2331  }
2332  }
2333  }
2334  /* There is no body, so t is a fact */
2335  else if (t->type->type_def==(def_type)predicate || t->type->type_def==(def_type)undef) {
2336  head=t;
2337  body=stack_psi_term(4);
2338  body->type=succeed;
2339  success=TRUE;
2340  }
2341  }
2342 
2343  if (success) {
2344  if (r) {
2345  if (redefine(head))
2346  push_goal(del_clause,head,body,(GENERIC)&(head->type->rule));
2347  else
2348  success=FALSE;
2349  }
2350  else
2351  push_goal(clause,head,body,(GENERIC)&(head->type->rule));
2352  }
2353  else
2354  Errorline("bad argument in %s.\n", (r?"retract":"clause"));
2355 
2356  return success;
2357 }
2358 
2359 
2360 
2361 /******** C_CLAUSE
2362  Find the clauses that unify with the argument in the rules.
2363  The argument must be a predicate or a function.
2364  Use PRED_CLAUSE to perform the search.
2365 */
2366 static long c_clause()
2367 {
2368  long success=FALSE;
2369  ptr_psi_term arg1,arg2,g;
2370 
2371  g=aim->aaaa_1;
2372  get_two_args(g->attr_list,&arg1,&arg2);
2373  success=pred_clause(arg1,0,g);
2374  return success;
2375 }
2376 
2377 
2378 
2379 /******** C_RETRACT
2380  Retract the first clause that unifies with the argument.
2381  Use PRED_CLAUSE to perform the search.
2382 */
2383 static long c_retract()
2384 {
2385  long success=FALSE;
2386  ptr_psi_term arg1,arg2,g;
2387 
2388  g=aim->aaaa_1;
2389  get_two_args(g->attr_list,&arg1,&arg2);
2390  success=pred_clause(arg1,1,g);
2391 
2392  return success;
2393 }
2394 
2395 
2396 
2397 /******** C_GLOBAL
2398  Declare that a symbol is a global variable.
2399  Handle multiple arguments and initialization
2400  (the initialization term is evaluated).
2401  If there is an error anywhere in the declaration,
2402  then evaluate and declare nothing.
2403 */
2404 static long c_global() /* RM: Feb 10 1993 */
2405 {
2406  int error=FALSE;
2407  int eval_2=FALSE;
2408  ptr_psi_term g;
2409 
2410  g=aim->aaaa_1;
2411  deref_ptr(g);
2412  if (g->attr_list) {
2413  /* Do error check of all arguments first: */
2414  global_error_check(g->attr_list, &error, &eval_2);
2415  if (eval_2) return !error;
2416  /* If no errors, then make the arguments global: */
2417  if (!error)
2418  global_tree(g->attr_list);
2419  } else {
2420  Errorline("argument(s) missing in %P\n",g);
2421  }
2422 
2423  return !error;
2424 }
2425 
2426 
2427 
2428 void global_error_check(n, error, eval_2)
2429  ptr_node n;
2430  int *error, *eval_2;
2431 {
2432  if (n) {
2433  ptr_psi_term t,a1,a2;
2434  int bad_init=FALSE;
2435  global_error_check(n->left, error, eval_2);
2436 
2437  t=(ptr_psi_term)n->data;
2438  deref_ptr(t);
2439  if (t->type==leftarrowsym) {
2440  get_two_args(t->attr_list,&a1,&a2);
2441  if (a1==NULL || a2==NULL) {
2442  Errorline("%P is an incorrect global variable declaration (%E).\n",t);
2443  *error=TRUE;
2444  bad_init=TRUE;
2445  } else {
2446  deref_ptr(a1);
2447  deref_ptr(a2);
2448  t=a1;
2449  if (deref_eval(a2)) *eval_2=TRUE;
2450  }
2451  }
2452  if (!bad_init && t->type->type_def!=(def_type)undef && t->type->type_def!=(def_type)global) {
2453  Errorline("%T %P cannot be redeclared as a global variable (%E).\n",
2454  t->type->type_def,
2455  t);
2456  t->type=error_psi_term->type;
2457  t->value_3=NULL; /* RM: Mar 23 1993 */
2458  *error=TRUE;
2459  }
2460 
2461  global_error_check(n->right, error, eval_2);
2462  }
2463 }
2464 
2465 
2467  ptr_node n;
2468 {
2469  if (n) {
2470  ptr_psi_term t;
2471  global_tree(n->left);
2472 
2473  t=(ptr_psi_term)n->data;
2474  deref_ptr(t);
2475  global_one(t);
2476 
2477  global_tree(n->right);
2478  }
2479 }
2480 
2481 
2482 void global_one(t)
2483  ptr_psi_term t;
2484 {
2485  ptr_psi_term u; // ,val;
2486 
2487  if (t->type==leftarrowsym) {
2488  get_two_args(t->attr_list,&t,&u);
2489  deref_ptr(t);
2490  deref_ptr(u);
2491  }
2492  else
2493  u=stack_psi_term(4);
2494 
2495  clear_copy();
2496  t->type->type_def=(def_type)global;
2497  t->type->init_value=quote_copy(u,HEAP); /* RM: Mar 23 1993 */
2498 
2499  /* eval_global_var(t); RM: Feb 4 1994 */
2500 
2501  /* RM: Nov 10 1993
2502  val=t->type->global_value;
2503  if (val && (GENERIC)val<heap_pointer) {
2504  deref_ptr(val);
2505  push_psi_ptr_value(val,&(val->coref));
2506  val->coref=u;
2507  } else
2508  t->type->global_value=u;
2509  */
2510 }
2511 
2512 
2513 
2514 /******** C_PERSISTENT
2515  Declare that a symbol is a persistent variable.
2516 */
2517 static long c_persistent() /* RM: Feb 10 1993 */
2518 {
2519  int error=FALSE;
2520  ptr_psi_term g;
2521 
2522  g=aim->aaaa_1;
2523  deref_ptr(g);
2524  if (g->attr_list) {
2525  /* Do error check of all arguments first: */
2526  persistent_error_check(g->attr_list, &error);
2527  /* If no errors, then make the arguments persistent: */
2528  if (!error)
2530  } else {
2531  Errorline("argument(s) missing in %P\n",g);
2532  }
2533 
2534  return !error;
2535 }
2536 
2537 
2539  ptr_node n;
2540  int *error;
2541 {
2542  if (n) {
2543  ptr_psi_term t;
2544  persistent_error_check(n->left, error);
2545 
2546  t=(ptr_psi_term)n->data;
2547  deref_ptr(t);
2548  if (t->type->type_def!=(def_type)undef && t->type->type_def!=(def_type)global) {
2549  Errorline("%T %P cannot be redeclared persistent (%E).\n",
2550  t->type->type_def,
2551  t);
2552  t->type=error_psi_term->type;
2553  *error=TRUE;
2554  }
2555 
2556  persistent_error_check(n->right, error);
2557  }
2558 }
2559 
2560 
2562  ptr_node n;
2563 {
2564  if (n) {
2565  ptr_psi_term t;
2566  persistent_tree(n->left);
2567 
2568  t=(ptr_psi_term)n->data;
2569  deref_ptr(t);
2570  persistent_one(t);
2571 
2572  persistent_tree(n->right);
2573  }
2574 }
2575 
2576 
2578  ptr_psi_term t;
2579 {
2581  if ((GENERIC)t->type->global_value<(GENERIC)heap_pointer)
2582  t->type->global_value=heap_psi_term(4);
2583 }
2584 
2585 
2586 
2587 /******** C_OPEN_IN
2588  Create a stream for input from the specified file.
2589 */
2590 static long c_open_in()
2591 {
2592  long success=FALSE;
2593  ptr_psi_term arg1,arg2,g;
2594  char *fn;
2595 
2596  g=aim->aaaa_1;
2597  deref_ptr(g);
2598  get_two_args(g->attr_list,&arg1,&arg2);
2599  if(arg1) {
2600  deref(arg1);
2601  if (psi_to_string(arg1,&fn))
2602  if (arg2) {
2603  deref(arg2);
2604  deref_args(g,set_1_2);
2605  if (is_top(arg2)) {
2606  if (open_input_file(fn)) {
2607  /* push_ptr_value(psi_term_ptr,&(arg2->coref)); 9.6 */
2608  push_psi_ptr_value(arg2,(GENERIC *)&(arg2->coref));
2609  arg2->coref=input_state;
2610  success=TRUE;
2611  }
2612  else
2613  success=FALSE;
2614  }
2615  else
2616  Errorline("bad input stream in %P.\n",g);
2617  }
2618  else
2619  Errorline("no stream in %P.\n",g);
2620  else
2621  Errorline("bad file name in %P.\n",g);
2622  }
2623  else
2624  Errorline("no file name in %P.\n",g);
2625 
2626  return success;
2627 }
2628 
2629 
2630 
2631 /******** C_OPEN_OUT
2632  Create a stream for output from the specified file.
2633 */
2634 static long c_open_out()
2635 {
2636  long success=FALSE;
2637  ptr_psi_term arg1,arg2,arg3,g;
2638  char *fn;
2639 
2640  g=aim->aaaa_1;
2641  deref_ptr(g);
2642  get_two_args(g->attr_list,&arg1,&arg2);
2643  if(arg1) {
2644  deref(arg1);
2645  if (psi_to_string(arg1,&fn))
2646  if (arg2) {
2647  deref(arg2);
2648  deref(g);
2649  if (overlap_type(arg2->type,stream)) /* 10.8 */
2650  if (open_output_file(fn)) {
2651  arg3=stack_psi_term(4);
2652  arg3->type=stream;
2653  arg3->value_3=(GENERIC)output_stream;
2654  /* push_ptr_value(psi_term_ptr,&(arg2->coref)); 9.6 */
2655  push_psi_ptr_value(arg2,(GENERIC *)&(arg2->coref));
2656  arg2->coref=arg3;
2657  success=TRUE;
2658  }
2659  else
2660  success=FALSE;
2661  else
2662  Errorline("bad stream in %P.\n",g);
2663  }
2664  else
2665  Errorline("no stream in %P.\n",g);
2666  else
2667  Errorline("bad file name in %P.\n",g);
2668  }
2669  else
2670  Errorline("no file name in %P.\n",g);
2671 
2672  return success;
2673 }
2674 
2675 
2676 
2677 /******** C_SET_INPUT
2678  Set the current input stream to a given stream.
2679  If the given stream is closed, then do nothing.
2680 */
2681 static long c_set_input()
2682 {
2683  long success=FALSE;
2684  ptr_psi_term arg1,arg2,g;
2685  FILE *thestream;
2686 
2687  g=aim->aaaa_1;
2688  deref_ptr(g);
2689  get_two_args(g->attr_list,&arg1,&arg2);
2690  if (arg1) {
2691  deref(arg1);
2692  deref_args(g,set_1);
2693  if (equal_types(arg1->type,inputfilesym)) {
2694  success=TRUE;
2696  thestream=get_stream(arg1);
2697  if (thestream!=NULL) {
2698  input_state=arg1;
2700  }
2701  }
2702  else
2703  Errorline("bad stream in %P.\n",g);
2704  }
2705  else
2706  Errorline("no stream in %P.\n",g);
2707 
2708  return success;
2709 }
2710 
2711 
2712 
2713 /******** C_SET_OUTPUT
2714  Set the current output stream.
2715 */
2716 static long c_set_output()
2717 {
2718  long success=FALSE;
2719  ptr_psi_term arg1,arg2,g;
2720 
2721  g=aim->aaaa_1;
2722  deref_ptr(g);
2723  get_two_args(g->attr_list,&arg1,&arg2);
2724  if(arg1) {
2725  deref(arg1);
2726  deref_args(g,set_1);
2727  if(equal_types(arg1->type,stream) && arg1->value_3) {
2728  success=TRUE;
2729  output_stream=(FILE *)arg1->value_3;
2730  }
2731  else
2732  Errorline("bad stream in %P.\n",g);
2733  }
2734  else
2735  Errorline("no stream in %P.\n",g);
2736 
2737  return success;
2738 }
2739 
2740 /******** C_CLOSE
2741  Close a stream.
2742 */
2743 static long c_close()
2744 {
2745  long success=FALSE;
2746  long inclose,outclose;
2747  ptr_psi_term arg1,arg2,g; // ,s;
2748 
2749  g=aim->aaaa_1;
2750  deref_ptr(g);
2751  get_two_args(g->attr_list,&arg1,&arg2);
2752  if (arg1) {
2753  deref(arg1);
2754  deref_args(g,set_1);
2755  /*
2756  if (sub_type(arg1->type,sys_stream))
2757  return sys_close(arg1);
2758  */
2759  outclose=equal_types(arg1->type,stream) && arg1->value_3;
2760  inclose=FALSE;
2761  if (equal_types(arg1->type,inputfilesym)) {
2763  if (n) {
2764  arg1=(ptr_psi_term)n->data;
2765  inclose=(arg1->value_3!=NULL);
2766  }
2767  }
2768 
2769  if (inclose || outclose) {
2770  success=TRUE;
2771  (void)fclose((FILE *)arg1->value_3);
2772 
2773  if (inclose && (FILE *)arg1->value_3==input_stream)
2774  (void)open_input_file("stdin");
2775  else if (outclose && (FILE *)arg1->value_3==output_stream)
2776  (void)open_output_file("stdout");
2777 
2778  arg1->value_3=NULL;
2779  }
2780  else
2781  Errorline("bad stream in %P.\n",g);
2782  }
2783  else
2784  Errorline("no stream in %P.\n",g);
2785 
2786  return success;
2787 }
2788 
2789 
2790 
2791 
2792 /******** C_GET
2793  Read the next character from the current input stream and return
2794  its Ascii code. This includes blank characters, so this predicate
2795  differs slightly from Edinburgh Prolog's get(X).
2796  At end of file, return the psi-term 'end_of_file'.
2797 */
2798 static long c_get()
2799 {
2800  long success=TRUE;
2801  ptr_psi_term arg1,arg2,g,t;
2802  long c;
2803 
2804  g=aim->aaaa_1;
2805  deref_ptr(g);
2806  get_two_args(g->attr_list,&arg1,&arg2);
2807  if (arg1) {
2808  deref(arg1);
2809  deref_args(g,set_1);
2810 
2811  if (eof_flag) {
2812  success=FALSE;
2813  }
2814  else {
2815  prompt="";
2816  c=read_char();
2817  t=stack_psi_term(0);
2818  if (c==EOF) {
2819  t->type=eof;
2820  eof_flag=TRUE;
2821  }
2822  else {
2823  t->type=integer;
2824  t->value_3=heap_alloc(sizeof(REAL)); /* 12.5 */
2825  * (REAL *)t->value_3 = (REAL) c;
2826  }
2827  }
2828 
2829  if (success) {
2830  push_goal(unify,t,arg1,NULL);
2831  (void)i_check_out(t);
2832  }
2833  }
2834  else {
2835  Errorline("argument missing in %P.\n",g);
2836  success=FALSE;
2837  }
2838 
2839  return success;
2840 }
2841 
2842 
2843 
2844 /******** C_PUT, C_PUT_ERR
2845  Write the root of a psi-term to the current output stream or to stderr.
2846  This routine accepts the string type (which is written without quotes),
2847  a number type (whose integer part is considered an Ascii code if it is
2848  in the range 0..255), and any other psi-term (in which case its name is
2849  written).
2850 */
2851 static long c_put_main(long); /* Forward declaration */
2852 
2853 static long c_put()
2854 {
2855  return c_put_main(FALSE);
2856 }
2857 
2858 static long c_put_err()
2859 {
2860  return c_put_main(TRUE);
2861 }
2862 
2863 static long c_put_main(to_stderr)
2864  long to_stderr;
2865 {
2866  long i,success=FALSE;
2867  ptr_psi_term arg1,arg2,g;
2868  char tstr[2], *str=tstr;
2869 
2870  g=aim->aaaa_1;
2871  deref_ptr(g);
2872  get_two_args(g->attr_list,&arg1,&arg2);
2873  if (arg1) {
2874  deref(arg1);
2875  deref_args(g,set_1);
2876  if ((equal_types(arg1->type,integer) || equal_types(arg1->type,real))
2877  && arg1->value_3) {
2878  i = (unsigned long) floor(*(REAL *) arg1->value_3);
2879  if (i==(unsigned long)(unsigned char)i) {
2880  str[0] = i; str[1] = 0;
2881  success=TRUE;
2882  }
2883  else {
2884  Errorline("out-of-range character value in %P.\n",g);
2885  }
2886  }
2887  else if (psi_to_string(arg1,&str)) {
2888  success=TRUE;
2889  }
2890  if (success)
2891  fprintf((to_stderr?stderr:output_stream),"%s",str);
2892  }
2893  else
2894  Errorline("argument missing in %P.\n",g);
2895 
2896  return success;
2897 }
2898 
2899 
2900 
2901 /******** GENERIC_WRITE
2902  Implements write, writeq, pretty_write, pretty_writeq.
2903 */
2904 static long generic_write()
2905 {
2906  ptr_psi_term g;
2907 
2908  g=aim->aaaa_1;
2909  /* deref_rec(g); */
2910  deref_args(g,set_empty);
2911  pred_write(g->attr_list);
2912  /* fflush(output_stream); */
2913  return TRUE;
2914 }
2915 
2916 /******** C_WRITE_ERR
2917  Write a list of arguments to stderr. Print cyclical terms
2918  correctly, but don't use the pretty printer indentation.
2919 */
2920 static long c_write_err()
2921 {
2922  indent=FALSE;
2928  return generic_write();
2929 }
2930 
2931 /******** C_WRITEQ_ERR
2932  Write a list of arguments to stderr in a form that allows them to be
2933  read in again. Print cyclical terms correctly, but don't use the pretty
2934  printer indentation.
2935 */
2936 static long c_writeq_err()
2937 {
2938  indent=FALSE;
2939  const_quote=TRUE;
2944  return generic_write();
2945 }
2946 
2947 /******** C_WRITE
2948  Write a list of arguments. Print cyclical terms
2949  correctly, but don't use the pretty printer indentation.
2950 */
2951 static long c_write()
2952 {
2953  indent=FALSE;
2959  return generic_write();
2960 }
2961 
2962 /******** C_WRITEQ
2963  Write a list of arguments in a form that allows them to be read in
2964  again. Print cyclical terms correctly, but don't use the pretty
2965  printer indentation.
2966 */
2967 static long c_writeq()
2968 {
2969  indent=FALSE;
2970  const_quote=TRUE;
2975  return generic_write();
2976 }
2977 
2978 /******** C_WRITE_CANONICAL
2979  Write a list of arguments in a form that allows them to be read in
2980  again. Print cyclical terms correctly, but don't use the pretty
2981  printer indentation.
2982 */
2983 static long c_write_canonical()
2984 {
2985  indent=FALSE;
2986  const_quote=TRUE;
2990  write_canon=TRUE;
2991  return generic_write();
2992 }
2993 
2994 /******** C_PRETTY_WRITE
2995  The same as write, only indenting if output is wider than PAGEWIDTH.
2996 */
2997 static long c_pwrite()
2998 {
2999  indent=TRUE;
3005  return generic_write();
3006 }
3007 
3008 
3009 /******** C_PRETTY_WRITEQ
3010  The same as writeq, only indenting if output is wider than PAGEWIDTH.
3011 */
3012 static long c_pwriteq()
3013 {
3014  indent=TRUE;
3015  const_quote=TRUE;
3020  return generic_write();
3021 }
3022 
3023 
3024 
3025 /******** C_PAGE_WIDTH
3026  Set the page width.
3027 */
3028 static long c_page_width()
3029 {
3030  long success=FALSE;
3031  ptr_psi_term arg1,arg2,g;
3032  long pw;
3033 
3034  g=aim->aaaa_1;
3035  deref_ptr(g);
3036  get_two_args(g->attr_list,&arg1,&arg2);
3037  if(arg1) {
3038  deref(arg1);
3039  deref_args(g,set_1);
3040  if (equal_types(arg1->type,integer) && arg1->value_3) {
3041  pw = *(REAL *)arg1->value_3;
3042  if (pw>0)
3043  page_width=pw;
3044  else
3045  Errorline("argument in %P must be positive.\n",g);
3046  success=TRUE;
3047  }
3048  else if (sub_type(integer,arg1->type)) {
3050  success=TRUE;
3051  }
3052  else
3053  Errorline("bad argument in %P.\n",g);
3054  }
3055  else
3056  Errorline("argument missing in %P.\n",g);
3057 
3058  return success;
3059 }
3060 
3061 
3062 
3063 /******** C_PRINT_DEPTH
3064  Set the depth limit of printing.
3065 */
3066 static long c_print_depth()
3067 {
3068  long success=FALSE;
3069  ptr_psi_term arg1,arg2,g;
3070  long dl;
3071 
3072  g=aim->aaaa_1;
3073  deref_ptr(g);
3074  get_two_args(g->attr_list,&arg1,&arg2);
3075  if (arg1) {
3076  deref(arg1);
3077  deref_args(g,set_1);
3078  if (equal_types(arg1->type,integer) && arg1->value_3) {
3079  dl = *(REAL *)arg1->value_3;
3080  if (dl>=0)
3081  print_depth=dl;
3082  else
3083  Errorline("argument in %P must be positive or zero.\n",g);
3084  success=TRUE;
3085  }
3086  else if (sub_type(integer,arg1->type)) {
3088  success=TRUE;
3089  }
3090  else
3091  Errorline("bad argument in %P.\n",g);
3092  }
3093  else {
3094  /* No arguments: reset print depth to default value */
3096  success=TRUE;
3097  }
3098 
3099  return success;
3100 }
3101 
3102 
3103 
3104 /******** C_ROOTSORT
3105  Return the principal sort of the argument == create a copy with the
3106  attributes detached.
3107 */
3108 static long c_rootsort()
3109 {
3110  long success=TRUE;
3111  ptr_psi_term arg1,arg2,arg3,g,other;
3112 
3113  g=aim->aaaa_1;
3114  deref_ptr(g);
3115  arg3=aim->bbbb_1;
3116  deref(arg3);
3117  get_two_args(g->attr_list,&arg1,&arg2);
3118  if(arg1) {
3119  deref(arg1);
3120  deref_args(g,set_1);
3121  other=stack_psi_term(4); /* 19.11 */
3122  other->type=arg1->type;
3123  other->value_3=arg1->value_3;
3124  resid_aim=NULL;
3125  push_goal(unify,arg3,other,NULL);
3126  }
3127  else
3128  curry();
3129 
3130  return success;
3131 }
3132 
3133 
3134 
3135 
3136 /******** C_DISJ
3137  This implements disjunctions (A;B).
3138  A nonexistent A or B is taken to mean 'fail'.
3139  Disjunctions should not be implemented in Life, because doing so results in
3140  both A and B being evaluated before the disjunction is.
3141  Disjunctions could be implemented in Life if there were a 'melt' predicate.
3142 */
3143 static long c_disj()
3144 {
3145  long success=TRUE;
3146  ptr_psi_term arg1,arg2,g;
3147 
3148  g=aim->aaaa_1;
3149  resid_aim=NULL;
3150  deref_ptr(g);
3151  get_two_args(g->attr_list,&arg1,&arg2);
3152  deref_args(g,set_1_2);
3153  traceline("pushing predicate disjunction choice point for %P\n",g);
3155  if (arg1) push_goal(prove,arg1,(ptr_psi_term)DEFRULES,(GENERIC)NULL);
3156  if (!arg1 && !arg2) {
3157  success=FALSE;
3158  Errorline("neither first nor second arguments exist in %P.\n",g);
3159  }
3160 
3161  return success;
3162 }
3163 
3164 
3165 
3166 /******** C_COND
3167  This implements COND(Condition,Then,Else).
3168  First Condition is evaluated. If it returns true, return the Then value.
3169  If it returns false, return the Else value. Either the Then or the Else
3170  values may be omitted, in which case they are considered to be true.
3171 */
3172 static long c_cond()
3173 {
3174  long success=TRUE;
3175  ptr_psi_term arg1,arg2,result,g;
3176  ptr_psi_term *arg1addr;
3177  REAL val1;
3178  long num1;
3179  ptr_node n;
3180 
3181  g=aim->aaaa_1;
3182  deref_ptr(g);
3183  result=aim->bbbb_1;
3184  deref(result);
3185 
3186  get_one_arg_addr(g->attr_list,&arg1addr);
3187  if (arg1addr) {
3188  arg1= *arg1addr;
3189  deref_ptr(arg1);
3190  if (arg1->type->type_def==(def_type)predicate) {
3191  ptr_psi_term call_once;
3192  ptr_node ca;
3193 
3194  /* Transform cond(pred,...) into cond(call_once(pred),...) */
3195  goal_stack=aim;
3196  call_once=stack_psi_term(0);
3197  call_once->type=calloncesym;
3198  call_once->attr_list=(ca=STACK_ALLOC(node));
3199  ca->key=one;
3200  ca->left=ca->right=NULL;
3201  ca->data=(GENERIC)arg1;
3202  push_ptr_value(psi_term_ptr,(GENERIC *)arg1addr);
3203  *arg1addr=call_once;
3204  return success;
3205  }
3206  deref(arg1);
3207  deref_args(g,set_1_2_3);
3208  success=get_bool_value(arg1,&val1,&num1);
3209  if (success) {
3210  if (num1) {
3211  resid_aim=NULL;
3212  n=find(FEATCMP,(val1?two:three),g->attr_list);
3213  if (n) {
3214  arg2=(ptr_psi_term)n->data;
3215  /* mark_eval(arg2); XXX 24.8 */
3216  push_goal(unify,result,arg2,NULL);
3217  (void)i_check_out(arg2);
3218  }
3219  else {
3220  ptr_psi_term trueterm;
3221  trueterm=stack_psi_term(4);
3222  trueterm->type=lf_true;
3223  push_goal(unify,result,trueterm,NULL);
3224  }
3225  }
3226  else
3227  residuate(arg1);
3228  }
3229  else /* RM: Apr 15 1993 */
3230  Errorline("argument to cond is not boolean in %P\n",g);
3231  }
3232  else
3233  curry();
3234 
3235  return success;
3236 }
3237 
3238 
3239 
3240 /******** C_EXIST_FEATURE
3241  Here we evaluate "has_feature(Label,Psi-term,Value)". This
3242  is a boolean function that returns true iff Psi-term
3243  has the feature Label.
3244 
3245  Added optional 3rd argument which is unified with the feature value if it exists.
3246 */
3247 
3248 static long c_exist_feature() /* PVR: Dec 17 1992 */ /* PVR 11.4.94 */
3249 {
3250  long success=TRUE,v;
3251  ptr_psi_term arg1,arg2,arg3,funct,result,ans;
3252  ptr_node n;
3253  char * label;
3254  /* char *thebuffer="integer"; 18.5 */
3255  char thebuffer[20]; /* Maximum number of digits in an integer */
3256  // char *np1;
3257 
3258  funct=aim->aaaa_1;
3259  deref_ptr(funct);
3260  result=aim->bbbb_1;
3261  get_two_args(funct->attr_list,&arg1,&arg2);
3262 
3263  n=find(FEATCMP,three,funct->attr_list); /* RM: Feb 10 1993 */
3264  if(n)
3265  arg3=(ptr_psi_term)n->data;
3266  else
3267  arg3=NULL;
3268 
3269  if (arg1 && arg2) {
3270  deref(arg1);
3271  deref(arg2);
3272 
3273  if(arg3) /* RM: Feb 10 1993 */
3274  deref(arg3);
3275 
3276  deref_args(funct,set_1_2);
3277  label=NULL;
3278 
3279  if (arg1->value_3 && sub_type(arg1->type,quoted_string))
3280  label=(char *)arg1->value_3;
3281  else if (arg1->value_3 && sub_type(arg1->type,integer)) {
3282  v= *(REAL *)arg1->value_3;
3283  (void)snprintf(thebuffer,20,"%ld",(long)v);
3284  label=heap_copy_string(thebuffer); /* A little voracious */
3285  } else if (arg1->type->keyword->private_feature) {
3286  label=arg1->type->keyword->combined_name;
3287  } else
3288  label=arg1->type->keyword->symbol;
3289 
3290  n=find(FEATCMP,(char *)label,arg2->attr_list);
3291  ans=stack_psi_term(4);
3292  ans->type=(n!=NULL)?lf_true:lf_false;
3293 
3294  if(arg3 && n) /* RM: Feb 10 1993 */
3296 
3297  push_goal(unify,result,ans,NULL);
3298  }
3299  else
3300  curry();
3301 
3302  return success;
3303 }
3304 
3305 
3306 
3307 
3308 /******** C_FEATURES
3309  Convert the feature names of a psi_term into a list of psi-terms.
3310  This uses the MAKE_FEATURE_LIST routine.
3311 */
3312 static long c_features()
3313 {
3314  long success=TRUE;
3315  ptr_psi_term arg1,arg2,funct,result;
3316  /* ptr_psi_term the_list; RM: Dec 9 1992
3317  Modified the routine to use 'cons'
3318  instead of the old list representation.
3319  */
3320  /* RM: Mar 11 1993 Added MODULE argument */
3321  ptr_module module=NULL;
3322  ptr_module save_current;
3323 
3324 
3325 
3326 
3327  funct=aim->aaaa_1;
3328  deref_ptr(funct);
3329  result=aim->bbbb_1;
3330  get_two_args(funct->attr_list,&arg1,&arg2);
3331 
3332 
3333  if(arg2) {
3334  deref(arg2);
3335  success=get_module(arg2,&module);
3336  }
3337  else
3338  module=current_module;
3339 
3340 
3341  if(arg1 && success) {
3342  deref(arg1);
3343  deref_args(funct,set_1);
3344  resid_aim=NULL;
3345 
3346  save_current=current_module;
3347  if(module)
3348  current_module=module;
3349 
3350  push_goal(unify,
3351  result,
3352  make_feature_list(arg1->attr_list,stack_nil(),module,0),
3353  NULL);
3354 
3355  current_module=save_current;
3356  }
3357  else
3358  curry();
3359 
3360  return success;
3361 }
3362 
3363 
3364 
3365 /******** C_FEATURES
3366  Return the list of values of the features of a term.
3367 */
3368 static long c_feature_values()
3369 {
3370  long success=TRUE;
3371  ptr_psi_term arg1,arg2,funct,result;
3372  /* ptr_psi_term the_list; RM: Dec 9 1992
3373  Modified the routine to use 'cons'
3374  instead of the old list representation.
3375  */
3376  /* RM: Mar 11 1993 Added MODULE argument */
3377  ptr_module module=NULL;
3378  ptr_module save_current;
3379 
3380 
3381  funct=aim->aaaa_1;
3382  deref_ptr(funct);
3383  result=aim->bbbb_1;
3384  get_two_args(funct->attr_list,&arg1,&arg2);
3385 
3386 
3387  if(arg2) {
3388  deref(arg2);
3389  success=get_module(arg2,&module);
3390  }
3391  else
3392  module=current_module;
3393 
3394 
3395  if(arg1 && success) {
3396  deref(arg1);
3397  deref_args(funct,set_1);
3398  resid_aim=NULL;
3399 
3400  save_current=current_module;
3401  if(module)
3402  current_module=module;
3403 
3404  push_goal(unify,
3405  result,
3406  make_feature_list(arg1->attr_list,stack_nil(),module,1),
3407  NULL);
3408 
3409  current_module=save_current;
3410  }
3411  else
3412  curry();
3413 
3414  return success;
3415 }
3416 
3417 
3418 
3419 /* Return TRUE iff T is a type that should not show up as part of the
3420  type hierarchy, i.e. it is an internal hidden type. */
3422  ptr_definition t;
3423 {
3424  return (/* (t==conjunction) || 19.8 */
3425  /* (t==disjunction) || RM: Dec 9 1992 */
3426  (t==constant) || (t==variable) ||
3427  (t==comment) || (t==functor));
3428 }
3429 
3430 
3431 
3432 /* Collect properties of the symbols in the symbol table, and make a
3433  psi-term list of them.
3434  This routine is parameterized (by sel) to collect three properties:
3435  1. All symbols that are types with no parents.
3436  2. All symbols that are of 'undef' type.
3437  3. The operator triples of all operators.
3438 
3439  Note the similarity between this routine and a tree-to-list
3440  routine in Prolog. The pointer manipulations are simpler in
3441  Prolog, though.
3442 
3443  If the number of symbols is very large, this routine may run out of space
3444  before garbage collection.
3445 */
3446 ptr_psi_term collect_symbols(sel) /* RM: Feb 3 1993 */
3447  long sel;
3448 
3449 {
3450  ptr_psi_term new;
3451  ptr_definition def;
3452  long botflag;
3453  ptr_psi_term result;
3454 
3455 
3456  result=stack_nil();
3457 
3458  for(def=first_definition;def;def=def->next) {
3459 
3460  if (sel==least_sel || sel==greatest_sel) {
3461  botflag=(sel==least_sel);
3462 
3463  /* Insert the node if it's a good one */
3464  if (((botflag?def->children:def->parents)==NULL &&
3465  def!=top && def!=nothing &&
3466  def->type_def==(def_type)type_it ||
3467  def->type_def==(def_type)undef)
3468  && !hidden_type(def)) {
3469  /* Create the node that will be inserted */
3470  new=stack_psi_term(4);
3471  new->type=def;
3472  result=stack_cons((ptr_psi_term)new,(ptr_psi_term)result);
3473  }
3474  }
3475  else if (sel==op_sel) {
3476  ptr_operator_data od=def->op_data;
3477 
3478  while (od) {
3479  ptr_psi_term name_loc,type;
3480 
3481  new=stack_psi_term(4);
3482  new->type=opsym;
3483  result=stack_cons((ptr_psi_term)new,(ptr_psi_term)result);
3484 
3486 
3487  type=stack_psi_term(4);
3488  switch (od->type) {
3489  case xf:
3490  type->type=xf_sym;
3491  break;
3492  case yf:
3493  type->type=yf_sym;
3494  break;
3495  case fx:
3496  type->type=fx_sym;
3497  break;
3498  case fy:
3499  type->type=fy_sym;
3500  break;
3501  case xfx:
3502  type->type=xfx_sym;
3503  break;
3504  case xfy:
3505  type->type=xfy_sym;
3506  break;
3507  case yfx:
3508  type->type=yfx_sym;
3509  break;
3510  }
3511  stack_add_psi_attr(new,two,type);
3512 
3513  name_loc=stack_psi_term(4);
3514  name_loc->type=def;
3515  stack_add_psi_attr(new,three,name_loc);
3516 
3517  od=od->next;
3518  }
3519  }
3520  }
3521 
3522  return result;
3523 }
3524 
3525 
3526 
3527 /******** C_OPS
3528  Return a list of all operators (represented as 3-tuples op(prec,type,atom)).
3529  This function has no arguments.
3530 */
3531 static long c_ops()
3532 {
3533  long success=TRUE;
3534  ptr_psi_term result, g, t;
3535 
3536  g=aim->aaaa_1;
3537  deref_args(g,set_empty);
3538  result=aim->bbbb_1;
3539  t=collect_symbols(op_sel); /* RM: Feb 3 1993 */
3540  push_goal(unify,result,t,NULL);
3541 
3542  return success;
3543 }
3544 
3545 
3546 
3547 
3548 /* PVR 23.2.94 -- Added this to fix c_strip and c_copy_pointer */
3549 /* Make a copy of an attr_list structure, keeping the same leaf pointers */
3551  ptr_node n;
3552 {
3553  ptr_node m;
3554 
3555  if (n==NULL) return NULL;
3556 
3557  m = STACK_ALLOC(node);
3558  m->key = n->key;
3559  m->data = n->data;
3560  m->left = copy_attr_list(n->left);
3561  m->right = copy_attr_list(n->right);
3562  return m;
3563 }
3564 
3565 
3566 /******** C_STRIP
3567  Return the attributes of a psi-term, that is, a psi-term of type @ but with
3568  all the attributes of the argument.
3569 */
3570 static long c_strip()
3571 {
3572  long success=TRUE;
3573  ptr_psi_term arg1,arg2,funct,result;
3574 
3575  funct=aim->aaaa_1;
3576  deref_ptr(funct);
3577  result=aim->bbbb_1;
3578  get_two_args(funct->attr_list,&arg1,&arg2);
3579  if(arg1) {
3580  deref(arg1);
3581  deref_args(funct,set_1);
3582  resid_aim=NULL;
3583  /* PVR 23.2.94 */
3584  merge_unify(&(result->attr_list),copy_attr_list(arg1->attr_list));
3585  }
3586  else
3587  curry();
3588 
3589  return success;
3590 }
3591 
3592 
3593 
3594 
3595 /******** C_SAME_ADDRESS
3596  Return TRUE if two arguments share the same address.
3597 */
3598 static long c_same_address()
3599 {
3600  long success=TRUE;
3601  ptr_psi_term arg1,arg2,funct,result;
3602  REAL val3;
3603  long num3;
3604 
3605  funct=aim->aaaa_1;
3606  deref_ptr(funct);
3607  result=aim->bbbb_1;
3608  get_two_args(funct->attr_list,&arg1,&arg2);
3609 
3610  if (arg1 && arg2) {
3611  success=get_bool_value(result,&val3,&num3);
3612  resid_aim=NULL;
3613  deref(arg1);
3614  deref(arg2);
3615  deref_args(funct,set_1_2);
3616 
3617  if (num3) {
3618  if (val3)
3619  push_goal(unify,arg1,arg2,NULL);
3620  else
3621  success=(arg1!=arg2);
3622  }
3623  else
3624  if (arg1==arg2)
3625  unify_bool_result(result,TRUE);
3626  else
3627  unify_bool_result(result,FALSE);
3628  }
3629  else
3630  curry();
3631 
3632  return success;
3633 }
3634 
3635 
3636 
3637 /******** C_DIFF_ADDRESS
3638  Return TRUE if two arguments have different addresses.
3639 */
3640 static long c_diff_address()
3641 {
3642  long success=TRUE;
3643  ptr_psi_term arg1,arg2,funct,result;
3644  REAL val3;
3645  long num3;
3646 
3647  funct=aim->aaaa_1;
3648  deref_ptr(funct);
3649  result=aim->bbbb_1;
3650  get_two_args(funct->attr_list,&arg1,&arg2);
3651 
3652  if (arg1 && arg2) {
3653  success=get_bool_value(result,&val3,&num3);
3654  resid_aim=NULL;
3655  deref(arg1);
3656  deref(arg2);
3657  deref_args(funct,set_1_2);
3658 
3659  if (num3) {
3660  if (val3)
3661  push_goal(unify,arg1,arg2,NULL);
3662  else
3663  success=(arg1==arg2);
3664  }
3665  else
3666  if (arg1==arg2)
3667  unify_bool_result(result,FALSE);
3668  else
3669  unify_bool_result(result,TRUE);
3670  }
3671  else
3672  curry();
3673 
3674  return success;
3675 }
3676 
3677 
3678 
3679 
3680 /******** C_EVAL
3681  Evaluate an expression and return its value.
3682 */
3683 static long c_eval()
3684 {
3685  long success=TRUE;
3686  ptr_psi_term arg1, copy_arg1, arg2, funct, result;
3687 
3688  funct = aim->aaaa_1;
3689  deref_ptr(funct);
3690  result = aim->bbbb_1;
3691  deref(result);
3692  get_two_args(funct->attr_list, &arg1, &arg2);
3693  if (arg1) {
3694  deref(arg1);
3695  deref_args(funct,set_1);
3696  assert((unsigned long)(arg1->type)!=4);
3697  clear_copy();
3698  copy_arg1 = eval_copy(arg1,STACK);
3699  resid_aim = NULL;
3700  push_goal(unify,copy_arg1,result,NULL);
3701  (void)i_check_out(copy_arg1);
3702  } else
3703  curry();
3704 
3705  return success;
3706 }
3707 
3708 
3709 
3710 
3711 /******** C_EVAL_INPLACE
3712  Evaluate an expression and return its value.
3713 */
3714 static long c_eval_inplace()
3715 {
3716  long success=TRUE;
3717  ptr_psi_term arg1,/* copy_arg1, */ arg2, funct, result;
3718 
3719  funct = aim->aaaa_1;
3720  deref_ptr(funct);
3721  result = aim->bbbb_1;
3722  deref(result);
3723  get_two_args(funct->attr_list, &arg1, &arg2);
3724  if (arg1) {
3725  deref(arg1);
3726  deref_args(funct,set_1);
3727  resid_aim = NULL;
3728  mark_eval(arg1);
3729  push_goal(unify,arg1,result,NULL);
3730  (void)i_check_out(arg1);
3731  } else
3732  curry();
3733 
3734  return success;
3735 }
3736 
3737 
3738 
3739 
3740 /******** C_QUOTE
3741  Quote an expression, i.e. do not evaluate it but mark it as completely
3742  evaluated.
3743  This works if the function is declared as non_strict.
3744 */
3745 static long c_quote()
3746 {
3747  long success=TRUE;
3748  ptr_psi_term arg1,arg2,funct,result;
3749 
3750  funct = aim->aaaa_1;
3751  deref_ptr(funct);
3752  result = aim->bbbb_1;
3753  deref(result);
3754  get_two_args(funct->attr_list, &arg1, &arg2);
3755  if (arg1) {
3756  push_goal(unify,arg1,result,NULL);
3757  } else
3758  curry();
3759 
3760  return success;
3761 }
3762 
3763 
3764 
3765 /******** C_SPLIT_DOUBLE
3766  Split a double into two 32-bit words.
3767 */
3768 
3769 static long c_split_double()
3770 {
3771  long success=FALSE;
3772  ptr_psi_term arg1,arg2,funct,result;
3773  long n;
3774  union {
3775  double d;
3776  struct {
3777  int hi;
3778  int lo;
3779  } w2;
3780  }hack;
3781  double hi,lo;
3782  long n1,n2;
3783 
3784  funct = aim->aaaa_1;
3785  deref_ptr(funct);
3786  result=aim->bbbb_1;
3787 
3788  get_two_args(funct->attr_list, &arg1, &arg2);
3789  if(arg1 && arg2) {
3790  deref_ptr(arg1);
3791  deref_ptr(arg2);
3792  deref_ptr(result);
3793  if(get_real_value(result,(REAL *)&(hack.d),&n) &&
3794  get_real_value(arg1 ,(REAL *)&hi ,&n1) &&
3795  get_real_value(arg2 ,(REAL *)&lo ,&n2)) {
3796 
3797 
3798  if(n) {
3799 
3800  (void)unify_real_result(arg1,(REAL)hack.w2.hi);
3801  (void)unify_real_result(arg2,(REAL)hack.w2.lo);
3802  success=TRUE;
3803  }
3804  else
3805  if(n1 && n2) {
3806 
3807  hack.w2.hi=(int)hi;
3808  hack.w2.lo=(int)lo;
3809  (void)unify_real_result(result,hack.d);
3810  success=TRUE;
3811  }
3812  else {
3813 
3814  residuate(result);
3815  residuate2(arg1,arg2);
3816  }
3817  }
3818  else
3819  Errorline("non-numeric arguments in %P\n",funct);
3820  }
3821  else
3822  curry();
3823 
3824  return success;
3825 }
3826 
3827 
3828 
3829 /******** C_STRING_ADDRESS
3830  Return the address of a string.
3831 */
3832 
3833 static long c_string_address()
3834 {
3835  long success=FALSE;
3836  ptr_psi_term arg1,arg2,funct,result,t;
3837  REAL val;
3838  long num;
3839  long smaller;
3840 
3841 
3842  funct = aim->aaaa_1;
3843  deref_ptr(funct);
3844  result=aim->bbbb_1;
3845 
3846  get_two_args(funct->attr_list, &arg1, &arg2);
3847  if(arg1) {
3848  deref_ptr(arg1);
3849  deref_ptr(result);
3850  success=matches(arg1->type,quoted_string,&smaller);
3851  if (success) {
3852  if (arg1->value_3) {
3853  (void)unify_real_result(result,(REAL)(long)(arg1->value_3));
3854  }
3855  else {
3856  if((success=get_real_value(result,&val,&num))) {
3857  if(num) {
3858  t=stack_psi_term(4);
3859  t->type=quoted_string;
3860  t->value_3=(GENERIC)&val; // changed to addr djd
3861  push_goal(unify,t,arg1,NULL);
3862  }
3863  else
3864  residuate2(arg1,result);
3865 
3866  }
3867  else
3868  Errorline("result is not a real in %P\n",funct);
3869  }
3870  }
3871  else
3872  Errorline("argument is not a string in %P\n",funct);
3873  }
3874  else
3875  curry();
3876 
3877  return success;
3878 }
3879 
3880 
3881 
3882 /******** C_CHDIR
3883  Change the current working directory
3884 */
3885 
3886 static long c_chdir()
3887 {
3888  long success=FALSE;
3889  ptr_psi_term arg1,arg2,funct; // result, t;
3890  // double val;
3891  // int num;
3892  long smaller;
3893 
3894 
3895  funct = aim->aaaa_1;
3896  deref_ptr(funct);
3897 
3898  get_two_args(funct->attr_list, &arg1, &arg2);
3899  if(arg1) {
3900  deref_ptr(arg1);
3901  if(matches(arg1->type,quoted_string,&smaller) && arg1->value_3)
3902  success=!chdir(expand_file_name((char *)arg1->value_3));
3903  else
3904  Errorline("bad argument in %P\n",funct);
3905  }
3906  else
3907  Errorline("argument missing in %P\n",funct);
3908 
3909  return success;
3910 }
3911 
3912 
3913 
3914 /******** C_CALL_ONCE
3915  Prove a predicate, return true or false if it succeeds or fails.
3916  An implicit cut is performed: only only solution is given.
3917 */
3918 #if 0 /* DENYS Jan 25 1995 */
3919 static long c_call_once()
3920 {
3921  long success=TRUE;
3922  ptr_psi_term arg1,arg2,funct,result,other;
3923  ptr_choice_point cutpt;
3924 
3925  funct=aim->aaaa_1;
3926  deref_ptr(funct);
3927  result=aim->bbbb_1;
3928  get_two_args(funct->attr_list,&arg1,&arg2);
3929  if (arg1) {
3930  deref_ptr(arg1);
3931  deref_args(funct,set_1);
3932  if(arg1->type==top)
3933  residuate(arg1);
3934  else
3935  if(FALSE /*arg1->type->type!=predicate*/) {
3936  success=FALSE;
3937  Errorline("argument of %P should be a predicate.\n",funct);
3938  }
3939  else {
3940  resid_aim=NULL;
3941  cutpt=choice_stack;
3942 
3943  /* Result is FALSE */
3944  other=stack_psi_term(0);
3945  other->type=lf_false;
3946 
3947  push_choice_point(unify,result,other,NULL);
3948 
3949  /* Result is TRUE */
3950  other=stack_psi_term(0);
3951  other->type=lf_true;
3952 
3953  push_goal(unify,result,other,NULL);
3954  push_goal(eval_cut,other,cutpt,NULL);
3955  push_goal(prove,arg1,DEFRULES,NULL);
3956  }
3957  }
3958  else
3959  curry();
3960 
3961  return success;
3962 }
3963 #endif
3964 
3965 
3966 
3967 /******** C_CALL
3968  Prove a predicate, return true or false if it succeeds or fails.
3969  No implicit cut is performed.
3970 */
3971 static long c_call()
3972 {
3973  long success=TRUE;
3974  ptr_psi_term arg1,arg2,funct,result,other;
3975  ptr_choice_point cutpt;
3976 
3977  funct=aim->aaaa_1;
3978  deref_ptr(funct);
3979  result=aim->bbbb_1;
3980  get_two_args(funct->attr_list,&arg1,&arg2);
3981  if (arg1) {
3982  deref_ptr(arg1);
3983  deref_args(funct,set_1);
3984  if(arg1->type==top)
3985  residuate(arg1);
3986  else
3987  if(FALSE /*arg1->type->type_def!=predicate*/) {
3988  success=FALSE;
3989  Errorline("argument of %P should be a predicate.\n",funct);
3990  }
3991  else {
3992  resid_aim=NULL;
3993  cutpt=choice_stack;
3994 
3995  /* Result is FALSE */
3996  other=stack_psi_term(0);
3997  other->type=lf_false;
3998 
3999  push_choice_point(unify,result,other,NULL);
4000 
4001  /* Result is TRUE */
4002  other=stack_psi_term(0);
4003  other->type=lf_true;
4004 
4005  push_goal(unify,result,other,NULL);
4007  }
4008  }
4009  else
4010  curry();
4011 
4012  return success;
4013 }
4014 
4015 
4016 
4017 /******** C_BK_ASSIGN()
4018  This implements backtrackable assignment.
4019 */
4020 static long c_bk_assign()
4021 {
4022  long success=FALSE;
4023  ptr_psi_term arg1,arg2,g;
4024 
4025  g=aim->aaaa_1;
4026  deref_ptr(g);
4027  get_two_args(g->attr_list,&arg1,&arg2);
4028  if (arg1 && arg2) {
4029  success=TRUE;
4030  deref(arg1);
4031  deref_rec(arg2); /* 17.9 */
4032  /* deref(arg2); 17.9 */
4033  deref_args(g,set_1_2);
4034  if (arg1 != arg2) {
4035 
4036  /* RM: Mar 10 1993 */
4037  if((GENERIC)arg1>=heap_pointer) {
4038  Errorline("cannot use '<-' on persistent value in %P\n",g);
4039  return c_abort();
4040  }
4041 
4042 
4043 #ifdef TS
4044  if (!trail_condition(arg1)) {
4045  /* If no trail, then can safely overwrite the psi-term */
4046  release_resid_notrail(arg1);
4047  *arg1 = *arg2;
4048  push_psi_ptr_value(arg2,(GENERIC *)&(arg2->coref)); /* 14.12 */
4049  arg2->coref=arg1; /* 14.12 */
4050  }
4051  else {
4052  push_psi_ptr_value(arg1,(GENERIC *)&(arg1->coref));
4053  arg1->coref=arg2;
4054  release_resid(arg1);
4055  }
4056 #else
4057  push_psi_ptr_value(arg1,(GENERIC *)&(arg1->coref));
4058  arg1->coref=arg2;
4059  release_resid(arg1);
4060 #endif
4061  }
4062  }
4063  else
4064  Errorline("argument missing in %P.\n",g);
4065 
4066  return success;
4067 }
4068 
4069 
4070 
4071 
4072 /******** C_ASSIGN()
4073  This implements non-backtrackable assignment.
4074  It doesn't work because backtrackable unifications can have been made before
4075  this assignment was reached. It is complicated by the fact that the assigned
4076  term has to be copied into the heap as it becomes a permanent object.
4077 */
4078 static long c_assign()
4079 {
4080  long success=FALSE;
4081  ptr_psi_term arg1,arg2,g; // perm ,smallest;
4082 
4083  g=aim->aaaa_1;
4084  deref_ptr(g);
4085  get_two_args(g->attr_list,&arg1,&arg2);
4086  if (arg1 && arg2) {
4087  success=TRUE;
4088  deref_ptr(arg1);
4089  deref_rec(arg2); /* 17.9 */
4090  /* deref(arg2); 17.9 */
4091  deref_args(g,set_1_2);
4092  if ((GENERIC)arg1<heap_pointer || arg1!=arg2) {
4093  clear_copy();
4094  *arg1 = *exact_copy(arg2,HEAP);
4095  }
4096  }
4097  else
4098  Errorline("argument missing in %P.\n",g);
4099 
4100  return success;
4101 }
4102 
4103 
4104 
4105 /******** C_GLOBAL_ASSIGN()
4106  This implements non-backtrackable assignment on global variables.
4107 
4108  Closely modelled on 'c_assign', except that pointers to the heap are not
4109  copied again onto the heap.
4110 */
4111 
4112 static long c_global_assign()
4113 {
4114  long success=FALSE;
4115  ptr_psi_term arg1,arg2,g; // ,perm,smallest;
4116  ptr_psi_term new;
4117 
4118  g=aim->aaaa_1;
4119  deref_ptr(g);
4120  get_two_args(g->attr_list,&arg1,&arg2);
4121  if (arg1 && arg2) {
4122  success=TRUE;
4123  deref_rec(arg1);
4124  deref_rec(arg2);
4125  deref_args(g,set_1_2);
4126  if (arg1!=arg2) {
4127 
4128  clear_copy();
4129  new=inc_heap_copy(arg2);
4130 
4131  if((GENERIC)arg1<heap_pointer) {
4132  push_psi_ptr_value(arg1,(GENERIC *)&(arg1->coref));
4133  arg1->coref= new;
4134  }
4135  else {
4136  *arg1= *new; /* Overwrite in-place */
4137  new->coref=arg1;
4138  }
4139  }
4140  }
4141  else
4142  Errorline("argument missing in %P.\n",g);
4143 
4144  return success;
4145 }
4146 
4147 
4148 
4149 /******** C_UNIFY_FUNC
4150  An explicit unify function that curries on its two arguments.
4151 */
4152 static long c_unify_func()
4153 {
4154  long success=TRUE;
4155  ptr_psi_term funct,arg1,arg2,result;
4156 
4157  funct=aim->aaaa_1;
4158  deref_ptr(funct);
4159  get_two_args(funct->attr_list,&arg1,&arg2);
4160  if (arg1 && arg2) {
4161  deref(arg1);
4162  deref(arg2);
4163  deref_args(funct,set_1_2);
4164  result=aim->bbbb_1;
4165  push_goal(unify,arg1,result,NULL);
4166  push_goal(unify,arg1,arg2,NULL);
4167  }
4168  else
4169  curry();
4170 
4171  return success;
4172 }
4173 
4174 
4175 
4176 
4177 /******** C_UNIFY_PRED()
4178  This unifies its two arguments (i.e. implements the predicate A=B).
4179 */
4180 static long c_unify_pred()
4181 {
4182  long success=FALSE;
4183  ptr_psi_term arg1,arg2,g;
4184 
4185  g=aim->aaaa_1;
4186  deref_ptr(g);
4187  get_two_args(g->attr_list,&arg1,&arg2);
4188  if (arg1 && arg2) {
4189  deref_args(g,set_1_2);
4190  success=TRUE;
4191  push_goal(unify,arg1,arg2,NULL);
4192  }
4193  else
4194  Errorline("argument missing in %P.\n",g);
4195 
4196  return success;
4197 }
4198 
4199 
4200 
4201 
4202 /******** C_COPY_POINTER
4203  Make a fresh copy of the input's sort, keeping exactly the same
4204  arguments as before (i.e., copying the sort and feature table but not
4205  the feature values).
4206 */
4207 static long c_copy_pointer() /* PVR: Dec 17 1992 */
4208 {
4209  long success=TRUE;
4210  ptr_psi_term funct,arg1,result,other;
4211 
4212  funct=aim->aaaa_1;
4213  deref_ptr(funct);
4214  get_one_arg(funct->attr_list,&arg1);
4215  if (arg1) {
4216  deref(arg1);
4217  deref_args(funct,set_1);
4218  other=stack_psi_term(4);
4219  other->type=arg1->type;
4220  other->value_3=arg1->value_3;
4221  other->attr_list=copy_attr_list(arg1->attr_list); /* PVR 23.2.94 */
4222  result=aim->bbbb_1;
4223  push_goal(unify,other,result,NULL);
4224  }
4225  else
4226  curry();
4227 
4228  return success;
4229 }
4230 
4231 
4232 
4233 /******** C_COPY_TERM
4234  Make a fresh copy of the input argument, keeping its structure
4235  but with no connections to the input.
4236 */
4237 static long c_copy_term()
4238 {
4239  long success=TRUE;
4240  ptr_psi_term funct,arg1,copy_arg1,result;
4241 
4242  funct=aim->aaaa_1;
4243  deref_ptr(funct);
4244  get_one_arg(funct->attr_list,&arg1);
4245  if (arg1) {
4246  deref(arg1);
4247  deref_args(funct,set_1);
4248  result=aim->bbbb_1;
4249  clear_copy();
4250  copy_arg1=exact_copy(arg1,STACK);
4251  push_goal(unify,copy_arg1,result,NULL);
4252  }
4253  else
4254  curry();
4255 
4256  return success;
4257 }
4258 
4259 
4260 
4261 
4262 /******** C_UNDO
4263  This will prove a goal on backtracking.
4264  This is a completely uninteresting implmentation which is equivalent to:
4265 
4266  undo.
4267  undo(G) :- G.
4268 
4269  The problem is that it can be affected by CUT.
4270  A correct implementation would be very simple:
4271  stack the pair (ADDRESS=NULL, VALUE=GOAL) onto the trail and when undoing
4272  push the goal onto the goal-stack.
4273 */
4274 static long c_undo()
4275 {
4276  long success=TRUE;
4277  ptr_psi_term arg1,arg2,g;
4278 
4279  g=aim->aaaa_1;
4280  deref_ptr(g);
4281  get_two_args(g->attr_list,&arg1,&arg2);
4282  if (arg1) {
4283  deref_args(g,set_1);
4285  }
4286  else {
4287  success=FALSE;
4288  Errorline("argument missing in %P.\n",g);
4289  }
4290 
4291  return success;
4292 }
4293 
4294 
4295 
4296 
4297 /******** C_FREEZE_INNER
4298  This implements the freeze and implies predicates.
4299  For example:
4300 
4301  freeze(g)
4302 
4303  The proof will use matching on the heads of g's definition rather than
4304  unification to prove Goal. An implicit cut is put at the beginning
4305  of each clause body. Body goals are executed in the same way as
4306  without freeze. Essentially, the predicate is called as if it were
4307  a function.
4308 
4309  implies(g)
4310 
4311  The proof will use matching as for freeze, but there is no cut at the
4312  beginning of the clause body & no residuation is done (the clause
4313  fails if its head is not implied by the caller). Essentially, the
4314  predicate is called as before except that matching is used instead
4315  of unification to decide whether to enter a clause.
4316 */
4317 static long c_freeze_inner(freeze_flag)
4318  long freeze_flag;
4319 {
4320  long success=TRUE;
4321  ptr_psi_term arg1,g;
4322  ptr_psi_term head, body;
4323  ptr_pair_list rule;
4324  /* RESID */ ptr_resid_block rb;
4325  ptr_choice_point cutpt;
4326  ptr_psi_term match_date;
4327 
4328  g=aim->aaaa_1;
4329  deref_ptr(g);
4330  get_one_arg(g->attr_list,&arg1);
4331 
4332  if (arg1) {
4333  deref_ptr(arg1);
4334  /* if (!arg1->type->evaluate_args) mark_quote(arg1); 8.9 */ /* 18.2 PVR */
4335  deref_args(g,set_1);
4336  deref_ptr(arg1);
4337 
4338  if (arg1->type->type_def!=(def_type)predicate) {
4339  success=FALSE;
4340  Errorline("the argument %P of freeze must be a predicate.\n",arg1);
4341  /* main_loop_ok=FALSE; 8.9 */
4342  return success;
4343  }
4344  resid_aim=aim;
4345  match_date=(ptr_psi_term)stack_pointer;
4346  cutpt=choice_stack; /* 13.6 */
4347  /* Third argument of freeze's aim is used to keep track of which */
4348  /* clause is being tried in the frozen goal. */
4349  rule=(ptr_pair_list)aim->cccc_1; /* 8.9 */ /* Isn't aim->cccc always NULL? */
4350  resid_vars=NULL;
4351  curried=FALSE;
4352  can_curry=TRUE; /* 8.9 */
4353 
4354  if (!rule) rule=arg1->type->rule; /* 8.9 */
4355  /* if ((unsigned long)rule==DEFRULES) rule=arg1->type->rule; 8.9 */
4356 
4357  if (rule) {
4358  traceline("evaluate frozen predicate %P\n",g);
4359  /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
4360 
4361  if ((unsigned long)rule<=MAX_BUILT_INS) {
4362  success=FALSE; /* 8.9 */
4363  Errorline("the argument %P of freeze must be user-defined.\n",arg1); /* 8.9 */
4364  return success; /* 8.9 */
4365  /* Removed obsolete stuff here 11.9 */
4366  }
4367  else {
4368  while (rule && (rule->aaaa_2==NULL || rule->bbbb_2==NULL)) {
4369  rule=rule->next;
4370  traceline("alternative clause has been retracted\n");
4371  }
4372  if (rule) {
4373  /* RESID */ rb = STACK_ALLOC(resid_block);
4374  /* RESID */ save_resid(rb,match_date);
4375  /* RESID */ /* resid_aim = NULL; */
4376 
4377  clear_copy();
4378  if (TRUE /*arg1->type->evaluate_args 8.9 */)
4379  head=eval_copy(rule->aaaa_2,STACK);
4380  else
4381  head=quote_copy(rule->aaaa_2,STACK);
4382  body=eval_copy(rule->bbbb_2,STACK);
4383  head->status=4;
4384 
4385  if (rule->next)
4386  /* push_choice_point(prove,g,rule->next,NULL); 8.9 */
4388 
4389  push_goal(prove,body,(ptr_psi_term)DEFRULES,NULL);
4390  if (freeze_flag) /* 12.10 */
4391  push_goal(freeze_cut,body,(ptr_psi_term)cutpt,(GENERIC)rb); /* 13.6 */
4392  else
4393  push_goal(implies_cut,body,(ptr_psi_term)cutpt,(GENERIC)rb);
4394  /* RESID */ push_goal(match,arg1,head,(GENERIC)rb);
4395  /* eval_args(head->attr_list); */
4396  }
4397  else {
4398  success=FALSE;
4399  /* resid_aim=NULL; */
4400  }
4401  }
4402  }
4403  else {
4404  success=FALSE;
4405  /* resid_aim=NULL; */
4406  }
4407  resid_aim=NULL;
4408  resid_vars=NULL; /* 22.9 */
4409  }
4410  else {
4411  success=FALSE;
4412  Errorline("goal missing in %P.\n",g);
4413  }
4414 
4415  /* match_date=NULL; */ /* 13.6 */
4416  return success;
4417 }
4418 
4419 
4420 /******** C_FREEZE()
4421  See c_freeze_inner.
4422 */
4423 static long c_freeze()
4424 {
4425  return c_freeze_inner(TRUE);
4426 }
4427 
4428 
4429 /******** C_IMPLIES()
4430  See c_freeze_inner.
4431 */
4432 static long c_implies()
4433 {
4434  return c_freeze_inner(FALSE);
4435 }
4436 
4437 
4438 /* RM: May 6 1993 Changed C_CHAR to return a string */
4439 
4440 /******** C_CHAR
4441  Create a 1 character string from an ASCII code.
4442 */
4443 static long c_char()
4444 
4445 
4446 {
4447  long success=TRUE;
4448  ptr_psi_term arg1,arg2,funct,result;
4449  // long smaller;
4450  // long num1;
4451  // REAL val1;
4452  char *str;
4453 
4454  funct=aim->aaaa_1;
4455  deref_ptr(funct);
4456  result=aim->bbbb_1;
4457  deref(result);
4458 
4459  get_two_args(funct->attr_list,&arg1,&arg2);
4460  if (arg1) {
4461  deref(arg1);
4462  deref_args(funct,set_1);
4463  if (overlap_type(arg1->type,integer)) {
4464  if (arg1->value_3) {
4465  ptr_psi_term t;
4466 
4467  t=stack_psi_term(4);
4468  t->type=quoted_string;
4469  str=(char *)heap_alloc(2);
4470  str[0] = (unsigned char) floor(*(REAL *) arg1->value_3);
4471  str[1] = 0;
4472  t->value_3=(GENERIC)str;
4473 
4474  push_goal(unify,t,result,NULL);
4475  }
4476  else
4477  residuate(arg1);
4478  }
4479  else {
4480  Errorline("argument of %P must be an integer.\n",funct);
4481  success=FALSE;
4482  }
4483  }
4484  else
4485  curry();
4486 
4487  return success;
4488 }
4489 
4490 
4491 
4492 
4493 /******** C_ASCII
4494  Return the Ascii code of the first character of a string or of a
4495  psi-term's name.
4496 */
4497 static long c_ascii()
4498 {
4499  long success=TRUE;
4500  ptr_psi_term arg1,arg2,funct,result;
4501  long smaller;
4502  // long num1;
4503  // REAL val1;
4504 
4505  funct=aim->aaaa_1;
4506  deref_ptr(funct);
4507  result=aim->bbbb_1;
4508  deref(result);
4509 
4510  /* success=get_real_value(result,&val1,&num1); */
4511  /* if (success) { */
4512  get_two_args(funct->attr_list,&arg1,&arg2);
4513  if (arg1) {
4514  deref(arg1);
4515  deref_args(funct,set_1);
4516  success=matches(arg1->type,quoted_string,&smaller);
4517  if (success) {
4518  if (arg1->value_3) {
4519  (void) unify_real_result(result,(REAL)(*((unsigned char *)arg1->value_3)));
4520  }
4521  else
4522  residuate(arg1);
4523  }
4524  else {/* RM: Feb 18 1994 */
4525  success=FALSE;
4526  Errorline("String argument expected in '%P'\n",funct);
4527  }
4528  /*
4529  else {
4530  success=TRUE;
4531  unify_real_result(result,(REAL)(*((unsigned char *)arg1->type->keyword->symbol)));
4532  }
4533  */
4534  }
4535  else
4536  curry();
4537  /* } */
4538 
4539  return success;
4540 }
4541 
4542 
4543 
4544 /******** C_STRING2PSI(P)
4545  Convert a string to a psi-term whose name is the string's value.
4546 */
4547 static long c_string2psi()
4548 {
4549  long success=TRUE;
4550  ptr_psi_term arg1,arg2, /* arg3, */ funct,result,t;
4551  // long smaller;
4552  ptr_module mod=NULL; /* RM: Mar 11 1993 */
4553  ptr_module save_current; /* RM: Mar 12 1993 */
4554 
4555 
4556  funct=aim->aaaa_1;
4557  deref_ptr(funct);
4558  result=aim->bbbb_1;
4559  deref(result);
4560 
4561  get_two_args(funct->attr_list,&arg1,&arg2);
4562  if(arg1)
4563  deref(arg1);
4564  if(arg2)
4565  deref(arg2);
4566  deref_args(funct,set_1_2);
4567 
4568  if (arg1) {
4569  success=overlap_type(arg1->type,quoted_string);
4570  if(success) {
4571 
4572  /* RM: Mar 11 1993 */
4573  if(arg2)
4574  success=get_module(arg2,&mod);
4575 
4576  if (success) {
4577  if(!arg1->value_3)
4578  residuate(arg1);
4579  else {
4580  t=stack_psi_term(4);
4581  save_current=current_module;
4582  if(mod)
4583  current_module=mod;
4584  t->type=update_symbol(mod,(char *)arg1->value_3);
4585  current_module=save_current;
4586  if(t->type==error_psi_term->type)
4587  success=FALSE;
4588  else
4589  push_goal(unify,t,result,NULL);
4590  }
4591  }
4592  }
4593  else {
4594  success=FALSE;
4595  warningline("argument of '%P' is not a string.\n",funct);
4596  /* report_warning(funct,"argument is not a string"); 9.9 */
4597  }
4598  }
4599  else
4600  curry();
4601 
4602  if(!success)
4603  Errorline("error occurred in '%P'\n",funct);
4604 
4605  return success;
4606 }
4607 
4608 
4609 
4610 /******** C_PSI2STRING(P)
4611  Convert a psi-term's name into a string with the name as value.
4612 */
4613 static long c_psi2string()
4614 {
4615  long success=TRUE;
4616  ptr_psi_term arg1, /* arg3, */ funct,result,t;
4617  char buf[100]; /* RM: Mar 10 1993 */
4618 
4619  funct=aim->aaaa_1;
4620  deref_ptr(funct);
4621  result=aim->bbbb_1;
4622  deref(result);
4623 
4624  get_one_arg(funct->attr_list,&arg1);
4625  if (arg1) {
4626  deref(arg1);
4627  deref_args(funct,set_1);
4628  t=stack_psi_term(0);
4629  t->type=quoted_string;
4630 
4631  /* RM: Mar 10 1993 */
4632  if(arg1->value_3 && sub_type(arg1->type,real)) {
4633  (void)snprintf(buf,100,"%g", *((double *)(arg1->value_3)));
4634  t->value_3=(GENERIC)heap_copy_string(buf);
4635  }
4636  else
4637  if(arg1->value_3 && sub_type(arg1->type,quoted_string)) {
4638  t->value_3=(GENERIC)heap_copy_string((char *)arg1->value_3);
4639  }
4640  else
4642 
4643  push_goal(unify,t,result,NULL);
4644  }
4645  else
4646  curry();
4647 
4648  return success;
4649 }
4650 
4651 
4652 
4653 /******** C_INT2STRING(P)
4654  Convert an integer psi-term into a string representing its value.
4655 */
4656 static long c_int2string()
4657 {
4658  char val[STRLEN]; /* Big enough for a _long_ number */
4659  long success=TRUE,i;
4660  ptr_psi_term arg1, /* arg3, */ funct,result,t;
4661  REAL the_int,next,neg;
4662 
4663  funct=aim->aaaa_1;
4664  deref_ptr(funct);
4665  result=aim->bbbb_1;
4666  deref(result);
4667 
4668  get_one_arg(funct->attr_list,&arg1);
4669  if (arg1) {
4670  deref(arg1);
4671  deref_args(funct,set_1);
4672  if (overlap_type(arg1->type,integer)) {
4673  if (arg1->value_3) {
4674  the_int = *(REAL *)arg1->value_3;
4675 
4676  if (the_int!=floor(the_int)) return FALSE;
4677 
4678  neg = (the_int<0.0);
4679  if (neg) the_int = -the_int;
4680  i=STRLEN;
4681  i--;
4682  val[i]=0;
4683  do {
4684  i--;
4685  if (i<=0) {
4686  Errorline("internal buffer too small for int2str(%P).\n",arg1);
4687  return FALSE;
4688  }
4689  next = floor(the_int/10);
4690  val[i]= '0' + (unsigned long) (the_int-next*10);
4691  the_int = next;
4692  } while (the_int);
4693 
4694  if (neg) { i--; val[i]='-'; }
4695  t=stack_psi_term(0);
4696  t->type=quoted_string;
4697  t->value_3=(GENERIC)heap_copy_string(&val[i]);
4698  push_goal(unify,t,result,NULL);
4699  }
4700  else
4701  residuate(arg1);
4702  }
4703  else
4704  success=FALSE;
4705  }
4706  else
4707  curry();
4708 
4709  return success;
4710 }
4711 
4712 
4713 
4714 /******** C_SUCH_THAT
4715  This implements 'Value | Goal'.
4716  First it unifies Value with the result, then it proves Goal.
4717 
4718  This routine is different than the straight-forward implementation in Life
4719  which would have been: "V|G => cond(G,V,{})" because
4720  V is evaluated and unified before G is proved.
4721 */
4722 static long c_such_that()
4723 {
4724  long success=TRUE;
4725  ptr_psi_term arg1,arg2,funct,result;
4726 
4727  funct=aim->aaaa_1;
4728  deref_ptr(funct);
4729  result=aim->bbbb_1;
4730  get_two_args(funct->attr_list,&arg1,&arg2);
4731  if (arg1 && arg2) {
4732  deref_ptr(arg1);
4733  deref_ptr(arg2);
4734  deref_args(funct,set_1_2);
4735  resid_aim=NULL;
4737  push_goal(unify,arg1,result,NULL);
4738  (void)i_check_out(arg1);
4739  }
4740  else
4741  curry();
4742 
4743  return success;
4744 }
4745 
4746 
4747 
4748 /* Return an attr_list with one argument */
4750 {
4751  ptr_node n;
4752 
4753  n = STACK_ALLOC(node);
4754  n->key = one;
4755  n->data = NULL; /* To be filled in later */
4756  n->left = NULL;
4757  n->right = NULL;
4758 
4759  return n;
4760 }
4761 
4762 
4763 /* Return a psi term with one or two args, and the addresses of the args */
4764 ptr_psi_term new_psi_term(numargs, typ, a1, a2)
4765  long numargs;
4766  ptr_definition typ;
4767  ptr_psi_term **a1, **a2;
4768 {
4769  ptr_psi_term t;
4770  ptr_node n1, n2;
4771 
4772  if (numargs==2) {
4773  n2 = STACK_ALLOC(node);
4774  n2->key = two;
4775  *a2 = (ptr_psi_term *) &(n2->data);
4776  n2->left = NULL;
4777  n2->right = NULL;
4778  }
4779  else
4780  n2=NULL;
4781 
4782  n1 = STACK_ALLOC(node);
4783  n1->key = one;
4784  *a1 = (ptr_psi_term *) &(n1->data);
4785  n1->left = NULL;
4786  n1->right = n2;
4787 
4788  t=stack_psi_term(4);
4789  t->type = typ;
4790  t->attr_list = n1;
4791 
4792  return t;
4793 }
4794 
4795 
4796 /* Return TRUE iff there are some rules r */
4797 /* This is true for a user-defined function or predicate with a definition, */
4798 /* and for a type with constraints. */
4799 long has_rules(r)
4800  ptr_pair_list r;
4801 {
4802  if (r==NULL) return FALSE;
4803  while (r) {
4804  if (r->aaaa_2!=NULL) return TRUE;
4805  r=r->next;
4806  }
4807  return FALSE;
4808 }
4809 
4810 /* Return TRUE if rules r are for a built-in */
4812  ptr_pair_list r;
4813 {
4814  return ((unsigned long)r>0 && (unsigned long)r<MAX_BUILT_INS);
4815 }
4816 
4817 
4818 /* List the characteristics (delay_check, dynamic/static, non_strict) */
4819 /* in such a way that they can be immediately read in. */
4821  ptr_psi_term t;
4822 {
4823  ptr_definition d = t->type;
4824  ptr_pair_list r = t->type->rule;
4825  long prflag=FALSE;
4826 
4827  if (t->type->type_def==(def_type)type_it) {
4828  if (!d->always_check) {
4829  if (is_built_in(r)) fprintf(output_stream,"%% ");
4830  fprintf(output_stream,"delay_check(");
4831  display_psi_stream(t);
4832  fprintf(output_stream,")?\n");
4833  prflag=TRUE;
4834  }
4835  } else {
4836  if (!d->protected) {
4837  if (is_built_in(r)) fprintf(output_stream,"%% ");
4838  fprintf(output_stream,"%s(",(d->protected?"static":"dynamic"));
4839  display_psi_stream(t);
4840  fprintf(output_stream,")?\n");
4841  prflag=TRUE;
4842  }
4843  }
4844  if (!d->evaluate_args) {
4845  if (is_built_in(r)) fprintf(output_stream,"%% ");
4846  fprintf(output_stream,"non_strict(");
4847  display_psi_stream(t);
4848  fprintf(output_stream,")?\n");
4849  prflag=TRUE;
4850  }
4851  /* if (prflag) fprintf(output_stream,"\n"); */
4852 }
4853 
4854 
4855 /******** C_LISTING
4856  List the definition of a predicate or a function, and the own constraints
4857  of a type (i.e. the non-inherited constraints).
4858 */
4859 static long c_listing()
4860 {
4861  long success=TRUE;
4862  ptr_psi_term arg1,arg2,g;
4863  def_type fp;
4864  ptr_pair_list r;
4865  ptr_node n;
4866  ptr_psi_term t, t2, *a1, *a2, *a3;
4867  char *s1,*s2;
4868 
4869  g=aim->aaaa_1;
4870  deref_ptr(g);
4871  get_two_args(g->attr_list,&arg1,&arg2);
4872  if (arg1) {
4873  deref_ptr(arg1);
4874  list_special(arg1);
4875  fp=arg1->type->type_def;
4876  r=arg1->type->rule;
4877  if (is_built_in(r) || !has_rules(r)) {
4878 
4879  if (is_built_in(r)) {
4880  s1="built-in ";
4881  s2="";
4882  }
4883  else {
4884  s1="user-defined ";
4885  s2=" with an empty definition";
4886  }
4887  switch ((long)fp) {
4888  case (long)function_it:
4889  fprintf(output_stream,"%% '%s' is a %sfunction%s.\n",
4890  arg1->type->keyword->symbol,s1,s2);
4891  break;
4892  case (long)predicate:
4893  fprintf(output_stream,"%% '%s' is a %spredicate%s.\n",
4894  arg1->type->keyword->symbol,s1,s2);
4895  break;
4896  case (long)type_it:
4897  if (arg1->value_3) {
4898  fprintf(output_stream,"%% ");
4899  if (arg1->type!=quoted_string) fprintf(output_stream,"'");
4900  display_psi_stream(arg1);
4901  if (arg1->type!=quoted_string) fprintf(output_stream,"'");
4902  fprintf(output_stream," is a value of sort '%s'.\n",
4903  arg1->type->keyword->symbol);
4904  }
4905  break;
4906 
4907  case (long)global: /* RM: Feb 9 1993 */
4908  fprintf(output_stream,"%% ");
4909  outputline("'%s' is a %sglobal variable worth %P.\n",
4910  arg1->type->keyword->symbol,
4911  s1,
4912  arg1->type->global_value);
4913  break;
4914 
4915 #ifdef CLIFE
4916  case (long)block: /* AA: Mar 10 1993 */
4917  fprintf(output_stream,"%% '%s' is a %block.\n",
4918  arg1->type->keyword->symbol,"","");
4919 #endif
4920 
4921  default:
4922  fprintf(output_stream,"%% '%s' is undefined.\n", arg1->type->keyword->symbol);
4923  }
4924  }
4925  else {
4926  if (fp==(def_type)type_it || fp==(def_type)function_it || fp==(def_type)predicate) {
4927  n = one_attr();
4928  if (fp==(def_type)function_it)
4929  t = new_psi_term(2, funcsym, &a1, &a2);
4930  else if (fp==(def_type)predicate)
4931  t = new_psi_term(2, predsym, &a1, &a2);
4932  else { /* fp==type */
4933  t = new_psi_term(1, typesym, &a3, &a2); /* a2 is a dummy */
4934  t2 = new_psi_term(2, such_that, &a1, &a2);
4935  }
4936  n->data = (GENERIC) t;
4937  while (r) {
4938  *a1 = r->aaaa_2; /* Func, pred, or type */
4939  *a2 = r->bbbb_2;
4940  if (r->aaaa_2) {
4941  /* Handle an attribute constraint with no predicate: */
4942  if (fp==(def_type)type_it) { if (r->bbbb_2==NULL) *a3 = r->aaaa_2; else *a3 = t2; }
4943  listing_pred_write(n, (fp==(def_type)function_it)||(fp==(def_type)type_it));
4944  fprintf(output_stream,".\n");
4945  }
4946  r = r->next;
4947  }
4948  /* fprintf(output_stream,"\n"); */
4949  /* fflush(output_stream); */
4950  }
4951  else {
4952  success=FALSE;
4953  Errorline("argument of %P must be a predicate, function, or sort.\n",g);
4954  }
4955  }
4956  }
4957  else {
4958  success=FALSE;
4959  Errorline("argument missing in %P.\n",g);
4960  }
4961 
4962  return success;
4963 }
4964 
4965 
4966 
4967 /******** C_print_codes
4968  Print the codes of all the sorts.
4969 */
4970 static long c_print_codes()
4971 {
4972  ptr_psi_term t;
4973 
4974  t=aim->aaaa_1;
4975  deref_args(t,set_empty);
4976  outputline("There are %d sorts.\n",type_count);
4977  print_codes();
4978  return TRUE;
4979 }
4980 
4981 
4982 
4983 /*********************** TEMPLATES FOR NEW PREDICATES AND FUNCTIONS *******/
4984 
4985 
4986 
4987 /******** C_PRED
4988  Template for C built-in predicates.
4989 */
4990 static long c_pred()
4991 {
4992  long success=TRUE;
4993  ptr_psi_term arg1,arg2,g;
4994 
4995  g=aim->aaaa_1;
4996  deref_ptr(g);
4997  get_two_args(g->attr_list,&arg1,&arg2);
4998  if (arg1 && arg2) {
4999  deref_args(g,set_1_2);
5000  }
5001  else {
5002  success=FALSE;
5003  Errorline("argument(s) missing in %P.\n",g);
5004  }
5005 
5006  return success;
5007 }
5008 
5009 
5010 
5011 /******** C_FUNCT
5012  Template for C built-in functions.
5013 */
5014 static long c_funct()
5015 {
5016  long success=TRUE;
5017  ptr_psi_term arg1,arg2,funct;
5018 
5019 
5020  funct=aim->aaaa_1;
5021  deref_ptr(funct);
5022 
5023  get_two_args(funct->attr_list,&arg1,&arg2);
5024 
5025  if (arg1 && arg2) {
5026  deref_args(funct,set_1_2);
5027  }
5028  else
5029  curry();
5030 
5031  return success;
5032 }
5033 
5034 
5035 
5036 /******************************************************************************
5037 
5038  Here are the routines which allow a new built_in type, predicate or function
5039  to be declared.
5040 
5041 ****************************************************************************/
5042 
5043 
5044 
5045 /******** NEW_BUILT_IN(m,s,t,r)
5046  Add a new built-in predicate or function.
5047  Used also in x_pred.c
5048 
5049  M=module.
5050  S=string.
5051  T=type (function or predicate).
5052  R=address of C routine to call.
5053 */
5054 void new_built_in(m,s,t,r)
5055  ptr_module m;
5056  char *s;
5057  def_type t;
5058  long (*r)();
5059 {
5060  ptr_definition d;
5061  if (built_in_index >= MAX_BUILT_INS) {
5062  fprintf(stderr,"Too many primitives, increase MAX_BUILT_INS in extern.h\n");
5063  exit(EXIT_FAILURE);
5064  }
5065 
5066  if(m!=current_module) /* RM: Jan 13 1993 */
5067  (void)set_current_module(m);
5068 
5069  d=update_symbol(m,s); /* RM: Jan 8 1993 */
5070  d->type_def=t;
5071  built_in_index++;
5074 }
5075 
5076 
5077 
5078 /******** OP_DECLARE(p,t,s)
5079  Declare that string S is an operator of precedence P and of type T where
5080  T=xf, fx, yf, fy, xfx etc...
5081 */
5082 static void op_declare(p,t,s)
5083  long p;
5084  operator t;
5085  char *s;
5086 {
5087  ptr_definition d;
5088  ptr_operator_data od;
5089 
5090  if (p>MAX_PRECEDENCE || p<0) {
5091  Errorline("operator precedence must be in the range 0..%d.\n",
5092  MAX_PRECEDENCE);
5093  return;
5094  }
5095  d=update_symbol(NULL,s);
5096 
5097  od= (ptr_operator_data) heap_alloc (sizeof(operator_data));
5098  /* od= (ptr_operator_data) malloc (sizeof(operator_data)); 12.6 */
5099 
5100  od->precedence=p;
5101  od->type=t;
5102  od->next=d->op_data;
5103  d->op_data=od;
5104 }
5105 
5106 
5107 
5108 /******** DECLARE_OPERATOR(t)
5109  Declare a new operator or change a pre-existing one.
5110 
5111  For example: '*op*'(3,xfx,+)?
5112  T is the OP declaration.
5113 */
5115  ptr_psi_term t;
5116 {
5117  ptr_psi_term prec,type,atom;
5118  ptr_node n;
5119  char *s;
5120  long p;
5121  operator kind=nop;
5122  long success=FALSE;
5123 
5124  deref_ptr(t);
5125  n=t->attr_list;
5126  get_two_args(n,&prec,&type);
5127  n=find(FEATCMP,three,n);
5128  if (n && prec && type) {
5129  atom=(ptr_psi_term )n->data;
5130  deref_ptr(prec);
5131  deref_ptr(type);
5132  deref_ptr(atom);
5133  if (!atom->value_3) {
5134  s=atom->type->keyword->symbol;
5135  if (sub_type(prec->type,integer) && prec->value_3) { /* 10.8 */
5136  p = * (REAL *)prec->value_3;
5137  if (p>0 && p<=MAX_PRECEDENCE) {
5138 
5139  if (type->type == xf_sym) kind=xf;
5140  else if (type->type == yf_sym) kind=yf;
5141  else if (type->type == fx_sym) kind=fx;
5142  else if (type->type == fy_sym) kind=fy;
5143  else if (type->type == xfx_sym) kind=xfx;
5144  else if (type->type == xfy_sym) kind=xfy;
5145  else if (type->type == yfx_sym) kind=yfx;
5146  else
5147  Errorline("bad operator kind '%s'.\n",type->type->keyword->symbol);
5148 
5149  if (kind!=nop) {
5150  op_declare(p,kind,s);
5151  success=TRUE;
5152  }
5153  }
5154  else
5155  Errorline("precedence must range from 1 to 1200 in %P.\n",t);
5156  }
5157  else
5158  Errorline("precedence must be a positive integer in %P.\n",t);
5159  }
5160  else
5161  Errorline("numbers or strings may not be operators in %P.\n",t);
5162  }
5163  else
5164  Errorline("argument missing in %P.\n",t);
5165 
5166  return success;
5167 }
5168 
5169 
5170 
5171 char *str_conc(s1,s2)
5172  char *s1, *s2;
5173 {
5174  char *result;
5175 
5176  result=(char *)heap_alloc(strlen(s1)+strlen(s2)+1);
5177  sprintf(result,"%s%s",s1,s2);
5178 
5179  return result;
5180 }
5181 
5182 
5183 
5184 char *sub_str(s,p,n)
5185  char *s;
5186  long p;
5187  long n;
5188 {
5189  char *result;
5190  long i;
5191  long l;
5192 
5193  l=strlen(s);
5194  if(p>l || p<0 || n<0)
5195  n=0;
5196  else
5197  if(p+n-1>l)
5198  n=l-p+1;
5199 
5200  result=(char *)heap_alloc(n+1);
5201  for(i=0;i<n;i++)
5202  *(result+i)= *(s+p+i-1);
5203 
5204  *(result+n)=0;
5205 
5206  return result;
5207 }
5208 
5209 
5210 
5211 long append_files(s1,s2)
5212  char *s1, *s2;
5213 {
5214  FILE *f1;
5215  FILE *f2;
5216  long result=FALSE;
5217 
5218  f1=fopen(s1,"a");
5219  if(f1) {
5220  f2=fopen(s2,"r");
5221  if(f2) {
5222  while(!feof(f2))
5223  (void)fputc(fgetc(f2),f1);
5224  (void)fclose(f2);
5225  (void)fclose(f1);
5226  result=TRUE;
5227  }
5228  else
5229  Errorline("couldn't open \"%s\"\n",f2);
5230  /* printf("*** Error: couldn't open \"%s\"\n",f2); PVR 14.9.93 */
5231  }
5232  else
5233  Errorline("couldn't open \"%s\"\n",f1);
5234  /* printf("*** Error: couldn't open \"%s\"\n",f1); PVR 14.9.93 */
5235 
5236  return result;
5237 }
5238 
5239 
5240 
5241 
5242 /******** C_CONCATENATE
5243  Concatenate the strings in arguments 1 and 2.
5244 */
5246 {
5247  ptr_psi_term result,funct,temp_result;
5248  ptr_node n1, n2;
5249  long success=TRUE;
5250  long all_args=TRUE;
5251  char * c_result;
5252  ptr_psi_term arg1;
5253  char * c_arg1;
5254  ptr_psi_term arg2;
5255  char * c_arg2;
5256 
5257  funct=aim->aaaa_1;
5258  deref_ptr(funct);
5259  result=aim->bbbb_1;
5260 
5261  /* Evaluate all arguments first: */
5262  n1=find(FEATCMP,one,funct->attr_list);
5263  if (n1) {
5264  arg1= (ptr_psi_term )n1->data;
5265  deref(arg1);
5266  }
5267  n2=find(FEATCMP,two,funct->attr_list);
5268  if (n2) {
5269  arg2= (ptr_psi_term )n2->data;
5270  deref(arg2);
5271  }
5272  deref_args(funct,set_1_2);
5273 
5274  if (success) {
5275  if (n1) {
5276  if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
5277  if (arg1->value_3)
5278  c_arg1= (char *)arg1->value_3;
5279  else {
5280  residuate(arg1);
5281  all_args=FALSE;
5282  }
5283  else
5284  success=FALSE;
5285  }
5286  else {
5287  all_args=FALSE;
5288  curry();
5289  };
5290  };
5291 
5292  if (success) {
5293  if (n2) {
5294  if (overlap_type(arg2->type,quoted_string)) /* 10.8 */
5295  if (arg2->value_3)
5296  c_arg2= (char *)arg2->value_3;
5297  else {
5298  residuate(arg2);
5299  all_args=FALSE;
5300  }
5301  else
5302  success=FALSE;
5303  }
5304  else {
5305  all_args=FALSE;
5306  curry();
5307  }
5308  }
5309 
5310  if(success && all_args) {
5311  c_result=str_conc( c_arg1, c_arg2 );
5312  temp_result=stack_psi_term(0);
5313  temp_result->type=quoted_string;
5314  temp_result->value_3= (GENERIC)c_result;
5315  push_goal(unify,temp_result,result,NULL);
5316  }
5317 
5318  return success;
5319 }
5320 
5321 
5322 
5323 /******** C_MODULE_NAME
5324  Return the module in which a term resides.
5325 */
5326 static long c_module_name()
5327 {
5328  long success=TRUE;
5329  ptr_psi_term arg1,arg2,funct,result;
5330 
5331 
5332  funct=aim->aaaa_1;
5333  result=aim->bbbb_1;
5334  deref_ptr(funct);
5335  deref_ptr(result);
5336 
5337  get_two_args(funct->attr_list,&arg1,&arg2);
5338 
5339  if (arg1) {
5340  deref_ptr(arg1);
5341  arg2=stack_psi_term(0);
5342  arg2->type=quoted_string;
5344  push_goal(unify,arg2,result,NULL);
5345  }
5346  else
5347  curry();
5348 
5349  return success;
5350 }
5351 
5352 
5353 
5354 /******** C_COMBINED_NAME
5355  Return the string module#name for a term.
5356 */
5357 static long c_combined_name()
5358 {
5359  long success=TRUE;
5360  ptr_psi_term arg1,arg2,funct,result;
5361 
5362 
5363  funct=aim->aaaa_1;
5364  result=aim->bbbb_1;
5365  deref_ptr(funct);
5366  deref_ptr(result);
5367 
5368  get_two_args(funct->attr_list,&arg1,&arg2);
5369 
5370  if (arg1) {
5371  deref_ptr(arg1);
5372  arg2=stack_psi_term(0);
5373  arg2->type=quoted_string;
5375  push_goal(unify,arg2,result,NULL);
5376  }
5377  else
5378  curry();
5379 
5380  return success;
5381 }
5382 
5383 
5384 
5385 
5386 /******** C_STRING_LENGTH
5387  Return the length of the string in argument 1.
5388 */
5390 {
5391  ptr_psi_term result,funct;
5392  ptr_node n1;
5393  long success=TRUE;
5394  long all_args=TRUE;
5395  long c_result;
5396  ptr_psi_term arg1;
5397  char * c_arg1;
5398 
5399  funct=aim->aaaa_1;
5400  deref_ptr(funct);
5401  result=aim->bbbb_1;
5402 
5403  /* Evaluate all arguments first: */
5404  n1=find(FEATCMP,one,funct->attr_list);
5405  if (n1) {
5406  arg1= (ptr_psi_term )n1->data;
5407  deref(arg1);
5408  }
5409  deref_args(funct,set_1);
5410 
5411  if (success) {
5412  if (n1) {
5413  if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
5414  if (arg1->value_3)
5415  c_arg1= (char *)arg1->value_3;
5416  else {
5417  residuate(arg1);
5418  all_args=FALSE;
5419  }
5420  else
5421  success=FALSE;
5422  }
5423  else {
5424  all_args=FALSE;
5425  curry();
5426  };
5427  };
5428 
5429  if (success && all_args) {
5430  c_result=strlen(c_arg1);
5431  push_goal(unify,real_stack_psi_term(0,(REAL)c_result),result,NULL);
5432  };
5433 
5434  return success;
5435 }
5436 
5437 
5438 
5439 
5440 /******** C_SUB_STRING
5441  Return the substring of argument 1 from position argument 2 for a
5442  length of argument 3 characters.
5443 */
5445 {
5446  ptr_psi_term result,funct,temp_result;
5447  ptr_node n1,n2,n3;
5448  long success=TRUE;
5449  long all_args=TRUE;
5450  char * c_result;
5451  ptr_psi_term arg1;
5452  char * c_arg1;
5453  ptr_psi_term arg2;
5454  long c_arg2;
5455  ptr_psi_term arg3;
5456  long c_arg3;
5457 
5458  funct=aim->aaaa_1;
5459  deref_ptr(funct);
5460  result=aim->bbbb_1;
5461 
5462  /* Evaluate all arguments first: */
5463  n1=find(FEATCMP,one,funct->attr_list);
5464  if (n1) {
5465  arg1= (ptr_psi_term )n1->data;
5466  deref(arg1);
5467  }
5468  n2=find(FEATCMP,two,funct->attr_list);
5469  if (n2) {
5470  arg2= (ptr_psi_term )n2->data;
5471  deref(arg2);
5472  }
5473  n3=find(FEATCMP,three,funct->attr_list);
5474  if (n3) {
5475  arg3= (ptr_psi_term )n3->data;
5476  deref(arg3);
5477  }
5478  deref_args(funct,set_1_2_3);
5479 
5480  if (success) {
5481  if (n1) {
5482  if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
5483  if (arg1->value_3)
5484  c_arg1= (char *)arg1->value_3;
5485  else {
5486  residuate(arg1);
5487  all_args=FALSE;
5488  }
5489  else
5490  success=FALSE;
5491  }
5492  else {
5493  all_args=FALSE;
5494  curry();
5495  };
5496  };
5497 
5498  if (success) {
5499  if (n2) {
5500  if (overlap_type(arg2->type,integer)) /* 10.8 */
5501  if (arg2->value_3)
5502  c_arg2= (long)(* (double *)(arg2->value_3));
5503  else {
5504  residuate(arg2);
5505  all_args=FALSE;
5506  }
5507  else
5508  success=FALSE;
5509  }
5510  else {
5511  all_args=FALSE;
5512  curry();
5513  };
5514  };
5515 
5516  if (success) {
5517  if (n3) {
5518  if (overlap_type(arg3->type,integer)) /* 10.8 */
5519  if (arg3->value_3)
5520  c_arg3= (long)(* (double *)(arg3->value_3));
5521  else {
5522  residuate(arg3);
5523  all_args=FALSE;
5524  }
5525  else
5526  success=FALSE;
5527  }
5528  else {
5529  all_args=FALSE;
5530  curry();
5531  };
5532  };
5533 
5534  if (success && all_args) {
5535  c_result=sub_str(c_arg1,c_arg2,c_arg3);
5536  temp_result=stack_psi_term(0);
5537  temp_result->type=quoted_string;
5538  temp_result->value_3=(GENERIC)c_result;
5539  push_goal(unify,temp_result,result,NULL);
5540  };
5541 
5542  return success;
5543 }
5544 
5545 
5546 
5547 
5548 /******** C_APPEND_FILE
5549  Append the file named by argument 2 to the file named by argument 1.
5550  This predicate will not residuate; it requires string arguments.
5551 */
5553 {
5554  ptr_psi_term g;
5555  ptr_node n1,n2;
5556  long success=TRUE;
5557  ptr_psi_term arg1;
5558  char * c_arg1;
5559  ptr_psi_term arg2;
5560  char * c_arg2;
5561 
5562  g=aim->aaaa_1;
5563  deref_ptr(g);
5564 
5565  /* Evaluate all arguments first: */
5566  n1=find(FEATCMP,one,g->attr_list);
5567  if (n1) {
5568  arg1= (ptr_psi_term )n1->data;
5569  deref(arg1);
5570  }
5571  n2=find(FEATCMP,two,g->attr_list);
5572  if (n2) {
5573  arg2= (ptr_psi_term )n2->data;
5574  deref(arg2);
5575  }
5576  deref_args(g,set_1_2);
5577 
5578  if (success) {
5579  if (n1) {
5580  if (overlap_type(arg1->type,quoted_string))
5581  if (arg1->value_3)
5582  c_arg1= (char *)arg1->value_3;
5583  else {
5584  success=FALSE;
5585  Errorline("bad argument in %P.\n",g);
5586  }
5587  else
5588  success=FALSE;
5589  }
5590  else {
5591  success=FALSE;
5592  Errorline("bad argument in %P.\n",g);
5593  };
5594  };
5595 
5596  if (success) {
5597  if (n2) {
5598  if (overlap_type(arg2->type,quoted_string))
5599  if (arg2->value_3)
5600  c_arg2= (char *)arg2->value_3;
5601  else {
5602  success=FALSE;
5603  Errorline("bad argument in %P.\n",g);
5604  }
5605  else
5606  success=FALSE;
5607  }
5608  else {
5609  success=FALSE;
5610  Errorline("bad argument in %P.\n",g);
5611  };
5612  };
5613 
5614  if (success)
5615  success=append_files(c_arg1,c_arg2);
5616 
5617  return success;
5618 }
5619 
5620 
5621 
5622 /******** C_RANDOM
5623  Return an integer random number between 0 and abs(argument1).
5624  Uses the Unix random() function (rand_r(&seed) for Solaris).
5625 */
5626 long c_random()
5627 {
5628  ptr_psi_term result,funct;
5629  ptr_node n1;
5630  long success=TRUE;
5631  long all_args=TRUE;
5632  long c_result;
5633  ptr_psi_term arg1;
5634  long c_arg1;
5635 
5636  funct=aim->aaaa_1;
5637  deref_ptr(funct);
5638  result=aim->bbbb_1;
5639 
5640  /* Evaluate all arguments first: */
5641  n1=find(FEATCMP,one,funct->attr_list);
5642  if (n1) {
5643  arg1= (ptr_psi_term )n1->data;
5644  deref(arg1);
5645  }
5646  deref_args(funct,set_1);
5647 
5648  if (success) {
5649  if (n1) {
5650  if (overlap_type(arg1->type,integer))
5651  if (arg1->value_3)
5652  c_arg1= (long)(* (double *)(arg1->value_3));
5653  else {
5654  residuate(arg1);
5655  all_args=FALSE;
5656  }
5657  else
5658  success=FALSE;
5659  }
5660  else {
5661  all_args=FALSE;
5662  curry();
5663  }
5664  }
5665 
5666  if (success && all_args) {
5667  if (c_arg1) {
5668 #ifdef SOLARIS
5669  c_result=(rand_r(&randomseed)<<15) + rand_r(&randomseed);
5670 #else
5671  c_result=random();
5672 #endif
5673  c_result=c_result-(c_result/c_arg1)*c_arg1;
5674  }
5675  else
5676  c_result=0;
5677 
5678  push_goal(unify,real_stack_psi_term(0,(REAL)c_result),result,NULL);
5679  }
5680 
5681  return success;
5682 }
5683 
5684 
5685 
5686 /******** C_INITRANDOM
5687  Uses its integer argument to initialize
5688  the random number generator, which is the Unix random() function.
5689 */
5691 {
5692  ptr_psi_term t;
5693  ptr_node n1;
5694  long success=TRUE;
5695  long all_args=TRUE;
5696  // long c_result;
5697  ptr_psi_term arg1;
5698  long c_arg1;
5699 
5700  t=aim->aaaa_1;
5701  deref_ptr(t);
5702 
5703  /* Evaluate all arguments first: */
5704  n1=find(FEATCMP,one,t->attr_list);
5705  if (n1) {
5706  arg1= (ptr_psi_term )n1->data;
5707  deref(arg1);
5708  }
5709  deref_args(t,set_1);
5710 
5711  if (success) {
5712  if (n1) {
5713  if (overlap_type(arg1->type,integer))
5714  if (arg1->value_3)
5715  c_arg1= (long)(* (double *)(arg1->value_3));
5716  else {
5717  residuate(arg1);
5718  all_args=FALSE;
5719  }
5720  else
5721  success=FALSE;
5722  }
5723  else {
5724  all_args=FALSE;
5725  }
5726  }
5727 
5728 #ifdef SOLARIS
5729  if (success && all_args) randomseed=c_arg1;
5730 #else
5731  if (success && all_args) srandom(c_arg1);
5732 #endif
5733 
5734  return success;
5735 }
5736 
5737 
5738 
5739 /******** C_DEREF_LENGTH
5740  Return the length of the dereference chain for argument 1.
5741 */
5742 /* RM: Jul 15 1993 */
5744 {
5745  ptr_psi_term result,funct;
5746  long success=TRUE;
5747  int count;
5748  ptr_psi_term arg1; // ,arg2;
5749  ptr_node n1;
5750 
5751  funct=aim->aaaa_1;
5752  deref_ptr(funct);
5753  result=aim->bbbb_1;
5754 
5755  n1=find(FEATCMP,one,funct->attr_list);
5756  if (n1) {
5757  count=0;
5758  arg1= (ptr_psi_term )n1->data;
5759  while(arg1->coref) {
5760  count++;
5761  arg1=arg1->coref;
5762  }
5763  success=unify_real_result(result,(REAL)count);
5764  }
5765  else
5766  curry();
5767 
5768  return success;
5769 }
5770 
5771 
5772 
5773 /******** C_ARGS
5774  Return the Unix "ARGV" array as a list of strings.
5775 */
5776 /* RM: Sep 20 1993 */
5777 long c_args()
5778 {
5779  ptr_psi_term result,list,str;
5780  long success=TRUE;
5781  int i;
5782 
5783  result=aim->bbbb_1;
5784 
5785  list=stack_nil();
5786  for(i=arg_c-1;i>=0;i--) {
5787  str=stack_psi_term(0);
5788  str->type=quoted_string;
5790  list=stack_cons((ptr_psi_term)str,(ptr_psi_term)list);
5791  }
5792  push_goal(unify,result,list,NULL);
5793 
5794  return success;
5795 }
5796 
5797 /******** INIT_BUILT_IN_TYPES
5798  Initialise the symbol tree with the built-in types.
5799  Declare all built-in predicates and functions.
5800  Initialise system type variables.
5801  Declare all standard operators.
5802 
5803  Called by life.c
5804 */
5806 {
5807  ptr_definition t;
5808 
5809  /* symbol_table=NULL; RM: Feb 3 1993 */
5810 
5811 
5812 
5813  /* RM: Jan 13 1993 */
5814  /* Initialize the minimum syntactic symbols */
5815  (void)set_current_module(syntax_module); /* RM: Feb 3 1993 */
5817  (void)update_symbol(syntax_module,"[");
5818  (void)update_symbol(syntax_module,"]");
5819  (void)update_symbol(syntax_module,"(");
5820  (void)update_symbol(syntax_module,")");
5821  (void)update_symbol(syntax_module,"{");
5822  (void)update_symbol(syntax_module,"}");
5823  (void)update_symbol(syntax_module,".");
5824  (void)update_symbol(syntax_module,"?");
5825 
5826 
5831  eof =update_symbol(syntax_module,"end_of_file");
5835  life_or =update_symbol(syntax_module,";");/* RM: Apr 6 1993 */
5836  minus_symbol =update_symbol(syntax_module,"-");/* RM: Jun 21 1993 */
5842 
5843  /* RM: Jul 7 1993 */
5846 
5847 
5848 
5849  /* RM: Feb 3 1993 */
5851  error_psi_term=heap_psi_term(4); /* 8.10 */
5852  error_psi_term->type=update_symbol(bi_module,"*** ERROR ***");
5854 
5855  apply =update_symbol(bi_module,"apply");
5856  boolean =update_symbol(bi_module,"bool");
5857  boolpredsym =update_symbol(bi_module,"bool_pred");
5858  built_in =update_symbol(bi_module,"built_in");
5859  calloncesym =update_symbol(bi_module,"call_once");
5860  /* colon sym */
5861  /* comma sym */
5862  comment =update_symbol(bi_module,"comment");
5863 
5864 
5865  /* RM: Dec 11 1992 conjunctions have been totally scrapped it seems */
5866  /* conjunction=update_symbol("*conjunction*"); 19.8 */
5867 
5868  constant =update_symbol(bi_module,"*constant*");
5869  disjunction =update_symbol(bi_module,"disj");/*RM:9 Dec 92*/
5870  lf_false =update_symbol(bi_module,"false");
5871  functor =update_symbol(bi_module,"functor");
5872  iff =update_symbol(bi_module,"cond");
5874  alist =update_symbol(bi_module,"cons");/*RM:9 Dec 92*/
5875  nothing =update_symbol(bi_module,"bottom");
5876  nil =update_symbol(bi_module,"nil");/*RM:9 Dec 92*/
5878  real =update_symbol(bi_module,"real");
5879  stream =update_symbol(bi_module,"stream");
5880  succeed =update_symbol(bi_module,"succeed");
5881  lf_true =update_symbol(bi_module,"true");
5882  timesym =update_symbol(bi_module,"time");
5883  variable =update_symbol(bi_module,"*variable*");
5884  opsym =update_symbol(bi_module,"op");
5885  loadsym =update_symbol(bi_module,"load");
5886  dynamicsym =update_symbol(bi_module,"dynamic");
5887  staticsym =update_symbol(bi_module,"static");
5888  encodesym =update_symbol(bi_module,"encode");
5889  listingsym =update_symbol(bi_module,"c_listing");
5890  /* provesym =update_symbol(bi_module,"prove"); */
5891  delay_checksym =update_symbol(bi_module,"delay_check");
5892  eval_argsym =update_symbol(bi_module,"non_strict");
5893  inputfilesym =update_symbol(bi_module,"input_file");
5894  call_handlersym =update_symbol(bi_module,"call_handler");
5902  nullsym =update_symbol(bi_module,"<NULL PSI TERM>");
5905 
5906 
5907  (void)set_current_module(no_module); /* RM: Feb 3 1993 */
5908  t=update_symbol(no_module,"1");
5909  one=t->keyword->symbol;
5910  t=update_symbol(no_module,"2");
5911  two=t->keyword->symbol;
5912  t=update_symbol(no_module,"3");
5913  three=t->keyword->symbol;
5914  (void)set_current_module(bi_module); /* RM: Feb 3 1993 */
5915  t=update_symbol(bi_module,"year");
5916  year_attr=t->keyword->symbol;
5917  t=update_symbol(bi_module,"month");
5919  t=update_symbol(bi_module,"day");
5920  day_attr=t->keyword->symbol;
5921  t=update_symbol(bi_module,"hour");
5922  hour_attr=t->keyword->symbol;
5923  t=update_symbol(bi_module,"minute");
5925  t=update_symbol(bi_module,"second");
5927  t=update_symbol(bi_module,"weekday");
5929 
5932 
5933  /* Built-in routines */
5934  // bi_list = fopen("bi_list.txt","w");
5935 
5936  /* Program database */
5938  new_built_in(bi_module,"static",(def_type)predicate,c_static);
5939  new_built_in(bi_module,"assert",(def_type)predicate,c_assert_last);
5940  new_built_in(bi_module,"asserta",(def_type)predicate,c_assert_first);
5941  new_built_in(bi_module,"clause",(def_type)predicate,c_clause);
5942  new_built_in(bi_module,"retract",(def_type)predicate,c_retract);
5943  new_built_in(bi_module,"setq",(def_type)predicate,c_setq);
5944  new_built_in(bi_module,"c_listing",(def_type)predicate,c_listing);
5945  new_built_in(bi_module,"print_codes",(def_type)predicate,c_print_codes);
5946 
5947  /* File I/O */
5948  new_built_in(bi_module,"get",(def_type)predicate,c_get);
5949  new_built_in(bi_module,"put",(def_type)predicate,c_put);
5950  new_built_in(bi_module,"open_in",(def_type)predicate,c_open_in);
5951  new_built_in(bi_module,"open_out",(def_type)predicate,c_open_out);
5952  new_built_in(bi_module,"set_input",(def_type)predicate,c_set_input);
5953  new_built_in(bi_module,"set_output",(def_type)predicate,c_set_output);
5954  new_built_in(bi_module,"exists_file",(def_type)predicate,c_exists);
5955  new_built_in(bi_module,"close",(def_type)predicate,c_close);
5956  new_built_in(bi_module,"simple_load",(def_type)predicate,c_load);
5957  new_built_in(bi_module,"put_err",(def_type)predicate,c_put_err);
5958  new_built_in(bi_module,"chdir",(def_type)predicate,c_chdir);
5959 
5960  /* Term I/O */
5961  new_built_in(bi_module,"write",(def_type)predicate,c_write);
5962  new_built_in(bi_module,"writeq",(def_type)predicate,c_writeq);
5963  new_built_in(bi_module,"pretty_write",(def_type)predicate,c_pwrite);
5964  new_built_in(bi_module,"pretty_writeq",(def_type)predicate,c_pwriteq);
5965  new_built_in(bi_module,"write_canonical",(def_type)predicate,c_write_canonical);
5966  new_built_in(bi_module,"page_width",(def_type)predicate,c_page_width);
5967  new_built_in(bi_module,"print_depth",(def_type)predicate,c_print_depth);
5968  new_built_in(bi_module,"put_err",(def_type)predicate,c_put_err);
5970  new_built_in(bi_module,"read",(def_type)predicate,c_read_psi);
5971  new_built_in(bi_module,"read_token",(def_type)predicate,c_read_token);
5972  new_built_in(bi_module,"c_op",(def_type)predicate,c_op); /* RM: Jan 13 1993 */
5973  new_built_in(bi_module,"ops",(def_type)function_it,c_ops);
5974  new_built_in(bi_module,"write_err",(def_type)predicate,c_write_err);
5975  new_built_in(bi_module,"writeq_err",(def_type)predicate,c_writeq_err);
5976 
5977  /* Type checks */
5978  new_built_in(bi_module,"nonvar",(def_type)function_it,c_nonvar);
5979  new_built_in(bi_module,"var",(def_type)function_it,c_var);
5980  new_built_in(bi_module,"is_function",(def_type)function_it,c_is_function);
5981  new_built_in(bi_module,"is_predicate",(def_type)function_it,c_is_predicate);
5982  new_built_in(bi_module,"is_sort",(def_type)function_it,c_is_sort);
5983 
5986  (def_type)function_it,
5988 
5989  /* RM: Dec 16 1992 So the symbol can be changed easily */
5990 
5991 
5992  /* Arithmetic */
5994 
5995  /* Comparison */
5996  new_built_in(syntax_module,"<",(def_type)function_it,c_lt);
5997  new_built_in(syntax_module,"=<",(def_type)function_it,c_ltoe);
5998  new_built_in(syntax_module,">",(def_type)function_it,c_gt);
5999  new_built_in(syntax_module,">=",(def_type)function_it,c_gtoe);
6000  new_built_in(syntax_module,"=\\=",(def_type)function_it,c_diff);
6001  new_built_in(syntax_module,"=:=",(def_type)function_it,c_equal);
6002  new_built_in(syntax_module,"and",(def_type)function_it,c_and);
6003  new_built_in(syntax_module,"or",(def_type)function_it,c_or);
6004  new_built_in(syntax_module,"not",(def_type)function_it,c_not);
6005  new_built_in(syntax_module,"xor",(def_type)function_it,c_xor);
6006  new_built_in(syntax_module,"===",(def_type)function_it,c_same_address);
6007 
6008  /* RM: Nov 22 1993 */
6009  new_built_in(syntax_module,"\\===",(def_type)function_it,c_diff_address);
6010 
6011  /* Psi-term navigation */
6012  new_built_in(bi_module,"features",(def_type)function_it,c_features);
6013  new_built_in(bi_module,"feature_values",(def_type)function_it,c_feature_values); /* RM: Mar 3 1994 */
6014 
6015  /* RM: Jul 20 1993 */
6016 
6017  new_built_in(syntax_module,".",(def_type)function_it,c_project);/* RM: Jul 7 1993 */
6018  new_built_in(bi_module,"root_sort",(def_type)function_it,c_rootsort);
6019  new_built_in(bi_module,"strip",(def_type)function_it,c_strip);
6020  new_built_in(bi_module,"copy_pointer",(def_type)function_it,c_copy_pointer); /* PVR: Dec 17 1992 */
6021  new_built_in(bi_module,"has_feature",(def_type)function_it,c_exist_feature); /* PVR: Dec 17 1992 */
6022 
6023  /* Unification and assignment */
6025  /* new_built_in(syntax_module,"<<-",(def_type)predicate,c_assign); RM: Feb 24 1993 */
6026 
6027  /* RM: Feb 24 1993 */
6029  /* new_built_in(syntax_module,"<<<-",(def_type)predicate,c_global_assign); */
6030 
6031  /* RM: Feb 8 1993 */
6032  new_built_in(syntax_module,"{}",(def_type)function_it,c_fail); /* RM: Feb 16 1993 */
6034  new_built_in(syntax_module,"&",(def_type)function_it,c_unify_func);
6035  new_built_in(bi_module,"copy_term",(def_type)function_it,c_copy_term);
6036  /* UNI new_built_in(syntax_module,":",(def_type)function_it,c_unify_func); */
6037 
6038  /* Type hierarchy navigation */
6040 
6041  /* String and character utilities */
6042  new_built_in(bi_module,"str2psi",(def_type)function_it,c_string2psi);
6043  new_built_in(bi_module,"psi2str",(def_type)function_it,c_psi2string);
6044  new_built_in(bi_module,"int2str",(def_type)function_it,c_int2string);
6045  new_built_in(bi_module,"asc",(def_type)function_it,c_ascii);
6046  new_built_in(bi_module,"chr",(def_type)function_it,c_char);
6047 
6048  /* Control */
6049  new_built_in(syntax_module,"|",(def_type)function_it,c_such_that);
6050  new_built_in(bi_module,"cond",(def_type)function_it,c_cond);
6051  new_built_in(bi_module,"if",(def_type)function_it,c_cond);
6052  new_built_in(bi_module,"eval",(def_type)function_it,c_eval);
6053  new_built_in(bi_module,"evalin",(def_type)function_it,c_eval_inplace);
6054  /* new_built_in(bi_module,"quote",(def_type)function_it,c_quote); */
6055  /*new_built_in(bi_module,"call_once",(def_type)function_it,c_call_once);*/ /* DENYS: Jan 25 1995 */
6056  /* new_built_in(bi_module,"call",(def_type)function_it,c_call); */
6057  /* new_built_in(bi_module,"undefined",(def_type)function_it,c_fail); */ /* RM: Jan 13 1993 */
6058  new_built_in(bi_module,"print_variables",(def_type)predicate,c_print_variables);
6059  new_built_in(bi_module,"get_choice",(def_type)function_it,c_get_choice);
6060  new_built_in(bi_module,"set_choice",(def_type)predicate,c_set_choice);
6061  new_built_in(bi_module,"exists_choice",(def_type)function_it,c_exists_choice);
6062  new_built_in(bi_module,"apply",(def_type)function_it,c_apply);
6063  new_built_in(bi_module,"bool_pred",(def_type)predicate,c_boolpred);
6064 
6067  /* new_built_in(syntax_module,"::",(def_type)predicate,c_declaration); */
6070  new_built_in(syntax_module,";",(def_type)predicate,c_disj);
6072  new_built_in(syntax_module,",",(def_type)predicate,c_succeed);
6073  new_built_in(bi_module,"abort",(def_type)predicate,c_abort);
6074  new_built_in(bi_module,"halt",(def_type)predicate,c_halt);
6075  new_built_in(bi_module,"succeed",(def_type)predicate,c_succeed);
6076  new_built_in(bi_module,"repeat",(def_type)predicate,c_repeat);
6077  new_built_in(bi_module,"fail",(def_type)predicate,c_fail);
6078  /* new_built_in(bi_module,"freeze",(def_type)predicate,c_freeze); PVR 16.9.93 */
6079  new_built_in(bi_module,"implies",(def_type)predicate,c_implies);
6080  new_built_in(bi_module,"undo",(def_type)predicate,c_undo);
6081  new_built_in(bi_module,"delay_check",(def_type)predicate,c_delay_check);
6082  new_built_in(bi_module,"non_strict",(def_type)predicate,c_non_strict);
6083 
6084  /* System */
6086 
6087  new_built_in(bi_module,"strcon",(def_type)function_it,c_concatenate);
6088  new_built_in(bi_module,"strlen",(def_type)function_it,c_string_length);
6089  new_built_in(bi_module,"substr",(def_type)function_it,c_sub_string);
6090  new_built_in(bi_module,"append_file",(def_type)predicate,c_append_file);
6091  new_built_in(bi_module,"random",(def_type)function_it,c_random);
6092  new_built_in(bi_module,"initrandom",(def_type)predicate,c_initrandom);
6093 
6094  /* RM: Jan 8 1993 */
6095  new_built_in(bi_module,"set_module",(def_type)predicate,c_set_module);
6096  new_built_in(bi_module,"open_module",(def_type)predicate,c_open_module);
6097  new_built_in(bi_module,"public",(def_type)predicate,c_public);
6098  new_built_in(bi_module,"private",(def_type)predicate,c_private);
6099  new_built_in(bi_module,"display_modules",(def_type)predicate,c_display_modules);
6100  new_built_in(bi_module,"trace_input",(def_type)predicate,c_trace_input);
6101  new_built_in(bi_module,"substitute",(def_type)predicate,c_replace);
6102  new_built_in(bi_module,"current_module",(def_type)function_it,c_current_module);
6103  new_built_in(bi_module,"module_name",(def_type)function_it,c_module_name);
6104  new_built_in(bi_module,"combined_name",(def_type)function_it,c_combined_name);
6105  /* new_built_in(bi_module,"#",(def_type)function_it,c_module_access); */
6106 
6107  /* Hack so '.set_up' doesn't issue a Warning message */
6108  /* RM: Feb 3 1993 */
6109  hash_lookup(bi_module->symbol_table,"set_module")->public=TRUE;
6111 
6112  /* RM: Jan 29 1993 */
6113  abortsym=update_symbol(bi_module,"abort"); /* 26.1 */
6114  aborthooksym=update_symbol(bi_module,"aborthook"); /* 26.1 */
6115  tracesym=update_symbol(bi_module,"trace"); /* 26.1 */
6116 
6117 
6118  /* RM: Feb 9 1993 */
6119  new_built_in(bi_module,"global",(def_type)predicate,c_global);
6120  new_built_in(bi_module,"persistent",(def_type)predicate,c_persistent);
6121  new_built_in(bi_module,"display_persistent",(def_type)predicate,c_display_persistent);
6122  new_built_in(bi_module,"alias",(def_type)predicate,c_alias);
6123 
6124  /* RM: Mar 11 1993 */
6125  new_built_in(bi_module,"private_feature",(def_type)predicate,c_private_feature);
6126  add_module1=update_symbol(bi_module,"features");
6127  add_module2=update_symbol(bi_module,"str2psi");
6128  add_module3=update_symbol(bi_module,"feature_values"); /* RM: Mar 3 1994 */
6129 
6130  /* RM: Jun 29 1993 */
6131  new_built_in(bi_module,"split_double",(def_type)function_it,c_split_double);
6132  new_built_in(bi_module,"string_address",(def_type)function_it,c_string_address);
6133 
6134  /* RM: Jul 15 1993 */
6135  new_built_in(bi_module,"deref_length",(def_type)function_it,c_deref_length);
6136 
6137 
6138  /* RM: Sep 20 1993 */
6139  new_built_in(bi_module,"argv",(def_type)function_it,c_args);
6140 
6141  /* RM: Jan 28 1994 */
6142  new_built_in(bi_module,"public_symbols",(def_type)function_it,all_public_symbols);
6143 
6144 #ifdef CLIFE
6145  life_reals();
6146 #endif /* CLIFE */
6147 
6149  // fclose(bi_list);
6150 }
static long c_diff()
Definition: built_ins.c:1257
#define prove
Definition: def_const.h:273
ptr_definition encodesym
Definition: def_glob.h:116
void new_built_in(ptr_module m, char *s, def_type t, long(*r)())
Definition: built_ins.c:5054
static long c_get()
Definition: built_ins.c:2798
static long c_listing()
Definition: built_ins.c:4859
static long c_char()
Definition: built_ins.c:4443
ptr_definition such_that
Definition: def_glob.h:105
ptr_definition boolpredsym
Definition: def_glob.h:74
ptr_psi_term aaaa_1
Definition: def_struct.h:224
static long c_is_sort()
Definition: built_ins.c:1498
ptr_psi_term aaaa_2
Definition: def_struct.h:189
ptr_keyword hash_lookup(ptr_hash_table table, char *symbol)
Definition: hash_table.c:133
long c_initrandom()
Definition: built_ins.c:5690
ptr_residuation resid
Definition: def_struct.h:173
long trail_condition(psi_term *Q)
Definition: login.c:2490
ptr_definition abortsym
Definition: def_glob.h:64
static long built_in_index
Definition: built_ins.c:13
#define predicate
Definition: def_const.h:361
#define function_it
Definition: def_const.h:362
ptr_definition timesym
Definition: def_glob.h:108
void get_two_args(ptr_node t, ptr_psi_term *a, ptr_psi_term *b)
Definition: login.c:37
#define is_top(T)
Definition: def_macro.h:108
static long c_exists()
Definition: built_ins.c:1642
long open_output_file(char *file)
void undo(ptr_stack limit)
Definition: login.c:646
static long c_combined_name()
Definition: built_ins.c:5357
void get_one_arg_addr(ptr_node t, ptr_psi_term **a)
Definition: login.c:115
#define HEAP
Definition: def_const.h:147
long assert_first
Definition: def_glob.h:58
static long c_exists_choice()
Definition: built_ins.c:1812
#define yfx
Definition: def_const.h:268
static long c_static()
Definition: built_ins.c:1563
static long c_read(long)
Definition: built_ins.c:1999
#define FEATCMP
Definition: def_const.h:257
ptr_definition xfy_sym
Definition: def_glob.h:127
ptr_definition staticsym
Definition: def_glob.h:115
void clear_copy()
Definition: copy.c:52
static long c_write()
Definition: built_ins.c:2951
static long c_pwriteq()
Definition: built_ins.c:3012
static long c_unify_func()
Definition: built_ins.c:4152
static long c_clause()
Definition: built_ins.c:2366
struct wl_definition * def_type
Definition: def_struct.h:32
static long c_declaration()
Definition: built_ins.c:2172
ptr_psi_term stack_cons(ptr_psi_term head, ptr_psi_term tail)
Definition: built_ins.c:47
char evaluate_args
Definition: def_struct.h:136
long c_random()
Definition: built_ins.c:5626
void insert_type_builtins()
Definition: bi_type.c:655
void residuate(ptr_psi_term t)
Definition: lefun.c:113
#define least_sel
Definition: def_const.h:6
void listing_pred_write(ptr_node n, long fflag)
Definition: print.c:1341
void exit_life(long nl_flag)
Definition: built_ins.c:2090
long c_public()
Definition: modules.c:671
long main_loop_ok
Definition: def_glob.h:48
static long c_put_main(long)
Definition: built_ins.c:2863
long pred_clause(ptr_psi_term t, long r, ptr_psi_term g)
Definition: built_ins.c:2300
static long c_pwrite()
Definition: built_ins.c:2997
ptr_definition loadsym
Definition: def_glob.h:113
char * combined_name
Definition: def_struct.h:92
static long c_ascii()
Definition: built_ins.c:4497
static long c_retract()
Definition: built_ins.c:2383
long c_display_modules()
Definition: modules.c:723
static long c_features()
Definition: built_ins.c:3312
#define xfx
Definition: def_const.h:265
static long c_delay_check()
Definition: built_ins.c:1580
void push_ptr_value(type_ptr t, GENERIC *p)
Definition: login.c:360
ptr_goal goal_stack
Definition: def_glob.h:50
ptr_module current_module
Definition: def_glob.h:161
#define NOTQUIET
Definition: def_macro.h:10
static long c_fail()
Definition: built_ins.c:1336
ptr_definition dynamicsym
Definition: def_glob.h:114
static long c_quote()
Definition: built_ins.c:3745
ptr_definition opsym
Definition: def_glob.h:112
ptr_psi_term real_stack_psi_term(long stat, REAL thereal)
Definition: lefun.c:38
long type_count
Definition: def_glob.h:46
ptr_definition comment
Definition: def_glob.h:80
static long c_exist_feature()
Definition: built_ins.c:3248
static long c_rootsort()
Definition: built_ins.c:3108
void push_choice_point(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
Definition: login.c:591
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
Definition: login.c:555
#define def_ptr
Definition: def_const.h:173
psi_term parse(long *q)
Definition: parser.c:877
long eof_flag
Definition: def_glob.h:196
ptr_node bk_stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:309
ptr_definition stream
Definition: def_glob.h:103
static long c_persistent()
Definition: built_ins.c:2517
long c_deref_length()
Definition: built_ins.c:5743
void init_system()
Definition: lib.c:77
void list_special(ptr_psi_term t)
Definition: built_ins.c:4820
static long generic_write()
Definition: built_ins.c:2904
ptr_definition listingsym
Definition: def_glob.h:117
static long c_call_once()
Definition: sys.c:1662
ptr_psi_term exact_copy(ptr_psi_term t, long heap_flag)
Definition: copy.c:195
#define global
Definition: def_const.h:364
void unify_bool_result(ptr_psi_term t, long v)
Definition: built_ins.c:329
#define NOT_CODED
Definition: def_const.h:134
long only_arg1(ptr_psi_term t, ptr_psi_term *arg1)
Definition: built_ins.c:1528
void save_parse_state(ptr_parse_block pb)
Definition: token.c:350
static long c_freeze_inner(long freeze_flag)
Definition: built_ins.c:4317
ptr_pair_list next
Definition: def_struct.h:191
char * two
Definition: def_glob.h:251
static long c_project()
Definition: built_ins.c:1157
#define undef
Definition: def_const.h:360
GENERIC cccc_1
Definition: def_struct.h:226
void merge_unify(ptr_node *u, ptr_node v)
Definition: login.c:1070
ptr_definition commasym
Definition: def_glob.h:79
long(* c_rule[MAX_BUILT_INS])()
Definition: def_glob.h:247
static long c_int2string()
Definition: built_ins.c:4656
ptr_psi_term heap_psi_term(long stat)
Definition: lefun.c:63
void delete_attr(char *s, ptr_node *n)
Definition: trees.c:466
ptr_operator_data next
Definition: def_struct.h:49
long redefine(ptr_psi_term t)
Definition: types.c:91
static long c_same_address()
Definition: built_ins.c:3598
void push_psi_ptr_value(ptr_psi_term q, GENERIC *p)
Definition: login.c:443
static long c_xor()
Definition: built_ins.c:1033
ptr_psi_term null_psi_term
Definition: def_glob.h:140
#define implies_cut
Definition: def_const.h:281
void persistent_error_check(ptr_node n, int *error)
Definition: built_ins.c:2538
void restore_parse_state(ptr_parse_block pb)
Definition: token.c:365
#define fx
Definition: def_const.h:262
void display_psi_stream(ptr_psi_term t)
Definition: print.c:1449
ptr_psi_term new_psi_term(long numargs, ptr_definition typ, ptr_psi_term **a1, ptr_psi_term **a2)
Definition: built_ins.c:4764
long get_real_value(ptr_psi_term t, REAL *v, long *n)
Definition: built_ins.c:246
void persistent_tree(ptr_node n)
Definition: built_ins.c:2561
def_type type_def
Definition: def_struct.h:133
static long c_unify_pred()
Definition: built_ins.c:4180
static void unify_bool(ptr_psi_term arg)
Definition: built_ins.c:878
static long c_cond()
Definition: built_ins.c:3172
long c_set_module()
Definition: modules.c:483
long c_append_file()
Definition: built_ins.c:5552
long write_corefs
Definition: def_glob.h:182
#define deref_rec(P)
Definition: def_macro.h:144
void global_error_check(ptr_node n, int *error, int *eval_2)
Definition: built_ins.c:2428
ptr_psi_term stack_bytes(char *s, int n)
Definition: built_ins.c:117
long matches(ptr_definition t1, ptr_definition t2, long *smaller)
Definition: types.c:1565
void assert_protected(ptr_node n, long prot)
Definition: types.c:235
ptr_definition fy_sym
Definition: def_glob.h:125
static long c_string2psi()
Definition: built_ins.c:4547
#define set_empty
Definition: def_const.h:193
static long c_read_psi()
Definition: built_ins.c:1995
long file_date
Definition: def_glob.h:60
#define DEFRULES
Definition: def_const.h:138
long write_resids
Definition: def_glob.h:183
static long c_lt()
Definition: built_ins.c:613
long c_abort()
Definition: built_ins.c:2117
ptr_definition aborthooksym
Definition: def_glob.h:65
static long c_boolpred()
Definition: built_ins.c:815
static long c_diff_address()
Definition: built_ins.c:3640
void persistent_one(ptr_psi_term t)
Definition: built_ins.c:2577
static long c_open_out()
Definition: built_ins.c:2634
void nonnum_warning(ptr_psi_term t, ptr_psi_term arg1, ptr_psi_term arg2)
Definition: error.c:796
ptr_definition constant
Definition: def_glob.h:82
#define FACT
Definition: def_const.h:151
static long c_print_codes()
Definition: built_ins.c:4970
long c_args()
Definition: built_ins.c:5777
ptr_hash_table symbol_table
Definition: def_struct.h:79
long indent
Definition: def_glob.h:179
void get_one_arg(ptr_node t, ptr_psi_term *a)
Definition: login.c:86
#define set_1
Definition: def_const.h:194
ptr_keyword keyword
Definition: def_struct.h:124
struct tms life_start life_end
Definition: def_glob.h:17
GENERIC data
Definition: def_struct.h:185
ptr_definition top
Definition: def_glob.h:106
void curry()
Definition: lefun.c:157
#define NULL
Definition: def_const.h:203
ptr_node var_tree
Definition: def_glob.h:26
ptr_node distinct_tree(ptr_node t)
Definition: copy.c:334
ptr_psi_term input_state
Definition: def_glob.h:199
#define xfy
Definition: def_const.h:267
static long c_string_address()
Definition: built_ins.c:3833
ptr_definition quote
Definition: def_glob.h:100
static long c_op()
Definition: built_ins.c:1612
static long c_ltoe()
Definition: built_ins.c:746
long c_open_module()
Definition: modules.c:514
long page_width
Definition: def_glob.h:43
char * three
Definition: def_glob.h:252
char * symbol
Definition: def_struct.h:91
char * heap_ncopy_string(char *s, int n)
Definition: trees.c:128
char * sub_str(char *s, long p, long n)
Definition: built_ins.c:5184
#define nop
Definition: def_const.h:260
ptr_definition apply
Definition: def_glob.h:72
FILE * get_stream(ptr_psi_term t)
Definition: token.c:219
#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
long overlap_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1486
#define REAL
Definition: def_const.h:72
static long c_assign()
Definition: built_ins.c:4078
ptr_definition update_symbol(ptr_module module, char *symbol)
Definition: modules.c:264
#define op_sel
Definition: def_const.h:8
static long c_parse()
Definition: built_ins.c:1905
static long c_freeze()
Definition: built_ins.c:4423
ptr_node heap_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:276
void insert_system_builtins()
Definition: bi_sys.c:626
ptr_resid_list resid_vars
Definition: def_glob.h:221
static long c_page_width()
Definition: built_ins.c:3028
long assert_ok
Definition: def_glob.h:59
int get_module(ptr_psi_term psi, ptr_module *module)
Definition: modules.c:1207
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
static long c_gtoe()
Definition: built_ins.c:680
ptr_definition minus_symbol
Definition: def_glob.h:96
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
static long c_psi2string()
Definition: built_ins.c:4613
static long c_pred()
Definition: built_ins.c:4990
ptr_definition xfx_sym
Definition: def_glob.h:126
long sub_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1544
void traceline(char *format,...)
Definition: error.c:157
static long c_repeat()
Definition: built_ins.c:1360
#define type_it
Definition: def_const.h:363
long c_display_persistent()
Definition: modules.c:759
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
ptr_definition add_module3
Definition: def_glob.h:69
static long c_global_assign()
Definition: built_ins.c:4112
static long c_split_double()
Definition: built_ins.c:3769
long line_count
Definition: def_glob.h:39
ptr_definition next
Definition: def_struct.h:148
ptr_psi_term quote_copy(ptr_psi_term t, long heap_flag)
Definition: copy.c:200
void Errorline(char *format,...)
Definition: error.c:414
ptr_definition yf_sym
Definition: def_glob.h:124
char * heap_copy_string(char *s)
Definition: trees.c:147
ptr_definition disj_nil
Definition: def_glob.h:85
static long c_write_err()
Definition: built_ins.c:2920
static long c_apply()
Definition: built_ins.c:1112
#define set_1_2
Definition: def_const.h:196
void assert_delay_check(ptr_node n)
Definition: types.c:303
ptr_int_list cons(GENERIC v, ptr_int_list l)
Definition: types.c:164
void stack_add_int_attr(ptr_psi_term t, char *attrname, long value)
Definition: token.c:73
ptr_definition nullsym
Definition: def_glob.h:129
ptr_definition real
Definition: def_glob.h:102
static long c_writeq_err()
Definition: built_ins.c:2936
ptr_psi_term stack_pair(ptr_psi_term left, ptr_psi_term right)
Definition: built_ins.c:67
#define UNDEF
Definition: def_const.h:132
static long c_global()
Definition: built_ins.c:2404
#define greatest_sel
Definition: def_const.h:7
long check_real(ptr_psi_term t, REAL *v, long *n)
Definition: built_ins.c:217
void residuate2(ptr_psi_term u, ptr_psi_term v)
Definition: lefun.c:130
ptr_node stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:291
#define deref_ptr(P)
Definition: def_macro.h:95
void bk_mark_quote(ptr_psi_term t)
Definition: copy.c:630
static long c_get_choice()
Definition: built_ins.c:1720
ptr_definition alist
Definition: def_glob.h:94
void print_codes()
Definition: types.c:1178
ptr_definition functor
Definition: def_glob.h:91
ptr_definition eqsym
Definition: def_glob.h:87
void insert_sys_builtins()
Definition: sys.c:1760
void global_tree(ptr_node n)
Definition: built_ins.c:2466
char * key
Definition: def_struct.h:182
static long c_writeq()
Definition: built_ins.c:2967
#define freeze_cut
Definition: def_const.h:280
ptr_definition eof
Definition: def_glob.h:86
ptr_psi_term distinct_copy(ptr_psi_term t)
Definition: copy.c:358
long c_sub_string()
Definition: built_ins.c:5444
#define TRUE
Definition: def_const.h:127
#define STREAM
Definition: def_const.h:225
long all_public_symbols()
Definition: modules.c:1349
static long c_open_in()
Definition: built_ins.c:2590
long has_rules(ptr_pair_list r)
Definition: built_ins.c:4799
ptr_definition first_definition
Definition: def_glob.h:3
static long c_dynamic()
Definition: built_ins.c:1548
static void clean_trail(ptr_choice_point cutpt)
Definition: login.c:757
static long c_logical_main(long sel)
Definition: built_ins.c:890
ptr_psi_term error_psi_term
Definition: def_glob.h:23
long append_files(char *s1, char *s2)
Definition: built_ins.c:5211
long c_string_length()
Definition: built_ins.c:5389
ptr_definition built_in
Definition: def_glob.h:75
ptr_definition integer
Definition: def_glob.h:93
#define match
Definition: def_const.h:283
void mark_eval(ptr_psi_term t)
Definition: copy.c:452
ptr_definition lf_true
Definition: def_glob.h:107
ptr_psi_term stack_int(long n)
Definition: built_ins.c:87
ptr_definition iff
Definition: def_glob.h:92
ptr_definition final_dot
Definition: def_glob.h:137
void release_resid_notrail(ptr_psi_term t)
Definition: lefun.c:420
ptr_pair_list rule
Definition: def_struct.h:126
static long c_non_strict()
Definition: built_ins.c:1597
static long c_copy_term()
Definition: built_ins.c:4237
ptr_psi_term global_value
Definition: def_struct.h:141
static long c_undo()
Definition: built_ins.c:4274
#define FALSE
Definition: def_const.h:128
static long c_eval()
Definition: built_ins.c:3683
static long c_nonvar()
Definition: built_ins.c:1405
#define deref(P)
Definition: def_macro.h:142
int arg_c
Definition: def_glob.h:5
long is_built_in(ptr_pair_list r)
Definition: built_ins.c:4811
#define set_1_2_3
Definition: def_const.h:197
long var_occurred
Definition: def_glob.h:189
ptr_definition quoted_string
Definition: def_glob.h:101
ptr_definition succeed
Definition: def_glob.h:104
#define clause
Definition: def_const.h:285
long c_halt()
Definition: built_ins.c:2084
static long c_disj()
Definition: built_ins.c:3143
int operator
Definition: def_struct.h:20
static long c_eval_disjunction()
Definition: built_ins.c:569
char * arg_v[10]
Definition: def_glob.h:6
ptr_psi_term stack_psi_term(long stat)
Definition: lefun.c:15
ptr_definition and
Definition: def_glob.h:71
long const_quote
Definition: def_glob.h:180
FILE * input_stream
Definition: def_glob.h:38
struct wl_operator_data * ptr_operator_data
Definition: def_struct.h:28
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 c_current_module()
Definition: modules.c:956
ptr_definition leftarrowsym
Definition: def_glob.h:88
ptr_module syntax_module
Definition: def_glob.h:159
ptr_definition calloncesym
Definition: def_glob.h:76
static long c_succeed()
Definition: built_ins.c:1346
ptr_psi_term bbbb_2
Definition: def_struct.h:190
void init_parse_state()
Definition: token.c:381
static long c_and()
Definition: built_ins.c:963
ptr_psi_term stack_nil()
Definition: built_ins.c:29
ptr_goal aim
Definition: def_glob.h:49
void pred_write(ptr_node n)
Definition: print.c:1365
long print_depth
Definition: def_glob.h:178
static long c_implies()
Definition: built_ins.c:4432
char * module_name
Definition: def_struct.h:75
char * weekday_attr
Definition: def_glob.h:259
ptr_definition disjunction
Definition: def_glob.h:84
ptr_psi_term coref
Definition: def_struct.h:172
GENERIC heap_pointer
Definition: def_glob.h:12
static long c_strip()
Definition: built_ins.c:3570
char * one
Definition: def_glob.h:250
ptr_psi_term inc_heap_copy(ptr_psi_term t)
Definition: copy.c:211
static long get_bool(ptr_definition typ)
Definition: built_ins.c:870
#define equal_types(A, B)
Definition: def_macro.h:106
#define STACK_ALLOC(A)
Definition: def_macro.h:16
void mark_quote(ptr_psi_term t)
Definition: copy.c:601
static long c_put_err()
Definition: built_ins.c:2858
#define xf
Definition: def_const.h:261
long c_private_feature()
Definition: modules.c:1288
#define unify
Definition: def_const.h:274
static long c_or()
Definition: built_ins.c:968
static long c_assert_last()
Definition: built_ins.c:2270
ptr_definition add_module2
Definition: def_glob.h:68
ptr_node find(long comp, char *keystr, ptr_node tree)
Definition: trees.c:341
void save_resid(ptr_resid_block rb, ptr_psi_term match_date)
Definition: lefun.c:1256
#define PRINT_DEPTH
Definition: def_const.h:92
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
static long c_close()
Definition: built_ins.c:2743
static long c_read_token()
Definition: built_ins.c:1997
static long c_not()
Definition: built_ins.c:980
void restore_state(ptr_psi_term t)
Definition: token.c:267
#define yf
Definition: def_const.h:263
void outputline(char *format,...)
Definition: error.c:79
ptr_definition delay_checksym
Definition: def_glob.h:118
long c_trace_input()
Definition: modules.c:795
#define load
Definition: def_const.h:288
ptr_node one_attr()
Definition: built_ins.c:4749
long str_to_int(char *s)
Definition: print.c:103
ptr_psi_term make_feature_list(ptr_node tree, ptr_psi_term tail, ptr_module module, int val)
Definition: built_ins.c:156
ptr_definition yfx_sym
Definition: def_glob.h:128
ptr_definition final_question
Definition: def_glob.h:138
long can_curry
Definition: def_glob.h:224
static long c_is_predicate()
Definition: built_ins.c:1467
static long c_var()
Definition: built_ins.c:1374
ptr_module module
Definition: def_struct.h:90
long c_alias()
Definition: modules.c:1164
#define MAX_PRECEDENCE
Definition: def_const.h:103
void encode_types()
Definition: types.c:1015
long deref_eval(ptr_psi_term t)
Definition: lefun.c:1087
long c_concatenate()
Definition: built_ins.c:5245
static long c_is_function()
Definition: built_ins.c:1436
ptr_definition add_module1
Definition: def_glob.h:67
static long c_funct()
Definition: built_ins.c:5014
ptr_definition tracesym
Definition: def_glob.h:109
long curried
Definition: def_glob.h:223
void insert_math_builtins()
Definition: bi_math.c:1318
#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
static long c_put()
Definition: built_ins.c:2853
static long c_eval_inplace()
Definition: built_ins.c:3714
ptr_psi_term collect_symbols(long sel)
Definition: built_ins.c:3446
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
void read_token_b(ptr_psi_term tok)
Definition: token.c:1069
void save_state(ptr_psi_term t)
Definition: token.c:230
char * prompt
Definition: def_glob.h:42
ptr_definition fx_sym
Definition: def_glob.h:123
void init_built_in_types()
Definition: built_ins.c:5805
long c_private()
Definition: modules.c:697
char * minute_attr
Definition: def_glob.h:257
ptr_definition cut
Definition: def_glob.h:83
long print_variables(long printflag)
Definition: print.c:1272
long unify_real_result(ptr_psi_term t, REAL v)
Definition: built_ins.c:371
static long c_not_implemented()
Definition: built_ins.c:2157
long file_exists(char *s)
Definition: built_ins.c:1622
long read_char()
Definition: token.c:587
unsigned long global_time_stamp
Definition: login.c:19
long c_replace()
Definition: modules.c:917
long declare_operator(ptr_psi_term t)
Definition: built_ins.c:5114
FILE * output_stream
Definition: def_glob.h:41
static long c_chdir()
Definition: built_ins.c:3886
int private_feature
Definition: def_struct.h:95
#define MAX_BUILT_INS
Definition: def_const.h:82
ptr_definition nothing
Definition: def_glob.h:98
ptr_definition nil
Definition: def_glob.h:97
#define STRLEN
Definition: def_const.h:86
char * year_attr
Definition: def_glob.h:253
void inherit_always_check()
Definition: types.c:994
ptr_module no_module
Definition: def_glob.h:157
GENERIC stack_pointer
Definition: def_glob.h:14
long stringparse
Definition: def_glob.h:202
void global_one(ptr_psi_term t)
Definition: built_ins.c:2482
static long c_bk_assign()
Definition: built_ins.c:4020
ptr_int_list code
Definition: def_struct.h:129
ptr_psi_term eval_copy(ptr_psi_term t, long heap_flag)
Definition: copy.c:205
ptr_definition update_feature(ptr_module module, char *feature)
Definition: modules.c:1315
char * second_attr
Definition: def_glob.h:258
char * day_attr
Definition: def_glob.h:255
static ptr_node copy_attr_list(ptr_node n)
Definition: built_ins.c:3550
ptr_module bi_module
Definition: def_glob.h:155
float garbage_time
Definition: def_glob.h:16
void warningline(char *format,...)
Definition: error.c:327
char * stringinput
Definition: def_glob.h:203
ptr_definition predsym
Definition: def_glob.h:99
static long c_ops()
Definition: built_ins.c:3531
int public
Definition: def_struct.h:94
static long c_set_input()
Definition: built_ins.c:2681
static long c_equal()
Definition: built_ins.c:488
static void op_declare(long p, operator t, char *s)
Definition: built_ins.c:5082
ptr_definition type
Definition: def_struct.h:165
char * hour_attr
Definition: def_glob.h:256
ptr_psi_term bbbb_1
Definition: def_struct.h:225
ptr_definition boolean
Definition: def_glob.h:73
void stdin_cleareof()
Definition: token.c:42
unsigned long * GENERIC
Definition: def_struct.h:17
static long c_setq()
Definition: built_ins.c:2194
ptr_psi_term stack_string(char *s)
Definition: built_ins.c:102
static long c_module_name()
Definition: built_ins.c:5326
ptr_definition xf_sym
Definition: def_glob.h:122
static long c_write_canonical()
Definition: built_ins.c:2983
static long c_gt()
Definition: built_ins.c:422
#define QUOTED_TRUE
Definition: def_const.h:123
char * str_conc(char *s1, char *s2)
Definition: built_ins.c:5171
long hidden_type(ptr_definition t)
Definition: built_ins.c:3421
ptr_int_list children
Definition: def_struct.h:131
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
char * expand_file_name(char *s)
Definition: token.c:449
static long c_load()
Definition: built_ins.c:1682
ptr_definition colonsym
Definition: def_glob.h:78
static long get_bool_value(ptr_psi_term t, REAL *v, long *n)
Definition: built_ins.c:284
ptr_definition inputfilesym
Definition: def_glob.h:120
ptr_definition variable
Definition: def_glob.h:111
static long c_print_depth()
Definition: built_ins.c:3066
ptr_node attr_list
Definition: def_struct.h:171
long open_input_file(char *file)
Definition: token.c:504
static long c_copy_pointer()
Definition: built_ins.c:4207
static long c_call()
Definition: built_ins.c:3971
static long c_feature_values()
Definition: built_ins.c:3368
ptr_module set_current_module(ptr_module module)
Definition: modules.c:95
static long c_assert_first()
Definition: built_ins.c:2242
void assert_clause(ptr_psi_term t)
Definition: login.c:267
static long c_print_variables()
Definition: built_ins.c:1867
static long c_set_choice()
Definition: built_ins.c:1757
ptr_operator_data op_data
Definition: def_struct.h:139
long i_check_out(ptr_psi_term t)
Definition: lefun.c:985
ptr_definition call_handlersym
Definition: def_glob.h:121
GENERIC heap_alloc(long s)
Definition: memory.c:1518
static void set_parse_queryflag(ptr_node thelist, long sort)
Definition: built_ins.c:1877
ptr_choice_point choice_stack
Definition: def_glob.h:51
long write_stderr
Definition: def_glob.h:181
static long c_set_output()
Definition: built_ins.c:2716
ptr_definition eval_argsym
Definition: def_glob.h:119
ptr_definition funcsym
Definition: def_glob.h:90
char * month_attr
Definition: def_glob.h:254
ptr_definition typesym
Definition: def_glob.h:110
static long c_such_that()
Definition: built_ins.c:4722
#define STACK
Definition: def_const.h:148
#define assert(N)
Definition: memory.c:104
#define fy
Definition: def_const.h:264
ptr_node right
Definition: def_struct.h:184
void assert_args_not_eval(ptr_node n)
Definition: types.c:273
long write_canon
Definition: def_glob.h:184
long psi_to_string(ptr_psi_term t, char **fn)
Definition: built_ins.c:133
#define psi_term_ptr
Definition: def_const.h:170
ptr_int_list parents
Definition: def_struct.h:130
#define int_ptr
Definition: def_const.h:172