Wild Life  2.29
 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 
17 
18 /******** PRINT_DEF_TYPE(t)
19  This prints type T to stderr, where T=predicate, function or type.
20 */
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)
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 */
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;
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 {
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 */
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
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 */
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 */
327 ptr_node n;
328 {
329  ptr_definition d;
330 
331  if (n) {
332  d=((ptr_keyword)n->data)->definition;
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 */
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 */
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;
491  Errorline("the %T '%s' may not be redefined as a sort.\n",
492  d->type_def, d->keyword->symbol);
493  }
494  else {
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 */
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)
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 */
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) {
636 
637  insert_own_prop(d);
639 
640  kids=d->children;
641 
642  while(kids) {
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  }
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)
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)
724 }
725 
726 
727 
728 /******** TWO_TO_THE(p)
729  Return the code worth 2^p.
730 */
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 */
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)
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)
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 
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)
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 */
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 */
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)
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 */
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 */
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;
1025 
1026  top->parents=NULL;
1027  top->children=NULL;
1028 
1029  /* The following definitions are vital to avoid crashes */
1031  make_type_link(lf_true,boolean);
1032  make_type_link(lf_false,boolean);
1033 
1034  /* These just might be useful */
1036  make_type_link(boolean,built_in);
1038 
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 
1137 
1138  /* Inherit 'FALSE' always_check flags to all types' children */
1140 
1141  traceline("*** Encoding done, %d sorts\n",type_count);
1142 
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 
1169  types_done=TRUE;
1170  }
1171 }
1172 
1173 
1174 
1175 /******** PRINT_CODES()
1176  Print all the codes.
1177 */
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 
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 }
void find_adults()
Definition: types.c:516
ptr_psi_term aaaa_2
Definition: def_struct.h:189
long type_cyclicity(ptr_definition d, ptr_int_list anc)
Definition: types.c:907
#define predicate
Definition: def_const.h:361
#define function_it
Definition: def_const.h:362
char already_loaded
Definition: def_struct.h:137
void get_two_args(ptr_node t, ptr_psi_term *a, ptr_psi_term *b)
get_two_args
Definition: login.c:47
ptr_definition * gamma_table
Definition: types.c:16
void least_sorts()
Definition: types.c:700
void perr(char *str)
Definition: error.c:659
struct wl_definition * def_type
Definition: def_struct.h:32
void assert_complicated_type(ptr_psi_term t)
Definition: types.c:375
char evaluate_args
Definition: def_struct.h:136
void assert_args_not_eval(ptr_node n)
Definition: types.c:273
void encode_types()
Definition: types.c:1015
void exit_life(long nl_flag)
exit_life
Definition: built_ins.c:2220
char * combined_name
Definition: def_struct.h:92
long type_count
Definition: def_glob.h:46
long strict_matches(ptr_psi_term t1, ptr_psi_term t2, long *smaller)
Definition: types.c:1608
#define global
Definition: def_const.h:364
#define NOT_CODED
Definition: def_const.h:134
long redefine(ptr_psi_term t)
Definition: types.c:91
ptr_pair_list next
Definition: def_struct.h:191
#define undef
Definition: def_const.h:360
ptr_int_list two_to_the(long p)
Definition: types.c:731
long assert_less(ptr_psi_term t1, ptr_psi_term t2)
Definition: types.c:183
void perr_sort_list(ptr_int_list anc)
Definition: types.c:882
void propagate_definitions()
Definition: types.c:622
void clear_coding()
Definition: types.c:685
def_type type_def
Definition: def_struct.h:133
long file_date
Definition: def_glob.h:60
void perr_sort_cycle(ptr_int_list anc)
Definition: types.c:892
#define INT_SIZE
Definition: def_const.h:144
long sub_CodeType()
long overlap_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1486
void clear_already_loaded(ptr_node n)
Definition: types.c:326
ptr_keyword keyword
Definition: def_struct.h:124
void assert_protected(ptr_node n, long prot)
Definition: types.c:235
ptr_int_list copyTypeCode(ptr_int_list u)
Definition: types.c:760
void perr_s(char *s1, char *s2)
Definition: error.c:665
void remove_cycles(ptr_definition d, ptr_int_list *dl)
Definition: types.c:73
ptr_int_list cons(GENERIC v, ptr_int_list l)
Definition: types.c:164
ptr_definition top
Definition: def_glob.h:106
#define NULL
Definition: def_const.h:203
long warningflag
Definition: def_glob.h:270
ptr_psi_term input_state
Definition: def_glob.h:199
void make_sys_type_links()
Definition: sys.c:1726
char * symbol
Definition: def_struct.h:91
#define REAL
Definition: def_const.h:72
ptr_triple_list next
Definition: def_struct.h:199
ptr_definition cccc_4
Definition: def_struct.h:198
long types_modified
Definition: def_glob.h:47
void inherit_always_check()
Definition: types.c:994
long assert_ok
Definition: def_glob.h:59
char always_check
Definition: def_struct.h:134
void traceline(char *format,...)
Definition: error.c:157
#define type_it
Definition: def_const.h:363
ptr_definition next
Definition: def_struct.h:148
void make_type_link(ptr_definition t1, ptr_definition t2)
Definition: types.c:848
void Errorline(char *format,...)
Definition: error.c:414
#define EOLN
Definition: def_const.h:140
long bit_length(ptr_int_list c)
Definition: types.c:1648
#define wl_const_3(S)
Definition: def_macro.h:104
ptr_definition real
Definition: def_glob.h:102
#define deref_ptr(P)
Definition: def_macro.h:95
long glb(ptr_definition t1, ptr_definition t2, ptr_definition *t3, ptr_int_list *c3)
Definition: types.c:1388
void perr_sort(ptr_definition d)
Definition: types.c:876
#define TRUE
Definition: def_const.h:127
void propagate_always_check(ptr_definition d, long *ch)
Definition: types.c:950
ptr_definition first_definition
Definition: def_glob.h:3
void all_sorts()
Definition: types.c:716
ptr_definition built_in
Definition: def_glob.h:75
ptr_definition integer
Definition: def_glob.h:93
void one_pass_always_check(long *ch)
Definition: types.c:976
ptr_definition lf_true
Definition: def_glob.h:107
long glb_value(long result, long f, GENERIC c, GENERIC value1, GENERIC value2, GENERIC *value)
Definition: types.c:1206
ptr_pair_list rule
Definition: def_struct.h:126
#define FALSE
Definition: def_const.h:128
long glb_code(long f1, GENERIC c1, long f2, GENERIC c2, long *f3, GENERIC *c3)
Definition: types.c:1263
void assert_delay_check(ptr_node n)
Definition: types.c:303
ptr_definition quoted_string
Definition: def_glob.h:101
void insert_prop(ptr_definition d, ptr_triple_list prop)
Definition: types.c:580
struct wl_definition * ptr_definition
Definition: def_struct.h:31
long sub_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1544
GENERIC value_3
Definition: def_struct.h:170
ptr_definition lf_false
Definition: def_glob.h:89
ptr_psi_term bbbb_2
Definition: def_struct.h:190
ptr_psi_term bbbb_4
Definition: def_struct.h:197
ptr_definition disjunction
Definition: def_glob.h:84
#define STACK_ALLOC(A)
Definition: def_macro.h:16
void assert_type(ptr_psi_term t)
Definition: types.c:345
void restore_state(ptr_psi_term t)
Definition: token.c:267
void outputline(char *format,...)
Definition: error.c:79
struct wl_keyword * ptr_keyword
Definition: def_struct.h:99
void print_codes()
Definition: types.c:1178
void equalize_codes(int len)
Definition: types.c:806
long type_member()
long types_done
Definition: def_glob.h:36
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
char * prompt
Definition: def_glob.h:42
long read_char()
Definition: token.c:587
#define MAX_BUILT_INS
Definition: def_const.h:82
ptr_definition nothing
Definition: def_glob.h:98
ptr_definition nil
Definition: def_glob.h:97
#define equ_tok(A, B)
Definition: def_macro.h:62
void insert_own_prop(ptr_definition d)
Definition: types.c:539
ptr_int_list code
Definition: def_struct.h:129
ptr_int_list decode(ptr_int_list c)
Definition: types.c:1678
void add_rule(ptr_psi_term head, ptr_psi_term body, def_type typ)
add_rule
Definition: login.c:167
void warningline(char *format,...)
Definition: error.c:327
ptr_int_list children
Definition: def_glob.h:354
ptr_int_list adults
Definition: def_glob.h:354
ptr_definition type
Definition: def_struct.h:165
void assert_attributes(ptr_psi_term t)
Definition: types.c:468
GENERIC value_1
Definition: def_struct.h:54
void print_def_type(def_type t)
Definition: types.c:21
unsigned long * GENERIC
Definition: def_struct.h:17
long count_sorts(long c0)
Definition: types.c:669
ptr_triple_list properties
Definition: def_struct.h:127
struct wl_int_list * ptr_int_list
Definition: def_struct.h:29
ptr_int_list children
Definition: def_struct.h:131
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
ptr_node attr_list
Definition: def_struct.h:171
long open_input_file(char *file)
Definition: token.c:504
long yes_or_no()
Definition: types.c:44
ptr_psi_term aaaa_4
Definition: def_struct.h:196
GENERIC heap_alloc(long s)
heap_alloc
Definition: memory.c:1616
#define assert(N)
Definition: memory.c:113
void or_codes(ptr_int_list u, ptr_int_list v)
Definition: types.c:780
long matches(ptr_definition t1, ptr_definition t2, long *smaller)
Definition: types.c:1565
ptr_int_list next
Definition: def_struct.h:55
ptr_int_list parents
Definition: def_struct.h:130