Wild Life: built_ins.c Source File

Wild Life 2.30

- Main Page
- Data Structures
- Files

- File List
- Globals

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