Wild Life: types.c Source File

Wild Life 2.29

- Main Page
- Data Structures
- Files

- File List
- Globals

All Data Structures Files Functions Variables Typedefs Macros
types.c
Go to the documentation of this file.
1 /* Copyright 1991 Digital Equipment Corporation.
2 ** All Rights Reserved.
3 *****************************************************************/
4 /* $Id: types.c,v 1.7 1994/12/15 22:28:56 duchier Exp $ */
5
6 /****************************************************************************
7
8 These routines implement type encoding using the "Transitive Closure"
9 binary encoding algorithm.
10
11 ****************************************************************************/
12
13 #include "defs.h"
14
15
16 ptr_definition *gamma_table = NULL;
17
18 /******** PRINT_DEF_TYPE(t)
19 This prints type T to stderr, where T=predicate, function or type.
20 */
21 void print_def_type(t)
22 def_type t;
23 {
24 switch ((long)t) {
25 case (long)predicate:
26 perr("predicate");
27 break;
28 case (long)function_it:
29 perr("function");
30 break;
31 case (long)type_it:
32 perr("sort");
33 break;
34 case (long)global: /* RM: Feb 8 1993 */
35 perr("global variable");
36 break;
37 default:
38 perr("undefined");
39 }
40 }
41
42
43 /* Confirm an important change */
44 long yes_or_no()
45 {
46 char *old_prompt;
47 long c,d;
48 ptr_psi_term old_state_loc;
49
50 perr("*** Are you really sure you want to do that ");
51 old_prompt=prompt;
52 prompt="(y/n)?";
53 old_state_loc=input_state;
54 (void)open_input_file("stdin");
55
56 do {
57 do {
58 c=read_char();
59 } while (c!=EOLN && c>0 && c<=32);
60 } while (c!='y' && c!='n');
61
62 d=c;
63 while (d!=EOLN && d!=EOF) d=read_char();
64
65 prompt=old_prompt;
66 input_state=old_state_loc;
67 restore_state(old_state_loc);
68 return (c=='y');
69 }
70
71
72 /* Remove references to d in d's children or parents */
73 void remove_cycles(d, dl)
74 ptr_definition d;
75 ptr_int_list *dl;
76 {
77 while (*dl) {
78 if (((ptr_definition)(*dl)->value_1)==d)
79 *dl = (*dl)->next;
80 else
81 dl= &((*dl)->next);
82 }
83 }
84
85
86
87 /******** REDEFINE(t)
88 This decides whether a definition (a sort, function, or predicate)
89 may be extended or not.
90 */
91 long redefine(t)
92 ptr_psi_term t;
93 {
94 ptr_definition d; // ,d2;
95 // ptr_int_list l,*l2;
96 long success=TRUE;
97
98 deref_ptr(t);
99 d=t->type;
100 if (d->date<file_date) {
101 if (d->type_def==(def_type)type_it) {
102 /* Except for top, sorts are always unprotected, with a warning. */
103 if (FALSE /*d==top*/) {
104 Errorline("the top sort '@' may not be extended.\n");
105 success=FALSE;
106 }
107 /* RM: Mar 25 1993
108 else if (d!=top)
109 warningline("extending definition of sort '%s'.\n",d->keyword->symbol);
110 */
111 }
112 else if (d->protected && d->type_def!=(def_type)undef) {
113 if (d->date>0) {
114 /* The term was entered in a previous file, and therefore */
115 /* cannot be altered. */
116 Errorline("the %T '%s' may not be changed.\n", /* RM: Jan 27 1993 */
117 d->type_def, d->keyword->combined_name);
118 success=FALSE;
119 }
120 else {
121 if (d->rule && (unsigned long)d->rule<=MAX_BUILT_INS /*&& input_stream==stdin*/) {
122 /* d is a built-in, and therefore cannot be altered. */
123 Errorline("the built-in %T '%s' may not be extended.\n",
124 d->type_def, d->keyword->symbol);
125 success=FALSE;
126 }
127 else {
128 /* d is not a built-in, and therefore can be altered. */
129 warningline("extending the %T '%s'.\n",d->type_def,d->keyword->symbol);
130 if (warningflag) if (!yes_or_no()) success=FALSE;
131 }
132 }
133 }
134
135 if (success) {
136 if (d->type_def==(def_type)type_it) { /* d is an already existing type */
137 /* Remove cycles in the type hierarchy of d */
138 /* This is done by Richard's version, and I don't know why. */
139 /* It seems to be a no-op. */
140 remove_cycles(d, &(d->children));
141 remove_cycles(d, &(d->parents));
142 /* d->rule=NULL; */ /* Types must keep their rules! */
143 /* d->properties=NULL; */ /* Types get new properties from encode */
144 }
145 if (d->date==0) d->date=file_date;
146 /* d->type=undef; */ /* Objects keep their type! */
147 /* d->always_check=TRUE; */
148 /* d->protected=TRUE; */
149 /* d->children=NULL; */
150 /* d->parents=NULL; */
151 /* d->code=NOT_CODED; */
152 }
153 }
154
155 return success;
156 }
157
158
159
160
161 /******** CONS(value,list)
162 Returns the list [VALUE|LIST]
163 */
164 ptr_int_list cons(v,l)
165 GENERIC v;
166 ptr_int_list l;
167 {
168 ptr_int_list n;
169
170 n=HEAP_ALLOC(int_list);
171 n->value_1=v;
172 n->next=l;
173
174 return n;
175 }
176
177
178
179 /******** ASSERT_LESS(t1,t2)
180 Assert that T1 <| T2.
181 Return false if some sort of error occurred.
182 */
183 long assert_less(t1,t2)
184 ptr_psi_term t1,t2;
185 {
186 ptr_definition d1,d2;
187 long ok=FALSE;
188 deref_ptr(t1);
189 deref_ptr(t2);
190
191 if (t1->type==top) {
192 Errorline("the top sort '@' may not be a subsort.\n");
193 return FALSE;
194 }
195 if (t1->value_3 || t2->value_3) {
196 Errorline("the declaration '%P <| %P' is illegal.\n",t1,t2);
197 return FALSE;
198 }
199 /* Note: A *full* cyclicity check of the hierarchy is done in encode_types. */
200 if (t1->type==t2->type) {
201 Errorline("cyclic sort declarations are not allowed.\n");
202 return FALSE;
203 }
204
205 if (!redefine(t1)) return FALSE;
206 if (!redefine(t2)) return FALSE;
207 d1=t1->type;
208 d2=t2->type;
209 if (d1->type_def==(def_type)predicate || d1->type_def==(def_type)function_it) {
210 Errorline("the %T '%s' may not be redefined as a sort.\n",
211 d1->type_def, d1->keyword->symbol);
212 }
213 else if (d2->type_def==(def_type)predicate || d2->type_def==(def_type)function_it) {
214 Errorline("the %T '%s' may not be redefined as a sort.\n",
215 d2->type_def, d2->keyword->symbol);
216 }
217 else {
218 d1->type_def=(def_type)type_it;
219 d2->type_def=(def_type)type_it;
220 types_modified=TRUE;
221 make_type_link(d1, d2); /* 1.7 */
222 /* d1->parents=cons(d2,d1->parents); */
223 /* d2->children=cons(d1,d2->children); */
224 ok=TRUE;
225 }
226
227 return ok;
228 }
229
230
231
232 /******** ASSERT_PROTECTED(n,prot)
233 Mark all the nodes in the attribute tree N with protect flag prot.
234 */
235 void assert_protected(n,prot)
236 ptr_node n;
237 long prot;
238 {
239 ptr_psi_term t;
240
241 if (n) {
242 assert_protected(n->left,prot);
243
244 t=(ptr_psi_term)n->data;
245 deref_ptr(t);
246 if (t->type) {
247 if (t->type->type_def==(def_type)type_it) {
248 warningline("'%s' is a sort. It can be extended without a declaration.\n",
249 t->type->keyword->symbol);
250 }
251 else if ((unsigned long)t->type->rule<MAX_BUILT_INS &&
252 (unsigned long)t->type->rule>0) {
253 if (!prot)
254 warningline("'%s' is a built-in--it has not been made dynamic.\n",
255 t->type->keyword->symbol);
256 }
257 else {
258 t->type->protected=prot;
259 if (prot) t->type->date&=(~1); else t->type->date|=1;
260 }
261 }
262
263 assert_protected(n->right,prot);
264 }
265 }
266
267
268
269 /******** ASSERT_ARGS_NOT_EVAL(n)
270 Mark all the nodes in the attribute tree N as having unevaluated arguments,
271 if they are functions or predicates.
272 */
273 void assert_args_not_eval(n)
274 ptr_node n;
275 {
276 ptr_psi_term t;
277
278 if (n) {
279 assert_args_not_eval(n->left);
280
281 t=(ptr_psi_term)n->data;
282 deref_ptr(t);
283 if (t->type) {
284 if (t->type->type_def==(def_type)type_it) {
285 warningline("'%s' is a sort--only functions and predicates\
286 can have unevaluated arguments.\n",t->type->keyword->symbol);
287 }
288 else
289 t->type->evaluate_args=FALSE;
290 }
291
292 assert_args_not_eval(n->right);
293 }
294 }
295
296
297
298 /******** ASSERT_DELAY_CHECK(n)
299 Assert that the types in the attribute tree N will have their
300 properties checked only when they have attributes. If they
301 have no attributes, then no properties are checked.
302 */
303 void assert_delay_check(n)
304 ptr_node n;
305 {
306 if (n) {
307 ptr_psi_term t;
308 assert_delay_check(n->left);
309
310 t=(ptr_psi_term)n->data;
311 deref_ptr(t);
312 if (t->type) {
313 t->type->always_check=FALSE;
314 }
315
316 assert_delay_check(n->right);
317 }
318 }
319
320
321
322 /******** CLEAR_ALREADY_LOADED()
323 Clear the 'already_loaded' flags in all symbol table entries.
324 Done at each top level prompt.
325 */
326 void clear_already_loaded(n)
327 ptr_node n;
328 {
329 ptr_definition d;
330
331 if (n) {
332 d=((ptr_keyword)n->data)->definition;
333 d->already_loaded=FALSE;
334 clear_already_loaded(n->left);
335 clear_already_loaded(n->right);
336 }
337 }
338
339
340
341 /******** ASSERT_TYPE(t)
342 T is the psi_term <|(type1,type2).
343 Add that to the type-definitions.
344 */
345 void assert_type(t)
346 ptr_psi_term t;
347 {
348 ptr_psi_term arg1,arg2;
349
350 get_two_args(t->attr_list,&arg1,&arg2);
351 if(arg1==NULL || arg2==NULL) {
352 Errorline("bad sort declaration '%P' (%E).\n",t);
353 }
354 else
355 assert_ok=assert_less(arg1,arg2);
356 }
357
358
359
360 /******** ASSERT_COMPLICATED_TYPE
361 This deals with all the type declarations of the form:
362
363 a(attr) <| b. % (a<|b)
364 a(attr) <| b | pred.
365
366 a(attr) <| {b;c;d}. % (a<|b, a<|c, a<|d)
367 a(attr) <| {b;c;d} | pred.
368
369 a := b(attr). % (a<|b)
370 a := b(attr) | pred.
371
372 a := {b(attr1);c(attr2);d(attr3)}. % (b<|a,c<|a,d<|a)
373 a := {b(attr1);c(attr2);d(attr3)} | pred.
374 */
375 void assert_complicated_type(t)
376 ptr_psi_term t;
377 {
378 ptr_psi_term arg2,typ1,typ2,pred=NULL;
379 // ptr_list lst;
380 long eqflag = equ_tok((*t),":=");
381 long ok, any_ok=FALSE;
382
383 get_two_args(t->attr_list,&typ1,&arg2);
384
385 if (typ1 && arg2) {
386 deref_ptr(typ1);
387 deref_ptr(arg2);
388 typ2=arg2;
389 if (!strcmp(arg2->type->keyword->symbol,"|")) {
390 typ2=NULL;
391 get_two_args(arg2->attr_list,&arg2,&pred);
392 if (arg2) {
393 deref_ptr(arg2);
394 typ2=arg2;
395 }
396 }
397 if (typ2) {
398 if (typ2->type==disjunction) {
399
400 if (typ1->attr_list && eqflag) {
401 warningline("attributes ignored left of ':=' declaration (%E).\n");
402 }
403 while(typ2 && typ2->type!=nil) {
404 get_two_args(typ2->attr_list,&arg2,&typ2); /* RM: Dec 14 1992 */
405 if(typ2)
406 deref_ptr(typ2);
407 if (arg2) {
408 deref_ptr(arg2);
409 if (eqflag) {
410 ok=assert_less(arg2,typ1);
411 if (ok) any_ok=TRUE;
412 if (ok && (arg2->attr_list || pred!=NULL)) {
413 add_rule(arg2,pred,(def_type)type_it);
414 }
415 }
416 else {
417 ok=assert_less(typ1,arg2);
418 if (ok) any_ok=TRUE;
419 if (ok && arg2->attr_list) {
420 warningline("attributes ignored in sort declaration (%E).\n");
421 }
422 }
423 }
424 }
425 assert_ok=TRUE;
426 }
427 else if (eqflag) {
428 if (typ1->attr_list) {
429 warningline("attributes ignored left of ':=' declaration (%E).\n");
430 }
431 ok=assert_less(typ1,typ2);
432 if (ok) any_ok=TRUE;
433 typ2->type=typ1->type;
434 if (ok && (typ2->attr_list || pred!=NULL))
435 add_rule(typ2,pred,(def_type)type_it);
436 else
437 assert_ok=TRUE;
438 }
439 else {
440 if (typ2->attr_list) {
441 warningline("attributes ignored right of '<|' declaration (%E).\n");
442 }
443 ok=assert_less(typ1,typ2);
444 if (ok) any_ok=TRUE;
445 if (ok && (typ1->attr_list || pred!=NULL))
446 add_rule(typ1,pred,(def_type)type_it);
447 else
448 assert_ok=TRUE;
449 }
450 }
451 else {
452 Errorline("argument missing in sort declaration (%E).\n");
453 }
454 }
455 else {
456 Errorline("argument missing in sort declaration (%E).\n");
457 }
458 if (!any_ok) assert_ok=FALSE;
459 }
460
461
462
463 /******** ASSERT_ATTRIBUTES(t)
464 T is of the form ':: type(attributes) | pred', the attributes must be
465 appended to T's definition, and will be propagated after ENCODING to T's
466 subtypes.
467 */
468 void assert_attributes(t)
469 ptr_psi_term t;
470 {
471 ptr_psi_term arg1,arg2,pred=NULL,typ;
472 ptr_definition d;
473
474 get_two_args(t->attr_list,&arg1,&arg2);
475
476 if (arg1) {
477 typ=arg1;
478 deref_ptr(arg1);
479 if (!strcmp(arg1->type->keyword->symbol,"|")) {
480 get_two_args(arg1->attr_list,&arg1,&pred);
481 if (arg1) {
482 typ=arg1;
483 deref_ptr(arg1);
484 }
485 }
486
487 if (arg1 && wl_const_3(*arg1)) {
488 /* if (!redefine(arg1)) return; RM: Feb 19 1993 */
489 d=arg1->type;
490 if (d->type_def==(def_type)predicate || d->type_def==(def_type)function_it) {
491 Errorline("the %T '%s' may not be redefined as a sort.\n",
492 d->type_def, d->keyword->symbol);
493 }
494 else {
495 d->type_def=(def_type)type_it;
496 types_modified=TRUE;
497 add_rule(typ,pred,(def_type)type_it);
498 }
499 }
500 else {
501 Errorline("bad argument in sort declaration '%P' (%E).\n",t);
502 }
503 }
504 else {
505 Errorline("argument missing in sort declaration (%E).\n");
506 }
507 }
508
509
510
511 /******** FIND_ADULTS()
512 Returns the list of all the maximal types (apart from top) in the symbol
513 table. That is, types which have no parents.
514 This routine modifies the global variable 'adults'.
515 */
516 void find_adults() /* RM: Feb 3 1993 */
517
518 {
519 ptr_definition d;
520 ptr_int_list l;
521
522 for(d=first_definition;d;d=d->next)
523 if(d->type_def==(def_type)type_it && d->parents==NULL) {
524 l=HEAP_ALLOC(int_list);
525 l->value_1=(GENERIC)d;
526 l->next=adults;
527 adults=l;
528 }
529 }
530
531
532
533 /******** INSERT_OWN_PROP(definition)
534 Append a type's "rules" (i.e. its own attr. & constr.) to its property list.
535 The property list also contains the type's code.
536 A type's attributes and constraints are stored in the 'rule' field of the
537 definition.
538 */
539 void insert_own_prop(d)
540 ptr_definition d;
541 {
542 ptr_int_list l;
543 ptr_pair_list rule;
544 ptr_triple_list *t;
545 long flag;
546
547 l=HEAP_ALLOC(int_list);
548 l->value_1=(GENERIC)d;
549 l->next=children;
550 children=l;
551
552 rule = d->rule;
553 while (rule) {
554 t= &(d->properties);
555 flag=TRUE;
556
557 while (flag) {
558 if (*t)
559 if ((*t)->aaaa_4==rule->aaaa_2 && (*t)->bbbb_4==rule->bbbb_2 && (*t)->cccc_4==d)
560 flag=FALSE;
561 else
562 t= &((*t)->next);
563 else {
564 *t = HEAP_ALLOC(triple_list);
565 (*t)->aaaa_4=rule->aaaa_2;
566 (*t)->bbbb_4=rule->bbbb_2;
567 (*t)->cccc_4=d;
568 (*t)->next=NULL;
569 flag=FALSE;
570 }
571 }
572 rule=rule->next;
573 }
574 }
575
576
577 /******** INSERT_PROP(definition,prop)
578 Append the properties to the definition if they aren't already present.
579 */
580 void insert_prop(d,prop)
581 ptr_definition d;
582 ptr_triple_list prop;
583 {
584 ptr_int_list l;
585 ptr_triple_list *t;
586 long flag;
587
588 l=HEAP_ALLOC(int_list);
589 l->value_1=(GENERIC)d;
590 l->next=children;
591 children=l;
592
593 while (prop) {
594 t= &(d->properties);
595 flag=TRUE;
596
597 while (flag) {
598 if (*t)
599 if ((*t)->aaaa_4==prop->aaaa_4 && (*t)->bbbb_4==prop->bbbb_4 && (*t)->cccc_4==prop->cccc_4)
600 flag=FALSE;
601 else
602 t= &((*t)->next);
603 else {
604 *t = HEAP_ALLOC(triple_list);
605 (*t)->aaaa_4=prop->aaaa_4;
606 (*t)->bbbb_4=prop->bbbb_4;
607 (*t)->cccc_4=prop->cccc_4;
608 (*t)->next=NULL;
609 flag=FALSE;
610 }
611 }
612 prop=prop->next;
613 }
614 }
615
616
617
618 /******** PROPAGATE_DEFINITIONS()
619 This routine propagates the definition (attributes,predicates) of a type to
620 all its sons.
621 */
622 void propagate_definitions()
623 {
624 ptr_int_list kids;
625 ptr_definition d;
626
627 adults=NULL;
628 find_adults();
629
630 while (adults) {
631
632 children=NULL;
633
634 while (adults) {
635 d=(ptr_definition)adults->value_1;
636
637 insert_own_prop(d);
638 children=children->next;
639
640 kids=d->children;
641
642 while(kids) {
643 insert_prop((ptr_definition)kids->value_1,d->properties);
644 /* if (d->always_check && kids->value_1)
645 ((ptr_definition)kids->value_1)->always_check=TRUE; */
646 kids=kids->next;
647 }
648 adults=adults->next;
649 }
650 adults=children;
651 }
652 }
653
654
655
656 /******************************************************************************
657
658 The following routines implement sort encoding.
659
660 */
661
662
663
664 /******** COUNT_SORTS(c)
665 Count the number of sorts in the symbol table T.
666 Overestimates in the module version. RM: Jan 21 1993
667 No longer !! RM: Feb 3 1993
668 */
669 long count_sorts(c0) /* RM: Feb 3 1993 */
670 long c0;
671 {
672 ptr_definition d;
673
674 for(d=first_definition;d;d=d->next)
675 if (d->type_def==(def_type)type_it) c0++;
676
677 return c0;
678 }
679
680
681
682 /******** CLEAR_CODING()
683 Clear the bit-vector coding of the sorts.
684 */
685 void clear_coding() /* RM: Feb 3 1993 */
686
687 {
688 ptr_definition d;
689
690 for(d=first_definition;d;d=d->next)
691 if (d->type_def==(def_type)type_it) d->code=NOT_CODED;
692 }
693
694
695
696 /******** LEAST_SORTS()
697 Build the list of terminals (i.e. sorts with no children) in
698 nothing->parents.
699 */
700 void least_sorts() /* RM: Feb 3 1993 */
701
702 {
703 ptr_definition d;
704
705 for(d=first_definition;d;d=d->next)
706 if (d->type_def==(def_type)type_it && d->children==NULL && d!=nothing)
707 nothing->parents=cons((GENERIC)d,nothing->parents);
708 }
709
710
711
712 /******** ALL_SORTS()
713 Build a list of all sorts (except nothing) in nothing->parents.
714 */
715
716 void all_sorts() /* RM: Feb 3 1993 */
717
718 {
719 ptr_definition d;
720
721 for(d=first_definition;d;d=d->next)
722 if (d->type_def==(def_type)type_it && d!=nothing)
723 nothing->parents=cons((GENERIC)d,nothing->parents);
724 }
725
726
727
728 /******** TWO_TO_THE(p)
729 Return the code worth 2^p.
730 */
731 ptr_int_list two_to_the(p)
732 long p;
733 {
734 ptr_int_list result,code;
735 long v=1;
736
737 code=HEAP_ALLOC(int_list);
738 code->value_1=0;
739 code->next=NULL;
740 result=code;
741
742 while (p>=INT_SIZE) {
743 code->next=HEAP_ALLOC(int_list);
744 code=code->next;
745 code->value_1=0;
746 code->next=NULL;
747 p=p-INT_SIZE;
748 }
749
750 v= v<<p ;
751 code->value_1=(GENERIC)v;
752
753 return result;
754 }
755
756
757 /******** copyTypeCode(code)
758 returns copy of code on the heap
759 */
760 ptr_int_list copyTypeCode(u)
761 ptr_int_list u;
762 {
763 ptr_int_list code;
764
765 code = HEAP_ALLOC(int_list);
766 code->value_1=0;
767 code->next=NULL;
768
769 or_codes(code, u);
770
771 return code;
772 }
773
774
775
776 /******** OR_CODES(code1,code2)
777 Performs CODE1 := CODE1 or CODE2,
778 'or' being the binary logical operator on bits.
779 */
780 void or_codes(u,v)
781 ptr_int_list u,v;
782 {
783 while (v) {
784 u->value_1= (GENERIC)(((unsigned long)(u->value_1)) | ((unsigned long)(v->value_1)));
785 v=v->next;
786 if (u->next==NULL && v) {
787 u->next=HEAP_ALLOC(int_list);
788 u=u->next;
789 u->value_1=0;
790 u->next=NULL;
791 }
792 else
793 u=u->next;
794 }
795 }
796
797
798
799 /******** EQUALIZE_CODES(w)
800 Make sure all codes are w words long, by increasing the length of the
801 shorter ones.
802 This simplifies greatly the bitvector manipulation routines.
803 This operation should be done after encoding.
804 For correct operation, w>=maximum number of words used for a code.
805 */
806 void equalize_codes(len) /* RM: Feb 3 1993 */
807 int len;
808 {
809 ptr_definition d;
810 ptr_int_list c,*ci;
811 long i;
812 int w;
813
814 for(d=first_definition;d;d=d->next)
815 if (d->type_def==(def_type)type_it) {
816 c = d->code;
817 ci = &(d->code); /* RM: Feb 15 1993 */
818 w=len;
819
820 /* Count how many words have to be added */
821 while (c) {
822 ci= &(c->next);
823 c=c->next;
824 w--;
825 }
826 assert(w>=0);
827 /* Add the words */
828 for (i=0; i<w; i++) {
829 *ci = HEAP_ALLOC(int_list);
830 (*ci)->value_1=0;
831 ci= &((*ci)->next);
832 }
833 (*ci)=NULL;
834 }
835 }
836
837
838
839 long type_member();
840
841
842 /******** MAKE_TYPE_LINK(t1,t2)
843 Assert that T1 <| T2, this is used to initialise the built_in type relations
844 so that nothing really horrible happens if the user modifies built-in types
845 such as INT or LIST.
846 This routine also makes sure that top has no links.
847 */
848 void make_type_link(t1,t2)
849 ptr_definition t1, t2;
850 {
851 if (t2!=top && !type_member(t2,t1->parents))
852 t1->parents=cons((GENERIC)t2,t1->parents);
853 if (t2!=top && !type_member(t1,t2->children))
854 t2->children=cons((GENERIC)t1,t2->children);
855 }
856
857
858
859
860 /******** TYPE_MEMBER(t,tlst)
861 Return TRUE iff type t is in the list tlst.
862 */
863
864 long type_member(t,tlst)
865 ptr_definition t;
866 ptr_int_list tlst;
867 {
868 while (tlst) {
869 if (t==(ptr_definition)tlst->value_1) return TRUE;
870 tlst=tlst->next;
871 }
872 return FALSE;
873 }
874
875
876 void perr_sort(d)
877 ptr_definition d;
878 {
879 perr_s("%s",d->keyword->symbol);
880 }
881
882 void perr_sort_list(anc)
883 ptr_int_list anc;
884 {
885 if (anc) {
886 perr_sort_list(anc->next);
887 if (anc->next) perr(" <| ");
888 perr_sort((ptr_definition)anc->value_1);
889 }
890 }
891
892 void perr_sort_cycle(anc)
893 ptr_int_list anc;
894 {
895 perr_sort((ptr_definition)anc->value_1);
896 perr(" <| ");
897 perr_sort_list(anc);
898 }
899
900
901
902 /******** TYPE_CYCLICITY(d,anc)
903 Check cyclicity of type hierarchy.
904 If cyclic, return a TRUE error condition and print an error message
905 with a cycle.
906 */
907 long type_cyclicity(d,anc)
908 ptr_definition d;
909 ptr_int_list anc;
910 {
911 ptr_int_list p=d->parents;
912 ptr_definition pd;
913 long errflag;
914 int_list anc2;
915
916 while (p) {
917 pd=(ptr_definition)p->value_1;
918 /* If unmarked, mark and recurse */
919 if (pd->code==NOT_CODED) {
920 pd->code = (ptr_int_list)TRUE;
921 anc2.value_1=(GENERIC)pd;
922 anc2.next=anc;
923 errflag=type_cyclicity(pd,&anc2);
924 if (errflag) return TRUE;
925 }
926 /* If marked, check if it's in the ancestor list */
927 else {
928 if (type_member(pd,anc)) {
929 Errorline("there is a cycle in the sort hierarchy\n");
930 perr("*** Cycle: [");
931 perr_sort_cycle(anc);
932 perr("]\n");
933 exit_life(TRUE);
934 return TRUE;
935 }
936 }
937 p=p->next;
938 }
939 return FALSE;
940 }
941
942
943
944 /******** PROPAGATE_ALWAYS_CHECK(d,ch)
945 Recursively set the always_check flag to 'FALSE' for all d's
946 children. Continue until encountering only 'FALSE' values.
947 Return a TRUE flag if a change was made somewhere (for the
948 closure calculation).
949 */
950 void propagate_always_check(d,ch)
951 ptr_definition d;
952 long *ch;
953 {
954 ptr_int_list child_list;
955 ptr_definition child;
956
957 child_list = d->children;
958 while (child_list) {
959 child = (ptr_definition)child_list->value_1;
960 if (child->always_check) {
961 child->always_check = FALSE;
962 *ch = TRUE;
963 propagate_always_check(child,ch);
964 }
965 child_list = child_list->next;
966 }
967 }
968
969
970
971 /******** ONE_PASS_ALWAYS_CHECK(ch)
972 Go through the symbol table & propagate all FALSE always_check
973 flags of all sorts to their children. Return a TRUE flag
974 if a change was made somewhere (for the closure calculation).
975 */
976 void one_pass_always_check(ch)
977 long *ch;
978 {
979 ptr_definition d;
980
981
982 for(d=first_definition;d;d=d->next)
983 if (d->type_def==(def_type)type_it && !d->always_check)
984 propagate_always_check(d,ch);
985 }
986
987
988
989 /******** INHERIT_ALWAYS_CHECK()
990 The 'always_check' flag, if false, should be propagated to a sort's
991 children. This routine does a closure on this propagation operation
992 for all declared sorts.
993 */
994 void inherit_always_check()
995 {
996 long change;
997
998 do {
999 change=FALSE;
1000 one_pass_always_check(&change);
1001 } while (change);
1002 }
1003
1004
1005
1006 /******** ENCODE_TYPES()
1007 This routine performs type-coding using transitive closure.
1008 First any previous coding is undone.
1009 Then a new encryption is performed.
1010
1011 Some of these routines loop indefinitely if there is a circular type
1012 definition (an error should be reported but it isn't implemented (but it's
1013 quite easy to do)).
1014 */
1015 void encode_types()
1016 {
1017 long p=0,i,possible,ok=TRUE;
1018 ptr_int_list layer,l,kids,dads,code;
1019 ptr_definition xdef,kdef,ddef; //,err;
1020
1021 if (types_modified) {
1022
1023 nothing->parents=NULL;
1024 nothing->children=NULL;
1025
1026 top->parents=NULL;
1027 top->children=NULL;
1028
1029 /* The following definitions are vital to avoid crashes */
1030 make_type_link(integer,real);
1031 make_type_link(lf_true,boolean);
1032 make_type_link(lf_false,boolean);
1033
1034 /* These just might be useful */
1035 make_type_link(quoted_string,built_in);
1036 make_type_link(boolean,built_in);
1037 make_type_link(real,built_in);
1038
1039 make_sys_type_links();
1040
1041 type_count=count_sorts(-1); /* bottom does not count */
1042 clear_coding();
1043 nothing->parents=NULL; /* Must be cleared before all_sorts */
1044 all_sorts();
1045 if (type_cyclicity(nothing,NULL)) {
1046 clear_coding();
1047 return;
1048 }
1049 clear_coding();
1050 nothing->parents=NULL; /* Must be cleared before least_sorts */
1051 least_sorts();
1052
1053 nothing->code=NULL;
1054
1055 /* RM: Feb 17 1993 */
1056 traceline("*** Codes:\n%C= %s\n", NULL, nothing->keyword->symbol);
1057
1058 gamma_table=(ptr_definition *) heap_alloc(type_count*sizeof(definition));
1059
1060 layer=nothing->parents;
1061
1062 while (layer) {
1063 l=layer;
1064 do {
1065 xdef=(ptr_definition)l->value_1;
1066 if (xdef->code==NOT_CODED && xdef!=top) {
1067
1068 kids=xdef->children;
1069 code=two_to_the(p);
1070
1071 while (kids) {
1072 kdef=(ptr_definition)kids->value_1;
1073 or_codes(code,kdef->code);
1074 kids=kids->next;
1075 }
1076
1077 xdef->code=code;
1078 gamma_table[p]=xdef;
1079
1080 /* RM: Feb 17 1993 */
1081 traceline("%C = %s\n", code, xdef->keyword->symbol);
1082 p=p+1;
1083 }
1084
1085 l=l->next;
1086
1087 } while (l);
1088
1089 l=layer;
1090 layer=NULL;
1091
1092 do {
1093 xdef=(ptr_definition)l->value_1;
1094 dads=xdef->parents;
1095
1096 while (dads) {
1097 ddef=(ptr_definition)dads->value_1;
1098 if(ddef->code==NOT_CODED) {
1099
1100 possible=TRUE;
1101 kids=ddef->children;
1102
1103 while(kids && possible) {
1104 kdef=(ptr_definition)kids->value_1;
1105 if(kdef->code==NOT_CODED)
1106 possible=FALSE;
1107 kids=kids->next;
1108 }
1109 if(possible)
1110 layer=cons((GENERIC)ddef,layer);
1111 }
1112 dads=dads->next;
1113 }
1114 l=l->next;
1115 } while(l);
1116 }
1117
1118 top->code=two_to_the(p);
1119 for (i=0;i<p;i++)
1120 or_codes(top->code,two_to_the(i));
1121
1122 gamma_table[p]=top;
1123
1124 /* RM: Jan 13 1993 */
1125 /* Added the following line because type_count is now over generous
1126 because the same definition can be referenced several times in
1127 the symbol table because of modules
1128 */
1129 type_count=p+1;
1130 for(i=type_count;i<type_count;i++)
1131 gamma_table[i]=NULL;
1132
1133 traceline("%C = @\n\n", top->code);
1134 equalize_codes(p/32+1);
1135
1136 propagate_definitions();
1137
1138 /* Inherit 'FALSE' always_check flags to all types' children */
1139 inherit_always_check();
1140
1141 traceline("*** Encoding done, %d sorts\n",type_count);
1142
1143 if (overlap_type(real,quoted_string)) {
1144 Errorline("the sorts 'real' and 'string' are not disjoint.\n");
1145 ok=FALSE;
1146 }
1147
1148 /* RM: Dec 15 1992 I don't think this really matters any more
1149 if (overlap_type(real,alist)) {
1150 Errorline("the sorts 'real' and 'list' are not disjoint.\n");
1151 ok=FALSE;
1152 }
1153 */
1154
1155 /* RM: Dec 15 1992 I don't think this really matters any more
1156 if (overlap_type(alist,quoted_string)) {
1157 Errorline("the sorts 'list' and 'string' are not disjoint.\n");
1158 ok=FALSE;
1159 }
1160 */
1161
1162 if (!ok) {
1163 perr("*** Internal problem:\n");
1164 perr("*** Wild_Life may behave abnormally because some basic types\n");
1165 perr("*** have been defined incorrectly.\n\n");
1166 }
1167
1168 types_modified=FALSE;
1169 types_done=TRUE;
1170 }
1171 }
1172
1173
1174
1175 /******** PRINT_CODES()
1176 Print all the codes.
1177 */
1178 void print_codes()
1179 {
1180 long i;
1181
1182 for (i=0; i<type_count; i++) {
1183 outputline("%C = %s\n",
1184 gamma_table[i]->code,
1185 gamma_table[i]->keyword->combined_name);
1186 }
1187 }
1188
1189
1190 long sub_CodeType();
1191
1192
1193 /******** GLB_VALUE(result,f,c,value1,value2,value)
1194 Do the comparison of the value fields of two psi-terms.
1195 This is used in conjunction with glb_code to correctly implement
1196 completeness for disequality for psi-terms with non-NULL value fields.
1197 This must be preceded by a call to glb_code, since it uses the outputs
1198 of that call.
1199
1200 result result of preceding glb_code call (non-NULL iff non-empty intersec.)
1201 f,c sort intersection (sortflag & code) of preceding glb_code call.
1202 value1 value field of first psi-term.
1203 value2 value field of second psi-term.
1204 value output value field (if any).
1205 */
1206 long glb_value(result,f,c,value1,value2,value)
1207 long result;
1208 long f;
1209 GENERIC c;
1210 GENERIC value1,value2,*value;
1211 {
1212 ptr_int_list code;
1213
1214 if (!result) return FALSE;
1215 if (value1==NULL) {
1216 *value=value2;
1217 return TRUE;
1218 }
1219 if (value2==NULL) {
1220 *value=value1;
1221 return TRUE;
1222 }
1223 /* At this point, both value fields are non-NULL */
1224 /* and must be compared. */
1225
1226 /* Get a pointer to the sort code */
1227 code = f ? ((ptr_definition)c)->code : (ptr_int_list)c;
1228
1229 /* This rather time-consuming analysis is necessary if both objects */
1230 /* have non-NULL value fields. Note that only those objects with a */
1231 /* non-NULL value field needed for disentailment are looked at. */
1232 if (sub_CodeType(code,real->code)) {
1233 *value=value1;
1234 return (*(REAL *)value1 == *(REAL *)value2);
1235 }
1236 else if (sub_CodeType(code,quoted_string->code)) {
1237 *value=value1;
1238 return (!strcmp((char *)value1,(char *)value2));
1239 }
1240 else {
1241 /* All other sorts with 'value' fields always return TRUE, that is, */
1242 /* the value field plays no role in disentailment. */
1243 *value=value1;
1244 return TRUE;
1245 }
1246 }
1247
1248
1249
1250 /******** GLB_CODE(f1,c1,f2,c2,f3,c3) (21.9)
1251 Calculate glb of two type codes C1 and C2, put result in C3.
1252 Return a result value (see comments of glb(..)).
1253
1254 Sorts are stored as a 'Variant Record':
1255 f1==TRUE: c1 is a ptr_definition (an interned symbol).
1256 f1==FALSE: c1 is a ptr_int_list (a sort code).
1257 The result (f3,c3) is also in this format.
1258 This is needed to correctly handle psi-terms that don't have a sort code
1259 (for example, functions, predicates, and singleton sorts).
1260 The routine handles a bunch of special cases that keep f3==TRUE.
1261 Other than that, it is almost a replica of the inner loop of glb(..).
1262 */
1263 long glb_code(f1,c1,f2,c2,f3,c3)
1264 long f1,f2,*f3;
1265 GENERIC c1,c2,*c3;
1266 {
1267 long result=0;
1268 unsigned long v1,v2,v3;
1269 ptr_int_list cd1,cd2,*cd3; /* sort codes */
1270
1271 /* First, the cases where c1 & c2 are ptr_definitions: */
1272 if (f1 && f2) {
1273 if ((ptr_definition)c1==(ptr_definition)c2) {
1274 *c3=c1;
1275 result=1;
1276 }
1277 else if ((ptr_definition)c1==top) {
1278 *c3=c2;
1279 if ((ptr_definition)c2==top)
1280 result=1;
1281 else
1282 result=3;
1283 }
1284 else if ((ptr_definition)c2==top) {
1285 *c3=c1;
1286 result=2;
1287 }
1288 /* If both inputs are either top or the same ptr_definition */
1289 /* then can return quickly with a ptr_definition. */
1290 if (result) {
1291 *f3=TRUE; /* c3 is ptr_definition (an interned symbol) */
1292 return result;
1293 }
1294 }
1295 /* In the other cases, can't return with a ptr_definition: */
1296 cd1=(ptr_int_list)(f1?(GENERIC)((ptr_definition)c1)->code:c1);
1297 cd2=(ptr_int_list)(f2?(GENERIC)((ptr_definition)c2)->code:c2);
1298 cd3=(ptr_int_list*)c3;
1299 *f3=FALSE; /* cd3 is ptr_int_list (a sort code) */
1300 if (cd1==NOT_CODED) {
1301 if (cd2==NOT_CODED) {
1302 if (c1==c2) {
1303 *cd3=cd1;
1304 result=1;
1305 }
1306 else
1307 result=0;
1308 }
1309 else if (cd2==top->code) {
1310 *cd3=cd1;
1311 result=2;
1312 }
1313 else
1314 result=0;
1315 }
1316 else if (cd1==top->code) {
1317 if (cd2==top->code) {
1318 *cd3=cd1;
1319 result=1;
1320 }
1321 else {
1322 *cd3=cd2;
1323 result=3;
1324 }
1325 }
1326 else if (cd2==NOT_CODED)
1327 result=0;
1328 else if (cd2==top->code) {
1329 *cd3=cd1;
1330 result=2;
1331 }
1332 else while (cd1 && cd2) {
1333 /* Bit operations needed only if c1 & c2 coded & different from top */
1334 *cd3 = STACK_ALLOC(int_list);
1335 (*cd3)->next=NULL;
1336
1337 v1=(unsigned long)(cd1->value_1);
1338 v2=(unsigned long)(cd2->value_1);
1339 v3=v1 & v2;
1340 (*cd3)->value_1=(GENERIC)v3;
1341
1342 if (v3) {
1343 if (v3<v1 && v3<v2)
1344 result=4;
1345 else if (result!=4)
1346 if (v1<v2)
1347 result=2;
1348 else if (v1>v2)
1349 result=3;
1350 else
1351 result=1;
1352 }
1353 else if (result)
1354 if (v1 || v2)
1355 result=4;
1356
1357 cd1=cd1->next;
1358 cd2=cd2->next;
1359 cd3= &((*cd3)->next);
1360 }
1361
1362 return result;
1363 }
1364
1365
1366
1367 /******** GLB(t1,t2,t3)
1368 This function returns the Greatest Lower Bound of two types T1 and T2 in T3.
1369
1370 T3 = T1 /\ T2
1371
1372 If T3 is not a simple type then C3 is its code, and T3=NULL.
1373
1374 It also does some type comparing, and returns
1375
1376 0 if T3 = bottom
1377 1 if T1 = T2
1378 2 if T1 <| T2 ( T3 = T1 )
1379 3 if T1 |> T2 ( T3 = T2 )
1380 4 otherwise ( T3 strictly <| T1 and T3 strictly <| T2 )
1381
1382 These results are used for knowing when to inherit properties or release
1383 residuations.
1384 The t3 field is NULL iff a new type is needed to represent the
1385 result.
1386 */
1387 /* RM: May 7 1993 Fixed bug in when multiple word code */
1388 long glb(t1,t2,t3,c3)
1389 ptr_definition t1;
1390 ptr_definition t2;
1391 ptr_definition *t3;
1392 ptr_int_list *c3;
1393 {
1394 ptr_int_list c1,c2;
1395 long result=0;
1396 unsigned long v1,v2,v3;
1397 int e1,e2,b; /* RM: May 7 1993 */
1398
1399
1400
1401 *c3=NULL;
1402
1403 if (t1==t2) {
1404 result=1;
1405 *t3= t1;
1406 }
1407 else if (t1==top) {
1408 *t3= t2;
1409 if (t2==top)
1410 result=1;
1411 else
1412 result=3;
1413 }
1414 else if (t2==top) {
1415 result=2;
1416 *t3= t1;
1417 }
1418 else {
1419 /* printf("glb of %s and %s\n",
1420 t1->keyword->combined_name,
1421 t2->keyword->combined_name); */
1422
1423 c1=t1->code;
1424 c2=t2->code;
1425
1426 e1=TRUE;e2=TRUE;b=TRUE;
1427
1428 if (c1!=NOT_CODED && c2!=NOT_CODED) {
1429 result=0;
1430 while (c1 && c2) {
1431
1432 *c3 = STACK_ALLOC(int_list);
1433 (*c3)->next=NULL;
1434
1435 v1=(unsigned long)(c1->value_1);
1436 v2=(unsigned long)(c2->value_1);
1437 v3=v1 & v2;
1438
1439 /* printf("v1=%d, v2=%d, v3=%d\n",v1,v2,v3); */
1440
1441 (*c3)->value_1=(GENERIC)v3;
1442
1443 if(v3!=v1) /* RM: May 7 1993 */
1444 e1=FALSE;
1445 if(v3!=v2)
1446 e2=FALSE;
1447 if(v3)
1448 b=FALSE;
1449
1450 c1=c1->next;
1451 c2=c2->next;
1452 c3= &((*c3)->next);
1453 }
1454 *t3=NULL;
1455
1456 if(b) /* RM: May 7 1993 */
1457 result=0; /* 0 if T3 = bottom */
1458 else
1459 if(e1)
1460 if(e2)
1461 result=1; /* 1 if T1 = T2 */
1462 else
1463 result=2; /* 2 if T1 <| T2 ( T3 = T1 ) */
1464 else
1465 if(e2)
1466 result=3; /* 3 if T1 |> T2 ( T3 = T2 ) */
1467 else
1468 result=4; /* 4 otherwise */
1469 }
1470 }
1471
1472 if (!result) *t3=nothing;
1473
1474 /* printf("result=%d\n\n",result); */
1475
1476 return result;
1477 }
1478
1479
1480
1481 /******** OVERLAP_TYPE(t1,t2)
1482 This function returns TRUE if GLB(t1,t2)!=bottom.
1483 This is essentially the same thing as GLB, only it's faster 'cause we don't
1484 care about the resulting code.
1485 */
1486 long overlap_type(t1,t2)
1487 ptr_definition t1;
1488 ptr_definition t2;
1489 {
1490 ptr_int_list c1,c2;
1491 long result=TRUE;
1492
1493 if (t1!=t2 && t1!=top && t2!=top) {
1494
1495 c1=t1->code;
1496 c2=t2->code;
1497 result=FALSE;
1498
1499 if (c1!=NOT_CODED && c2!=NOT_CODED) {
1500 while (!result && c1 && c2) {
1501 result=(((unsigned long)(c1->value_1)) & ((unsigned long)(c2->value_1)));
1502 c1=c1->next;
1503 c2=c2->next;
1504 }
1505 }
1506 }
1507
1508 /*
1509 printf("overlap_type(%s,%s) => %ld\n",t1->def->keyword->symbol,t2->def->keyword->symbol,result);
1510 */
1511
1512 return result;
1513 }
1514
1515
1516 /******** SUB_CodeType(c1,c2)
1517 Return TRUE if code C1 is <| than type C2, that is if type represented
1518 by code C1 matches type represented by C2.
1519
1520 We already know that t1 and t2 are not top.
1521 */
1522 long sub_CodeType(c1,c2)
1523 ptr_int_list c1;
1524 ptr_int_list c2;
1525 {
1526 if (c1!=NOT_CODED && c2!=NOT_CODED) {
1527 while (c1 && c2) {
1528 if ((unsigned long)c1->value_1 & ~(unsigned long)c2->value_1) return FALSE;
1529 c1=c1->next;
1530 c2=c2->next;
1531 }
1532 }
1533 else
1534 return FALSE;
1535
1536 return TRUE;
1537 }
1538
1539
1540
1541 /******** SUB_TYPE(t1,t2)
1542 Return TRUE if type T1 is <| than type T2, that is if T1 matches T2.
1543 */
1544 long sub_type(t1,t2)
1545 ptr_definition t1;
1546 ptr_definition t2;
1547 {
1548 if (t1!=t2)
1549 if (t2!=top)
1550 {
1551 if (t1==top)
1552 return FALSE;
1553 else
1554 return sub_CodeType(t1->code, t2->code);
1555 }
1556 return TRUE;
1557 }
1558
1559
1560
1561 /******** MATCHES(t1,t2,s)
1562 Returns TRUE if GLB(t1,t2)!=bottom.
1563 Sets S to TRUE if type T1 is <| than type T2, that is if T1 matches T2.
1564 */
1565 long matches(t1,t2,smaller)
1566 ptr_definition t1;
1567 ptr_definition t2;
1568 long *smaller;
1569 {
1570 ptr_int_list c1,c2;
1571 long result=TRUE;
1572
1573 *smaller=TRUE;
1574
1575 if (t1!=t2)
1576 if (t2!=top)
1577 if (t1==top)
1578 *smaller=FALSE;
1579 else {
1580 c1=t1->code;
1581 c2=t2->code;
1582 result=FALSE;
1583
1584 if (c1!=NOT_CODED && c2!=NOT_CODED) {
1585 while (c1 && c2) {
1586 if ((unsigned long)c1->value_1 & (unsigned long)c2->value_1) result=TRUE;
1587 if ((unsigned long)c1->value_1 & ~(unsigned long)c2->value_1) *smaller=FALSE;
1588 c1=c1->next;
1589 c2=c2->next;
1590 }
1591 }
1592 else
1593 *smaller=FALSE;
1594 }
1595
1596 return result;
1597 }
1598
1599
1600
1601 /******** STRICT_MATCHES(t1,t2,s)
1602 Almost the same as matches, except that S is set to TRUE only
1603 if the type of t1 is strictly less than the type of t2.
1604 Because of the implementation of ints, reals, strings, and lists,
1605 this has to take the value field into account, and thus must
1606 be passed the whole psi-term.
1607 */
1608 long strict_matches(t1,t2,smaller)
1609 ptr_psi_term t1;
1610 ptr_psi_term t2;
1611 long *smaller;
1612 {
1613 long result,sm;
1614
1615 result=matches(t1->type,t2->type,&sm);
1616
1617 if (sm) {
1618 /* At this point, t1->type <| t2->type */
1619 if (t1->type==t2->type) {
1620 /* Same types: strict only if first has a value & second does not */
1621 if (t1->value_3!=NULL && t2->value_3==NULL)
1622 sm=TRUE;
1623 else
1624 sm=FALSE;
1625 }
1626 else {
1627 /* Different types: the first must be strictly smaller */
1628 sm=TRUE;
1629 }
1630 }
1631
1632 *smaller=sm;
1633 return result;
1634 }
1635
1636
1637
1638 /******** BIT_LENGTH(c)
1639 Returns the number of bits needed to code C. That is the rank of the first
1640 non NULL bit of C.
1641
1642 Examples:
1643 C= 1001001000 result=7
1644 C= 10000 result=1
1645 C= 0000000 result=0
1646
1647 */
1648 long bit_length(c)
1649 ptr_int_list c;
1650 {
1651 unsigned long p=0,dp=0,v=0,dv=0;
1652
1653 while (c) {
1654 v=(unsigned long)c->value_1;
1655 if(v) {
1656 dp=p;
1657 dv=v;
1658 }
1659 c=c->next;
1660 p=p+INT_SIZE;
1661 }
1662
1663 while (dv) {
1664 dp++;
1665 dv=dv>>1;
1666 }
1667
1668 return dp;
1669 }
1670
1671
1672
1673 /******** DECODE(c)
1674 Returns a list of the symbol names which make up the disjunction whose
1675 code is C.
1676 */
1677
1678 ptr_int_list decode(c)
1679 ptr_int_list c;
1680 {
1681 ptr_int_list c2,c3,c4,result=NULL,*prev;
1682 long p;
1683
1684 p=bit_length(c);
1685
1686 while (p) {
1687 p--;
1688 c2=gamma_table[p]->code;
1689 result=cons((GENERIC)gamma_table[p],result);
1690 prev= &c4;
1691 *prev=NULL;
1692
1693 while (c2) {
1694 c3=STACK_ALLOC(int_list);
1695 *prev=c3;
1696 prev= &(c3->next);
1697 *prev=NULL;
1698
1699 c3->value_1=(GENERIC)(((unsigned long)(c->value_1)) & ~((unsigned long)(c2->value_1)));
1700
1701 c=c->next;
1702 c2=c2->next;
1703 }
1704
1705 c=c4;
1706 p=bit_length(c);
1707 }
1708
1709 return result;
1710 }
find_adults
void find_adults()
Definition: types.c:516
wl_pair_list::aaaa_2
ptr_psi_term aaaa_2
Definition: def_struct.h:189
type_cyclicity
long type_cyclicity(ptr_definition d, ptr_int_list anc)
Definition: types.c:907
predicate
#define predicate
Definition: def_const.h:361
function_it
#define function_it
Definition: def_const.h:362
wl_definition::already_loaded
char already_loaded
Definition: def_struct.h:137
get_two_args
void get_two_args(ptr_node t, ptr_psi_term *a, ptr_psi_term *b)
Definition: login.c:37
gamma_table
ptr_definition * gamma_table
Definition: types.c:16
least_sorts
void least_sorts()
Definition: types.c:700
perr
void perr(char *str)
Definition: error.c:659
def_type
struct wl_definition * def_type
Definition: def_struct.h:32
assert_complicated_type
void assert_complicated_type(ptr_psi_term t)
Definition: types.c:375
wl_definition::evaluate_args
char evaluate_args
Definition: def_struct.h:136
assert_args_not_eval
void assert_args_not_eval(ptr_node n)
Definition: types.c:273
encode_types
void encode_types()
Definition: types.c:1015
exit_life
void exit_life(long nl_flag)
Definition: built_ins.c:2090
wl_keyword::combined_name
char * combined_name
Definition: def_struct.h:92
type_count
long type_count
Definition: def_glob.h:46
strict_matches
long strict_matches(ptr_psi_term t1, ptr_psi_term t2, long *smaller)
Definition: types.c:1608
global
#define global
Definition: def_const.h:364
NOT_CODED
#define NOT_CODED
Definition: def_const.h:134
redefine
long redefine(ptr_psi_term t)
Definition: types.c:91
wl_pair_list::next
ptr_pair_list next
Definition: def_struct.h:191
undef
#define undef
Definition: def_const.h:360
two_to_the
ptr_int_list two_to_the(long p)
Definition: types.c:731
assert_less
long assert_less(ptr_psi_term t1, ptr_psi_term t2)
Definition: types.c:183
perr_sort_list
void perr_sort_list(ptr_int_list anc)
Definition: types.c:882
propagate_definitions
void propagate_definitions()
Definition: types.c:622
clear_coding
void clear_coding()
Definition: types.c:685
wl_definition::type_def
def_type type_def
Definition: def_struct.h:133
defs.h
wl_psi_term
Definition: def_struct.h:161
file_date
long file_date
Definition: def_glob.h:60
perr_sort_cycle
void perr_sort_cycle(ptr_int_list anc)
Definition: types.c:892
INT_SIZE
#define INT_SIZE
Definition: def_const.h:144
sub_CodeType
long sub_CodeType()
overlap_type
long overlap_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1486
clear_already_loaded
void clear_already_loaded(ptr_node n)
Definition: types.c:326
wl_triple_list
Definition: def_struct.h:195
wl_definition::keyword
ptr_keyword keyword
Definition: def_struct.h:124
wl_pair_list
Definition: def_struct.h:188
assert_protected
void assert_protected(ptr_node n, long prot)
Definition: types.c:235
copyTypeCode
ptr_int_list copyTypeCode(ptr_int_list u)
Definition: types.c:760
perr_s
void perr_s(char *s1, char *s2)
Definition: error.c:665
remove_cycles
void remove_cycles(ptr_definition d, ptr_int_list *dl)
Definition: types.c:73
cons
ptr_int_list cons(GENERIC v, ptr_int_list l)
Definition: types.c:164
top
ptr_definition top
Definition: def_glob.h:106
NULL
#define NULL
Definition: def_const.h:203
warningflag
long warningflag
Definition: def_glob.h:270
input_state
ptr_psi_term input_state
Definition: def_glob.h:199
make_sys_type_links
void make_sys_type_links()
Definition: sys.c:1726
wl_keyword::symbol
char * symbol
Definition: def_struct.h:91
REAL
#define REAL
Definition: def_const.h:72
wl_triple_list::next
ptr_triple_list next
Definition: def_struct.h:199
wl_triple_list::cccc_4
ptr_definition cccc_4
Definition: def_struct.h:198
types_modified
long types_modified
Definition: def_glob.h:47
inherit_always_check
void inherit_always_check()
Definition: types.c:994
assert_ok
long assert_ok
Definition: def_glob.h:59
wl_definition::always_check
char always_check
Definition: def_struct.h:134
traceline
void traceline(char *format,...)
Definition: error.c:157
wl_int_list
Definition: def_struct.h:53
type_it
#define type_it
Definition: def_const.h:363
wl_definition::next
ptr_definition next
Definition: def_struct.h:148
make_type_link
void make_type_link(ptr_definition t1, ptr_definition t2)
Definition: types.c:848
Errorline
void Errorline(char *format,...)
Definition: error.c:414
EOLN
#define EOLN
Definition: def_const.h:140
bit_length
long bit_length(ptr_int_list c)
Definition: types.c:1648
wl_const_3
#define wl_const_3(S)
Definition: def_macro.h:104
real
ptr_definition real
Definition: def_glob.h:102
deref_ptr
#define deref_ptr(P)
Definition: def_macro.h:95
glb
long glb(ptr_definition t1, ptr_definition t2, ptr_definition *t3, ptr_int_list *c3)
Definition: types.c:1388
perr_sort
void perr_sort(ptr_definition d)
Definition: types.c:876
TRUE
#define TRUE
Definition: def_const.h:127
propagate_always_check
void propagate_always_check(ptr_definition d, long *ch)
Definition: types.c:950
first_definition
ptr_definition first_definition
Definition: def_glob.h:3
all_sorts
void all_sorts()
Definition: types.c:716
built_in
ptr_definition built_in
Definition: def_glob.h:75
integer
ptr_definition integer
Definition: def_glob.h:93
wl_definition::date
long date
Definition: def_struct.h:122
one_pass_always_check
void one_pass_always_check(long *ch)
Definition: types.c:976
lf_true
ptr_definition lf_true
Definition: def_glob.h:107
glb_value
long glb_value(long result, long f, GENERIC c, GENERIC value1, GENERIC value2, GENERIC *value)
Definition: types.c:1206
wl_definition::rule
ptr_pair_list rule
Definition: def_struct.h:126
FALSE
#define FALSE
Definition: def_const.h:128
glb_code
long glb_code(long f1, GENERIC c1, long f2, GENERIC c2, long *f3, GENERIC *c3)
Definition: types.c:1263
assert_delay_check
void assert_delay_check(ptr_node n)
Definition: types.c:303
quoted_string
ptr_definition quoted_string
Definition: def_glob.h:101
insert_prop
void insert_prop(ptr_definition d, ptr_triple_list prop)
Definition: types.c:580
ptr_definition
struct wl_definition * ptr_definition
Definition: def_struct.h:31
sub_type
long sub_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1544
wl_psi_term::value_3
GENERIC value_3
Definition: def_struct.h:170
lf_false
ptr_definition lf_false
Definition: def_glob.h:89
wl_pair_list::bbbb_2
ptr_psi_term bbbb_2
Definition: def_struct.h:190
wl_triple_list::bbbb_4
ptr_psi_term bbbb_4
Definition: def_struct.h:197
disjunction
ptr_definition disjunction
Definition: def_glob.h:84
STACK_ALLOC
#define STACK_ALLOC(A)
Definition: def_macro.h:16
assert_type
void assert_type(ptr_psi_term t)
Definition: types.c:345
restore_state
void restore_state(ptr_psi_term t)
Definition: token.c:267
outputline
void outputline(char *format,...)
Definition: error.c:79
ptr_keyword
struct wl_keyword * ptr_keyword
Definition: def_struct.h:99
wl_definition
Definition: def_struct.h:121
print_codes
void print_codes()
Definition: types.c:1178
equalize_codes
void equalize_codes(int len)
Definition: types.c:806
type_member
long type_member()
wl_definition::protected
char protected
Definition: def_struct.h:135
types_done
long types_done
Definition: def_glob.h:36
ptr_psi_term
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
prompt
char * prompt
Definition: def_glob.h:42
read_char
long read_char()
Definition: token.c:587
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
equ_tok
#define equ_tok(A, B)
Definition: def_macro.h:62
insert_own_prop
void insert_own_prop(ptr_definition d)
Definition: types.c:539
wl_definition::code
ptr_int_list code
Definition: def_struct.h:129
decode
ptr_int_list decode(ptr_int_list c)
Definition: types.c:1678
add_rule
void add_rule(ptr_psi_term head, ptr_psi_term body, def_type typ)
Definition: login.c:148
warningline
void warningline(char *format,...)
Definition: error.c:327
children
ptr_int_list children
Definition: def_glob.h:354
adults
ptr_int_list adults
Definition: def_glob.h:354
wl_node
Definition: def_struct.h:181
wl_psi_term::type
ptr_definition type
Definition: def_struct.h:165
assert_attributes
void assert_attributes(ptr_psi_term t)
Definition: types.c:468
wl_int_list::value_1
GENERIC value_1
Definition: def_struct.h:54
print_def_type
void print_def_type(def_type t)
Definition: types.c:21
GENERIC
unsigned long * GENERIC
Definition: def_struct.h:17
count_sorts
long count_sorts(long c0)
Definition: types.c:669
wl_definition::properties
ptr_triple_list properties
Definition: def_struct.h:127
ptr_int_list
struct wl_int_list * ptr_int_list
Definition: def_struct.h:29
wl_definition::children
ptr_int_list children
Definition: def_struct.h:131
HEAP_ALLOC
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
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
yes_or_no
long yes_or_no()
Definition: types.c:44
wl_triple_list::aaaa_4
ptr_psi_term aaaa_4
Definition: def_struct.h:196
heap_alloc
GENERIC heap_alloc(long s)
Definition: memory.c:1518
assert
#define assert(N)
Definition: memory.c:104
or_codes
void or_codes(ptr_int_list u, ptr_int_list v)
Definition: types.c:780
matches
long matches(ptr_definition t1, ptr_definition t2, long *smaller)
Definition: types.c:1565
wl_int_list::next
ptr_int_list next
Definition: def_struct.h:55
wl_definition::parents
ptr_int_list parents
Definition: def_struct.h:130