Wild Life: built_ins.c Source File

Wild Life 2.29

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