Wild Life  2.29
 All Data Structures Files Functions Variables Typedefs Macros
lub.c
Go to the documentation of this file.
1 /* tab:4
2  *
3  * lub.c - find least upper bound of the root sorts of two psi terms
4  *
5  * Copyright (c) 1992 Digital Equipment Corporation
6  * All Rights Reserved.
7  *
8  * The standard digital prl copyrights exist and where compatible
9  * the below also exists.
10  * Permission to use, copy, modify, and distribute this
11  * software and its documentation for any purpose and without
12  * fee is hereby granted, provided that the above copyright
13  * notice appear in all copies. Copyright holder(s) make no
14  * representation about the suitability of this software for
15  * any purpose. It is provided "as is" without express or
16  * implied warranty.
17  *
18  * Author: Seth Copen Goldstein
19  * Version: 26
20  * Creation Date: Fri Jun 5 12:14:39 1992
21  * Filename: lub.c
22  * History:
23  */
24 /* $Id: lub.c,v 1.3 1995/08/25 21:34:37 duchier Exp $ */
25 
26 #include "defs.h"
27 
29  ptr_int_list tail; /* attach copies of more to tail */
30  ptr_int_list more;
31 {
32  while (more)
33  {
34  tail->next = STACK_ALLOC(int_list);
35  tail= tail->next;
36  tail->value_1 = more->value_1;
37  tail->next = NULL;
38  more = more->next;
39  }
40  return tail;
41 }
42 
43 /* Set flags bit for all ancestors (i.e., higher up) of head */
44 void
45 mark_ancestors(def, flags)
46  ptr_definition def;
47  long *flags;
48 {
49  ptr_int_list par;
50 
51  par=def->parents;
52  while (par) {
54  long len;
55 
56  p=(ptr_definition)par->value_1;
57  len=bit_length(p->code);
58  if (!flags[len]) {
59  flags[len]=1;
60  mark_ancestors(p, flags);
61  }
62  par=par->next;
63  }
64 }
65 
66 static long bfs(p, ans, pattern, flags)
68  ptr_int_list ans;
69  ptr_int_list pattern;
70  long *flags;
71 {
73  ptr_int_list tail;
74  ptr_int_list par;
75  long len;
76  long found = 0;
77 
78  if (p == top)
79  {
81  return 0; // ADDED 0 DJD 2.05
82  }
83 
84  /* print_code(pattern);*/
85  /* printf("\n");*/
86 
87  par = p->parents;
88  if (par == NULL)
89  return 0; /* only parent is top */
90 
91  assert(par->value_1 != NULL);
92 
93  head->value_1 = par->value_1;
94  head->next = NULL;
95  par = par->next;
96  tail = appendIntList(head, par);
97 
98  while (head)
99  {
100  /* pc(head->value);*/
101  len = bit_length(((ptr_definition )head->value_1)->code);
102  if (!flags[len])
103  {
104  /* we havn't checked this type before */
105 
106  if (!((ptr_definition )head->value_1 == top) &&
107  !((ptr_definition )head->value_1 == built_in) &&
108  (sub_CodeType(pattern,((ptr_definition)head->value_1)->code)))
109  {
110  or_codes(ans, ((ptr_definition)head->value_1)->code);
111  /* print_code(ans);*/
112  /* printf("ans\n");*/
113  found++;
114  /* must set flags of ALL ancestors of head! */
115  mark_ancestors((ptr_definition)head->value_1,flags);
116  }
117  else
118  tail = appendIntList(tail,
119  ((ptr_definition )head->value_1)->parents);
120  flags[len] = 1;
121  }
122  head = head->next;
123  }
124  return found;
125 }
126 
127 
128 /******************************************/
129 /* make a decoded type list from one type */
130 /******************************************/
131 
133  ptr_definition x;
134 {
135  ptr_int_list ans;
136 
137  ans = STACK_ALLOC(int_list);
138  ans->value_1 = (GENERIC )x;
139  ans->next = NULL;
140  return ans;
141 }
142 
143 /*****************************************************************************/
144 /* returns a decoded type list of the root sorts that make up the least upper
145  * bound of the two terms, a &b. Deals with speacial cases of integers,
146  * strings, etc.
147  */
148 /*****************************************************************************/
149 
151  ptr_psi_term a;
152  ptr_psi_term b;
153  ptr_psi_term *pp;
154 {
155  ptr_definition ta; /* type of psi term a */
156  ptr_definition tb; /* type of psi term b */
157  long *flags; /* set to 1 if this type has been checked in
158  * the lub search.
159  */
160  ptr_int_list ans;
161  ptr_int_list pattern;
162  long found;
163 
164  ta = a->type;
165  tb = b->type;
166 
167  /* special cases first */
168 
169  if (isValue(a) && isValue(b) && sub_type(ta,tb) && sub_type(tb,ta))
170  {
171  /* special case of two values being of same type. Check that they
172  * might actually be same value before returning the type
173  */
174  if (isSubTypeValue(a, b))
175  {
176  /* since we alreadyuu know they are both values, isSubTypeValue
177  * returns TRUE if they are same value, else false
178  */
179 
180  *pp = a;
181  return NULL;
182  }
183  }
184 
185  if (sub_type(ta, tb)) return makeUnitList(tb);
186  if (sub_type(tb, ta)) return makeUnitList(ta);
187 
188  /* ta has the lub of tb&ta without the high bit set, search upwards for a
189  * type that has the same lower bits as ta
190  */
191 
192  /* get the pattern to search for */
193 
194  pattern = copyTypeCode(ta->code);
195  or_codes(pattern, tb->code); /* pattern to search for */
196  ans = copyTypeCode(pattern); /* resulting pattern */
197 
198  /* initialize the table to be non-searched */
199 
200  flags = (long *)stack_alloc(sizeof(unsigned long) * type_count);
201  memset(flags, 0, sizeof(unsigned long) * type_count);
202 
203  /* now do a breadth first search for each of arg1 and arg2 */
204 
205  found = bfs(ta, ans, pattern, flags);
206  found += bfs(tb, ans, pattern, flags);
207 
208  if (found)
209  ans = decode(ans);
210  else
211  ans = makeUnitList(top);
212 
213  return ans;
214 }
215 
216 
int isSubTypeValue(ptr_psi_term arg1, ptr_psi_term arg2)
Definition: bi_type.c:163
long type_count
Definition: def_glob.h:46
long bit_length(ptr_int_list c)
Definition: types.c:1648
ptr_int_list decode(ptr_int_list c)
Definition: types.c:1678
static long bfs(ptr_definition p, ptr_int_list ans, ptr_int_list pattern, long *flags)
Definition: lub.c:66
void or_codes(ptr_int_list u, ptr_int_list v)
Definition: types.c:780
ptr_int_list lub(ptr_psi_term a, ptr_psi_term b, ptr_psi_term *pp)
Definition: lub.c:150
ptr_int_list appendIntList(ptr_int_list tail, ptr_int_list more)
Definition: lub.c:28
ptr_definition top
Definition: def_glob.h:106
#define NULL
Definition: def_const.h:203
void mark_ancestors(ptr_definition def, long *flags)
Definition: lub.c:45
long sub_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1544
ptr_definition built_in
Definition: def_glob.h:75
struct wl_definition * ptr_definition
Definition: def_struct.h:31
#define STACK_ALLOC(A)
Definition: def_macro.h:16
ptr_int_list copyTypeCode(ptr_int_list u)
Definition: types.c:760
long sub_CodeType(ptr_int_list c1, ptr_int_list c2)
Definition: types.c:1522
ptr_int_list code
Definition: def_struct.h:129
long isValue(ptr_psi_term p)
Definition: bi_type.c:541
ptr_definition type
Definition: def_struct.h:165
GENERIC value_1
Definition: def_struct.h:54
unsigned long * GENERIC
Definition: def_struct.h:17
static ptr_int_list makeUnitList(ptr_definition x)
Definition: lub.c:132
GENERIC stack_alloc(long s)
Definition: memory.c:1542
#define assert(N)
Definition: memory.c:104
ptr_int_list next
Definition: def_struct.h:55