Wild Life  2.29
 All Data Structures Files Functions Variables Typedefs Macros
built_ins.c
Go to the documentation of this file.
1 
6 // Copyright 1991 Digital Equipment Corporation.
7 // All Rights Reserved.
8 
9 #include "defs.h"
10 
11 #ifdef SOLARIS
12 #include <stdlib.h>
13 static unsigned int randomseed;
14 #endif
15 
16 static long built_in_index=0;
17 
18 long all_public_symbols(); /* RM: Jan 28 1994 */
19 
27 
28 {
29  ptr_psi_term empty;
30 
31  empty=stack_psi_term(4);
32  empty->type=nil;
33 
34  return empty;
35 }
36 
47 {
49 
50  cons=stack_psi_term(4);
51  cons->type=alist;
52  if(head)
53  (void)stack_insert(FEATCMP,one,&(cons->attr_list),(GENERIC)head);
54  if(tail)
55  (void)stack_insert(FEATCMP,two,&(cons->attr_list),(GENERIC)tail);
56 
57  return cons;
58 }
59 
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 
92 {
93  ptr_psi_term m;
94  m=stack_psi_term(4);
95  m->type=integer;
96  m->value_3= heap_alloc(sizeof(REAL));
97  *(REAL *)m->value_3=(REAL)n;
98  return m;
99 }
100 
110 {
112  t->type = quoted_string;
114  return t;
115 }
116 
117 /*** RM: Dec 9 1992 (END) ***/
118 
128 ptr_psi_term stack_bytes(char *s,int n)
129 {
131  t->type = quoted_string;
133  return t;
134 }
135 
146 long psi_to_string(ptr_psi_term t, char ** fn)
147 {
148  if (equal_types(t->type,quoted_string)) {
149  if (t->value_3) {
150  *fn = (char *) t->value_3;
151  return TRUE;
152  }
153  else {
154  *fn = quoted_string->keyword->symbol;
155  return TRUE;
156  }
157  }
158  else {
159  *fn = t->type->keyword->symbol;
160  return TRUE;
161  }
162 }
163 
164 /*** RM: Dec 9 1992 (START) ***/
165 
177 {
178  ptr_psi_term new;
179  ptr_definition def;
180  double d; // strtod();
181 
182 
183  if(tree) {
184  if(tree->right)
185  tail=make_feature_list(tree->right,tail,module,val);
186 
187  /* Insert the feature name into the list */
188 
189  d=str_to_int(tree->key);
190  if (d== -1) { /* Feature is not a number */
191  def=update_feature(module,tree->key); /* Extract module RM: Feb 3 1993 */
192  if(def) {
193  if(val) /* RM: Mar 3 1994 Distinguish between features & values */
194  tail=stack_cons((ptr_psi_term)tree->data,(ptr_psi_term)tail);
195  else {
196  new=stack_psi_term(4);
197  new->type=def;
198  tail=stack_cons((ptr_psi_term)new,(ptr_psi_term)tail);
199  }
200  }
201  }
202  else { /* Feature is a number */
203  if(val) /* RM: Mar 3 1994 Distinguish between features & values */
204  tail=stack_cons((ptr_psi_term)tree->data,(ptr_psi_term)tail);
205  else {
206  new=stack_psi_term(4);
207  new->type=(d==floor(d))?integer:real;
208  new->value_3=heap_alloc(sizeof(REAL));
209  *(REAL *)new->value_3=(REAL)d;
210  tail=stack_cons((ptr_psi_term)new,(ptr_psi_term)tail);
211  }
212  }
213 
214  if(tree->left)
215  tail=make_feature_list(tree->left,tail,module,val);
216  }
217 
218  return tail;
219 }
220 
221 /*** RM: Dec 9 1992 (END) ***/
222 
232 long check_real(ptr_psi_term t,REAL *v,long *n)
233 {
234  long success=FALSE;
235  long smaller;
236 
237  if (t) {
238  success=matches(t->type,real,&smaller);
239  if (success) {
240  *n=FALSE;
241  if (smaller && t->value_3) {
242  *v= *(REAL *)t->value_3;
243  *n=TRUE;
244  }
245  }
246  }
247  return success;
248 }
249 
262 long get_real_value(ptr_psi_term t,REAL *v,long *n)
263 {
264  long success=FALSE;
265  long smaller;
266  if (t) {
267  success=matches(t->type,real,&smaller);
268  if (success) {
269  *n=FALSE;
270  if (smaller) {
271  if (t->value_3) {
272  *v= *(REAL *)t->value_3;
273  *n=TRUE;
274  }
275  }
276  else {
277  if((GENERIC)t<heap_pointer) { /* RM: Jun 8 1993 */
280  t->type=real;
281  t->status=0;
282  (void)i_check_out(t);
283  }
284  }
285  }
286  }
287  return success;
288 }
289 
301 static long get_bool_value(ptr_psi_term t,REAL *v,long *n)
302 {
303  long success=FALSE;
304  long smaller;
305 
306  if(t) {
307  success=matches(t->type,boolean,&smaller);
308  if(success) {
309  *n=FALSE;
310  if(smaller) {
311  if(matches(t->type,lf_false,&smaller) && smaller) {
312  *v= 0;
313  *n=TRUE;
314  }
315  else
316  if(matches(t->type,lf_true,&smaller) && smaller) {
317  *v= 1;
318  *n=TRUE;
319  }
320  }
321  else {
322  if((GENERIC)t<heap_pointer) { /* RM: Jun 8 1993 */
325  t->type=boolean;
326  t->status=0;
327  (void)i_check_out(t);
328  }
329  }
330  }
331  }
332 
333  return success;
334 }
335 
346 {
347  ptr_psi_term u;
348 
349  u=stack_psi_term(4);
350  u->type=v?lf_true:lf_false;
351  push_goal(unify,t,u,NULL);
352 
353  /* Completely commented out by Richard on Nov 25th 1993
354  What's *your* Birthday? Maybe you'd like a Birthday-Bug-Card!
355  tried restoring 2.07 DJD no effect on test suite - removed again 2.14 DJD
356 
357  if((GENERIC)t<heap_pointer) {
358  push_ptr_value(def_ptr,&(t->type));
359  if (v) {
360  t->type=lf_true;
361  t->status=0;
362  }
363  else {
364  t->type=lf_false;
365  t->status=0;
366  }
367 
368  i_check_out(t);
369  if (t->resid)
370  release_resid(t);
371  }
372  else {
373  warningline("the persistent term '%P' appears in a boolean constraint and cannot be refined\n",t);
374  }
375  / */
376 }
377 
388 {
389  long smaller;
390  long success=TRUE;
391 
392 #ifdef prlDEBUG
393  if (t->value_3) {
394  printf("*** BUG: value already present in UNIFY_REAL_RESULT\n");
395  }
396 #endif
397 
398  if((GENERIC)t<heap_pointer) { /* RM: Jun 8 1993 */
399  deref_ptr(t);
400  assert(t->value_3==NULL); /* 10.6 */
402  t->value_3=heap_alloc(sizeof(REAL)); /* 12.5 */
403  *(REAL *)t->value_3 = v;
404 
405  (void)matches(t->type,integer,&smaller);
406 
407  if (v==floor(v)){
408  if (!smaller) {
410  t->type=integer;
411  t->status=0;
412  }
413  }
414  else
415  if (smaller)
416  success=FALSE;
417 
418  if (success) {
419  (void)i_check_out(t);
420  if (t->resid)
421  release_resid(t);
422  }
423  }
424  else {
425  warningline("the persistent term '%P' appears in an arithmetic constraint and cannot be refined\n",t);
426  }
427 
428  return success;
429 }
430 
431 
432 
440 static long c_gt()
441 {
442  long success=TRUE;
443  ptr_psi_term arg1,arg2,arg3,t;
444  long num1,num2,num3;
445  REAL val1,val2,val3;
446 
447  t=aim->aaaa_1;
448  deref_ptr(t);
449  get_two_args(t->attr_list,&arg1,&arg2);
450  arg3=aim->bbbb_1;
451 
452  if (arg1) {
453  deref(arg1);
454  success=get_real_value(arg1,&val1,&num1);
455  if(success && arg2) {
456  deref(arg2);
457  deref_args(t,set_1_2);
458  success=get_real_value(arg2,&val2,&num2);
459  }
460  }
461 
462  if(success)
463  if(arg1 && arg2) {
464  deref(arg3);
465  success=get_bool_value(arg3,&val3,&num3);
466  if(success)
467  switch(num1+num2*2+num3*4) {
468  case 0:
469  residuate2(arg1,arg2);
470  break;
471  case 1:
472  residuate(arg2);
473  break;
474  case 2:
475  residuate(arg1);
476  break;
477  case 3:
478  unify_bool_result(arg3,(val1>val2));
479  break;
480  case 4:
481  residuate2(arg1,arg2);
482  break;
483  case 5:
484  residuate(arg2);
485  break;
486  case 6:
487  residuate(arg1);
488  break;
489  case 7:
490  success=(val3==(REAL)(val1>val2));
491  break;
492  }
493  }
494  else
495  curry();
496 
497  nonnum_warning(t,arg1,arg2);
498  return success;
499 }
500 
508 static long c_equal()
509 {
510  long success=TRUE;
511  ptr_psi_term arg1,arg2,arg3,t;
512  long num1,num2,num3;
513  REAL val1,val2,val3;
514 
515  t=aim->aaaa_1;
516  deref_ptr(t);
517  get_two_args(t->attr_list,&arg1,&arg2);
518  arg3=aim->bbbb_1;
519 
520  if(arg1) {
521  deref(arg1);
522  success=get_real_value(arg1,&val1,&num1);
523  if(success && arg2) {
524  deref(arg2);
525  deref_args(t,set_1_2);
526  success=get_real_value(arg2,&val2,&num2);
527  }
528  }
529 
530  if(success)
531  if(arg1 && arg2) {
532  deref(arg3);
533  success=get_bool_value(arg3,&val3,&num3);
534  if(success)
535  switch(num1+2*num2+4*num3) {
536  case 0:
537  if(arg1==arg2)
538  unify_bool_result(arg3,TRUE);
539  else
540  residuate2(arg1,arg2);
541  break;
542  case 1:
543  residuate2(arg2,arg3);
544  break;
545  case 2:
546  residuate2(arg1,arg3);
547  break;
548  case 3:
549  unify_bool_result(arg3,(val1==val2));
550  break;
551  case 4:
552  if(arg1==arg2 && !val3)
553  success=FALSE;
554  else
555  residuate2(arg1,arg2);
556  break;
557  case 5:
558  if(!val3)
559  residuate(arg2);
560  else
561  success=unify_real_result(arg2,val1);
562  break;
563  case 6:
564  if(!val3)
565  residuate(arg1);
566  else
567  success=unify_real_result(arg1,val2);
568  break;
569  case 7:
570  success=(val3==(REAL)(val1==val2));
571  break;
572  }
573  }
574  else
575  curry();
576 
577  nonnum_warning(t,arg1,arg2);
578  return success;
579 }
580 
581 /*** RM: 9 Dec 1992 (START) ***/
582 
590 static long c_eval_disjunction()
591 
592 {
593  ptr_psi_term arg1,arg2,funct,result;
594 
595 
596  funct=aim->aaaa_1;
597  deref_ptr(funct);
598  result=aim->bbbb_1;
599  get_two_args(funct->attr_list,&arg1,&arg2);
600 
601  /* deref_args(funct,set_1_2); Don't know about this */
602 
603  if (arg1 && arg2) {
604  deref_ptr(arg1);
605  deref_ptr(arg2);
606 
607  resid_aim=NULL; /* Function evaluation is over */
608 
609  if(arg2->type!=disj_nil) /* RM: Feb 1 1993 */
610  /* Create the alternative */
611  push_choice_point(eval,arg2,result,(GENERIC)funct->type->rule);
612 
613  /* Unify the result with the first argument */
614  push_goal(unify,result,arg1,NULL);
615  (void)i_check_out(arg1);
616  }
617  else {
618  Errorline("malformed disjunction '%P'\n",funct);
619  return (c_abort());
620  }
621 
622  return TRUE;
623 }
624 
625 /*** RM: 9 Dec 1992 (END) ***/
626 
627 
634 static long c_lt()
635 {
636  long success=TRUE;
637  ptr_psi_term arg1,arg2,arg3,t;
638  long num1,num2,num3;
639  REAL val1,val2,val3;
640 
641  t=aim->aaaa_1;
642  deref_ptr(t);
643  get_two_args(t->attr_list,&arg1,&arg2);
644  arg3=aim->bbbb_1;
645 
646  if(arg1) {
647  deref(arg1);
648  success=get_real_value(arg1,&val1,&num1);
649  if(success && arg2) {
650  deref(arg2);
651  deref_args(t,set_1_2);
652  success=get_real_value(arg2,&val2,&num2);
653  }
654  }
655 
656  if(success)
657  if(arg1 && arg2) {
658  deref(arg3);
659  success=get_bool_value(arg3,&val3,&num3);
660  if(success)
661  switch(num1+num2*2+num3*4) {
662  case 0:
663  residuate2(arg1,arg2);
664  break;
665  case 1:
666  residuate(arg2);
667  break;
668  case 2:
669  residuate(arg1);
670  break;
671  case 3:
672  unify_bool_result(arg3,(val1<val2));
673  break;
674  case 4:
675  residuate2(arg1,arg2);
676  break;
677  case 5:
678  residuate(arg2);
679  break;
680  case 6:
681  residuate(arg1);
682  break;
683  case 7:
684  success=(val3==(REAL)(val1<val2));
685  break;
686  }
687  }
688  else
689  curry();
690 
691  nonnum_warning(t,arg1,arg2);
692  return success;
693 }
694 
702 static long c_gtoe()
703 {
704  long success=TRUE;
705  ptr_psi_term arg1,arg2,arg3,t;
706  long num1,num2,num3;
707  REAL val1,val2,val3;
708 
709  t=aim->aaaa_1;
710  deref_ptr(t);
711  get_two_args(t->attr_list,&arg1,&arg2);
712  arg3=aim->bbbb_1;
713 
714  if(arg1) {
715  deref(arg1);
716  success=get_real_value(arg1,&val1,&num1);
717  if(success && arg2) {
718  deref(arg2);
719  deref_args(t,set_1_2);
720  success=get_real_value(arg2,&val2,&num2);
721  }
722  }
723 
724  if(success)
725  if(arg1 && arg2) {
726  deref(arg3);
727  success=get_bool_value(arg3,&val3,&num3);
728  if(success)
729  switch(num1+num2*2+num3*4) {
730  case 0:
731  residuate2(arg1,arg2);
732  break;
733  case 1:
734  residuate(arg2);
735  break;
736  case 2:
737  residuate(arg1);
738  break;
739  case 3:
740  unify_bool_result(arg3,(val1>=val2));
741  break;
742  case 4:
743  residuate2(arg1,arg2);
744  break;
745  case 5:
746  residuate(arg2);
747  break;
748  case 6:
749  residuate(arg1);
750  break;
751  case 7:
752  success=(val3==(REAL)(val1>=val2));
753  break;
754  }
755  }
756  else
757  curry();
758 
759  nonnum_warning(t,arg1,arg2);
760  return success;
761 }
762 
770 static long c_ltoe()
771 {
772  long success=TRUE;
773  ptr_psi_term arg1,arg2,arg3,t;
774  long num1,num2,num3;
775  REAL val1,val2,val3;
776 
777  t=aim->aaaa_1;
778  deref_ptr(t);
779  get_two_args(t->attr_list,&arg1,&arg2);
780  arg3=aim->bbbb_1;
781 
782  if(arg1) {
783  deref(arg1);
784  success=get_real_value(arg1,&val1,&num1);
785  if(success && arg2) {
786  deref(arg2);
787  deref_args(t,set_1_2);
788  success=get_real_value(arg2,&val2,&num2);
789  }
790  }
791 
792  if(success)
793  if(arg1 && arg2) {
794  deref(arg3);
795  success=get_bool_value(arg3,&val3,&num3);
796  if(success)
797  switch(num1+num2*2+num3*4) {
798  case 0:
799  residuate2(arg1,arg2);
800  break;
801  case 1:
802  residuate(arg2);
803  break;
804  case 2:
805  residuate(arg1);
806  break;
807  case 3:
808  unify_bool_result(arg3,(val1<=val2));
809  break;
810  case 4:
811  residuate2(arg1,arg2);
812  break;
813  case 5:
814  residuate(arg2);
815  break;
816  case 6:
817  residuate(arg1);
818  break;
819  case 7:
820  success=(val3==(REAL)(val1<=val2));
821  break;
822  }
823  }
824  else
825  curry();
826 
827  nonnum_warning(t,arg1,arg2);
828  return success;
829 }
830 
839 static long c_boolpred()
840 {
841  long success=TRUE,succ,lesseq;
842  ptr_psi_term t,arg1;
843 
844  t=aim->aaaa_1;
845  deref_ptr(t);
846  get_one_arg(t->attr_list,&arg1);
847  if (arg1) {
848  deref(arg1);
849  deref_args(t,set_1);
850  if (sub_type(boolean,arg1->type)) {
851  residuate(arg1);
852  }
853  else {
854  succ=matches(arg1->type,lf_true,&lesseq);
855  if (succ) {
856  if (lesseq) {
857  /* Function returns lf_true: success. */
858  }
859  else
860  residuate(arg1);
861  }
862  else {
863  succ=matches(arg1->type,lf_false,&lesseq);
864  if (succ) {
865  if (lesseq) {
866  /* Function returns lf_false: failure. */
867  success=FALSE;
868  }
869  else
870  residuate(arg1);
871  }
872  else {
873  /* Both lf_true and false are disentailed. */
874  if (arg1->type->type_def==(def_type)predicate) {
876  }
877  else {
878  Errorline("function result '%P' should be a boolean or a predicate.\n",
879  arg1);
880  return (c_abort());
881  }
882  }
883  }
884  }
885  }
886  else {
887  Errorline("missing argument to '*boolpred*'.\n");
888  return (c_abort());
889  }
890 
891  return success;
892 }
893 
899 static long get_bool(ptr_definition typ)
900 {
901  if (sub_type(typ,lf_true)) return TRUE;
902  else if (sub_type(typ,lf_false)) return FALSE;
903  else return UNDEF;
904 }
905 
912 static void unify_bool(ptr_psi_term arg)
913 {
914  ptr_psi_term tmp;
915 
916  tmp=stack_psi_term(4);
917  tmp->type=boolean;
918  push_goal(unify,tmp,arg,(GENERIC)NULL);
919 }
920 
929 static long c_logical_main(long sel)
930 {
931  long success=TRUE;
932  ptr_psi_term funct,arg1,arg2,arg3;
933  long sm1, sm2, sm3;
934  long a1comp, a2comp, a3comp;
935  long a1, a2, a3;
936 
937  funct=aim->aaaa_1;
938  deref_ptr(funct);
939  get_two_args(funct->attr_list,&arg1,&arg2);
940  if (arg1 && arg2) {
941  deref(arg1);
942  deref(arg2);
943  deref_args(funct,set_1_2);
944  arg3=aim->bbbb_1;
945  deref(arg3);
946 
947  a1comp = matches(arg1->type,boolean,&sm1);
948  a2comp = matches(arg2->type,boolean,&sm2);
949  a3comp = matches(arg3->type,boolean,&sm3);
950  if (a1comp && a2comp && a3comp) {
951  a1 = get_bool(arg1->type);
952  a2 = get_bool(arg2->type);
953  a3 = get_bool(arg3->type);
954  if (a1== !sel || a2== !sel) {
955  unify_bool_result(arg3,!sel);
956  } else if (a1==sel) {
957  /* tmp=stack_psi_term(4); */
958  /* tmp->type=boolean; */
959  /* push_goal(unify,tmp,arg3,NULL); */
960  push_goal(unify,arg2,arg3,(GENERIC)NULL);
961  } else if (a2==sel) {
962  /* tmp=stack_psi_term(4); */
963  /* tmp->type=boolean; */
964  /* push_goal(unify,tmp,arg3,NULL); */
965  push_goal(unify,arg1,arg3,(GENERIC)NULL);
966  } else if (a3==sel) {
967  unify_bool_result(arg1,sel);
968  unify_bool_result(arg2,sel);
969  } else if (arg1==arg2) {
970  /* tmp=stack_psi_term(4); */
971  /* tmp->type=boolean; */
972  /* push_goal(unify,tmp,arg3,NULL); */
973  push_goal(unify,arg1,arg3,(GENERIC)NULL);
974  } else {
975  if (a1==UNDEF) residuate(arg1);
976  if (a2==UNDEF) residuate(arg2);
977  if (a3==UNDEF) residuate(arg3);
978  }
979  if (!sm1) unify_bool(arg1);
980  if (!sm2) unify_bool(arg2);
981  if (!sm3) unify_bool(arg3);
982  }
983  else {
984  success=FALSE;
985  Errorline("Non-boolean argument or result in '%P'.\n",funct);
986  }
987  }
988  else
989  curry();
990 
991  return success;
992 }
993 
1001 static long c_and()
1002 {
1003  return c_logical_main(TRUE);
1004 }
1005 
1014 static long c_or()
1015 {
1016  return c_logical_main(FALSE);
1017 }
1018 
1027 static long c_not()
1028 {
1029  long success=TRUE;
1030  ptr_psi_term funct,arg1,arg2;
1031  long sm1, sm2;
1032  long a1comp, a2comp;
1033  long a1, a2;
1034 
1035  funct=aim->aaaa_1;
1036  deref_ptr(funct);
1037  get_one_arg(funct->attr_list,&arg1);
1038  if (arg1) {
1039  deref(arg1);
1040  deref_args(funct,set_1);
1041  arg2=aim->bbbb_1;
1042  deref(arg2);
1043 
1044  a1comp = matches(arg1->type,boolean,&sm1);
1045  a2comp = matches(arg2->type,boolean,&sm2);
1046  if (a1comp && a2comp) {
1047  a1 = get_bool(arg1->type);
1048  a2 = get_bool(arg2->type);
1049  if (a1==TRUE || a1==FALSE) {
1050  unify_bool_result(arg2,!a1);
1051  } else if (a2==TRUE || a2==FALSE) {
1052  unify_bool_result(arg1,!a2);
1053  } else if (arg1==arg2) {
1054  success=FALSE;
1055  } else {
1056  if (a1==UNDEF) residuate(arg1);
1057  if (a2==UNDEF) residuate(arg2);
1058  }
1059  if (!sm1) unify_bool(arg1);
1060  if (!sm2) unify_bool(arg2);
1061  }
1062  else {
1063  success=FALSE;
1064  Errorline("Non-boolean argument or result in '%P'.\n",funct);
1065  }
1066  }
1067  else
1068  curry();
1069 
1070  return success;
1071 }
1072 
1081 static long c_xor()
1082 {
1083  long success=TRUE;
1084  ptr_psi_term funct,arg1,arg2,arg3;
1085  long sm1, sm2, sm3;
1086  long a1comp, a2comp, a3comp;
1087  long a1, a2, a3;
1088 
1089  funct=aim->aaaa_1;
1090  deref_ptr(funct);
1091  get_two_args(funct->attr_list,&arg1,&arg2);
1092  if (arg1 && arg2) {
1093  deref(arg1);
1094  deref(arg2);
1095  deref_args(funct,set_1_2);
1096  arg3=aim->bbbb_1;
1097  deref(arg3);
1098 
1099  a1comp = matches(arg1->type,boolean,&sm1);
1100  a2comp = matches(arg2->type,boolean,&sm2);
1101  a3comp = matches(arg3->type,boolean,&sm3);
1102  if (a1comp && a2comp && a3comp) {
1103  a1 = get_bool(arg1->type);
1104  a2 = get_bool(arg2->type);
1105  a3 = get_bool(arg3->type);
1106  if ((a1==TRUE || a1==FALSE) && (a2==TRUE || a2==FALSE)) {
1107  unify_bool_result(arg3, a1^a2);
1108  } else if ((a1==TRUE || a1==FALSE) && (a3==TRUE || a3==FALSE)) {
1109  unify_bool_result(arg2, a1^a3);
1110  } else if ((a3==TRUE || a3==FALSE) && (a2==TRUE || a2==FALSE)) {
1111  unify_bool_result(arg1, a3^a2);
1112 
1113  } else if (a1==TRUE && arg3==arg2) {
1114  success=FALSE;
1115  } else if (a2==TRUE && arg3==arg2) {
1116  success=FALSE;
1117  } else if (a3==TRUE && arg1==arg2) {
1118  success=FALSE;
1119 
1120  } else if (a1==FALSE) {
1121  push_goal(unify,arg2,arg3,(GENERIC)NULL);
1122  } else if (a2==FALSE) {
1123  push_goal(unify,arg1,arg3,(GENERIC)NULL);
1124  } else if (a3==FALSE) {
1125  push_goal(unify,arg1,arg2,(GENERIC)NULL);
1126 
1127  } else if (arg1==arg2) {
1128  unify_bool_result(arg3,FALSE);
1129  } else if (arg1==arg3) {
1130  unify_bool_result(arg2,FALSE);
1131  } else if (arg3==arg2) {
1132  unify_bool_result(arg1,FALSE);
1133  } else {
1134  if (a1==UNDEF) residuate(arg1);
1135  if (a2==UNDEF) residuate(arg2);
1136  if (a3==UNDEF) residuate(arg3);
1137  }
1138  if (!sm1) unify_bool(arg1);
1139  if (!sm2) unify_bool(arg2);
1140  if (!sm3) unify_bool(arg3);
1141  }
1142  else {
1143  success=FALSE;
1144  Errorline("Non-boolean argument or result in '%P'.\n",funct);
1145  }
1146  }
1147  else
1148  curry();
1149 
1150  return success;
1151 }
1152 
1161 static long c_apply()
1162 {
1163  long success=TRUE;
1164  ptr_psi_term funct,other;
1165  ptr_node n,fattr;
1166 
1167  funct=aim->aaaa_1;
1168  deref_ptr(funct);
1170  if (n) {
1171  other=(ptr_psi_term )n->data;
1172  deref(other);
1173  if (other->type==top)
1174  residuate(other);
1175  else
1176  if(other->type && other->type->type_def!=(def_type)function_it) {
1177  success=FALSE;
1178  Errorline("argument is not a function in %P.\n",funct);
1179  }
1180  else {
1181  /* What we really want here is to merge all attributes in */
1182  /* funct->attr_list, except '*functor*', into other->attr_list. */
1183  clear_copy();
1184  other=distinct_copy(other);
1185  fattr=distinct_tree(funct->attr_list); /* Make distinct copy: PVR */
1186  push_goal(eval,other,aim->bbbb_1,(GENERIC)other->type->rule);
1187  merge_unify(&(other->attr_list),fattr);
1188  /* We don't want to remove anything from funct->attr_list here. */
1190  }
1191  }
1192  else
1193  curry();
1194 
1195  return success;
1196 }
1197 
1208 static long c_project()
1209 
1210 {
1211  long success=TRUE;
1212  ptr_psi_term arg1,arg2,funct,result;
1213  ptr_node n;
1214  char *label;
1215  double v;
1216 
1217  /* char *thebuffer="integer"; 18.5 */
1218  char thebuffer[20]; /* Maximum number of digits in an integer */
1219 
1220  funct=aim->aaaa_1;
1221  deref_ptr(funct);
1222  result=aim->bbbb_1;
1223  get_two_args(funct->attr_list,&arg1,&arg2);
1224  if (arg2 && arg1) {
1225  deref(arg1);
1226  deref(arg2);
1227  deref_args(funct,set_1_2);
1228 
1229  label=NULL;
1230 
1231  /* RM: Jul 20 1993: Don't residuate on 'string' etc... */
1232  if(arg2->type!=top) {
1233  if(arg2->value_3 && sub_type(arg2->type,quoted_string)) /* 10.8 */
1234  label=(char *)arg2->value_3;
1235  else
1236  if(arg2->value_3 && sub_type(arg2->type,integer)) { /* 10.8 */
1237  v= *(REAL *)arg2->value_3;
1238  if(v==floor(v)) {
1239  (void)snprintf(thebuffer,20,"%ld",(long)v);
1240  label=heap_copy_string(thebuffer); /* A little voracious */
1241  }
1242  else { /* RM: Jul 28 1993 */
1243  Errorline("non-integer numeric feature in %P\n",funct);
1244  return FALSE;
1245  }
1246  }
1247  else {
1248  if(arg2->type->keyword->private_feature) /* RM: Mar 12 1993 */
1249  label=arg2->type->keyword->combined_name;
1250  else
1251  label=arg2->type->keyword->symbol;
1252  }
1253  }
1254 
1255  if (label) {
1256  n=find(FEATCMP,(char *)label,arg1->attr_list);
1257 
1258  if (n)
1260  else if (arg1->type->type_def==(def_type)function_it && !(arg1->flags&QUOTED_TRUE)) {
1261  Errorline("attempt to add a feature to curried function %P\n",
1262  arg1);
1263  return FALSE;
1264  }
1265  else {
1266  deref_ptr(result);
1267  if((GENERIC)arg1>=heap_pointer) { /* RM: Feb 9 1993 */
1268  if((GENERIC)result<heap_pointer)
1269  push_psi_ptr_value(result,(GENERIC *)&(result->coref));
1270  clear_copy();
1271  result->coref=inc_heap_copy(result);
1272  (void)heap_insert(FEATCMP,label,&(arg1->attr_list),(GENERIC)result->coref);
1273  }
1274  else {
1275 
1276 #ifdef ARITY /* RM: Mar 29 1993 */
1277  arity_add(arg1,label);
1278 #endif
1279 
1280  /* RM: Mar 25 1993 */
1281  if(arg1->type->always_check || arg1->attr_list)
1282  (void)bk_stack_insert(FEATCMP,label,&(arg1->attr_list),(GENERIC)result);
1283  else {
1284  (void)bk_stack_insert(FEATCMP,label,&(arg1->attr_list),(GENERIC)result);
1285  fetch_def_lazy(arg1, arg1->type,arg1->type,NULL,NULL,0,0); // djd added zeros
1286  }
1287 
1288  if (arg1->resid)
1289  release_resid(arg1);
1290  }
1291  }
1292  }
1293  else
1294  residuate(arg2);
1295  }
1296  else
1297  curry();
1298 
1299  return success;
1300 }
1301 
1309 static long c_diff()
1310 {
1311  long success=TRUE;
1312  ptr_psi_term arg1,arg2,arg3,t;
1313  long num1,num2,num3;
1314  REAL val1,val2,val3;
1315 
1316  t=aim->aaaa_1;
1317  deref_ptr(t);
1318  get_two_args(t->attr_list,&arg1,&arg2);
1319  arg3=aim->bbbb_1;
1320 
1321  if(arg1) {
1322  deref(arg1);
1323  success=get_real_value(arg1,&val1,&num1);
1324  if(success && arg2) {
1325  deref(arg2);
1326  deref_args(t,set_1_2);
1327  success=get_real_value(arg2,&val2,&num2);
1328  }
1329  }
1330 
1331  if(success)
1332  if(arg1 && arg2) {
1333  deref(arg3);
1334  success=get_bool_value(arg3,&val3,&num3);
1335  if(success)
1336  switch(num1+2*num2+4*num3) {
1337  case 0:
1338  if(arg1==arg2)
1339  unify_bool_result(arg3,FALSE);
1340  else
1341  residuate2(arg1,arg2);
1342  break;
1343  case 1:
1344  residuate2(arg2,arg3);
1345  break;
1346  case 2:
1347  residuate2(arg1,arg3);
1348  break;
1349  case 3:
1350  unify_bool_result(arg3,(val1!=val2));
1351  break;
1352  case 4:
1353  if(arg1==arg2 && val3)
1354  success=FALSE;
1355  else
1356  residuate2(arg1,arg2);
1357  break;
1358  case 5:
1359  if(val3)
1360  residuate(arg2);
1361  else
1362  success=unify_real_result(arg2,val1);
1363  break;
1364  case 6:
1365  if(val3)
1366  residuate(arg1);
1367  else
1368  success=unify_real_result(arg1,val2);
1369  break;
1370  case 7:
1371  success=(val3==(REAL)(val1!=val2));
1372  break;
1373  }
1374  }
1375  else
1376  curry();
1377 
1378  nonnum_warning(t,arg1,arg2);
1379  return success;
1380 }
1381 
1389 static long c_fail()
1390 {
1391  return FALSE;
1392 }
1393 
1401 static long c_succeed()
1402 {
1403  ptr_psi_term t;
1404 
1405  t=aim->aaaa_1;
1406  deref_args(t,set_empty);
1407  return TRUE;
1408 }
1409 
1417 static long c_repeat()
1418 {
1419  ptr_psi_term t;
1420 
1421  t=aim->aaaa_1;
1422  deref_args(t,set_empty);
1424  return TRUE;
1425 }
1426 
1434 static long c_var()
1435 {
1436  long success=TRUE;
1437  ptr_psi_term arg1,result,g,other;
1438 
1439  g=aim->aaaa_1;
1440  deref_ptr(g);
1441  result=aim->bbbb_1;
1442  deref(result);
1443  get_one_arg(g->attr_list,&arg1);
1444  if (arg1) {
1445  deref(arg1);
1446  deref_args(g,set_1);
1447  other=stack_psi_term(4); /* 19.11 */
1448  other->type=((arg1->type==top)&&(arg1->attr_list==NULL))?lf_true:lf_false;
1449  resid_aim=NULL;
1450  push_goal(unify,result,other,NULL);
1451  }
1452  else {
1453  curry();
1454  /* Errorline("argument missing in %P.\n",t); */
1455  /* return c_abort(); */
1456  }
1457 
1458  return success;
1459 }
1460 
1468 static long c_nonvar()
1469 {
1470  long success=TRUE;
1471  ptr_psi_term arg1,result,g,other;
1472 
1473  g=aim->aaaa_1;
1474  deref_ptr(g);
1475  result=aim->bbbb_1;
1476  deref(result);
1477  get_one_arg(g->attr_list,&arg1);
1478  if (arg1) {
1479  deref(arg1);
1480  deref_args(g,set_1);
1481  other=stack_psi_term(4); /* 19.11 */
1482  other->type=((arg1->type==top)&&(arg1->attr_list==NULL))?lf_false:lf_true;
1483  resid_aim=NULL;
1484  push_goal(unify,result,other,NULL);
1485  }
1486  else {
1487  curry();
1488  /* Errorline("argument missing in %P.\n",t); */
1489  /* return c_abort(); */
1490  }
1491 
1492  return success;
1493 }
1494 
1502 static long c_is_function()
1503 {
1504  long success=TRUE;
1505  ptr_psi_term arg1,result,g,other;
1506 
1507  g=aim->aaaa_1;
1508  deref_ptr(g);
1509  result=aim->bbbb_1;
1510  deref(result);
1511  get_one_arg(g->attr_list,&arg1);
1512  if (arg1) {
1513  deref(arg1);
1514  deref_args(g,set_1);
1515  other=stack_psi_term(4); /* 19.11 */
1517  resid_aim=NULL;
1518  push_goal(unify,result,other,NULL);
1519  }
1520  else {
1521  curry();
1522  /* Errorline("argument missing in %P.\n",t); */
1523  /* return c_abort(); */
1524  }
1525 
1526  return success;
1527 }
1528 
1529 
1537 static long c_is_predicate()
1538 {
1539  long success=TRUE;
1540  ptr_psi_term arg1,result,g,other;
1541 
1542  g=aim->aaaa_1;
1543  deref_ptr(g);
1544  result=aim->bbbb_1;
1545  deref(result);
1546  get_one_arg(g->attr_list,&arg1);
1547  if (arg1) {
1548  deref(arg1);
1549  deref_args(g,set_1);
1550  other=stack_psi_term(4); /* 19.11 */
1551  other->type=(arg1->type->type_def==(def_type)predicate)?lf_true:lf_false;
1552  resid_aim=NULL;
1553  push_goal(unify,result,other,NULL);
1554  }
1555  else {
1556  curry();
1557  /* Errorline("argument missing in %P.\n",t); */
1558  /* return c_abort(); */
1559  }
1560 
1561  return success;
1562 }
1563 
1571 static long c_is_sort()
1572 {
1573  long success=TRUE;
1574  ptr_psi_term arg1,result,g,other;
1575 
1576  g=aim->aaaa_1;
1577  deref_ptr(g);
1578  result=aim->bbbb_1;
1579  deref(result);
1580  get_one_arg(g->attr_list,&arg1);
1581  if (arg1) {
1582  deref(arg1);
1583  deref_args(g,set_1);
1584  other=stack_psi_term(4); /* 19.11 */
1585  other->type=(arg1->type->type_def==(def_type)type_it)?lf_true:lf_false;
1586  resid_aim=NULL;
1587  push_goal(unify,result,other,NULL);
1588  }
1589  else {
1590  curry();
1591  /* Errorline("argument missing in %P.\n",t); */
1592  /* return c_abort(); */
1593  }
1594 
1595  return success;
1596 }
1597 
1607 {
1608  ptr_node n=t->attr_list;
1609 
1610  if (n && n->left==NULL && n->right==NULL && !featcmp(n->key,one)) {
1611  *arg1=(ptr_psi_term)n->data;
1612  return TRUE;
1613  }
1614  else
1615  return FALSE;
1616 }
1617 
1626 static long c_dynamic()
1627 {
1628  ptr_psi_term t=aim->aaaa_1;
1629  deref_ptr(t);
1630  /* mark_quote(t); 14.9 */
1632  return TRUE;
1633 }
1634 
1643 static long c_static()
1644 {
1645  ptr_psi_term t=aim->aaaa_1;
1646  deref_ptr(t);
1647  /* mark_quote(t); 14.9 */
1649  return TRUE;
1650 }
1651 
1662 static long c_delay_check()
1663 {
1664  ptr_psi_term t=aim->aaaa_1;
1665 
1666  deref_ptr(t);
1667  /* mark_quote(t); 14.9 */
1670  return TRUE;
1671 }
1672 
1681 static long c_non_strict()
1682 {
1683  ptr_psi_term t=aim->aaaa_1;
1684 
1685  deref_ptr(t);
1686  /* mark_quote(t); 14.9 */
1688  return TRUE;
1689 }
1690 
1698 static long c_op()
1699 {
1700  // long declare_operator();
1701  ptr_psi_term t=aim->aaaa_1;
1702 
1703  return declare_operator(t);
1704 }
1705 
1712 long file_exists(char *s)
1713 {
1714  FILE *f;
1715  char *e;
1716  long success=FALSE;
1717 
1718  e=expand_file_name(s);
1719  if ((f=fopen(e,"r"))) {
1720  (void)fclose(f);
1721  success=TRUE;
1722  }
1723  return success;
1724 }
1725 
1733 static long c_exists()
1734 {
1735  ptr_psi_term g;
1736  ptr_node n;
1737  long success=TRUE;
1738  ptr_psi_term arg1;
1739  char *c_arg1;
1740 
1741  g=aim->aaaa_1;
1742  deref_ptr(g);
1743 
1744  if (success) {
1745  n=find(FEATCMP,one,g->attr_list);
1746  if (n) {
1747  arg1= (ptr_psi_term )n->data;
1748  deref(arg1);
1749  deref_args(g,set_1);
1750  if (!psi_to_string(arg1,&c_arg1)) {
1751  success=FALSE;
1752  Errorline("bad argument in %P.\n",g);
1753  }
1754  }
1755  else {
1756  success=FALSE;
1757  Errorline("bad argument in %P.\n",g);
1758  }
1759  }
1760 
1761  if (success)
1762  success=file_exists(c_arg1);
1763 
1764  return success;
1765 }
1766 
1775 static long c_load()
1776 {
1777  long success=FALSE;
1778  ptr_psi_term arg1,arg2,t;
1779  char *fn;
1780  t=aim->aaaa_1;
1781  deref_ptr(t);
1782  get_two_args(t->attr_list,&arg1,&arg2);
1783  if(arg1) {
1784  deref(arg1);
1785  deref_args(t,set_1);
1786  if (psi_to_string(arg1,&fn)) {
1787  success=open_input_file(fn);
1788  if (success) {
1789  file_date+=2;
1791  file_date+=2;
1792  }
1793  }
1794  else {
1795  Errorline("bad file name in %P.\n",t);
1796  success=FALSE;
1797  }
1798  }
1799  else {
1800  Errorline("no file name in %P.\n",t);
1801  success=FALSE;
1802  }
1803 
1804  return success;
1805 }
1806 
1815 static long c_get_choice()
1816 {
1817  long gts,success=TRUE;
1818  ptr_psi_term funct,result;
1819 
1820  funct=aim->aaaa_1;
1821  deref_ptr(funct);
1822  result=aim->bbbb_1;
1823  deref_args(funct,set_empty);
1824  if (choice_stack)
1825  gts=choice_stack->time_stamp;
1826  else
1827  gts=global_time_stamp-1;
1828  /* gts=INIT_TIME_STAMP; PVR 11.2.94 */
1829  push_goal(unify,result,real_stack_psi_term(4,(REAL)gts),NULL);
1830 
1831  return success;
1832 }
1833 
1854 static long c_set_choice()
1855 {
1856  REAL gts_r;
1857  long gts;
1858  long num,success=TRUE;
1859  ptr_psi_term t,arg1;
1860  ptr_choice_point cutpt;
1861 
1862  t=aim->aaaa_1;
1863  deref_ptr(t);
1864  get_one_arg(t->attr_list,&arg1);
1865  if (arg1) {
1866  deref(arg1);
1867  deref_args(t,set_1);
1868  success = get_real_value(arg1,&gts_r,&num);
1869  if (success) {
1870  if (num) {
1871  gts=(unsigned long)gts_r;
1872  if (choice_stack) {
1873  cutpt=choice_stack;
1874  while (cutpt && cutpt->time_stamp>gts) cutpt=cutpt->next;
1875  if (choice_stack!=cutpt) {
1876  choice_stack=cutpt;
1877 #ifdef CLEAN_TRAIL
1879 #endif
1880  }
1881  }
1882  }
1883  else {
1884  Errorline("bad argument to %P.\n",t);
1885  success=FALSE;
1886  }
1887  }
1888  else {
1889  Errorline("bad argument %P.\n",t);
1890  success=FALSE;
1891  }
1892  }
1893  else
1894  curry();
1895 
1896  return success;
1897 }
1898 
1911 static long c_exists_choice()
1912 {
1913  REAL gts_r;
1914  long ans,gts1,gts2,num,success=TRUE;
1915  ptr_psi_term funct,result,arg1,arg2,ans_term;
1916  ptr_choice_point cp;
1917 
1918  funct=aim->aaaa_1;
1919  deref_ptr(funct);
1920  result=aim->bbbb_1;
1921  deref_args(funct,set_empty);
1922  get_two_args(funct->attr_list,&arg1,&arg2);
1923  if (arg1 && arg2) {
1924  deref(arg1);
1925  deref(arg2);
1926  deref_args(funct,set_1_2);
1927  success = get_real_value(arg1,&gts_r,&num);
1928  if (success && num) {
1929  gts1 = (unsigned long) gts_r;
1930  success = get_real_value(arg2,&gts_r,&num);
1931  if (success && num) {
1932  gts2 = (unsigned long) gts_r;
1933  cp = choice_stack;
1934  if (cp) {
1935  while (cp && cp->time_stamp>gts2) cp=cp->next;
1936  ans=(cp && cp->time_stamp>gts1);
1937  }
1938  else
1939  ans=FALSE;
1940  ans_term=stack_psi_term(4);
1941  ans_term->type=ans?lf_true:lf_false;
1942  push_goal(unify,result,ans_term,NULL);
1943  }
1944  else {
1945  Errorline("bad second argument to %P.\n",funct);
1946  success=FALSE;
1947  }
1948  }
1949  else {
1950  Errorline("bad first argument %P.\n",funct);
1951  success=FALSE;
1952  }
1953  }
1954  else
1955  curry();
1956 
1957  return success;
1958 }
1959 
1968 static long c_print_variables()
1969 {
1970  long success=TRUE;
1971 
1972  (void)print_variables(TRUE); /* 21.1 */
1973 
1974  return success;
1975 }
1976 
1984 static void set_parse_queryflag(ptr_node thelist, long sort)
1985 {
1986  ptr_node n; /* node pointing to argument 2 */
1987  ptr_psi_term arg; /* argumenrt 2 psi-term */
1988  ptr_psi_term queryflag; /* query term created by this function */
1989 
1990  n=find(FEATCMP,two,thelist);
1991  if (n) {
1992  /* there was a second argument */
1993  arg=(ptr_psi_term)n->data;
1994  queryflag=stack_psi_term(4);
1995  queryflag->type =
1997  ((sort==QUERY)?"query":
1998  ((sort==FACT)?"declaration":"error")));
1999  push_goal(unify,queryflag,arg,NULL);
2000  }
2001 }
2002 
2013 static long c_parse()
2014 {
2015  long success=TRUE;
2016  ptr_psi_term arg1,arg2,arg3,funct,result;
2017  long smaller,sort,old_var_occurred;
2018  ptr_node n;
2019  parse_block pb;
2020 
2021  funct=aim->aaaa_1;
2022  deref_ptr(funct);
2023  result=aim->bbbb_1;
2024  get_one_arg(funct->attr_list,&arg1);
2025  if (arg1) {
2026  deref(arg1);
2027  deref_args(funct,set_1);
2028  success=matches(arg1->type,quoted_string,&smaller);
2029  if (success) {
2030  if (arg1->value_3) {
2031  ptr_psi_term t;
2032 
2033  /* Parse the string in its own state */
2034  save_parse_state(&pb);
2035  init_parse_state();
2036  stringparse=TRUE;
2037  stringinput=(char*)arg1->value_3;
2038 
2039  old_var_occurred=var_occurred;
2041  t=stack_copy_psi_term(parse(&sort));
2042 
2043  /* Optional second argument returns 'query', 'declaration', or 'error'. */
2044  n=find(FEATCMP,two,funct->attr_list);
2045  if (n) {
2046  ptr_psi_term queryflag;
2047  arg2=(ptr_psi_term)n->data;
2048  queryflag=stack_psi_term(4);
2049  queryflag->type=
2051  ((sort==QUERY)?"query":((sort==FACT)?"declaration":"error"))
2052  );
2053  push_goal(unify,queryflag,arg2,NULL);
2054  }
2055 
2056  /* Optional third argument returns true or false if the psi-term
2057  contains a variable or not. */
2058  n=find(FEATCMP,three,funct->attr_list);
2059  if (n) {
2060  ptr_psi_term varflag;
2061  arg3=(ptr_psi_term)n->data;
2062  varflag=stack_psi_term(4);
2063  varflag->type=var_occurred?lf_true:lf_false;
2064  push_goal(unify,varflag,arg3,NULL);
2065  }
2066 
2067  var_occurred = var_occurred || old_var_occurred;
2069  restore_parse_state(&pb);
2070 
2071  /* parse_ok flag says whether there was a syntax error. */
2072  if (TRUE /*parse_ok*/) {
2073  mark_quote(t);
2074  push_goal(unify,t,result,NULL);
2075  }
2076  else
2077  success=FALSE;
2078  }
2079  else
2080  residuate(arg1);
2081  }
2082  else
2083  success=FALSE;
2084  }
2085  else
2086  curry();
2087 
2088  return success;
2089 }
2090 
2091 static long c_read(long);
2092 
2098 static long c_read_psi()
2099 {
2100  return (c_read(TRUE));
2101 }
2102 
2108 static long c_read_token()
2109 {
2110  return (c_read(FALSE));
2111 }
2112 
2123 static long c_read(long psi_flag)
2124 {
2125  long success=TRUE;
2126  long sort;
2127  ptr_psi_term arg1,arg2,arg3,g,t;
2128  ptr_node old_var_tree;
2129  ptr_node n;
2130  int line=line_count+1;
2131 
2132  g=aim->aaaa_1;
2133  deref_ptr(g);
2134  get_one_arg(g->attr_list,&arg1);
2135  if (arg1) {
2136  deref_args(g,set_1);
2137  if (eof_flag) {
2138  Errorline("attempt to read past end of file (%E).\n");
2139  return (abort_life(TRUE));
2140  }
2141  else {
2142  prompt="";
2143  old_var_tree=var_tree;
2144  var_tree=NULL;
2145  if (psi_flag) {
2146 
2147  t=stack_copy_psi_term(parse(&sort));
2148 
2149 
2150  /* Optional second argument returns 'query', 'declaration', or
2151  'error'. */
2152  n=find(FEATCMP,two,g->attr_list); /* RM: Jun 8 1993 */
2153  if (n) {
2154  ptr_psi_term queryflag;
2155  arg2=(ptr_psi_term)n->data;
2156  queryflag=stack_psi_term(4);
2157  queryflag->type=
2159  ((sort==QUERY)?"query":((sort==FACT)?"declaration":"error"))
2160  );
2161  push_goal(unify,queryflag,arg2,NULL);
2162  }
2163 
2164 
2165  /* Optional third argument returns the starting line number */
2166  /* RM: Oct 11 1993 */
2167  n=find(FEATCMP,three,g->attr_list);
2168  if (n) {
2169  arg3=(ptr_psi_term)n->data;
2170  g=stack_psi_term(4);
2171  g->type=integer;
2172  g->value_3=heap_alloc(sizeof(REAL));
2173  *(REAL *)g->value_3=line;
2174  push_goal(unify,g,arg3,NULL);
2175  }
2176 
2177  }
2178  else {
2179  t=stack_psi_term(0);
2180  read_token_b(t);
2181  /* RM: Jan 5 1993 removed spurious argument: &quot (??) */
2182 
2183  }
2184  if (t->type==eof) eof_flag=TRUE;
2185  var_tree=old_var_tree;
2186  }
2187 
2188  if (success) {
2189  mark_quote(t);
2190  push_goal(unify,t,arg1,NULL);
2191  /* i_check_out(t); */
2192  }
2193  }
2194  else {
2195  Errorline("argument missing in %P.\n",g);
2196  success=FALSE;
2197  }
2198 
2199  return success;
2200 }
2201 
2209 long c_halt() /* RM: Jan 8 1993 Used to be 'void' */
2210 {
2211  exit_life(TRUE);
2212 }
2213 
2220 void exit_life(long nl_flag)
2221 {
2222  (void)open_input_file("stdin");
2223  (void)times(&life_end);
2224  if (NOTQUIET) { /* 21.1 */
2225  if (nl_flag) printf("\n");
2226  printf("*** Exiting Wild_Life ");
2227  printf("[%1.3fs cpu, %1.3fs gc (%2.1f%%)]\n",
2228  (life_end.tms_utime-life_start.tms_utime)/60.0,
2229  garbage_time,
2230  garbage_time*100 / ((life_end.tms_utime-life_start.tms_utime)/60.0)
2231  );
2232  }
2233 
2234 #ifdef ARITY /* RM: Mar 29 1993 */
2235  arity_end();
2236 #endif
2237 
2238  exit(EXIT_SUCCESS);
2239 }
2240 
2247 \
2248 long c_abort() /* RM: Feb 15 1993 */
2249 {
2250  return (abort_life(TRUE));
2251 }
2252 
2259 /* 26.1 */
2260 long abort_life(int nlflag) /* RM: Feb 15 1993 */
2261 {
2263  !aborthooksym->rule->bbbb_2 ||
2265  /* Do a true abort if aborthook is not a function or is equal to 'abort'.*/
2266  main_loop_ok = FALSE;
2267  undo(NULL); /* 8.10 */
2268  if(NOTQUIET) fprintf(stderr,"\n*** Abort"); /* RM: Feb 17 1993 */
2269  if(NOTQUIET && nlflag) fprintf(stderr,"\n");/* RM: Feb 17 1993 */
2270  } else {
2271  /* Do a 'user-defined abort': initialize the system, then */
2272  /* prove the user-defined abort routine (which is set by */
2273  /* means of 'setq(aborthook,user_defined_abort)'. */
2274  ptr_psi_term aborthook;
2275 
2276  undo(NULL);
2277  init_system();
2279  stdin_cleareof();
2280  if(NOTQUIET) fprintf(stderr,"\n*** Abort"); /* RM: Feb 17 1993 */
2281  if(NOTQUIET && nlflag) fprintf(stderr,"\n");/* RM: Feb 17 1993 */
2282  aborthook=stack_psi_term(0);
2283  aborthook->type=aborthooksym;
2285  }
2286  fprintf(stderr,"\n*** END Abort");
2287  return TRUE;
2288 }
2289 
2297 static long c_not_implemented()
2298 {
2299  ptr_psi_term t;
2300 
2301  t=aim->aaaa_1;
2302  deref_ptr(t);
2303  Errorline("built-in %P is not implemented yet.\n",t);
2304  return FALSE;
2305 }
2306 
2314 static long c_declaration()
2315 {
2316  ptr_psi_term t;
2317 
2318  t=aim->aaaa_1;
2319  deref_ptr(t);
2320  Errorline("%P is a declaration, not a query.\n",t);
2321  return FALSE;
2322 }
2323 
2337 static long c_setq()
2338 {
2339  long success=FALSE;
2340  ptr_psi_term arg1,arg2,g;
2341  ptr_pair_list p;
2342  ptr_definition d;
2343 
2344  g=aim->aaaa_1;
2345  get_two_args(g->attr_list,&arg1,&arg2);
2346  if (arg1 && arg2) {
2347  deref_rec(arg2); /* RM: Jan 6 1993 */
2348  deref_ptr(arg1);
2349  d=arg1->type;
2350  if (d->type_def==(def_type)function_it || d->type_def==(def_type)undef) {
2351  if (d->type_def==(def_type)undef || !d->protected) {
2352  if (!arg1->attr_list) {
2354  d->protected=FALSE;
2355  p=HEAP_ALLOC(pair_list);
2356  p->aaaa_2=heap_psi_term(4);
2357  p->aaaa_2->type=d;
2358  clear_copy();
2359  p->bbbb_2=quote_copy(arg2,HEAP);
2360  p->next=NULL;
2361  d->rule=p;
2362  success=TRUE;
2363  }
2364  else
2365  Errorline("%P may not have arguments in %P.\n",arg1,g);
2366  }
2367  else
2368  Errorline("%P should be dynamic in %P.\n",arg1,g);
2369  }
2370  else
2371  Errorline("%P should be a function or uninterpreted in %P.\n",arg1,g);
2372  }
2373  else
2374  Errorline("%P is missing one or both arguments.\n",g);
2375 
2376  return success;
2377 }
2378 
2387 static long c_assert_first()
2388 {
2389  long success=FALSE;
2390  ptr_psi_term arg1,g;
2391 
2392  g=aim->aaaa_1;
2393  bk_mark_quote(g); /* RM: Apr 7 1993 */
2394  get_one_arg(g->attr_list,&arg1);
2396  if (arg1) {
2397  deref_ptr(arg1);
2398  assert_clause(arg1);
2399  encode_types();
2400  success=assert_ok;
2401  }
2402  else {
2403  success=FALSE;
2404  Errorline("bad clause in %P.\n",g);
2405  }
2406 
2407  return success;
2408 }
2409 
2417 static long c_assert_last()
2418 {
2419  long success=FALSE;
2420  ptr_psi_term arg1,g;
2421 
2422  g=aim->aaaa_1;
2423  bk_mark_quote(g); /* RM: Apr 7 1993 */
2424  get_one_arg(g->attr_list,&arg1);
2426  if (arg1) {
2427  deref_ptr(arg1);
2428  assert_clause(arg1);
2429  encode_types();
2430  success=assert_ok;
2431  }
2432  else {
2433  success=FALSE;
2434  Errorline("bad clause in %P.\n",g);
2435  }
2436 
2437  return success;
2438 }
2439 
2453 {
2454  long success=FALSE;
2455  ptr_psi_term head,body;
2456 
2457  bk_mark_quote(g); /* RM: Apr 7 1993 */
2458  if (t) {
2459  deref_ptr(t);
2460 
2461  if (!strcmp(t->type->keyword->symbol,"->")) {
2462  get_two_args(t->attr_list,&head,&body);
2463  if (head) {
2464  deref_ptr(head);
2465  if (head && body &&
2466  (head->type->type_def==(def_type)function_it || head->type->type_def==(def_type)undef))
2467  success=TRUE;
2468  }
2469  }
2470  else if (!strcmp(t->type->keyword->symbol,":-")) {
2471  get_two_args(t->attr_list,&head,&body);
2472  if (head) {
2473  deref_ptr(head);
2474  if (head &&
2475  (head->type->type_def==(def_type)predicate || head->type->type_def==(def_type)undef)) {
2476  success=TRUE;
2477  if (!body) {
2478  body=stack_psi_term(4);
2479  body->type=succeed;
2480  }
2481  }
2482  }
2483  }
2484  /* There is no body, so t is a fact */
2485  else if (t->type->type_def==(def_type)predicate || t->type->type_def==(def_type)undef) {
2486  head=t;
2487  body=stack_psi_term(4);
2488  body->type=succeed;
2489  success=TRUE;
2490  }
2491  }
2492 
2493  if (success) {
2494  if (r) {
2495  if (redefine(head))
2496  push_goal(del_clause,head,body,(GENERIC)&(head->type->rule));
2497  else
2498  success=FALSE;
2499  }
2500  else
2501  push_goal(clause,head,body,(GENERIC)&(head->type->rule));
2502  }
2503  else
2504  Errorline("bad argument in %s.\n", (r?"retract":"clause"));
2505 
2506  return success;
2507 }
2508 
2509 
2510 
2520 static long c_clause()
2521 {
2522  long success=FALSE;
2523  ptr_psi_term arg1,arg2,g;
2524 
2525  g=aim->aaaa_1;
2526  get_two_args(g->attr_list,&arg1,&arg2);
2527  success=pred_clause(arg1,0,g);
2528  return success;
2529 }
2530 
2539 static long c_retract()
2540 {
2541  long success=FALSE;
2542  ptr_psi_term arg1,arg2,g;
2543 
2544  g=aim->aaaa_1;
2545  get_two_args(g->attr_list,&arg1,&arg2);
2546  success=pred_clause(arg1,1,g);
2547 
2548  return success;
2549 }
2550 
2562 static long c_global() /* RM: Feb 10 1993 */
2563 {
2564  int error=FALSE;
2565  int eval_2=FALSE;
2566  ptr_psi_term g;
2567 
2568  g=aim->aaaa_1;
2569  deref_ptr(g);
2570  if (g->attr_list) {
2571  /* Do error check of all arguments first: */
2572  global_error_check(g->attr_list, &error, &eval_2);
2573  if (eval_2) return !error;
2574  /* If no errors, then make the arguments global: */
2575  if (!error)
2576  global_tree(g->attr_list);
2577  } else {
2578  Errorline("argument(s) missing in %P\n",g);
2579  }
2580 
2581  return !error;
2582 }
2583 
2592 void global_error_check(ptr_node n,int * error,int * eval_2)
2593 {
2594  if (n) {
2595  ptr_psi_term t,a1,a2;
2596  int bad_init=FALSE;
2597  global_error_check(n->left, error, eval_2);
2598 
2599  t=(ptr_psi_term)n->data;
2600  deref_ptr(t);
2601  if (t->type==leftarrowsym) {
2602  get_two_args(t->attr_list,&a1,&a2);
2603  if (a1==NULL || a2==NULL) {
2604  Errorline("%P is an incorrect global variable declaration (%E).\n",t);
2605  *error=TRUE;
2606  bad_init=TRUE;
2607  } else {
2608  deref_ptr(a1);
2609  deref_ptr(a2);
2610  t=a1;
2611  if (deref_eval(a2)) *eval_2=TRUE;
2612  }
2613  }
2614  if (!bad_init && t->type->type_def!=(def_type)undef && t->type->type_def!=(def_type)global) {
2615  Errorline("%T %P cannot be redeclared as a global variable (%E).\n",
2616  t->type->type_def,
2617  t);
2618  t->type=error_psi_term->type;
2619  t->value_3=NULL; /* RM: Mar 23 1993 */
2620  *error=TRUE;
2621  }
2622 
2623  global_error_check(n->right, error, eval_2);
2624  }
2625 }
2626 
2633 {
2634  if (n) {
2635  ptr_psi_term t;
2636  global_tree(n->left);
2637 
2638  t=(ptr_psi_term)n->data;
2639  deref_ptr(t);
2640  global_one(t);
2641 
2642  global_tree(n->right);
2643  }
2644 }
2645 
2652 {
2653  ptr_psi_term u; // ,val;
2654 
2655  if (t->type==leftarrowsym) {
2656  get_two_args(t->attr_list,&t,&u);
2657  deref_ptr(t);
2658  deref_ptr(u);
2659  }
2660  else
2661  u=stack_psi_term(4);
2662 
2663  clear_copy();
2665  t->type->init_value=quote_copy(u,HEAP); /* RM: Mar 23 1993 */
2666 
2667  /* eval_global_var(t); RM: Feb 4 1994 */
2668 
2669  /* RM: Nov 10 1993
2670  val=t->type->global_value;
2671  if (val && (GENERIC)val<heap_pointer) {
2672  deref_ptr(val);
2673  push_psi_ptr_value(val,&(val->coref));
2674  val->coref=u;
2675  } else
2676  t->type->global_value=u;
2677  */
2678 }
2679 
2687 static long c_persistent() /* RM: Feb 10 1993 */
2688 {
2689  int error=FALSE;
2690  ptr_psi_term g;
2691 
2692  g=aim->aaaa_1;
2693  deref_ptr(g);
2694  if (g->attr_list) {
2695  /* Do error check of all arguments first: */
2696  persistent_error_check(g->attr_list, &error);
2697  /* If no errors, then make the arguments persistent: */
2698  if (!error)
2700  } else {
2701  Errorline("argument(s) missing in %P\n",g);
2702  }
2703 
2704  return !error;
2705 }
2706 
2713 {
2714  if (n) {
2715  ptr_psi_term t;
2716  persistent_error_check(n->left, error);
2717 
2718  t=(ptr_psi_term)n->data;
2719  deref_ptr(t);
2720  if (t->type->type_def!=(def_type)undef && t->type->type_def!=(def_type)global) {
2721  Errorline("%T %P cannot be redeclared persistent (%E).\n",
2722  t->type->type_def,
2723  t);
2724  t->type=error_psi_term->type;
2725  *error=TRUE;
2726  }
2727 
2728  persistent_error_check(n->right, error);
2729  }
2730 }
2731 
2738 {
2739  if (n) {
2740  ptr_psi_term t;
2741  persistent_tree(n->left);
2742 
2743  t=(ptr_psi_term)n->data;
2744  deref_ptr(t);
2745  persistent_one(t);
2746 
2747  persistent_tree(n->right);
2748  }
2749 }
2750 
2757 {
2761 }
2762 
2770 static long c_open_in()
2771 {
2772  long success=FALSE;
2773  ptr_psi_term arg1,arg2,g;
2774  char *fn;
2775 
2776  g=aim->aaaa_1;
2777  deref_ptr(g);
2778  get_two_args(g->attr_list,&arg1,&arg2);
2779  if(arg1) {
2780  deref(arg1);
2781  if (psi_to_string(arg1,&fn))
2782  if (arg2) {
2783  deref(arg2);
2784  deref_args(g,set_1_2);
2785  if (is_top(arg2)) {
2786  if (open_input_file(fn)) {
2787  /* push_ptr_value(psi_term_ptr,&(arg2->coref)); 9.6 */
2788  push_psi_ptr_value(arg2,(GENERIC *)&(arg2->coref));
2789  arg2->coref=input_state;
2790  success=TRUE;
2791  }
2792  else
2793  success=FALSE;
2794  }
2795  else
2796  Errorline("bad input stream in %P.\n",g);
2797  }
2798  else
2799  Errorline("no stream in %P.\n",g);
2800  else
2801  Errorline("bad file name in %P.\n",g);
2802  }
2803  else
2804  Errorline("no file name in %P.\n",g);
2805 
2806  return success;
2807 }
2808 
2816 static long c_open_out()
2817 {
2818  long success=FALSE;
2819  ptr_psi_term arg1,arg2,arg3,g;
2820  char *fn;
2821 
2822  g=aim->aaaa_1;
2823  deref_ptr(g);
2824  get_two_args(g->attr_list,&arg1,&arg2);
2825  if(arg1) {
2826  deref(arg1);
2827  if (psi_to_string(arg1,&fn))
2828  if (arg2) {
2829  deref(arg2);
2830  deref(g);
2831  if (overlap_type(arg2->type,stream)) /* 10.8 */
2832  if (open_output_file(fn)) {
2833  arg3=stack_psi_term(4);
2834  arg3->type=stream;
2835  arg3->value_3=(GENERIC)output_stream;
2836  /* push_ptr_value(psi_term_ptr,&(arg2->coref)); 9.6 */
2837  push_psi_ptr_value(arg2,(GENERIC *)&(arg2->coref));
2838  arg2->coref=arg3;
2839  success=TRUE;
2840  }
2841  else
2842  success=FALSE;
2843  else
2844  Errorline("bad stream in %P.\n",g);
2845  }
2846  else
2847  Errorline("no stream in %P.\n",g);
2848  else
2849  Errorline("bad file name in %P.\n",g);
2850  }
2851  else
2852  Errorline("no file name in %P.\n",g);
2853 
2854  return success;
2855 }
2856 
2865 static long c_set_input()
2866 {
2867  long success=FALSE;
2868  ptr_psi_term arg1,arg2,g;
2869  FILE *thestream;
2870 
2871  g=aim->aaaa_1;
2872  deref_ptr(g);
2873  get_two_args(g->attr_list,&arg1,&arg2);
2874  if (arg1) {
2875  deref(arg1);
2876  deref_args(g,set_1);
2877  if (equal_types(arg1->type,inputfilesym)) {
2878  success=TRUE;
2880  thestream=get_stream(arg1);
2881  if (thestream!=NULL) {
2882  input_state=arg1;
2884  }
2885  }
2886  else
2887  Errorline("bad stream in %P.\n",g);
2888  }
2889  else
2890  Errorline("no stream in %P.\n",g);
2891 
2892  return success;
2893 }
2894 
2902 static long c_set_output()
2903 {
2904  long success=FALSE;
2905  ptr_psi_term arg1,arg2,g;
2906 
2907  g=aim->aaaa_1;
2908  deref_ptr(g);
2909  get_two_args(g->attr_list,&arg1,&arg2);
2910  if(arg1) {
2911  deref(arg1);
2912  deref_args(g,set_1);
2913  if(equal_types(arg1->type,stream) && arg1->value_3) {
2914  success=TRUE;
2915  output_stream=(FILE *)arg1->value_3;
2916  }
2917  else
2918  Errorline("bad stream in %P.\n",g);
2919  }
2920  else
2921  Errorline("no stream in %P.\n",g);
2922 
2923  return success;
2924 }
2925 
2933 static long c_close()
2934 {
2935  long success=FALSE;
2936  long inclose,outclose;
2937  ptr_psi_term arg1,arg2,g; // ,s;
2938 
2939  g=aim->aaaa_1;
2940  deref_ptr(g);
2941  get_two_args(g->attr_list,&arg1,&arg2);
2942  if (arg1) {
2943  deref(arg1);
2944  deref_args(g,set_1);
2945  /*
2946  if (sub_type(arg1->type,sys_stream))
2947  return sys_close(arg1);
2948  */
2949  outclose=equal_types(arg1->type,stream) && arg1->value_3;
2950  inclose=FALSE;
2951  if (equal_types(arg1->type,inputfilesym)) {
2953  if (n) {
2954  arg1=(ptr_psi_term)n->data;
2955  inclose=(arg1->value_3!=NULL);
2956  }
2957  }
2958 
2959  if (inclose || outclose) {
2960  success=TRUE;
2961  (void)fclose((FILE *)arg1->value_3);
2962 
2963  if (inclose && (FILE *)arg1->value_3==input_stream)
2964  (void)open_input_file("stdin");
2965  else if (outclose && (FILE *)arg1->value_3==output_stream)
2966  (void)open_output_file("stdout");
2967 
2968  arg1->value_3=NULL;
2969  }
2970  else
2971  Errorline("bad stream in %P.\n",g);
2972  }
2973  else
2974  Errorline("no stream in %P.\n",g);
2975 
2976  return success;
2977 }
2978 
2989 static long c_get()
2990 {
2991  long success=TRUE;
2992  ptr_psi_term arg1,arg2,g,t;
2993  long c;
2994 
2995  g=aim->aaaa_1;
2996  deref_ptr(g);
2997  get_two_args(g->attr_list,&arg1,&arg2);
2998  if (arg1) {
2999  deref(arg1);
3000  deref_args(g,set_1);
3001 
3002  if (eof_flag) {
3003  success=FALSE;
3004  }
3005  else {
3006  prompt="";
3007  c=read_char();
3008  t=stack_psi_term(0);
3009  if (c==EOF) {
3010  t->type=eof;
3011  eof_flag=TRUE;
3012  }
3013  else {
3014  t->type=integer;
3015  t->value_3=heap_alloc(sizeof(REAL)); /* 12.5 */
3016  * (REAL *)t->value_3 = (REAL) c;
3017  }
3018  }
3019 
3020  if (success) {
3021  push_goal(unify,t,arg1,NULL);
3022  (void)i_check_out(t);
3023  }
3024  }
3025  else {
3026  Errorline("argument missing in %P.\n",g);
3027  success=FALSE;
3028  }
3029 
3030  return success;
3031 }
3032 
3033 static long c_put_main(long); /* Forward declaration */
3034 
3046 static long c_put()
3047 {
3048  return c_put_main(FALSE);
3049 }
3050 
3062 static long c_put_err()
3063 {
3064  return c_put_main(TRUE);
3065 }
3066 
3073 static long c_put_main(long to_stderr)
3074 {
3075  long i,success=FALSE;
3076  ptr_psi_term arg1,arg2,g;
3077  char tstr[2], *str=tstr;
3078 
3079  g=aim->aaaa_1;
3080  deref_ptr(g);
3081  get_two_args(g->attr_list,&arg1,&arg2);
3082  if (arg1) {
3083  deref(arg1);
3084  deref_args(g,set_1);
3085  if ((equal_types(arg1->type,integer) || equal_types(arg1->type,real))
3086  && arg1->value_3) {
3087  i = (unsigned long) floor(*(REAL *) arg1->value_3);
3088  if (i==(unsigned long)(unsigned char)i) {
3089  str[0] = i; str[1] = 0;
3090  success=TRUE;
3091  }
3092  else {
3093  Errorline("out-of-range character value in %P.\n",g);
3094  }
3095  }
3096  else if (psi_to_string(arg1,&str)) {
3097  success=TRUE;
3098  }
3099  if (success)
3100  fprintf((to_stderr?stderr:output_stream),"%s",str);
3101  }
3102  else
3103  Errorline("argument missing in %P.\n",g);
3104 
3105  return success;
3106 }
3107 
3115 static long generic_write()
3116 {
3117  ptr_psi_term g;
3118 
3119  g=aim->aaaa_1;
3120  /* deref_rec(g); */
3121  deref_args(g,set_empty);
3122  pred_write(g->attr_list);
3123  /* fflush(output_stream); */
3124  return TRUE;
3125 }
3126 
3135 static long c_write_err()
3136 {
3137  indent=FALSE;
3143  return generic_write();
3144 }
3145 
3155 static long c_writeq_err()
3156 {
3157  indent=FALSE;
3158  const_quote=TRUE;
3163  return generic_write();
3164 }
3165 
3174 static long c_write()
3175 {
3176  indent=FALSE;
3182  return generic_write();
3183 }
3184 
3194 static long c_writeq()
3195 {
3196  indent=FALSE;
3197  const_quote=TRUE;
3202  return generic_write();
3203 }
3204 
3214 static long c_write_canonical()
3215 {
3216  indent=FALSE;
3217  const_quote=TRUE;
3221  write_canon=TRUE;
3222  return generic_write();
3223 }
3224 
3232 static long c_pwrite()
3233 {
3234  indent=TRUE;
3240  return generic_write();
3241 }
3242 
3250 static long c_pwriteq()
3251 {
3252  indent=TRUE;
3253  const_quote=TRUE;
3258  return generic_write();
3259 }
3260 
3268 static long c_page_width()
3269 {
3270  long success=FALSE;
3271  ptr_psi_term arg1,arg2,g;
3272  long pw;
3273 
3274  g=aim->aaaa_1;
3275  deref_ptr(g);
3276  get_two_args(g->attr_list,&arg1,&arg2);
3277  if(arg1) {
3278  deref(arg1);
3279  deref_args(g,set_1);
3280  if (equal_types(arg1->type,integer) && arg1->value_3) {
3281  pw = *(REAL *)arg1->value_3;
3282  if (pw>0)
3283  page_width=pw;
3284  else
3285  Errorline("argument in %P must be positive.\n",g);
3286  success=TRUE;
3287  }
3288  else if (sub_type(integer,arg1->type)) {
3290  success=TRUE;
3291  }
3292  else
3293  Errorline("bad argument in %P.\n",g);
3294  }
3295  else
3296  Errorline("argument missing in %P.\n",g);
3297 
3298  return success;
3299 }
3300 
3308 static long c_print_depth()
3309 {
3310  long success=FALSE;
3311  ptr_psi_term arg1,arg2,g;
3312  long dl;
3313 
3314  g=aim->aaaa_1;
3315  deref_ptr(g);
3316  get_two_args(g->attr_list,&arg1,&arg2);
3317  if (arg1) {
3318  deref(arg1);
3319  deref_args(g,set_1);
3320  if (equal_types(arg1->type,integer) && arg1->value_3) {
3321  dl = *(REAL *)arg1->value_3;
3322  if (dl>=0)
3323  print_depth=dl;
3324  else
3325  Errorline("argument in %P must be positive or zero.\n",g);
3326  success=TRUE;
3327  }
3328  else if (sub_type(integer,arg1->type)) {
3330  success=TRUE;
3331  }
3332  else
3333  Errorline("bad argument in %P.\n",g);
3334  }
3335  else {
3336  /* No arguments: reset print depth to default value */
3338  success=TRUE;
3339  }
3340 
3341  return success;
3342 }
3343 
3352 static long c_rootsort()
3353 {
3354  long success=TRUE;
3355  ptr_psi_term arg1,arg2,arg3,g,other;
3356 
3357  g=aim->aaaa_1;
3358  deref_ptr(g);
3359  arg3=aim->bbbb_1;
3360  deref(arg3);
3361  get_two_args(g->attr_list,&arg1,&arg2);
3362  if(arg1) {
3363  deref(arg1);
3364  deref_args(g,set_1);
3365  other=stack_psi_term(4); /* 19.11 */
3366  other->type=arg1->type;
3367  other->value_3=arg1->value_3;
3368  resid_aim=NULL;
3369  push_goal(unify,arg3,other,NULL);
3370  }
3371  else
3372  curry();
3373 
3374  return success;
3375 }
3376 
3388 static long c_disj()
3389 {
3390  long success=TRUE;
3391  ptr_psi_term arg1,arg2,g;
3392 
3393  g=aim->aaaa_1;
3394  resid_aim=NULL;
3395  deref_ptr(g);
3396  get_two_args(g->attr_list,&arg1,&arg2);
3397  deref_args(g,set_1_2);
3398  traceline("pushing predicate disjunction choice point for %P\n",g);
3400  if (arg1) push_goal(prove,arg1,(ptr_psi_term)DEFRULES,(GENERIC)NULL);
3401  if (!arg1 && !arg2) {
3402  success=FALSE;
3403  Errorline("neither first nor second arguments exist in %P.\n",g);
3404  }
3405 
3406  return success;
3407 }
3408 
3419 static long c_cond()
3420 {
3421  long success=TRUE;
3422  ptr_psi_term arg1,arg2,result,g;
3423  ptr_psi_term *arg1addr;
3424  REAL val1;
3425  long num1;
3426  ptr_node n;
3427 
3428  g=aim->aaaa_1;
3429  deref_ptr(g);
3430  result=aim->bbbb_1;
3431  deref(result);
3432 
3433  get_one_arg_addr(g->attr_list,&arg1addr);
3434  if (arg1addr) {
3435  arg1= *arg1addr;
3436  deref_ptr(arg1);
3437  if (arg1->type->type_def==(def_type)predicate) {
3438  ptr_psi_term call_once;
3439  ptr_node ca;
3440 
3441  /* Transform cond(pred,...) into cond(call_once(pred),...) */
3442  goal_stack=aim;
3443  call_once=stack_psi_term(0);
3444  call_once->type=calloncesym;
3445  call_once->attr_list=(ca=STACK_ALLOC(node));
3446  ca->key=one;
3447  ca->left=ca->right=NULL;
3448  ca->data=(GENERIC)arg1;
3449  push_ptr_value(psi_term_ptr,(GENERIC *)arg1addr);
3450  *arg1addr=call_once;
3451  return success;
3452  }
3453  deref(arg1);
3454  deref_args(g,set_1_2_3);
3455  success=get_bool_value(arg1,&val1,&num1);
3456  if (success) {
3457  if (num1) {
3458  resid_aim=NULL;
3459  n=find(FEATCMP,(val1?two:three),g->attr_list);
3460  if (n) {
3461  arg2=(ptr_psi_term)n->data;
3462  /* mark_eval(arg2); XXX 24.8 */
3463  push_goal(unify,result,arg2,NULL);
3464  (void)i_check_out(arg2);
3465  }
3466  else {
3467  ptr_psi_term trueterm;
3468  trueterm=stack_psi_term(4);
3469  trueterm->type=lf_true;
3470  push_goal(unify,result,trueterm,NULL);
3471  }
3472  }
3473  else
3474  residuate(arg1);
3475  }
3476  else /* RM: Apr 15 1993 */
3477  Errorline("argument to cond is not boolean in %P\n",g);
3478  }
3479  else
3480  curry();
3481 
3482  return success;
3483 }
3484 
3496 static long c_exist_feature() /* PVR: Dec 17 1992 */ /* PVR 11.4.94 */
3497 {
3498  long success=TRUE,v;
3499  ptr_psi_term arg1,arg2,arg3,funct,result,ans;
3500  ptr_node n;
3501  char * label;
3502  /* char *thebuffer="integer"; 18.5 */
3503  char thebuffer[20]; /* Maximum number of digits in an integer */
3504  // char *np1;
3505 
3506  funct=aim->aaaa_1;
3507  deref_ptr(funct);
3508  result=aim->bbbb_1;
3509  get_two_args(funct->attr_list,&arg1,&arg2);
3510 
3511  n=find(FEATCMP,three,funct->attr_list); /* RM: Feb 10 1993 */
3512  if(n)
3513  arg3=(ptr_psi_term)n->data;
3514  else
3515  arg3=NULL;
3516 
3517  if (arg1 && arg2) {
3518  deref(arg1);
3519  deref(arg2);
3520 
3521  if(arg3) /* RM: Feb 10 1993 */
3522  deref(arg3);
3523 
3524  deref_args(funct,set_1_2);
3525  label=NULL;
3526 
3527  if (arg1->value_3 && sub_type(arg1->type,quoted_string))
3528  label=(char *)arg1->value_3;
3529  else if (arg1->value_3 && sub_type(arg1->type,integer)) {
3530  v= *(REAL *)arg1->value_3;
3531  (void)snprintf(thebuffer,20,"%ld",(long)v);
3532  label=heap_copy_string(thebuffer); /* A little voracious */
3533  } else if (arg1->type->keyword->private_feature) {
3534  label=arg1->type->keyword->combined_name;
3535  } else
3536  label=arg1->type->keyword->symbol;
3537 
3538  n=find(FEATCMP,(char *)label,arg2->attr_list);
3539  ans=stack_psi_term(4);
3540  ans->type=(n!=NULL)?lf_true:lf_false;
3541 
3542  if(arg3 && n) /* RM: Feb 10 1993 */
3544 
3545  push_goal(unify,result,ans,NULL);
3546  }
3547  else
3548  curry();
3549 
3550  return success;
3551 }
3552 
3561 static long c_features()
3562 {
3563  long success=TRUE;
3564  ptr_psi_term arg1,arg2,funct,result;
3565  /* ptr_psi_term the_list; RM: Dec 9 1992
3566  Modified the routine to use 'cons'
3567  instead of the old list representation.
3568  */
3569  /* RM: Mar 11 1993 Added MODULE argument */
3570  ptr_module module=NULL;
3571  ptr_module save_current;
3572 
3573  funct=aim->aaaa_1;
3574  deref_ptr(funct);
3575  result=aim->bbbb_1;
3576  get_two_args(funct->attr_list,&arg1,&arg2);
3577 
3578 
3579  if(arg2) {
3580  deref(arg2);
3581  success=get_module(arg2,&module);
3582  }
3583  else
3584  module=current_module;
3585 
3586  if(arg1 && success) {
3587  deref(arg1);
3588  deref_args(funct,set_1);
3589  resid_aim=NULL;
3590 
3591  save_current=current_module;
3592  if(module)
3593  current_module=module;
3594 
3595  push_goal(unify,
3596  result,
3597  make_feature_list(arg1->attr_list,stack_nil(),module,0),
3598  NULL);
3599 
3600  current_module=save_current;
3601  }
3602  else
3603  curry();
3604 
3605  return success;
3606 }
3607 
3615 static long c_feature_values()
3616 {
3617  long success=TRUE;
3618  ptr_psi_term arg1,arg2,funct,result;
3619  /* ptr_psi_term the_list; RM: Dec 9 1992
3620  Modified the routine to use 'cons'
3621  instead of the old list representation.
3622  */
3623  /* RM: Mar 11 1993 Added MODULE argument */
3624  ptr_module module=NULL;
3625  ptr_module save_current;
3626 
3627  funct=aim->aaaa_1;
3628  deref_ptr(funct);
3629  result=aim->bbbb_1;
3630  get_two_args(funct->attr_list,&arg1,&arg2);
3631 
3632  if(arg2) {
3633  deref(arg2);
3634  success=get_module(arg2,&module);
3635  }
3636  else
3637  module=current_module;
3638 
3639  if(arg1 && success) {
3640  deref(arg1);
3641  deref_args(funct,set_1);
3642  resid_aim=NULL;
3643 
3644  save_current=current_module;
3645  if(module)
3646  current_module=module;
3647 
3648  push_goal(unify,
3649  result,
3650  make_feature_list(arg1->attr_list,stack_nil(),module,1),
3651  NULL);
3652 
3653  current_module=save_current;
3654  }
3655  else
3656  curry();
3657 
3658  return success;
3659 }
3660 
3670 {
3671  return (/* (t==conjunction) || 19.8 */
3672  /* (t==disjunction) || RM: Dec 9 1992 */
3673  (t==constant) || (t==variable) ||
3674  (t==comment) || (t==functor));
3675 }
3676 
3696 ptr_psi_term collect_symbols(long sel) /* RM: Feb 3 1993 */
3697 {
3698  ptr_psi_term new;
3699  ptr_definition def;
3700  long botflag;
3701  ptr_psi_term result;
3702 
3703 
3704  result=stack_nil();
3705 
3706  for(def=first_definition;def;def=def->next) {
3707 
3708  if (sel==least_sel || sel==greatest_sel) {
3709  botflag=(sel==least_sel);
3710 
3711  /* Insert the node if it's a good one */
3712  if (((botflag?def->children:def->parents)==NULL &&
3713  def!=top && def!=nothing &&
3714  def->type_def==(def_type)type_it ||
3715  def->type_def==(def_type)undef)
3716  && !hidden_type(def)) {
3717  /* Create the node that will be inserted */
3718  new=stack_psi_term(4);
3719  new->type=def;
3720  result=stack_cons((ptr_psi_term)new,(ptr_psi_term)result);
3721  }
3722  }
3723  else if (sel==op_sel) {
3724  ptr_operator_data od=def->op_data;
3725 
3726  while (od) {
3727  ptr_psi_term name_loc,type;
3728 
3729  new=stack_psi_term(4);
3730  new->type=opsym;
3731  result=stack_cons((ptr_psi_term)new,(ptr_psi_term)result);
3732 
3734 
3735  type=stack_psi_term(4);
3736  switch (od->type) {
3737  case xf:
3738  type->type=xf_sym;
3739  break;
3740  case yf:
3741  type->type=yf_sym;
3742  break;
3743  case fx:
3744  type->type=fx_sym;
3745  break;
3746  case fy:
3747  type->type=fy_sym;
3748  break;
3749  case xfx:
3750  type->type=xfx_sym;
3751  break;
3752  case xfy:
3753  type->type=xfy_sym;
3754  break;
3755  case yfx:
3756  type->type=yfx_sym;
3757  break;
3758  }
3759  stack_add_psi_attr(new,two,type);
3760 
3761  name_loc=stack_psi_term(4);
3762  name_loc->type=def;
3763  stack_add_psi_attr(new,three,name_loc);
3764 
3765  od=od->next;
3766  }
3767  }
3768  }
3769 
3770  return result;
3771 }
3772 
3781 static long c_ops()
3782 {
3783  long success=TRUE;
3784  ptr_psi_term result, g, t;
3785 
3786  g=aim->aaaa_1;
3787  deref_args(g,set_empty);
3788  result=aim->bbbb_1;
3789  t=collect_symbols(op_sel); /* RM: Feb 3 1993 */
3790  push_goal(unify,result,t,NULL);
3791 
3792  return success;
3793 }
3794 
3803 {
3804  ptr_node m;
3805 
3806  if (n==NULL) return NULL;
3807 
3808  m = STACK_ALLOC(node);
3809  m->key = n->key;
3810  m->data = n->data;
3811  m->left = copy_attr_list(n->left);
3812  m->right = copy_attr_list(n->right);
3813  return m;
3814 }
3815 
3824 static long c_strip()
3825 {
3826  long success=TRUE;
3827  ptr_psi_term arg1,arg2,funct,result;
3828 
3829  funct=aim->aaaa_1;
3830  deref_ptr(funct);
3831  result=aim->bbbb_1;
3832  get_two_args(funct->attr_list,&arg1,&arg2);
3833  if(arg1) {
3834  deref(arg1);
3835  deref_args(funct,set_1);
3836  resid_aim=NULL;
3837  /* PVR 23.2.94 */
3838  merge_unify(&(result->attr_list),copy_attr_list(arg1->attr_list));
3839  }
3840  else
3841  curry();
3842 
3843  return success;
3844 }
3845 
3853 static long c_same_address()
3854 {
3855  long success=TRUE;
3856  ptr_psi_term arg1,arg2,funct,result;
3857  REAL val3;
3858  long num3;
3859 
3860  funct=aim->aaaa_1;
3861  deref_ptr(funct);
3862  result=aim->bbbb_1;
3863  get_two_args(funct->attr_list,&arg1,&arg2);
3864 
3865  if (arg1 && arg2) {
3866  success=get_bool_value(result,&val3,&num3);
3867  resid_aim=NULL;
3868  deref(arg1);
3869  deref(arg2);
3870  deref_args(funct,set_1_2);
3871 
3872  if (num3) {
3873  if (val3)
3874  push_goal(unify,arg1,arg2,NULL);
3875  else
3876  success=(arg1!=arg2);
3877  }
3878  else
3879  if (arg1==arg2)
3880  unify_bool_result(result,TRUE);
3881  else
3882  unify_bool_result(result,FALSE);
3883  }
3884  else
3885  curry();
3886 
3887  return success;
3888 }
3889 
3897 static long c_diff_address()
3898 {
3899  long success=TRUE;
3900  ptr_psi_term arg1,arg2,funct,result;
3901  REAL val3;
3902  long num3;
3903 
3904  funct=aim->aaaa_1;
3905  deref_ptr(funct);
3906  result=aim->bbbb_1;
3907  get_two_args(funct->attr_list,&arg1,&arg2);
3908 
3909  if (arg1 && arg2) {
3910  success=get_bool_value(result,&val3,&num3);
3911  resid_aim=NULL;
3912  deref(arg1);
3913  deref(arg2);
3914  deref_args(funct,set_1_2);
3915 
3916  if (num3) {
3917  if (val3)
3918  push_goal(unify,arg1,arg2,NULL);
3919  else
3920  success=(arg1==arg2);
3921  }
3922  else
3923  if (arg1==arg2)
3924  unify_bool_result(result,FALSE);
3925  else
3926  unify_bool_result(result,TRUE);
3927  }
3928  else
3929  curry();
3930 
3931  return success;
3932 }
3933 
3941 static long c_eval()
3942 {
3943  long success=TRUE;
3944  ptr_psi_term arg1, copy_arg1, arg2, funct, result;
3945 
3946  funct = aim->aaaa_1;
3947  deref_ptr(funct);
3948  result = aim->bbbb_1;
3949  deref(result);
3950  get_two_args(funct->attr_list, &arg1, &arg2);
3951  if (arg1) {
3952  deref(arg1);
3953  deref_args(funct,set_1);
3954  assert((unsigned long)(arg1->type)!=4);
3955  clear_copy();
3956  copy_arg1 = eval_copy(arg1,STACK);
3957  resid_aim = NULL;
3958  push_goal(unify,copy_arg1,result,NULL);
3959  (void)i_check_out(copy_arg1);
3960  } else
3961  curry();
3962 
3963  return success;
3964 }
3965 
3973 static long c_eval_inplace()
3974 {
3975  long success=TRUE;
3976  ptr_psi_term arg1,/* copy_arg1, */ arg2, funct, result;
3977 
3978  funct = aim->aaaa_1;
3979  deref_ptr(funct);
3980  result = aim->bbbb_1;
3981  deref(result);
3982  get_two_args(funct->attr_list, &arg1, &arg2);
3983  if (arg1) {
3984  deref(arg1);
3985  deref_args(funct,set_1);
3986  resid_aim = NULL;
3987  mark_eval(arg1);
3988  push_goal(unify,arg1,result,NULL);
3989  (void)i_check_out(arg1);
3990  } else
3991  curry();
3992 
3993  return success;
3994 }
3995 
4005 static long c_quote()
4006 {
4007  long success=TRUE;
4008  ptr_psi_term arg1,arg2,funct,result;
4009 
4010  funct = aim->aaaa_1;
4011  deref_ptr(funct);
4012  result = aim->bbbb_1;
4013  deref(result);
4014  get_two_args(funct->attr_list, &arg1, &arg2);
4015  if (arg1) {
4016  push_goal(unify,arg1,result,NULL);
4017  } else
4018  curry();
4019 
4020  return success;
4021 }
4022 
4030 static long c_split_double()
4031 {
4032  long success=FALSE;
4033  ptr_psi_term arg1,arg2,funct,result;
4034  long n;
4035  union {
4036  double d;
4037  struct {
4038  int hi;
4039  int lo;
4040  } w2;
4041  }hack;
4042  double hi,lo;
4043  long n1,n2;
4044 
4045  funct = aim->aaaa_1;
4046  deref_ptr(funct);
4047  result=aim->bbbb_1;
4048 
4049  get_two_args(funct->attr_list, &arg1, &arg2);
4050  if(arg1 && arg2) {
4051  deref_ptr(arg1);
4052  deref_ptr(arg2);
4053  deref_ptr(result);
4054  if(get_real_value(result,(REAL *)&(hack.d),&n) &&
4055  get_real_value(arg1 ,(REAL *)&hi ,&n1) &&
4056  get_real_value(arg2 ,(REAL *)&lo ,&n2)) {
4057 
4058 
4059  if(n) {
4060 
4061  (void)unify_real_result(arg1,(REAL)hack.w2.hi);
4062  (void)unify_real_result(arg2,(REAL)hack.w2.lo);
4063  success=TRUE;
4064  }
4065  else
4066  if(n1 && n2) {
4067 
4068  hack.w2.hi=(int)hi;
4069  hack.w2.lo=(int)lo;
4070  (void)unify_real_result(result,hack.d);
4071  success=TRUE;
4072  }
4073  else {
4074 
4075  residuate(result);
4076  residuate2(arg1,arg2);
4077  }
4078  }
4079  else
4080  Errorline("non-numeric arguments in %P\n",funct);
4081  }
4082  else
4083  curry();
4084 
4085  return success;
4086 }
4087 
4095 static long c_string_address()
4096 {
4097  long success=FALSE;
4098  ptr_psi_term arg1,arg2,funct,result,t;
4099  REAL val;
4100  long num;
4101  long smaller;
4102 
4103  funct = aim->aaaa_1;
4104  deref_ptr(funct);
4105  result=aim->bbbb_1;
4106 
4107  get_two_args(funct->attr_list, &arg1, &arg2);
4108  if(arg1) {
4109  deref_ptr(arg1);
4110  deref_ptr(result);
4111  success=matches(arg1->type,quoted_string,&smaller);
4112  if (success) {
4113  if (arg1->value_3) {
4114  (void)unify_real_result(result,(REAL)(long)(arg1->value_3));
4115  }
4116  else {
4117  if((success=get_real_value(result,&val,&num))) {
4118  if(num) {
4119  t=stack_psi_term(4);
4120  t->type=quoted_string;
4121  t->value_3=(GENERIC)&val; // changed to addr djd
4122  push_goal(unify,t,arg1,NULL);
4123  }
4124  else
4125  residuate2(arg1,result);
4126 
4127  }
4128  else
4129  Errorline("result is not a real in %P\n",funct);
4130  }
4131  }
4132  else
4133  Errorline("argument is not a string in %P\n",funct);
4134  }
4135  else
4136  curry();
4137 
4138  return success;
4139 }
4140 
4148 static long c_chdir()
4149 {
4150  long success=FALSE;
4151  ptr_psi_term arg1,arg2,funct;
4152  long smaller;
4153 
4154  funct = aim->aaaa_1;
4155  deref_ptr(funct);
4156 
4157  get_two_args(funct->attr_list, &arg1, &arg2);
4158  if(arg1) {
4159  deref_ptr(arg1);
4160  if(matches(arg1->type,quoted_string,&smaller) && arg1->value_3)
4161  success=!chdir(expand_file_name((char *)arg1->value_3));
4162  else
4163  Errorline("bad argument in %P\n",funct);
4164  }
4165  else
4166  Errorline("argument missing in %P\n",funct);
4167 
4168  return success;
4169 }
4170 
4171 /******** C_CALL_ONCE
4172  Prove a predicate, return true or false if it succeeds or fails.
4173  An implicit cut is performed: only only solution is given.
4174 */
4175 #if 0 /* DENYS Jan 25 1995 */
4176 static long c_call_once()
4177 {
4178  long success=TRUE;
4179  ptr_psi_term arg1,arg2,funct,result,other;
4180  ptr_choice_point cutpt;
4181 
4182  funct=aim->aaaa_1;
4183  deref_ptr(funct);
4184  result=aim->bbbb_1;
4185  get_two_args(funct->attr_list,&arg1,&arg2);
4186  if (arg1) {
4187  deref_ptr(arg1);
4188  deref_args(funct,set_1);
4189  if(arg1->type==top)
4190  residuate(arg1);
4191  else
4192  if(FALSE /*arg1->type->type!=predicate*/) {
4193  success=FALSE;
4194  Errorline("argument of %P should be a predicate.\n",funct);
4195  }
4196  else {
4197  resid_aim=NULL;
4198  cutpt=choice_stack;
4199 
4200  /* Result is FALSE */
4201  other=stack_psi_term(0);
4202  other->type=lf_false;
4203 
4204  push_choice_point(unify,result,other,NULL);
4205 
4206  /* Result is TRUE */
4207  other=stack_psi_term(0);
4208  other->type=lf_true;
4209 
4210  push_goal(unify,result,other,NULL);
4211  push_goal(eval_cut,other,cutpt,NULL);
4212  push_goal(prove,arg1,DEFRULES,NULL);
4213  }
4214  }
4215  else
4216  curry();
4217 
4218  return success;
4219 }
4220 #endif
4221 
4222 
4223 
4232 static long c_call()
4233 {
4234  long success=TRUE;
4235  ptr_psi_term arg1,arg2,funct,result,other;
4236  ptr_choice_point cutpt;
4237 
4238  funct=aim->aaaa_1;
4239  deref_ptr(funct);
4240  result=aim->bbbb_1;
4241  get_two_args(funct->attr_list,&arg1,&arg2);
4242  if (arg1) {
4243  deref_ptr(arg1);
4244  deref_args(funct,set_1);
4245  if(arg1->type==top)
4246  residuate(arg1);
4247  else
4248  if(FALSE /*arg1->type->type_def!=predicate*/) {
4249  success=FALSE;
4250  Errorline("argument of %P should be a predicate.\n",funct);
4251  }
4252  else {
4253  resid_aim=NULL;
4254  cutpt=choice_stack;
4255 
4256  /* Result is FALSE */
4257  other=stack_psi_term(0);
4258  other->type=lf_false;
4259 
4260  push_choice_point(unify,result,other,NULL);
4261 
4262  /* Result is TRUE */
4263  other=stack_psi_term(0);
4264  other->type=lf_true;
4265 
4266  push_goal(unify,result,other,NULL);
4268  }
4269  }
4270  else
4271  curry();
4272 
4273  return success;
4274 }
4275 
4283 static long c_bk_assign()
4284 {
4285  long success=FALSE;
4286  ptr_psi_term arg1,arg2,g;
4287 
4288  g=aim->aaaa_1;
4289  deref_ptr(g);
4290  get_two_args(g->attr_list,&arg1,&arg2);
4291  if (arg1 && arg2) {
4292  success=TRUE;
4293  deref(arg1);
4294  deref_rec(arg2); /* 17.9 */
4295  /* deref(arg2); 17.9 */
4296  deref_args(g,set_1_2);
4297  if (arg1 != arg2) {
4298 
4299  /* RM: Mar 10 1993 */
4300  if((GENERIC)arg1>=heap_pointer) {
4301  Errorline("cannot use '<-' on persistent value in %P\n",g);
4302  return c_abort();
4303  }
4304 
4305 
4306 #ifdef TS
4307  if (!trail_condition(arg1)) {
4308  /* If no trail, then can safely overwrite the psi-term */
4309  release_resid_notrail(arg1);
4310  *arg1 = *arg2;
4311  push_psi_ptr_value(arg2,(GENERIC *)&(arg2->coref)); /* 14.12 */
4312  arg2->coref=arg1; /* 14.12 */
4313  }
4314  else {
4315  push_psi_ptr_value(arg1,(GENERIC *)&(arg1->coref));
4316  arg1->coref=arg2;
4317  release_resid(arg1);
4318  }
4319 #else
4320  push_psi_ptr_value(arg1,(GENERIC *)&(arg1->coref));
4321  arg1->coref=arg2;
4322  release_resid(arg1);
4323 #endif
4324  }
4325  }
4326  else
4327  Errorline("argument missing in %P.\n",g);
4328 
4329  return success;
4330 }
4331 
4342 static long c_assign()
4343 {
4344  long success=FALSE;
4345  ptr_psi_term arg1,arg2,g; // perm ,smallest;
4346 
4347  g=aim->aaaa_1;
4348  deref_ptr(g);
4349  get_two_args(g->attr_list,&arg1,&arg2);
4350  if (arg1 && arg2) {
4351  success=TRUE;
4352  deref_ptr(arg1);
4353  deref_rec(arg2); /* 17.9 */
4354  /* deref(arg2); 17.9 */
4355  deref_args(g,set_1_2);
4356  if ((GENERIC)arg1<heap_pointer || arg1!=arg2) {
4357  clear_copy();
4358  *arg1 = *exact_copy(arg2,HEAP);
4359  }
4360  }
4361  else
4362  Errorline("argument missing in %P.\n",g);
4363 
4364  return success;
4365 }
4366 
4367 
4368 
4379 static long c_global_assign()
4380 {
4381  long success=FALSE;
4382  ptr_psi_term arg1,arg2,g; // ,perm,smallest;
4383  ptr_psi_term new;
4384 
4385  g=aim->aaaa_1;
4386  deref_ptr(g);
4387  get_two_args(g->attr_list,&arg1,&arg2);
4388  if (arg1 && arg2) {
4389  success=TRUE;
4390  deref_rec(arg1);
4391  deref_rec(arg2);
4392  deref_args(g,set_1_2);
4393  if (arg1!=arg2) {
4394 
4395  clear_copy();
4396  new=inc_heap_copy(arg2);
4397 
4398  if((GENERIC)arg1<heap_pointer) {
4399  push_psi_ptr_value(arg1,(GENERIC *)&(arg1->coref));
4400  arg1->coref= new;
4401  }
4402  else {
4403  *arg1= *new; /* Overwrite in-place */
4404  new->coref=arg1;
4405  }
4406  }
4407  }
4408  else
4409  Errorline("argument missing in %P.\n",g);
4410 
4411  return success;
4412 }
4413 
4421 static long c_unify_func()
4422 {
4423  long success=TRUE;
4424  ptr_psi_term funct,arg1,arg2,result;
4425 
4426  funct=aim->aaaa_1;
4427  deref_ptr(funct);
4428  get_two_args(funct->attr_list,&arg1,&arg2);
4429  if (arg1 && arg2) {
4430  deref(arg1);
4431  deref(arg2);
4432  deref_args(funct,set_1_2);
4433  result=aim->bbbb_1;
4434  push_goal(unify,arg1,result,NULL);
4435  push_goal(unify,arg1,arg2,NULL);
4436  }
4437  else
4438  curry();
4439 
4440  return success;
4441 }
4442 
4450 static long c_unify_pred()
4451 {
4452  long success=FALSE;
4453  ptr_psi_term arg1,arg2,g;
4454 
4455  g=aim->aaaa_1;
4456  deref_ptr(g);
4457  get_two_args(g->attr_list,&arg1,&arg2);
4458  if (arg1 && arg2) {
4459  deref_args(g,set_1_2);
4460  success=TRUE;
4461  push_goal(unify,arg1,arg2,NULL);
4462  }
4463  else
4464  Errorline("argument missing in %P.\n",g);
4465 
4466  return success;
4467 }
4468 
4478 static long c_copy_pointer() /* PVR: Dec 17 1992 */
4479 {
4480  long success=TRUE;
4481  ptr_psi_term funct,arg1,result,other;
4482 
4483  funct=aim->aaaa_1;
4484  deref_ptr(funct);
4485  get_one_arg(funct->attr_list,&arg1);
4486  if (arg1) {
4487  deref(arg1);
4488  deref_args(funct,set_1);
4489  other=stack_psi_term(4);
4490  other->type=arg1->type;
4491  other->value_3=arg1->value_3;
4492  other->attr_list=copy_attr_list(arg1->attr_list); /* PVR 23.2.94 */
4493  result=aim->bbbb_1;
4494  push_goal(unify,other,result,NULL);
4495  }
4496  else
4497  curry();
4498 
4499  return success;
4500 }
4501 
4510 static long c_copy_term()
4511 {
4512  long success=TRUE;
4513  ptr_psi_term funct,arg1,copy_arg1,result;
4514 
4515  funct=aim->aaaa_1;
4516  deref_ptr(funct);
4517  get_one_arg(funct->attr_list,&arg1);
4518  if (arg1) {
4519  deref(arg1);
4520  deref_args(funct,set_1);
4521  result=aim->bbbb_1;
4522  clear_copy();
4523  copy_arg1=exact_copy(arg1,STACK);
4524  push_goal(unify,copy_arg1,result,NULL);
4525  }
4526  else
4527  curry();
4528 
4529  return success;
4530 }
4531 
4548 static long c_undo()
4549 {
4550  long success=TRUE;
4551  ptr_psi_term arg1,arg2,g;
4552 
4553  g=aim->aaaa_1;
4554  deref_ptr(g);
4555  get_two_args(g->attr_list,&arg1,&arg2);
4556  if (arg1) {
4557  deref_args(g,set_1);
4559  }
4560  else {
4561  success=FALSE;
4562  Errorline("argument missing in %P.\n",g);
4563  }
4564 
4565  return success;
4566 }
4567 
4593 static long c_freeze_inner(long freeze_flag)
4594 {
4595  long success=TRUE;
4596  ptr_psi_term arg1,g;
4597  ptr_psi_term head, body;
4598  ptr_pair_list rule;
4599  /* RESID */ ptr_resid_block rb;
4600  ptr_choice_point cutpt;
4601  ptr_psi_term match_date;
4602 
4603  g=aim->aaaa_1;
4604  deref_ptr(g);
4605  get_one_arg(g->attr_list,&arg1);
4606 
4607  if (arg1) {
4608  deref_ptr(arg1);
4609  /* if (!arg1->type->evaluate_args) mark_quote(arg1); 8.9 */ /* 18.2 PVR */
4610  deref_args(g,set_1);
4611  deref_ptr(arg1);
4612 
4613  if (arg1->type->type_def!=(def_type)predicate) {
4614  success=FALSE;
4615  Errorline("the argument %P of freeze must be a predicate.\n",arg1);
4616  /* main_loop_ok=FALSE; 8.9 */
4617  return success;
4618  }
4619  resid_aim=aim;
4620  match_date=(ptr_psi_term)stack_pointer;
4621  cutpt=choice_stack; /* 13.6 */
4622  /* Third argument of freeze's aim is used to keep track of which */
4623  /* clause is being tried in the frozen goal. */
4624  rule=(ptr_pair_list)aim->cccc_1; /* 8.9 */ /* Isn't aim->cccc always NULL? */
4625  resid_vars=NULL;
4626  curried=FALSE;
4627  can_curry=TRUE; /* 8.9 */
4628 
4629  if (!rule) rule=arg1->type->rule; /* 8.9 */
4630  /* if ((unsigned long)rule==DEFRULES) rule=arg1->type->rule; 8.9 */
4631 
4632  if (rule) {
4633  traceline("evaluate frozen predicate %P\n",g);
4634  /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
4635 
4636  if ((unsigned long)rule<=MAX_BUILT_INS) {
4637  success=FALSE; /* 8.9 */
4638  Errorline("the argument %P of freeze must be user-defined.\n",arg1); /* 8.9 */
4639  return success; /* 8.9 */
4640  /* Removed obsolete stuff here 11.9 */
4641  }
4642  else {
4643  while (rule && (rule->aaaa_2==NULL || rule->bbbb_2==NULL)) {
4644  rule=rule->next;
4645  traceline("alternative clause has been retracted\n");
4646  }
4647  if (rule) {
4648  /* RESID */ rb = STACK_ALLOC(resid_block);
4649  /* RESID */ save_resid(rb,match_date);
4650  /* RESID */ /* resid_aim = NULL; */
4651 
4652  clear_copy();
4653  if (TRUE /*arg1->type->evaluate_args 8.9 */)
4654  head=eval_copy(rule->aaaa_2,STACK);
4655  else
4656  head=quote_copy(rule->aaaa_2,STACK);
4657  body=eval_copy(rule->bbbb_2,STACK);
4658  head->status=4;
4659 
4660  if (rule->next)
4661  /* push_choice_point(prove,g,rule->next,NULL); 8.9 */
4663 
4664  push_goal(prove,body,(ptr_psi_term)DEFRULES,NULL);
4665  if (freeze_flag) /* 12.10 */
4666  push_goal(freeze_cut,body,(ptr_psi_term)cutpt,(GENERIC)rb); /* 13.6 */
4667  else
4668  push_goal(implies_cut,body,(ptr_psi_term)cutpt,(GENERIC)rb);
4669  /* RESID */ push_goal(match,arg1,head,(GENERIC)rb);
4670  /* eval_args(head->attr_list); */
4671  }
4672  else {
4673  success=FALSE;
4674  /* resid_aim=NULL; */
4675  }
4676  }
4677  }
4678  else {
4679  success=FALSE;
4680  /* resid_aim=NULL; */
4681  }
4682  resid_aim=NULL;
4683  resid_vars=NULL; /* 22.9 */
4684  }
4685  else {
4686  success=FALSE;
4687  Errorline("goal missing in %P.\n",g);
4688  }
4689 
4690  /* match_date=NULL; */ /* 13.6 */
4691  return success;
4692 }
4693 
4694 
4702 static long c_freeze()
4703 {
4704  return c_freeze_inner(TRUE);
4705 }
4706 
4714 static long c_implies()
4715 {
4716  return c_freeze_inner(FALSE);
4717 }
4718 
4727 static long c_char()
4728 {
4729  long success=TRUE;
4730  ptr_psi_term arg1,arg2,funct,result;
4731  char *str;
4732 
4733  funct=aim->aaaa_1;
4734  deref_ptr(funct);
4735  result=aim->bbbb_1;
4736  deref(result);
4737 
4738  get_two_args(funct->attr_list,&arg1,&arg2);
4739  if (arg1) {
4740  deref(arg1);
4741  deref_args(funct,set_1);
4742  if (overlap_type(arg1->type,integer)) {
4743  if (arg1->value_3) {
4744  ptr_psi_term t;
4745 
4746  t=stack_psi_term(4);
4747  t->type=quoted_string;
4748  str=(char *)heap_alloc(2);
4749  str[0] = (unsigned char) floor(*(REAL *) arg1->value_3);
4750  str[1] = 0;
4751  t->value_3=(GENERIC)str;
4752 
4753  push_goal(unify,t,result,NULL);
4754  }
4755  else
4756  residuate(arg1);
4757  }
4758  else {
4759  Errorline("argument of %P must be an integer.\n",funct);
4760  success=FALSE;
4761  }
4762  }
4763  else
4764  curry();
4765 
4766  return success;
4767 }
4768 
4777 static long c_ascii()
4778 {
4779  long success=TRUE;
4780  ptr_psi_term arg1,arg2,funct,result;
4781  long smaller;
4782 
4783  funct=aim->aaaa_1;
4784  deref_ptr(funct);
4785  result=aim->bbbb_1;
4786  deref(result);
4787 
4788  /* success=get_real_value(result,&val1,&num1); */
4789  /* if (success) { */
4790  get_two_args(funct->attr_list,&arg1,&arg2);
4791  if (arg1) {
4792  deref(arg1);
4793  deref_args(funct,set_1);
4794  success=matches(arg1->type,quoted_string,&smaller);
4795  if (success) {
4796  if (arg1->value_3) {
4797  (void) unify_real_result(result,(REAL)(*((unsigned char *)arg1->value_3)));
4798  }
4799  else
4800  residuate(arg1);
4801  }
4802  else {/* RM: Feb 18 1994 */
4803  success=FALSE;
4804  Errorline("String argument expected in '%P'\n",funct);
4805  }
4806  /*
4807  else {
4808  success=TRUE;
4809  unify_real_result(result,(REAL)(*((unsigned char *)arg1->type->keyword->symbol)));
4810  }
4811  */
4812  }
4813  else
4814  curry();
4815  /* } */
4816 
4817  return success;
4818 }
4819 
4827 static long c_string2psi()
4828 {
4829  long success=TRUE;
4830  ptr_psi_term arg1,arg2, funct,result,t;
4831  ptr_module mod=NULL; /* RM: Mar 11 1993 */
4832  ptr_module save_current; /* RM: Mar 12 1993 */
4833 
4834 
4835  funct=aim->aaaa_1;
4836  deref_ptr(funct);
4837  result=aim->bbbb_1;
4838  deref(result);
4839 
4840  get_two_args(funct->attr_list,&arg1,&arg2);
4841  if(arg1)
4842  deref(arg1);
4843  if(arg2)
4844  deref(arg2);
4845  deref_args(funct,set_1_2);
4846 
4847  if (arg1) {
4848  success=overlap_type(arg1->type,quoted_string);
4849  if(success) {
4850 
4851  /* RM: Mar 11 1993 */
4852  if(arg2)
4853  success=get_module(arg2,&mod);
4854 
4855  if (success) {
4856  if(!arg1->value_3)
4857  residuate(arg1);
4858  else {
4859  t=stack_psi_term(4);
4860  save_current=current_module;
4861  if(mod)
4862  current_module=mod;
4863  t->type=update_symbol(mod,(char *)arg1->value_3);
4864  current_module=save_current;
4865  if(t->type==error_psi_term->type)
4866  success=FALSE;
4867  else
4868  push_goal(unify,t,result,NULL);
4869  }
4870  }
4871  }
4872  else {
4873  success=FALSE;
4874  warningline("argument of '%P' is not a string.\n",funct);
4875  /* report_warning(funct,"argument is not a string"); 9.9 */
4876  }
4877  }
4878  else
4879  curry();
4880 
4881  if(!success)
4882  Errorline("error occurred in '%P'\n",funct);
4883 
4884  return success;
4885 }
4886 
4894 static long c_psi2string()
4895 {
4896  long success=TRUE;
4897  ptr_psi_term arg1, /* arg3, */ funct,result,t;
4898  char buf[100]; /* RM: Mar 10 1993 */
4899 
4900  funct=aim->aaaa_1;
4901  deref_ptr(funct);
4902  result=aim->bbbb_1;
4903  deref(result);
4904 
4905  get_one_arg(funct->attr_list,&arg1);
4906  if (arg1) {
4907  deref(arg1);
4908  deref_args(funct,set_1);
4909  t=stack_psi_term(0);
4910  t->type=quoted_string;
4911 
4912  /* RM: Mar 10 1993 */
4913  if(arg1->value_3 && sub_type(arg1->type,real)) {
4914  (void)snprintf(buf,100,"%g", *((double *)(arg1->value_3)));
4915  t->value_3=(GENERIC)heap_copy_string(buf);
4916  }
4917  else
4918  if(arg1->value_3 && sub_type(arg1->type,quoted_string)) {
4919  t->value_3=(GENERIC)heap_copy_string((char *)arg1->value_3);
4920  }
4921  else
4923 
4924  push_goal(unify,t,result,NULL);
4925  }
4926  else
4927  curry();
4928 
4929  return success;
4930 }
4931 
4939 static long c_int2string()
4940 {
4941  char val[STRLEN]; /* Big enough for a _long_ number */
4942  long success=TRUE,i;
4943  ptr_psi_term arg1, /* arg3, */ funct,result,t;
4944  REAL the_int,next,neg;
4945 
4946  funct=aim->aaaa_1;
4947  deref_ptr(funct);
4948  result=aim->bbbb_1;
4949  deref(result);
4950 
4951  get_one_arg(funct->attr_list,&arg1);
4952  if (arg1) {
4953  deref(arg1);
4954  deref_args(funct,set_1);
4955  if (overlap_type(arg1->type,integer)) {
4956  if (arg1->value_3) {
4957  the_int = *(REAL *)arg1->value_3;
4958 
4959  if (the_int!=floor(the_int)) return FALSE;
4960 
4961  neg = (the_int<0.0);
4962  if (neg) the_int = -the_int;
4963  i=STRLEN;
4964  i--;
4965  val[i]=0;
4966  do {
4967  i--;
4968  if (i<=0) {
4969  Errorline("internal buffer too small for int2str(%P).\n",arg1);
4970  return FALSE;
4971  }
4972  next = floor(the_int/10);
4973  val[i]= '0' + (unsigned long) (the_int-next*10);
4974  the_int = next;
4975  } while (the_int);
4976 
4977  if (neg) { i--; val[i]='-'; }
4978  t=stack_psi_term(0);
4979  t->type=quoted_string;
4980  t->value_3=(GENERIC)heap_copy_string(&val[i]);
4981  push_goal(unify,t,result,NULL);
4982  }
4983  else
4984  residuate(arg1);
4985  }
4986  else
4987  success=FALSE;
4988  }
4989  else
4990  curry();
4991 
4992  return success;
4993 }
4994 
5007 static long c_such_that()
5008 {
5009  long success=TRUE;
5010  ptr_psi_term arg1,arg2,funct,result;
5011 
5012  funct=aim->aaaa_1;
5013  deref_ptr(funct);
5014  result=aim->bbbb_1;
5015  get_two_args(funct->attr_list,&arg1,&arg2);
5016  if (arg1 && arg2) {
5017  deref_ptr(arg1);
5018  deref_ptr(arg2);
5019  deref_args(funct,set_1_2);
5020  resid_aim=NULL;
5022  push_goal(unify,arg1,result,NULL);
5023  (void)i_check_out(arg1);
5024  }
5025  else
5026  curry();
5027 
5028  return success;
5029 }
5030 
5031 
5032 
5039 {
5040  ptr_node n;
5041 
5042  n = STACK_ALLOC(node);
5043  n->key = one;
5044  n->data = NULL; /* To be filled in later */
5045  n->left = NULL;
5046  n->right = NULL;
5047 
5048  return n;
5049 }
5050 
5061 {
5062  ptr_psi_term t;
5063  ptr_node n1, n2;
5064 
5065  if (numargs==2) {
5066  n2 = STACK_ALLOC(node);
5067  n2->key = two;
5068  *a2 = (ptr_psi_term *) &(n2->data);
5069  n2->left = NULL;
5070  n2->right = NULL;
5071  }
5072  else
5073  n2=NULL;
5074 
5075  n1 = STACK_ALLOC(node);
5076  n1->key = one;
5077  *a1 = (ptr_psi_term *) &(n1->data);
5078  n1->left = NULL;
5079  n1->right = n2;
5080 
5081  t=stack_psi_term(4);
5082  t->type = typ;
5083  t->attr_list = n1;
5084 
5085  return t;
5086 }
5087 
5098 {
5099  if (r==NULL) return FALSE;
5100  while (r) {
5101  if (r->aaaa_2!=NULL) return TRUE;
5102  r=r->next;
5103  }
5104  return FALSE;
5105 }
5106 
5115 {
5116  return ((unsigned long)r>0 && (unsigned long)r<MAX_BUILT_INS);
5117 }
5118 
5128 {
5129  ptr_definition d = t->type;
5130  ptr_pair_list r = t->type->rule;
5131  long prflag=FALSE;
5132 
5133  if (t->type->type_def==(def_type)type_it) {
5134  if (!d->always_check) {
5135  if (is_built_in(r)) fprintf(output_stream,"%% ");
5136  fprintf(output_stream,"delay_check(");
5137  display_psi_stream(t);
5138  fprintf(output_stream,")?\n");
5139  prflag=TRUE;
5140  }
5141  } else {
5142  if (!d->protected) {
5143  if (is_built_in(r)) fprintf(output_stream,"%% ");
5144  fprintf(output_stream,"%s(",(d->protected?"static":"dynamic"));
5145  display_psi_stream(t);
5146  fprintf(output_stream,")?\n");
5147  prflag=TRUE;
5148  }
5149  }
5150  if (!d->evaluate_args) {
5151  if (is_built_in(r)) fprintf(output_stream,"%% ");
5152  fprintf(output_stream,"non_strict(");
5153  display_psi_stream(t);
5154  fprintf(output_stream,")?\n");
5155  prflag=TRUE;
5156  }
5157  /* if (prflag) fprintf(output_stream,"\n"); */
5158 }
5159 
5168 static long c_listing()
5169 {
5170  long success=TRUE;
5171  ptr_psi_term arg1,arg2,g;
5172  def_type fp;
5173  ptr_pair_list r;
5174  ptr_node n;
5175  ptr_psi_term t, t2, *a1, *a2, *a3;
5176  char *s1,*s2;
5177 
5178  g=aim->aaaa_1;
5179  deref_ptr(g);
5180  get_two_args(g->attr_list,&arg1,&arg2);
5181  if (arg1) {
5182  deref_ptr(arg1);
5183  list_special(arg1);
5184  fp=arg1->type->type_def;
5185  r=arg1->type->rule;
5186  if (is_built_in(r) || !has_rules(r)) {
5187 
5188  if (is_built_in(r)) {
5189  s1="built-in ";
5190  s2="";
5191  }
5192  else {
5193  s1="user-defined ";
5194  s2=" with an empty definition";
5195  }
5196  switch ((long)fp) {
5197  case (long)function_it:
5198  fprintf(output_stream,"%% '%s' is a %sfunction%s.\n",
5199  arg1->type->keyword->symbol,s1,s2);
5200  break;
5201  case (long)predicate:
5202  fprintf(output_stream,"%% '%s' is a %spredicate%s.\n",
5203  arg1->type->keyword->symbol,s1,s2);
5204  break;
5205  case (long)type_it:
5206  if (arg1->value_3) {
5207  fprintf(output_stream,"%% ");
5208  if (arg1->type!=quoted_string) fprintf(output_stream,"'");
5209  display_psi_stream(arg1);
5210  if (arg1->type!=quoted_string) fprintf(output_stream,"'");
5211  fprintf(output_stream," is a value of sort '%s'.\n",
5212  arg1->type->keyword->symbol);
5213  }
5214  break;
5215 
5216  case (long)global: /* RM: Feb 9 1993 */
5217  fprintf(output_stream,"%% ");
5218  outputline("'%s' is a %sglobal variable worth %P.\n",
5219  arg1->type->keyword->symbol,
5220  s1,
5221  arg1->type->global_value);
5222  break;
5223 
5224 #ifdef CLIFE
5225  case (long)block: /* AA: Mar 10 1993 */
5226  fprintf(output_stream,"%% '%s' is a %block.\n",
5227  arg1->type->keyword->symbol,"","");
5228 #endif
5229 
5230  default:
5231  fprintf(output_stream,"%% '%s' is undefined.\n", arg1->type->keyword->symbol);
5232  }
5233  }
5234  else {
5235  if (fp==(def_type)type_it || fp==(def_type)function_it || fp==(def_type)predicate) {
5236  n = one_attr();
5237  if (fp==(def_type)function_it)
5238  t = new_psi_term(2, funcsym, &a1, &a2);
5239  else if (fp==(def_type)predicate)
5240  t = new_psi_term(2, predsym, &a1, &a2);
5241  else { /* fp==type */
5242  t = new_psi_term(1, typesym, &a3, &a2); /* a2 is a dummy */
5243  t2 = new_psi_term(2, such_that, &a1, &a2);
5244  }
5245  n->data = (GENERIC) t;
5246  while (r) {
5247  *a1 = r->aaaa_2; /* Func, pred, or type */
5248  *a2 = r->bbbb_2;
5249  if (r->aaaa_2) {
5250  /* Handle an attribute constraint with no predicate: */
5251  if (fp==(def_type)type_it) { if (r->bbbb_2==NULL) *a3 = r->aaaa_2; else *a3 = t2; }
5252  listing_pred_write(n, (fp==(def_type)function_it)||(fp==(def_type)type_it));
5253  fprintf(output_stream,".\n");
5254  }
5255  r = r->next;
5256  }
5257  /* fprintf(output_stream,"\n"); */
5258  /* fflush(output_stream); */
5259  }
5260  else {
5261  success=FALSE;
5262  Errorline("argument of %P must be a predicate, function, or sort.\n",g);
5263  }
5264  }
5265  }
5266  else {
5267  success=FALSE;
5268  Errorline("argument missing in %P.\n",g);
5269  }
5270 
5271  return success;
5272 }
5273 
5281 static long c_print_codes()
5282 {
5283  ptr_psi_term t;
5284 
5285  t=aim->aaaa_1;
5286  deref_args(t,set_empty);
5287  outputline("There are %d sorts.\n",type_count);
5288  print_codes();
5289  return TRUE;
5290 }
5291 
5292 /*********************** TEMPLATES FOR NEW PREDICATES AND FUNCTIONS *******/
5293 
5301 static long c_pred()
5302 {
5303  long success=TRUE;
5304  ptr_psi_term arg1,arg2,g;
5305 
5306  g=aim->aaaa_1;
5307  deref_ptr(g);
5308  get_two_args(g->attr_list,&arg1,&arg2);
5309  if (arg1 && arg2) {
5310  deref_args(g,set_1_2);
5311  }
5312  else {
5313  success=FALSE;
5314  Errorline("argument(s) missing in %P.\n",g);
5315  }
5316 
5317  return success;
5318 }
5319 
5327 static long c_funct()
5328 {
5329  long success=TRUE;
5330  ptr_psi_term arg1,arg2,funct;
5331 
5332 
5333  funct=aim->aaaa_1;
5334  deref_ptr(funct);
5335 
5336  get_two_args(funct->attr_list,&arg1,&arg2);
5337 
5338  if (arg1 && arg2) {
5339  deref_args(funct,set_1_2);
5340  }
5341  else
5342  curry();
5343 
5344  return success;
5345 }
5346 
5347 /******************************************************************************
5348 
5349  Here are the routines which allow a new built_in type, predicate or function
5350  to be declared.
5351 
5352 ****************************************************************************/
5353 
5371 void new_built_in(ptr_module m,char *s,def_type t,long (*r)())
5372 {
5373  ptr_definition d;
5374  if (built_in_index >= MAX_BUILT_INS) {
5375  fprintf(stderr,"Too many primitives, increase MAX_BUILT_INS in extern.h\n");
5376  exit(EXIT_FAILURE);
5377  }
5378 
5379  if(m!=current_module) /* RM: Jan 13 1993 */
5380  (void)set_current_module(m);
5381 
5382  d=update_symbol(m,s); /* RM: Jan 8 1993 */
5383  d->type_def=t;
5384  built_in_index++;
5387 }
5388 
5400 static void op_declare(long p,operator t,char *s)
5401 {
5402  ptr_definition d;
5403  ptr_operator_data od;
5404 
5405  if (p>MAX_PRECEDENCE || p<0) {
5406  Errorline("operator precedence must be in the range 0..%d.\n",
5407  MAX_PRECEDENCE);
5408  return;
5409  }
5410  d=update_symbol(NULL,s);
5411 
5412  od= (ptr_operator_data) heap_alloc (sizeof(operator_data));
5413  /* od= (ptr_operator_data) malloc (sizeof(operator_data)); 12.6 */
5414 
5415  od->precedence=p;
5416  od->type=t;
5417  od->next=d->op_data;
5418  d->op_data=od;
5419 }
5420 
5433 {
5434  ptr_psi_term prec,type,atom;
5435  ptr_node n;
5436  char *s;
5437  long p;
5438  operator kind=nop;
5439  long success=FALSE;
5440 
5441  deref_ptr(t);
5442  n=t->attr_list;
5443  get_two_args(n,&prec,&type);
5444  n=find(FEATCMP,three,n);
5445  if (n && prec && type) {
5446  atom=(ptr_psi_term )n->data;
5447  deref_ptr(prec);
5448  deref_ptr(type);
5449  deref_ptr(atom);
5450  if (!atom->value_3) {
5451  s=atom->type->keyword->symbol;
5452  if (sub_type(prec->type,integer) && prec->value_3) { /* 10.8 */
5453  p = * (REAL *)prec->value_3;
5454  if (p>0 && p<=MAX_PRECEDENCE) {
5455 
5456  if (type->type == xf_sym) kind=xf;
5457  else if (type->type == yf_sym) kind=yf;
5458  else if (type->type == fx_sym) kind=fx;
5459  else if (type->type == fy_sym) kind=fy;
5460  else if (type->type == xfx_sym) kind=xfx;
5461  else if (type->type == xfy_sym) kind=xfy;
5462  else if (type->type == yfx_sym) kind=yfx;
5463  else
5464  Errorline("bad operator kind '%s'.\n",type->type->keyword->symbol);
5465 
5466  if (kind!=nop) {
5467  op_declare(p,kind,s);
5468  success=TRUE;
5469  }
5470  }
5471  else
5472  Errorline("precedence must range from 1 to 1200 in %P.\n",t);
5473  }
5474  else
5475  Errorline("precedence must be a positive integer in %P.\n",t);
5476  }
5477  else
5478  Errorline("numbers or strings may not be operators in %P.\n",t);
5479  }
5480  else
5481  Errorline("argument missing in %P.\n",t);
5482 
5483  return success;
5484 }
5485 
5492 char *str_conc(char *s1,char *s2)
5493 {
5494  char *result;
5495 
5496  result=(char *)heap_alloc(strlen(s1)+strlen(s2)+1);
5497  sprintf(result,"%s%s",s1,s2);
5498 
5499  return result;
5500 }
5501 
5510 char *sub_str(char *s,long p,long n)
5511 {
5512  char *result;
5513  long i;
5514  long l;
5515 
5516  l=strlen(s);
5517  if(p>l || p<0 || n<0)
5518  n=0;
5519  else
5520  if(p+n-1>l)
5521  n=l-p+1;
5522 
5523  result=(char *)heap_alloc(n+1);
5524  for(i=0;i<n;i++)
5525  *(result+i)= *(s+p+i-1);
5526 
5527  *(result+n)=0;
5528 
5529  return result;
5530 }
5531 
5539 long append_files(char *s1,char *s2)
5540 {
5541  FILE *f1;
5542  FILE *f2;
5543  long result=FALSE;
5544 
5545  f1=fopen(s1,"a");
5546  if(f1) {
5547  f2=fopen(s2,"r");
5548  if(f2) {
5549  while(!feof(f2))
5550  (void)fputc(fgetc(f2),f1);
5551  (void)fclose(f2);
5552  (void)fclose(f1);
5553  result=TRUE;
5554  }
5555  else
5556  Errorline("couldn't open \"%s\"\n",f2);
5557  /* printf("*** Error: couldn't open \"%s\"\n",f2); PVR 14.9.93 */
5558  }
5559  else
5560  Errorline("couldn't open \"%s\"\n",f1);
5561  /* printf("*** Error: couldn't open \"%s\"\n",f1); PVR 14.9.93 */
5562 
5563  return result;
5564 }
5565 
5574 {
5575  ptr_psi_term result,funct,temp_result;
5576  ptr_node n1, n2;
5577  long success=TRUE;
5578  long all_args=TRUE;
5579  char * c_result;
5580  ptr_psi_term arg1;
5581  char * c_arg1;
5582  ptr_psi_term arg2;
5583  char * c_arg2;
5584 
5585  funct=aim->aaaa_1;
5586  deref_ptr(funct);
5587  result=aim->bbbb_1;
5588 
5589  /* Evaluate all arguments first: */
5590  n1=find(FEATCMP,one,funct->attr_list);
5591  if (n1) {
5592  arg1= (ptr_psi_term )n1->data;
5593  deref(arg1);
5594  }
5595  n2=find(FEATCMP,two,funct->attr_list);
5596  if (n2) {
5597  arg2= (ptr_psi_term )n2->data;
5598  deref(arg2);
5599  }
5600  deref_args(funct,set_1_2);
5601 
5602  if (success) {
5603  if (n1) {
5604  if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
5605  if (arg1->value_3)
5606  c_arg1= (char *)arg1->value_3;
5607  else {
5608  residuate(arg1);
5609  all_args=FALSE;
5610  }
5611  else
5612  success=FALSE;
5613  }
5614  else {
5615  all_args=FALSE;
5616  curry();
5617  };
5618  };
5619 
5620  if (success) {
5621  if (n2) {
5622  if (overlap_type(arg2->type,quoted_string)) /* 10.8 */
5623  if (arg2->value_3)
5624  c_arg2= (char *)arg2->value_3;
5625  else {
5626  residuate(arg2);
5627  all_args=FALSE;
5628  }
5629  else
5630  success=FALSE;
5631  }
5632  else {
5633  all_args=FALSE;
5634  curry();
5635  }
5636  }
5637 
5638  if(success && all_args) {
5639  c_result=str_conc( c_arg1, c_arg2 );
5640  temp_result=stack_psi_term(0);
5641  temp_result->type=quoted_string;
5642  temp_result->value_3= (GENERIC)c_result;
5643  push_goal(unify,temp_result,result,NULL);
5644  }
5645 
5646  return success;
5647 }
5648 
5656 static long c_module_name()
5657 {
5658  long success=TRUE;
5659  ptr_psi_term arg1,arg2,funct,result;
5660 
5661 
5662  funct=aim->aaaa_1;
5663  result=aim->bbbb_1;
5664  deref_ptr(funct);
5665  deref_ptr(result);
5666 
5667  get_two_args(funct->attr_list,&arg1,&arg2);
5668 
5669  if (arg1) {
5670  deref_ptr(arg1);
5671  arg2=stack_psi_term(0);
5672  arg2->type=quoted_string;
5674  push_goal(unify,arg2,result,NULL);
5675  }
5676  else
5677  curry();
5678 
5679  return success;
5680 }
5681 
5689 static long c_combined_name()
5690 {
5691  long success=TRUE;
5692  ptr_psi_term arg1,arg2,funct,result;
5693 
5694 
5695  funct=aim->aaaa_1;
5696  result=aim->bbbb_1;
5697  deref_ptr(funct);
5698  deref_ptr(result);
5699 
5700  get_two_args(funct->attr_list,&arg1,&arg2);
5701 
5702  if (arg1) {
5703  deref_ptr(arg1);
5704  arg2=stack_psi_term(0);
5705  arg2->type=quoted_string;
5707  push_goal(unify,arg2,result,NULL);
5708  }
5709  else
5710  curry();
5711 
5712  return success;
5713 }
5714 
5723 {
5724  ptr_psi_term result,funct;
5725  ptr_node n1;
5726  long success=TRUE;
5727  long all_args=TRUE;
5728  long c_result;
5729  ptr_psi_term arg1;
5730  char * c_arg1;
5731 
5732  funct=aim->aaaa_1;
5733  deref_ptr(funct);
5734  result=aim->bbbb_1;
5735 
5736  /* Evaluate all arguments first: */
5737  n1=find(FEATCMP,one,funct->attr_list);
5738  if (n1) {
5739  arg1= (ptr_psi_term )n1->data;
5740  deref(arg1);
5741  }
5742  deref_args(funct,set_1);
5743 
5744  if (success) {
5745  if (n1) {
5746  if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
5747  if (arg1->value_3)
5748  c_arg1= (char *)arg1->value_3;
5749  else {
5750  residuate(arg1);
5751  all_args=FALSE;
5752  }
5753  else
5754  success=FALSE;
5755  }
5756  else {
5757  all_args=FALSE;
5758  curry();
5759  };
5760  };
5761 
5762  if (success && all_args) {
5763  c_result=strlen(c_arg1);
5764  push_goal(unify,real_stack_psi_term(0,(REAL)c_result),result,NULL);
5765  };
5766 
5767  return success;
5768 }
5769 
5778 {
5779  ptr_psi_term result,funct,temp_result;
5780  ptr_node n1,n2,n3;
5781  long success=TRUE;
5782  long all_args=TRUE;
5783  char * c_result;
5784  ptr_psi_term arg1;
5785  char * c_arg1;
5786  ptr_psi_term arg2;
5787  long c_arg2;
5788  ptr_psi_term arg3;
5789  long c_arg3;
5790 
5791  funct=aim->aaaa_1;
5792  deref_ptr(funct);
5793  result=aim->bbbb_1;
5794 
5795  /* Evaluate all arguments first: */
5796  n1=find(FEATCMP,one,funct->attr_list);
5797  if (n1) {
5798  arg1= (ptr_psi_term )n1->data;
5799  deref(arg1);
5800  }
5801  n2=find(FEATCMP,two,funct->attr_list);
5802  if (n2) {
5803  arg2= (ptr_psi_term )n2->data;
5804  deref(arg2);
5805  }
5806  n3=find(FEATCMP,three,funct->attr_list);
5807  if (n3) {
5808  arg3= (ptr_psi_term )n3->data;
5809  deref(arg3);
5810  }
5811  deref_args(funct,set_1_2_3);
5812 
5813  if (success) {
5814  if (n1) {
5815  if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
5816  if (arg1->value_3)
5817  c_arg1= (char *)arg1->value_3;
5818  else {
5819  residuate(arg1);
5820  all_args=FALSE;
5821  }
5822  else
5823  success=FALSE;
5824  }
5825  else {
5826  all_args=FALSE;
5827  curry();
5828  };
5829  };
5830 
5831  if (success) {
5832  if (n2) {
5833  if (overlap_type(arg2->type,integer)) /* 10.8 */
5834  if (arg2->value_3)
5835  c_arg2= (long)(* (double *)(arg2->value_3));
5836  else {
5837  residuate(arg2);
5838  all_args=FALSE;
5839  }
5840  else
5841  success=FALSE;
5842  }
5843  else {
5844  all_args=FALSE;
5845  curry();
5846  };
5847  };
5848 
5849  if (success) {
5850  if (n3) {
5851  if (overlap_type(arg3->type,integer)) /* 10.8 */
5852  if (arg3->value_3)
5853  c_arg3= (long)(* (double *)(arg3->value_3));
5854  else {
5855  residuate(arg3);
5856  all_args=FALSE;
5857  }
5858  else
5859  success=FALSE;
5860  }
5861  else {
5862  all_args=FALSE;
5863  curry();
5864  };
5865  };
5866 
5867  if (success && all_args) {
5868  c_result=sub_str(c_arg1,c_arg2,c_arg3);
5869  temp_result=stack_psi_term(0);
5870  temp_result->type=quoted_string;
5871  temp_result->value_3=(GENERIC)c_result;
5872  push_goal(unify,temp_result,result,NULL);
5873  };
5874 
5875  return success;
5876 }
5877 
5887 {
5888  ptr_psi_term g;
5889  ptr_node n1,n2;
5890  long success=TRUE;
5891  ptr_psi_term arg1;
5892  char * c_arg1;
5893  ptr_psi_term arg2;
5894  char * c_arg2;
5895 
5896  g=aim->aaaa_1;
5897  deref_ptr(g);
5898 
5899  /* Evaluate all arguments first: */
5900  n1=find(FEATCMP,one,g->attr_list);
5901  if (n1) {
5902  arg1= (ptr_psi_term )n1->data;
5903  deref(arg1);
5904  }
5905  n2=find(FEATCMP,two,g->attr_list);
5906  if (n2) {
5907  arg2= (ptr_psi_term )n2->data;
5908  deref(arg2);
5909  }
5910  deref_args(g,set_1_2);
5911 
5912  if (success) {
5913  if (n1) {
5914  if (overlap_type(arg1->type,quoted_string))
5915  if (arg1->value_3)
5916  c_arg1= (char *)arg1->value_3;
5917  else {
5918  success=FALSE;
5919  Errorline("bad argument in %P.\n",g);
5920  }
5921  else
5922  success=FALSE;
5923  }
5924  else {
5925  success=FALSE;
5926  Errorline("bad argument in %P.\n",g);
5927  };
5928  };
5929 
5930  if (success) {
5931  if (n2) {
5932  if (overlap_type(arg2->type,quoted_string))
5933  if (arg2->value_3)
5934  c_arg2= (char *)arg2->value_3;
5935  else {
5936  success=FALSE;
5937  Errorline("bad argument in %P.\n",g);
5938  }
5939  else
5940  success=FALSE;
5941  }
5942  else {
5943  success=FALSE;
5944  Errorline("bad argument in %P.\n",g);
5945  };
5946  };
5947 
5948  if (success)
5949  success=append_files(c_arg1,c_arg2);
5950 
5951  return success;
5952 }
5953 
5962 long c_random()
5963 {
5964  ptr_psi_term result,funct;
5965  ptr_node n1;
5966  long success=TRUE;
5967  long all_args=TRUE;
5968  long c_result;
5969  ptr_psi_term arg1;
5970  long c_arg1;
5971 
5972  funct=aim->aaaa_1;
5973  deref_ptr(funct);
5974  result=aim->bbbb_1;
5975 
5976  /* Evaluate all arguments first: */
5977  n1=find(FEATCMP,one,funct->attr_list);
5978  if (n1) {
5979  arg1= (ptr_psi_term )n1->data;
5980  deref(arg1);
5981  }
5982  deref_args(funct,set_1);
5983 
5984  if (success) {
5985  if (n1) {
5986  if (overlap_type(arg1->type,integer))
5987  if (arg1->value_3)
5988  c_arg1= (long)(* (double *)(arg1->value_3));
5989  else {
5990  residuate(arg1);
5991  all_args=FALSE;
5992  }
5993  else
5994  success=FALSE;
5995  }
5996  else {
5997  all_args=FALSE;
5998  curry();
5999  }
6000  }
6001 
6002  if (success && all_args) {
6003  if (c_arg1) {
6004 #ifdef SOLARIS
6005  c_result=(rand_r(&randomseed)<<15) + rand_r(&randomseed);
6006 #else
6007  c_result=random();
6008 #endif
6009  c_result=c_result-(c_result/c_arg1)*c_arg1;
6010  }
6011  else
6012  c_result=0;
6013 
6014  push_goal(unify,real_stack_psi_term(0,(REAL)c_result),result,NULL);
6015  }
6016 
6017  return success;
6018 }
6019 
6029 {
6030  ptr_psi_term t;
6031  ptr_node n1;
6032  long success=TRUE;
6033  long all_args=TRUE;
6034  // long c_result;
6035  ptr_psi_term arg1;
6036  long c_arg1;
6037 
6038  t=aim->aaaa_1;
6039  deref_ptr(t);
6040 
6041  /* Evaluate all arguments first: */
6042  n1=find(FEATCMP,one,t->attr_list);
6043  if (n1) {
6044  arg1= (ptr_psi_term )n1->data;
6045  deref(arg1);
6046  }
6047  deref_args(t,set_1);
6048 
6049  if (success) {
6050  if (n1) {
6051  if (overlap_type(arg1->type,integer))
6052  if (arg1->value_3)
6053  c_arg1= (long)(* (double *)(arg1->value_3));
6054  else {
6055  residuate(arg1);
6056  all_args=FALSE;
6057  }
6058  else
6059  success=FALSE;
6060  }
6061  else {
6062  all_args=FALSE;
6063  }
6064  }
6065 
6066 #ifdef SOLARIS
6067  if (success && all_args) randomseed=c_arg1;
6068 #else
6069  if (success && all_args) srandom(c_arg1);
6070 #endif
6071 
6072  return success;
6073 }
6074 
6084 {
6085  ptr_psi_term result,funct;
6086  long success=TRUE;
6087  int count;
6088  ptr_psi_term arg1; // ,arg2;
6089  ptr_node n1;
6090 
6091  funct=aim->aaaa_1;
6092  deref_ptr(funct);
6093  result=aim->bbbb_1;
6094 
6095  n1=find(FEATCMP,one,funct->attr_list);
6096  if (n1) {
6097  count=0;
6098  arg1= (ptr_psi_term )n1->data;
6099  while(arg1->coref) {
6100  count++;
6101  arg1=arg1->coref;
6102  }
6103  success=unify_real_result(result,(REAL)count);
6104  }
6105  else
6106  curry();
6107 
6108  return success;
6109 }
6110 
6118 long c_args()
6119 {
6120  ptr_psi_term result,list,str;
6121  long success=TRUE;
6122  int i;
6123 
6124  result=aim->bbbb_1;
6125 
6126  list=stack_nil();
6127  for(i=arg_c-1;i>=0;i--) {
6128  str=stack_psi_term(0);
6129  str->type=quoted_string;
6131  list=stack_cons((ptr_psi_term)str,(ptr_psi_term)list);
6132  }
6133  push_goal(unify,result,list,NULL);
6134 
6135  return success;
6136 }
6137 
6151 {
6152  ptr_definition t;
6153 
6154  /* symbol_table=NULL; RM: Feb 3 1993 */
6155 
6156 
6157 
6158  /* RM: Jan 13 1993 */
6159  /* Initialize the minimum syntactic symbols */
6160  (void)set_current_module(syntax_module); /* RM: Feb 3 1993 */
6162  (void)update_symbol(syntax_module,"[");
6163  (void)update_symbol(syntax_module,"]");
6164  (void)update_symbol(syntax_module,"(");
6165  (void)update_symbol(syntax_module,")");
6166  (void)update_symbol(syntax_module,"{");
6167  (void)update_symbol(syntax_module,"}");
6168  (void)update_symbol(syntax_module,".");
6169  (void)update_symbol(syntax_module,"?");
6170 
6171 
6176  eof =update_symbol(syntax_module,"end_of_file");
6180  life_or =update_symbol(syntax_module,";");/* RM: Apr 6 1993 */
6181  minus_symbol =update_symbol(syntax_module,"-");/* RM: Jun 21 1993 */
6187 
6188  /* RM: Jul 7 1993 */
6191 
6192 
6193 
6194  /* RM: Feb 3 1993 */
6196  error_psi_term=heap_psi_term(4); /* 8.10 */
6197  error_psi_term->type=update_symbol(bi_module,"*** ERROR ***");
6199 
6200  apply =update_symbol(bi_module,"apply");
6201  boolean =update_symbol(bi_module,"bool");
6202  boolpredsym =update_symbol(bi_module,"bool_pred");
6203  built_in =update_symbol(bi_module,"built_in");
6204  calloncesym =update_symbol(bi_module,"call_once");
6205  /* colon sym */
6206  /* comma sym */
6207  comment =update_symbol(bi_module,"comment");
6208 
6209 
6210  /* RM: Dec 11 1992 conjunctions have been totally scrapped it seems */
6211  /* conjunction=update_symbol("*conjunction*"); 19.8 */
6212 
6213  constant =update_symbol(bi_module,"*constant*");
6214  disjunction =update_symbol(bi_module,"disj");/*RM:9 Dec 92*/
6215  lf_false =update_symbol(bi_module,"false");
6216  functor =update_symbol(bi_module,"functor");
6217  iff =update_symbol(bi_module,"cond");
6219  alist =update_symbol(bi_module,"cons");/*RM:9 Dec 92*/
6220  nothing =update_symbol(bi_module,"bottom");
6221  nil =update_symbol(bi_module,"nil");/*RM:9 Dec 92*/
6223  real =update_symbol(bi_module,"real");
6224  stream =update_symbol(bi_module,"stream");
6225  succeed =update_symbol(bi_module,"succeed");
6226  lf_true =update_symbol(bi_module,"true");
6227  timesym =update_symbol(bi_module,"time");
6228  variable =update_symbol(bi_module,"*variable*");
6229  opsym =update_symbol(bi_module,"op");
6230  loadsym =update_symbol(bi_module,"load");
6231  dynamicsym =update_symbol(bi_module,"dynamic");
6232  staticsym =update_symbol(bi_module,"static");
6233  encodesym =update_symbol(bi_module,"encode");
6234  listingsym =update_symbol(bi_module,"c_listing");
6235  /* provesym =update_symbol(bi_module,"prove"); */
6236  delay_checksym =update_symbol(bi_module,"delay_check");
6237  eval_argsym =update_symbol(bi_module,"non_strict");
6238  inputfilesym =update_symbol(bi_module,"input_file");
6239  call_handlersym =update_symbol(bi_module,"call_handler");
6247  nullsym =update_symbol(bi_module,"<NULL PSI TERM>");
6250 
6251 
6252  (void)set_current_module(no_module); /* RM: Feb 3 1993 */
6253  t=update_symbol(no_module,"1");
6254  one=t->keyword->symbol;
6255  t=update_symbol(no_module,"2");
6256  two=t->keyword->symbol;
6257  t=update_symbol(no_module,"3");
6258  three=t->keyword->symbol;
6259  (void)set_current_module(bi_module); /* RM: Feb 3 1993 */
6260  t=update_symbol(bi_module,"year");
6261  year_attr=t->keyword->symbol;
6262  t=update_symbol(bi_module,"month");
6264  t=update_symbol(bi_module,"day");
6265  day_attr=t->keyword->symbol;
6266  t=update_symbol(bi_module,"hour");
6267  hour_attr=t->keyword->symbol;
6268  t=update_symbol(bi_module,"minute");
6270  t=update_symbol(bi_module,"second");
6272  t=update_symbol(bi_module,"weekday");
6274 
6277 
6278  /* Built-in routines */
6279  // bi_list = fopen("bi_list.txt","w");
6280 
6281  /* Program database */
6283  new_built_in(bi_module,"static",(def_type)predicate,c_static);
6284  new_built_in(bi_module,"assert",(def_type)predicate,c_assert_last);
6285  new_built_in(bi_module,"asserta",(def_type)predicate,c_assert_first);
6286  new_built_in(bi_module,"clause",(def_type)predicate,c_clause);
6287  new_built_in(bi_module,"retract",(def_type)predicate,c_retract);
6288  new_built_in(bi_module,"setq",(def_type)predicate,c_setq);
6289  new_built_in(bi_module,"c_listing",(def_type)predicate,c_listing);
6290  new_built_in(bi_module,"print_codes",(def_type)predicate,c_print_codes);
6291 
6292  /* File I/O */
6293  new_built_in(bi_module,"get",(def_type)predicate,c_get);
6294  new_built_in(bi_module,"put",(def_type)predicate,c_put);
6295  new_built_in(bi_module,"open_in",(def_type)predicate,c_open_in);
6296  new_built_in(bi_module,"open_out",(def_type)predicate,c_open_out);
6297  new_built_in(bi_module,"set_input",(def_type)predicate,c_set_input);
6298  new_built_in(bi_module,"set_output",(def_type)predicate,c_set_output);
6299  new_built_in(bi_module,"exists_file",(def_type)predicate,c_exists);
6300  new_built_in(bi_module,"close",(def_type)predicate,c_close);
6301  new_built_in(bi_module,"simple_load",(def_type)predicate,c_load);
6302  new_built_in(bi_module,"put_err",(def_type)predicate,c_put_err);
6303  new_built_in(bi_module,"chdir",(def_type)predicate,c_chdir);
6304 
6305  /* Term I/O */
6306  new_built_in(bi_module,"write",(def_type)predicate,c_write);
6307  new_built_in(bi_module,"writeq",(def_type)predicate,c_writeq);
6308  new_built_in(bi_module,"pretty_write",(def_type)predicate,c_pwrite);
6309  new_built_in(bi_module,"pretty_writeq",(def_type)predicate,c_pwriteq);
6310  new_built_in(bi_module,"write_canonical",(def_type)predicate,c_write_canonical);
6311  new_built_in(bi_module,"page_width",(def_type)predicate,c_page_width);
6312  new_built_in(bi_module,"print_depth",(def_type)predicate,c_print_depth);
6313  new_built_in(bi_module,"put_err",(def_type)predicate,c_put_err);
6315  new_built_in(bi_module,"read",(def_type)predicate,c_read_psi);
6316  new_built_in(bi_module,"read_token",(def_type)predicate,c_read_token);
6317  new_built_in(bi_module,"c_op",(def_type)predicate,c_op); /* RM: Jan 13 1993 */
6318  new_built_in(bi_module,"ops",(def_type)function_it,c_ops);
6319  new_built_in(bi_module,"write_err",(def_type)predicate,c_write_err);
6320  new_built_in(bi_module,"writeq_err",(def_type)predicate,c_writeq_err);
6321 
6322  /* Type checks */
6323  new_built_in(bi_module,"nonvar",(def_type)function_it,c_nonvar);
6324  new_built_in(bi_module,"var",(def_type)function_it,c_var);
6325  new_built_in(bi_module,"is_function",(def_type)function_it,c_is_function);
6326  new_built_in(bi_module,"is_predicate",(def_type)function_it,c_is_predicate);
6327  new_built_in(bi_module,"is_sort",(def_type)function_it,c_is_sort);
6328 
6331  (def_type)function_it,
6333 
6334  /* RM: Dec 16 1992 So the symbol can be changed easily */
6335 
6336 
6337  /* Arithmetic */
6339 
6340  /* Comparison */
6341  new_built_in(syntax_module,"<",(def_type)function_it,c_lt);
6342  new_built_in(syntax_module,"=<",(def_type)function_it,c_ltoe);
6343  new_built_in(syntax_module,">",(def_type)function_it,c_gt);
6344  new_built_in(syntax_module,">=",(def_type)function_it,c_gtoe);
6345  new_built_in(syntax_module,"=\\=",(def_type)function_it,c_diff);
6346  new_built_in(syntax_module,"=:=",(def_type)function_it,c_equal);
6347  new_built_in(syntax_module,"and",(def_type)function_it,c_and);
6348  new_built_in(syntax_module,"or",(def_type)function_it,c_or);
6349  new_built_in(syntax_module,"not",(def_type)function_it,c_not);
6350  new_built_in(syntax_module,"xor",(def_type)function_it,c_xor);
6351  new_built_in(syntax_module,"===",(def_type)function_it,c_same_address);
6352 
6353  /* RM: Nov 22 1993 */
6354  new_built_in(syntax_module,"\\===",(def_type)function_it,c_diff_address);
6355 
6356  /* Psi-term navigation */
6357  new_built_in(bi_module,"features",(def_type)function_it,c_features);
6358  new_built_in(bi_module,"feature_values",(def_type)function_it,c_feature_values); /* RM: Mar 3 1994 */
6359 
6360  /* RM: Jul 20 1993 */
6361 
6362  new_built_in(syntax_module,".",(def_type)function_it,c_project);/* RM: Jul 7 1993 */
6363  new_built_in(bi_module,"root_sort",(def_type)function_it,c_rootsort);
6364  new_built_in(bi_module,"strip",(def_type)function_it,c_strip);
6365  new_built_in(bi_module,"copy_pointer",(def_type)function_it,c_copy_pointer); /* PVR: Dec 17 1992 */
6366  new_built_in(bi_module,"has_feature",(def_type)function_it,c_exist_feature); /* PVR: Dec 17 1992 */
6367 
6368  /* Unification and assignment */
6370  /* new_built_in(syntax_module,"<<-",(def_type)predicate,c_assign); RM: Feb 24 1993 */
6371 
6372  /* RM: Feb 24 1993 */
6374  /* new_built_in(syntax_module,"<<<-",(def_type)predicate,c_global_assign); */
6375 
6376  /* RM: Feb 8 1993 */
6377  new_built_in(syntax_module,"{}",(def_type)function_it,c_fail); /* RM: Feb 16 1993 */
6379  new_built_in(syntax_module,"&",(def_type)function_it,c_unify_func);
6380  new_built_in(bi_module,"copy_term",(def_type)function_it,c_copy_term);
6381  /* UNI new_built_in(syntax_module,":",(def_type)function_it,c_unify_func); */
6382 
6383  /* Type hierarchy navigation */
6385 
6386  /* String and character utilities */
6387  new_built_in(bi_module,"str2psi",(def_type)function_it,c_string2psi);
6388  new_built_in(bi_module,"psi2str",(def_type)function_it,c_psi2string);
6389  new_built_in(bi_module,"int2str",(def_type)function_it,c_int2string);
6390  new_built_in(bi_module,"asc",(def_type)function_it,c_ascii);
6391  new_built_in(bi_module,"chr",(def_type)function_it,c_char);
6392 
6393  /* Control */
6394  new_built_in(syntax_module,"|",(def_type)function_it,c_such_that);
6395  new_built_in(bi_module,"cond",(def_type)function_it,c_cond);
6396  new_built_in(bi_module,"if",(def_type)function_it,c_cond);
6397  new_built_in(bi_module,"eval",(def_type)function_it,c_eval);
6398  new_built_in(bi_module,"evalin",(def_type)function_it,c_eval_inplace);
6399  /* new_built_in(bi_module,"quote",(def_type)function_it,c_quote); */
6400  /*new_built_in(bi_module,"call_once",(def_type)function_it,c_call_once);*/ /* DENYS: Jan 25 1995 */
6401  /* new_built_in(bi_module,"call",(def_type)function_it,c_call); */
6402  /* new_built_in(bi_module,"undefined",(def_type)function_it,c_fail); */ /* RM: Jan 13 1993 */
6403  new_built_in(bi_module,"print_variables",(def_type)predicate,c_print_variables);
6404  new_built_in(bi_module,"get_choice",(def_type)function_it,c_get_choice);
6405  new_built_in(bi_module,"set_choice",(def_type)predicate,c_set_choice);
6406  new_built_in(bi_module,"exists_choice",(def_type)function_it,c_exists_choice);
6407  new_built_in(bi_module,"apply",(def_type)function_it,c_apply);
6408  new_built_in(bi_module,"bool_pred",(def_type)predicate,c_boolpred);
6409 
6412  /* new_built_in(syntax_module,"::",(def_type)predicate,c_declaration); */
6415  new_built_in(syntax_module,";",(def_type)predicate,c_disj);
6417  new_built_in(syntax_module,",",(def_type)predicate,c_succeed);
6418  new_built_in(bi_module,"abort",(def_type)predicate,c_abort);
6419  new_built_in(bi_module,"halt",(def_type)predicate,c_halt);
6420  new_built_in(bi_module,"succeed",(def_type)predicate,c_succeed);
6421  new_built_in(bi_module,"repeat",(def_type)predicate,c_repeat);
6422  new_built_in(bi_module,"fail",(def_type)predicate,c_fail);
6423  /* new_built_in(bi_module,"freeze",(def_type)predicate,c_freeze); PVR 16.9.93 */
6424  new_built_in(bi_module,"implies",(def_type)predicate,c_implies);
6425  new_built_in(bi_module,"undo",(def_type)predicate,c_undo);
6426  new_built_in(bi_module,"delay_check",(def_type)predicate,c_delay_check);
6427  new_built_in(bi_module,"non_strict",(def_type)predicate,c_non_strict);
6428 
6429  /* System */
6431 
6432  new_built_in(bi_module,"strcon",(def_type)function_it,c_concatenate);
6433  new_built_in(bi_module,"strlen",(def_type)function_it,c_string_length);
6434  new_built_in(bi_module,"substr",(def_type)function_it,c_sub_string);
6435  new_built_in(bi_module,"append_file",(def_type)predicate,c_append_file);
6436  new_built_in(bi_module,"random",(def_type)function_it,c_random);
6437  new_built_in(bi_module,"initrandom",(def_type)predicate,c_initrandom);
6438 
6439  /* RM: Jan 8 1993 */
6440  new_built_in(bi_module,"set_module",(def_type)predicate,c_set_module);
6441  new_built_in(bi_module,"open_module",(def_type)predicate,c_open_module);
6442  new_built_in(bi_module,"public",(def_type)predicate,c_public);
6443  new_built_in(bi_module,"private",(def_type)predicate,c_private);
6444  new_built_in(bi_module,"display_modules",(def_type)predicate,c_display_modules);
6445  new_built_in(bi_module,"trace_input",(def_type)predicate,c_trace_input);
6446  new_built_in(bi_module,"substitute",(def_type)predicate,c_replace);
6447  new_built_in(bi_module,"current_module",(def_type)function_it,c_current_module);
6448  new_built_in(bi_module,"module_name",(def_type)function_it,c_module_name);
6449  new_built_in(bi_module,"combined_name",(def_type)function_it,c_combined_name);
6450  /* new_built_in(bi_module,"#",(def_type)function_it,c_module_access); */
6451 
6452  /* Hack so '.set_up' doesn't issue a Warning message */
6453  /* RM: Feb 3 1993 */
6454  hash_lookup(bi_module->symbol_table,"set_module")->public=TRUE;
6456 
6457  /* RM: Jan 29 1993 */
6458  abortsym=update_symbol(bi_module,"abort"); /* 26.1 */
6459  aborthooksym=update_symbol(bi_module,"aborthook"); /* 26.1 */
6460  tracesym=update_symbol(bi_module,"trace"); /* 26.1 */
6461 
6462 
6463  /* RM: Feb 9 1993 */
6464  new_built_in(bi_module,"global",(def_type)predicate,c_global);
6465  new_built_in(bi_module,"persistent",(def_type)predicate,c_persistent);
6466  new_built_in(bi_module,"display_persistent",(def_type)predicate,c_display_persistent);
6467  new_built_in(bi_module,"alias",(def_type)predicate,c_alias);
6468 
6469  /* RM: Mar 11 1993 */
6470  new_built_in(bi_module,"private_feature",(def_type)predicate,c_private_feature);
6471  add_module1=update_symbol(bi_module,"features");
6472  add_module2=update_symbol(bi_module,"str2psi");
6473  add_module3=update_symbol(bi_module,"feature_values"); /* RM: Mar 3 1994 */
6474 
6475  /* RM: Jun 29 1993 */
6476  new_built_in(bi_module,"split_double",(def_type)function_it,c_split_double);
6477  new_built_in(bi_module,"string_address",(def_type)function_it,c_string_address);
6478 
6479  /* RM: Jul 15 1993 */
6480  new_built_in(bi_module,"deref_length",(def_type)function_it,c_deref_length);
6481 
6482 
6483  /* RM: Sep 20 1993 */
6484  new_built_in(bi_module,"argv",(def_type)function_it,c_args);
6485 
6486  /* RM: Jan 28 1994 */
6487  new_built_in(bi_module,"public_symbols",(def_type)function_it,all_public_symbols);
6488 
6489 #ifdef CLIFE
6490  life_reals();
6491 #endif /* CLIFE */
6492 
6494  // fclose(bi_list);
6495 }
static long c_diff()
c_diff
Definition: built_ins.c:1309
#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)())
new_built_in
Definition: built_ins.c:5371
static long c_get()
c_get
Definition: built_ins.c:2989
static long c_listing()
c_listing
Definition: built_ins.c:5168
static long c_char()
c_char
Definition: built_ins.c:4727
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
void insert_math_builtins()
insert math builtins into table
Definition: bi_math.c:1346
static long c_is_sort()
c_is_sort
Definition: built_ins.c:1571
ptr_psi_term aaaa_2
Definition: def_struct.h:189
ptr_keyword hash_lookup(ptr_hash_table table, char *symbol)
HASH_LOOKUP.
Definition: hash_table.c:131
long c_initrandom()
c_initrandom
Definition: built_ins.c:6028
ptr_residuation resid
Definition: def_struct.h:173
long trail_condition(psi_term *Q)
trail_condition
Definition: login.c:2632
ptr_definition abortsym
Definition: def_glob.h:64
static long built_in_index
Definition: built_ins.c:16
#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)
get_two_args
Definition: login.c:47
void push_ptr_value(type_ptr t, GENERIC *p)
push_ptr_value
Definition: login.c:383
#define is_top(T)
Definition: def_macro.h:108
static long c_exists()
c_exists
Definition: built_ins.c:1733
ptr_psi_term init_value
Definition: def_struct.h:142
long open_output_file(char *file)
void undo(ptr_stack limit)
undo
Definition: login.c:691
static long c_combined_name()
c_combined_name
Definition: built_ins.c:5689
void get_one_arg_addr(ptr_node t, ptr_psi_term **a)
get_one_arg_addr
Definition: login.c:132
#define HEAP
Definition: def_const.h:147
long assert_first
Definition: def_glob.h:58
static long c_exists_choice()
c_exists_choice
Definition: built_ins.c:1911
#define yfx
Definition: def_const.h:268
static long c_static()
c_static
Definition: built_ins.c:1643
static long c_read(long)
c_read
Definition: built_ins.c:2123
#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()
clear_copy
Definition: copy.c:53
static long c_write()
c_write
Definition: built_ins.c:3174
static long c_pwriteq()
c_pwriteq
Definition: built_ins.c:3250
static long c_unify_func()
c_unify_func
Definition: built_ins.c:4421
static long c_clause()
c_clause
Definition: built_ins.c:2520
struct wl_definition * def_type
Definition: def_struct.h:32
static long c_declaration()
c_declaration
Definition: built_ins.c:2314
ptr_psi_term stack_cons(ptr_psi_term head, ptr_psi_term tail)
stack_cons
Definition: built_ins.c:46
char evaluate_args
Definition: def_struct.h:136
long c_random()
c_random
Definition: built_ins.c:5962
void insert_type_builtins()
void insert_type_builtins
Definition: bi_type.c:820
void residuate(ptr_psi_term t)
residuate
Definition: lefun.c:125
#define least_sel
Definition: def_const.h:6
void listing_pred_write(ptr_node n, long fflag)
listing_pred_write
Definition: print.c:1438
void exit_life(long nl_flag)
exit_life
Definition: built_ins.c:2220
FILE * get_stream(ptr_psi_term t)
get_stream
Definition: token.c:278
long c_public()
c_public
Definition: modules.c:687
long main_loop_ok
Definition: def_glob.h:48
static long c_put_main(long)
c_put_main
Definition: built_ins.c:3073
long pred_clause(ptr_psi_term t, long r, ptr_psi_term g)
pred_clause
Definition: built_ins.c:2452
static long c_pwrite()
c_pwrite
Definition: built_ins.c:3232
ptr_definition loadsym
Definition: def_glob.h:113
char * combined_name
Definition: def_struct.h:92
static long c_ascii()
c_ascii
Definition: built_ins.c:4777
static long c_retract()
c_retract
Definition: built_ins.c:2539
long c_display_modules()
c_display_modules
Definition: modules.c:739
static long c_features()
c_features
Definition: built_ins.c:3561
#define xfx
Definition: def_const.h:265
static long c_delay_check()
static long c_delay_check()
Definition: built_ins.c:1662
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()
c_fail
Definition: built_ins.c:1389
ptr_definition dynamicsym
Definition: def_glob.h:114
static long c_quote()
c_quote
Definition: built_ins.c:4005
ptr_definition opsym
Definition: def_glob.h:112
ptr_psi_term real_stack_psi_term(long stat, REAL thereal)
real_stack_psi_term
Definition: lefun.c:48
long type_count
Definition: def_glob.h:46
ptr_definition comment
Definition: def_glob.h:80
static long c_exist_feature()
c_exist_feature
Definition: built_ins.c:3496
static long c_rootsort()
c_rootsort
Definition: built_ins.c:3352
void push_choice_point(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
push_choice_point
Definition: login.c:638
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
push_goal
Definition: login.c:600
#define def_ptr
Definition: def_const.h:173
psi_term parse(long *q)
parse
Definition: parser.c:907
long eof_flag
Definition: def_glob.h:196
ptr_node bk_stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
bk_stack_insert
Definition: trees.c:357
ptr_definition stream
Definition: def_glob.h:103
static long c_persistent()
c_persistent
Definition: built_ins.c:2687
long c_deref_length()
c_deref_length
Definition: built_ins.c:6083
void init_system()
init_system
Definition: lib.c:94
void list_special(ptr_psi_term t)
list_special
Definition: built_ins.c:5127
static long generic_write()
generic_write
Definition: built_ins.c:3115
ptr_definition listingsym
Definition: def_glob.h:117
static long c_call_once()
c_call_once
Definition: sys.c:2090
ptr_psi_term exact_copy(ptr_psi_term t, long heap_flag)
exact_copy
Definition: copy.c:176
#define global
Definition: def_const.h:364
void unify_bool_result(ptr_psi_term t, long v)
unify_bool_result
Definition: built_ins.c:345
#define NOT_CODED
Definition: def_const.h:134
long only_arg1(ptr_psi_term t, ptr_psi_term *arg1)
only_arg1
Definition: built_ins.c:1606
void save_parse_state(ptr_parse_block pb)
save_parse_state
Definition: token.c:425
static long c_freeze_inner(long freeze_flag)
c_freeze_inner
Definition: built_ins.c:4593
ptr_pair_list next
Definition: def_struct.h:191
char * two
Definition: def_glob.h:251
static long c_project()
c_project
Definition: built_ins.c:1208
#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:1146
ptr_definition commasym
Definition: def_glob.h:79
long(* c_rule[MAX_BUILT_INS])()
Definition: def_glob.h:247
static long c_int2string()
c_int2string
Definition: built_ins.c:4939
ptr_psi_term heap_psi_term(long stat)
heap_psi_term
Definition: lefun.c:75
void delete_attr(char *s, ptr_node *n)
delete_attr
Definition: trees.c:522
char * heap_ncopy_string(char *s, int n)
heap_ncopy_string
Definition: trees.c:150
ptr_operator_data next
Definition: def_struct.h:49
long redefine(ptr_psi_term t)
redefine
Definition: types.c:104
static long c_same_address()
c_same_address
Definition: built_ins.c:3853
void push_psi_ptr_value(ptr_psi_term q, GENERIC *p)
push_psi_ptr_value
Definition: login.c:474
static long c_xor()
c_xor
Definition: built_ins.c:1081
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)
persistent_error_check
Definition: built_ins.c:2712
void restore_parse_state(ptr_parse_block pb)
restore_parse_state
Definition: token.c:444
#define fx
Definition: def_const.h:262
void display_psi_stream(ptr_psi_term t)
display_psi_stream
Definition: print.c:1564
ptr_psi_term new_psi_term(long numargs, ptr_definition typ, ptr_psi_term **a1, ptr_psi_term **a2)
new_psi_term
Definition: built_ins.c:5060
long get_real_value(ptr_psi_term t, REAL *v, long *n)
get_real_value
Definition: built_ins.c:262
void persistent_tree(ptr_node n)
persistent_tree
Definition: built_ins.c:2737
def_type type_def
Definition: def_struct.h:133
static long c_unify_pred()
c_unify_pred
Definition: built_ins.c:4450
static void unify_bool(ptr_psi_term arg)
unify_bool
Definition: built_ins.c:912
static long c_cond()
c_cond
Definition: built_ins.c:3419
long c_set_module()
c_set_module
Definition: modules.c:488
long c_append_file()
c_append_file
Definition: built_ins.c:5886
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)
global_error_check
Definition: built_ins.c:2592
ptr_psi_term stack_bytes(char *s, int n)
stack_bytes
Definition: built_ins.c:128
long matches(ptr_definition t1, ptr_definition t2, long *smaller)
matches
Definition: types.c:1666
void assert_protected(ptr_node n, long prot)
assert_protected
Definition: types.c:255
ptr_definition fy_sym
Definition: def_glob.h:125
static long c_string2psi()
c_string2psi
Definition: built_ins.c:4827
#define set_empty
Definition: def_const.h:193
static long c_read_psi()
c_read_psi
Definition: built_ins.c:2098
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()
c_lt C_LT Less than.
Definition: built_ins.c:634
long c_abort()
c_abort
Definition: built_ins.c:2248
ptr_definition aborthooksym
Definition: def_glob.h:65
static long c_boolpred()
c_boolpred
Definition: built_ins.c:839
static long c_diff_address()
c_diff_address
Definition: built_ins.c:3897
void persistent_one(ptr_psi_term t)
persistent_one
Definition: built_ins.c:2756
static long c_open_out()
c_open_out
Definition: built_ins.c:2816
void nonnum_warning(ptr_psi_term t, ptr_psi_term arg1, ptr_psi_term arg2)
nonnum_warning
Definition: error.c:953
ptr_definition constant
Definition: def_glob.h:82
#define FACT
Definition: def_const.h:151
static long c_print_codes()
c_print_codes
Definition: built_ins.c:5281
long c_args()
c_args
Definition: built_ins.c:6118
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)
get_one_arg
Definition: login.c:99
#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()
curry
Definition: lefun.c:174
#define NULL
Definition: def_const.h:203
ptr_node var_tree
Definition: def_glob.h:26
ptr_node distinct_tree(ptr_node t)
distinct_tree
Definition: copy.c:366
ptr_psi_term input_state
Definition: def_glob.h:199
#define xfy
Definition: def_const.h:267
static long c_string_address()
c_string_address
Definition: built_ins.c:4095
ptr_definition quote
Definition: def_glob.h:100
static long c_op()
c_op
Definition: built_ins.c:1698
static long c_ltoe()
c_ltoe
Definition: built_ins.c:770
long c_open_module()
c_open_module
Definition: modules.c:519
long page_width
Definition: def_glob.h:43
char * three
Definition: def_glob.h:252
char * symbol
Definition: def_struct.h:91
#define nop
Definition: def_const.h:260
ptr_definition apply
Definition: def_glob.h:72
#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)
overlap_type
Definition: types.c:1579
#define REAL
Definition: def_const.h:72
static long c_assign()
c_assign
Definition: built_ins.c:4342
ptr_definition update_symbol(ptr_module module, char *symbol)
update_symbol
Definition: modules.c:270
#define op_sel
Definition: def_const.h:8
static long c_parse()
c_parse
Definition: built_ins.c:2013
static long c_freeze()
c_freeze
Definition: built_ins.c:4702
ptr_node heap_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
heap_insert
Definition: trees.c:320
void insert_system_builtins()
insert_system_builtins
Definition: bi_sys.c:744
ptr_resid_list resid_vars
Definition: def_glob.h:221
static long c_page_width()
c_page_width
Definition: built_ins.c:3268
long assert_ok
Definition: def_glob.h:59
int get_module(ptr_psi_term psi, ptr_module *module)
get_module
Definition: modules.c:1226
char always_check
Definition: def_struct.h:134
long abort_life(int nlflag)
abort_life
Definition: built_ins.c:2260
#define eval
Definition: def_const.h:278
static long c_gtoe()
c_gtoe
Definition: built_ins.c:702
ptr_definition minus_symbol
Definition: def_glob.h:96
void stack_add_psi_attr(ptr_psi_term t, char *attrname, ptr_psi_term g)
stack_add_psi_attr
Definition: token.c:239
void release_resid(ptr_psi_term t)
release_resid
Definition: lefun.c:445
ptr_node left
Definition: def_struct.h:183
static long c_psi2string()
c_psi2string
Definition: built_ins.c:4894
static long c_pred()
c_pred
Definition: built_ins.c:5301
ptr_definition xfx_sym
Definition: def_glob.h:126
long sub_type(ptr_definition t1, ptr_definition t2)
sub_type
Definition: types.c:1642
void traceline(char *format,...)
traceline
Definition: error.c:186
static long c_repeat()
c_repeat
Definition: built_ins.c:1417
#define type_it
Definition: def_const.h:363
long c_display_persistent()
c_display_persistent
Definition: modules.c:775
void fetch_def_lazy(ptr_psi_term u, ptr_definition old1, ptr_definition old2, ptr_node old1attr, ptr_node old2attr, long old1stat, long old2stat)
fetch_def_lazy
Definition: login.c:1276
ptr_definition add_module3
Definition: def_glob.h:69
static long c_global_assign()
c_global_assign
Definition: built_ins.c:4379
static long c_split_double()
c_split_double
Definition: built_ins.c:4030
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)
quote_copy
Definition: copy.c:186
void Errorline(char *format,...)
Errorline.
Definition: error.c:465
ptr_definition yf_sym
Definition: def_glob.h:124
ptr_definition disj_nil
Definition: def_glob.h:85
static long c_write_err()
c_write_err
Definition: built_ins.c:3135
static long c_apply()
c_apply
Definition: built_ins.c:1161
#define set_1_2
Definition: def_const.h:196
void assert_delay_check(ptr_node n)
assert_delay_check
Definition: types.c:326
ptr_int_list cons(GENERIC v, ptr_int_list l)
cons
Definition: types.c:179
void stack_add_int_attr(ptr_psi_term t, char *attrname, long value)
stack_add_int_attr
Definition: token.c:94
ptr_definition nullsym
Definition: def_glob.h:129
ptr_definition real
Definition: def_glob.h:102
static long c_writeq_err()
c_writeq_err
Definition: built_ins.c:3155
ptr_psi_term stack_pair(ptr_psi_term left, ptr_psi_term right)
stack_pair
Definition: built_ins.c:69
#define UNDEF
Definition: def_const.h:132
static long c_global()
c_global
Definition: built_ins.c:2562
#define greatest_sel
Definition: def_const.h:7
long check_real(ptr_psi_term t, REAL *v, long *n)
check_real
Definition: built_ins.c:232
void residuate2(ptr_psi_term u, ptr_psi_term v)
residuate2
Definition: lefun.c:144
ptr_node stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
stack_insert
Definition: trees.c:337
char * sub_str(char *s, long p, long n)
sub_str
Definition: built_ins.c:5510
#define deref_ptr(P)
Definition: def_macro.h:95
void bk_mark_quote(ptr_psi_term t)
bk_mark_quote
Definition: copy.c:709
static long c_get_choice()
c_get_choice
Definition: built_ins.c:1815
ptr_definition alist
Definition: def_glob.h:94
char * heap_copy_string(char *s)
heap_copy_string
Definition: trees.c:172
void print_codes()
print_codes
Definition: types.c:1256
ptr_definition functor
Definition: def_glob.h:91
ptr_definition eqsym
Definition: def_glob.h:87
void insert_sys_builtins()
insert_sys_builtins
Definition: sys.c:2215
void global_tree(ptr_node n)
global_tree
Definition: built_ins.c:2632
char * key
Definition: def_struct.h:182
static long c_writeq()
c_writeq
Definition: built_ins.c:3194
#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)
distinct_copy
Definition: copy.c:393
long c_sub_string()
c_sub_string
Definition: built_ins.c:5777
#define TRUE
Definition: def_const.h:127
#define STREAM
Definition: def_const.h:225
long all_public_symbols()
all_public_symbols
Definition: modules.c:1363
static long c_open_in()
c_open_in
Definition: built_ins.c:2770
long has_rules(ptr_pair_list r)
has_rules
Definition: built_ins.c:5097
ptr_definition first_definition
Definition: def_glob.h:3
static long c_dynamic()
c_dynamic
Definition: built_ins.c:1626
static void clean_trail(ptr_choice_point cutpt)
clean_trail
Definition: login.c:810
static long c_logical_main(long sel)
c_logical_main
Definition: built_ins.c:929
ptr_psi_term error_psi_term
Definition: def_glob.h:23
long append_files(char *s1, char *s2)
append_files
Definition: built_ins.c:5539
long c_string_length()
c_string_length
Definition: built_ins.c:5722
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)
mark_eval
Definition: copy.c:498
ptr_definition lf_true
Definition: def_glob.h:107
ptr_psi_term stack_int(long n)
stack_int
Definition: built_ins.c:91
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)
release_resid_notrail
Definition: lefun.c:456
ptr_pair_list rule
Definition: def_struct.h:126
static long c_non_strict()
c_non_strict
Definition: built_ins.c:1681
static long c_copy_term()
c_copy_term
Definition: built_ins.c:4510
ptr_psi_term global_value
Definition: def_struct.h:141
static long c_undo()
c_undo
Definition: built_ins.c:4548
#define FALSE
Definition: def_const.h:128
static long c_eval()
c_eval
Definition: built_ins.c:3941
static long c_nonvar()
c_nonvar
Definition: built_ins.c:1468
#define deref(P)
Definition: def_macro.h:142
int arg_c
Definition: def_glob.h:5
long is_built_in(ptr_pair_list r)
is_built_in
Definition: built_ins.c:5114
#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()
c_halt
Definition: built_ins.c:2209
static long c_disj()
c_disj
Definition: built_ins.c:3388
static long c_eval_disjunction()
c_eval_disjunction
Definition: built_ins.c:590
char * arg_v[10]
Definition: def_glob.h:6
ptr_psi_term stack_psi_term(long stat)
stack_psi_term
Definition: lefun.c:21
char * expand_file_name(char *s)
expand_file_name
Definition: token.c:537
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()
c_current_module
Definition: modules.c:974
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()
c_succeed
Definition: built_ins.c:1401
ptr_psi_term bbbb_2
Definition: def_struct.h:190
void init_parse_state()
init_parse_state
Definition: token.c:464
static long c_and()
c_and
Definition: built_ins.c:1001
ptr_psi_term stack_nil()
stack_nil
Definition: built_ins.c:26
ptr_goal aim
Definition: def_glob.h:49
void pred_write(ptr_node n)
pred_write
Definition: print.c:1469
long print_depth
Definition: def_glob.h:178
static long c_implies()
c_implies
Definition: built_ins.c:4714
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()
c_strip
Definition: built_ins.c:3824
char * one
Definition: def_glob.h:250
ptr_psi_term inc_heap_copy(ptr_psi_term t)
inc_heap_copy
Definition: copy.c:206
static long get_bool(ptr_definition typ)
get_bool
Definition: built_ins.c:899
#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)
mark_quote
Definition: copy.c:675
static long c_put_err()
c_put_err
Definition: built_ins.c:3062
#define xf
Definition: def_const.h:261
long c_private_feature()
c_private_feature
Definition: modules.c:1302
#define unify
Definition: def_const.h:274
static long c_or()
c_or
Definition: built_ins.c:1014
static long c_assert_last()
c_assert_last
Definition: built_ins.c:2417
ptr_definition add_module2
Definition: def_glob.h:68
ptr_node find(long comp, char *keystr, ptr_node tree)
find
Definition: trees.c:394
void save_resid(ptr_resid_block rb, ptr_psi_term match_date)
save_resid
Definition: lefun.c:1398
#define PRINT_DEPTH
Definition: def_const.h:92
ptr_psi_term stack_copy_psi_term(psi_term t)
stack_copy_psi_term
Definition: parser.c:205
long featcmp(char *str1, char *str2)
featcmp
Definition: trees.c:106
ptr_definition life_or
Definition: def_glob.h:95
static long c_close()
c_close
Definition: built_ins.c:2933
static long c_read_token()
c_read_token
Definition: built_ins.c:2108
static long c_not()
c_not
Definition: built_ins.c:1027
void restore_state(ptr_psi_term t)
restore_state
Definition: token.c:334
#define yf
Definition: def_const.h:263
void outputline(char *format,...)
void outputline(char *format,...)
Definition: error.c:101
ptr_definition delay_checksym
Definition: def_glob.h:118
long c_trace_input()
c_trace_input
Definition: modules.c:810
#define load
Definition: def_const.h:288
ptr_node one_attr()
one_attr
Definition: built_ins.c:5038
long str_to_int(char *s)
str_to_int
Definition: print.c:118
ptr_psi_term make_feature_list(ptr_node tree, ptr_psi_term tail, ptr_module module, int val)
make_feature_list
Definition: built_ins.c:176
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()
c_is_predicate
Definition: built_ins.c:1537
static long c_var()
static long c_var()
Definition: built_ins.c:1434
ptr_module module
Definition: def_struct.h:90
long c_alias()
c_alias
Definition: modules.c:1180
#define MAX_PRECEDENCE
Definition: def_const.h:103
void encode_types()
encode_types
Definition: types.c:1091
long deref_eval(ptr_psi_term t)
deref_eval
Definition: lefun.c:1180
long c_concatenate()
c_concatenate
Definition: built_ins.c:5573
static long c_is_function()
c_is_function
Definition: built_ins.c:1502
char * str_conc(char *s1, char *s2)
str_conc
Definition: built_ins.c:5492
ptr_definition add_module1
Definition: def_glob.h:67
static long c_funct()
c_funct
Definition: built_ins.c:5327
ptr_definition tracesym
Definition: def_glob.h:109
long curried
Definition: def_glob.h:223
#define del_clause
Definition: def_const.h:286
#define eval_cut
Definition: def_const.h:279
#define deref_args(P, S)
Definition: def_macro.h:145
static long c_put()
c_put
Definition: built_ins.c:3046
static long c_eval_inplace()
c_eval_inplace
Definition: built_ins.c:3973
ptr_psi_term collect_symbols(long sel)
collect_symbols
Definition: built_ins.c:3696
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
void read_token_b(ptr_psi_term tok)
read_token_b
Definition: token.c:1197
void save_state(ptr_psi_term t)
save_state
Definition: token.c:293
char * prompt
Definition: def_glob.h:42
ptr_definition fx_sym
Definition: def_glob.h:123
void init_built_in_types()
init_built_in_types
Definition: built_ins.c:6150
long c_private()
c_private
Definition: modules.c:714
char * minute_attr
Definition: def_glob.h:257
ptr_definition cut
Definition: def_glob.h:83
long print_variables(long printflag)
print_variables
Definition: print.c:1368
long unify_real_result(ptr_psi_term t, REAL v)
unify_real_result
Definition: built_ins.c:387
static long c_not_implemented()
c_not_implemented
Definition: built_ins.c:2297
long file_exists(char *s)
file_exists
Definition: built_ins.c:1712
long read_char()
read_char
Definition: token.c:680
unsigned long global_time_stamp
Definition: login.c:28
long c_replace()
c_replace
Definition: modules.c:936
long declare_operator(ptr_psi_term t)
declare_operator
Definition: built_ins.c:5432
FILE * output_stream
Definition: def_glob.h:41
static long c_chdir()
c_chdir
Definition: built_ins.c:4148
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()
inherit_always_check
Definition: types.c:1068
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)
global_one
Definition: built_ins.c:2651
static long c_bk_assign()
c_bk_assign
Definition: built_ins.c:4283
ptr_int_list code
Definition: def_struct.h:129
ptr_psi_term eval_copy(ptr_psi_term t, long heap_flag)
eval_copy
Definition: copy.c:196
ptr_definition update_feature(ptr_module module, char *feature)
update_feature
Definition: modules.c:1331
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)
copy_attr_list
Definition: built_ins.c:3802
ptr_module bi_module
Definition: def_glob.h:155
float garbage_time
Definition: def_glob.h:16
void warningline(char *format,...)
warningline
Definition: error.c:371
char * stringinput
Definition: def_glob.h:203
ptr_definition predsym
Definition: def_glob.h:99
static long c_ops()
c_ops
Definition: built_ins.c:3781
int public
Definition: def_struct.h:94
static long c_set_input()
c_set_input
Definition: built_ins.c:2865
static long c_equal()
static long c_equal()
Definition: built_ins.c:508
static void op_declare(long p, operator t, char *s)
op_declare
Definition: built_ins.c:5400
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()
stdin_cleareof
Definition: token.c:51
unsigned long * GENERIC
Definition: def_struct.h:17
static long c_setq()
c_setq
Definition: built_ins.c:2337
ptr_psi_term stack_string(char *s)
stack_string
Definition: built_ins.c:109
static long c_module_name()
c_module_name
Definition: built_ins.c:5656
ptr_definition xf_sym
Definition: def_glob.h:122
static long c_write_canonical()
c_write_canonical
Definition: built_ins.c:3214
static long c_gt()
c_gt
Definition: built_ins.c:440
#define QUOTED_TRUE
Definition: def_const.h:123
long hidden_type(ptr_definition t)
hidden_type
Definition: built_ins.c:3669
ptr_int_list children
Definition: def_struct.h:131
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
static long c_load()
c_load
Definition: built_ins.c:1775
ptr_definition colonsym
Definition: def_glob.h:78
static long get_bool_value(ptr_psi_term t, REAL *v, long *n)
get_bool_value
Definition: built_ins.c:301
ptr_definition inputfilesym
Definition: def_glob.h:120
ptr_definition variable
Definition: def_glob.h:111
static long c_print_depth()
c_print_depth
Definition: built_ins.c:3308
ptr_node attr_list
Definition: def_struct.h:171
long open_input_file(char *file)
open_input_file
Definition: token.c:594
static long c_copy_pointer()
c_copy_pointer
Definition: built_ins.c:4478
static long c_call()
c_call
Definition: built_ins.c:4232
static long c_feature_values()
c_feature_values
Definition: built_ins.c:3615
ptr_module set_current_module(ptr_module module)
set_current_module
Definition: modules.c:100
static long c_assert_first()
c_assert_first
Definition: built_ins.c:2387
void assert_clause(ptr_psi_term t)
assert_clause
Definition: login.c:287
static long c_print_variables()
c_print_variables
Definition: built_ins.c:1968
static long c_set_choice()
c_set_choice
Definition: built_ins.c:1854
ptr_operator_data op_data
Definition: def_struct.h:139
long i_check_out(ptr_psi_term t)
i_check_out
Definition: lefun.c:1033
ptr_definition call_handlersym
Definition: def_glob.h:121
GENERIC heap_alloc(long s)
heap_alloc
Definition: memory.c:1616
static void set_parse_queryflag(ptr_node thelist, long sort)
set_parse_queryflag
Definition: built_ins.c:1984
ptr_choice_point choice_stack
Definition: def_glob.h:51
long write_stderr
Definition: def_glob.h:181
static long c_set_output()
c_set_output
Definition: built_ins.c:2902
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()
c_such_that
Definition: built_ins.c:5007
#define STACK
Definition: def_const.h:148
#define assert(N)
Definition: memory.c:113
#define fy
Definition: def_const.h:264
ptr_node right
Definition: def_struct.h:184
void assert_args_not_eval(ptr_node n)
assert_args_not_eval
Definition: types.c:294
long write_canon
Definition: def_glob.h:184
long psi_to_string(ptr_psi_term t, char **fn)
psi_to_string
Definition: built_ins.c:146
#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