Warning: Attempt to read property "date" on null in /usr/local/www/websvn.planix.org/blame.php on line 247

Warning: Attempt to read property "msg" on null in /usr/local/www/websvn.planix.org/blame.php on line 247
WebSVN – tendra.SVN – Blame – //branches/tendra5/src/installers/common/construct/misc_c.c – Rev 2

Subversion Repositories tendra.SVN

Rev

Go to most recent revision | Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 7u83 1 
/*
2 
    		 Crown Copyright (c) 1997
3 
 
4 
    This TenDRA(r) Computer Program is subject to Copyright
5 
    owned by the United Kingdom Secretary of State for Defence
6 
    acting through the Defence Evaluation and Research Agency
7 
    (DERA).  It is made available to Recipients with a
8 
    royalty-free licence for its use, reproduction, transfer
9 
    to other parties and amendment for any purpose not excluding
10 
    product development provided that any such use et cetera
11 
    shall be deemed to be acceptance of the following conditions:-
12 
 
13 
        (1) Its Recipients shall ensure that this Notice is
14 
        reproduced upon any copies or amended versions of it;
15 
 
16 
        (2) Any amended version of it shall be clearly marked to
17 
        show both the nature of and the organisation responsible
18 
        for the relevant amendment or amendments;
19 
 
20 
        (3) Its onward transfer from a recipient to another
21 
        party shall be deemed to be that party's acceptance of
22 
        these conditions;
23 
 
24 
        (4) DERA gives no warranty or assurance as to its
25 
        quality or suitability for any purpose and DERA accepts
26 
        no liability whatsoever in relation to any use to which
27 
        it may be put.
28 
*/
29 
 
30 
 
31 
/**********************************************************************
32 
$Author: release $
33 
$Date: 1998/01/17 15:55:47 $
34 
$Revision: 1.1.1.1 $
35 
$Log: misc_c.c,v $
36 
 * Revision 1.1.1.1  1998/01/17  15:55:47  release
37 
 * First version to be checked into rolling release.
38 
 *
39 
 * Revision 1.1  1995/04/06  10:44:05  currie
40 
 * Initial revision
41 
 *
42 
***********************************************************************/
43 
 
44 
 
45 
 
46 
 
47 
#include "config.h"
48 
#include "common_types.h"
49 
#include "exp.h"
50 
#include "expmacs.h"
51 
#include "tags.h"
52 
#include "externs.h"
53 
#include "shapemacs.h"
54 
#include "complex_eq.h"
55 
 
56 
#include "misc_c.h"
57 
 
58 
static int invar_list
59 
    PROTO_N ( (e) )
60 
    PROTO_T ( exp e )
61 
{
62 
  while (1) {
63 
    if (e==nilexp)
64 
      return 1;
65 
    if (!invariant_to_apply(e))
66 
      return 0;
67 
    if (last(e))
68 
      return 1;
69 
    e = bro(e);
70 
  };
71 
}
72 
 
73 
/* determines if e has no side effects and the same value
74 
   if evaluated immediately before and after any procedure
75 
   call (including a recursive one). The evaluation of the
76 
   procedure arguments is assumed to to affect the value of e.
77 
   e will not be nilexp.
78 
*/
79 
int invariant_to_apply
80 
    PROTO_N ( (e) )
81 
    PROTO_T ( exp e )
82 
{
83 
  if (name(e) == cont_tag)
84 
     return (name(son(e)) == name_tag && isvar(son(son(e))) &&
85 
		iscaonly(son(son(e))) && !isglob(son(son(e))));
86 
 
87 
  if (name(e) == seq_tag || name(e)  == ident_tag ||
88 
	(name(e) >= plus_tag && name(e) < cont_tag) ||
89 
	name(e) == field_tag || name(e) == reff_tag)
90 
    return invar_list(son(e));
91 
 
92 
  if (name(e) == contvol_tag)
93 
    return 0;
94 
 
95 
  return 1;
96 
}
97 
 
98 
int is_tester
99 
    PROTO_N ( (e, eq) )
100 
    PROTO_T ( exp e X int eq )
101 
{
102 
  if (name(e) == test_tag || name(e) == testbit_tag) {
103 
    if (!eq || test_number(e) == f_equal)
104 
      return 1;
105 
  };
106 
  return 0;
107 
}
108 
 
109 
int take_out_of_line
110 
    PROTO_N ( (first, alt, in_repeat, scale) )
111 
    PROTO_T ( exp first X exp alt X int in_repeat X double scale )
112 
{
113 
  int extract;
114 
  extract = in_repeat &&
115 
		    name(first) == seq_tag &&
116 
		    name(sh(first)) == bothd &&
117 
		    no(son(alt)) == 1 &&
118 
		    ((is_tester(son(son(first)), 0) &&
119 
		      pt(son(son(first))) == alt) ||
120 
		     (name(son(son(first))) == ident_tag &&
121 
		      is_tester(bro(son(son(son(first)))), 0) &&
122 
		      pt(bro(son(son(son(first))))) == alt)
123 
		     );
124 
  if (!extract &&
125 
	      name(first) == seq_tag &&
126 
	      no(son(alt)) == 1 &&
127 
	      name(bro(son(first))) == apply_tag &&
128 
	      ((is_tester(son(son(first)), 0) &&
129 
		      pt(son(son(first))) == alt) ||
130 
		     (name(son(son(first))) == ident_tag &&
131 
		      is_tester(bro(son(son(son(first)))), 0) &&
132 
		      pt(bro(son(son(son(first))))) == alt)
133 
	      ))
134 
	    extract = 1;
135 
 
136 
  if (!extract &&
137 
		    name(first) == seq_tag &&
138 
		    no(son(alt)) == 1 &&
139 
		    ((is_tester(son(son(first)), 1) &&
140 
		      pt(son(son(first))) == alt &&
141 
			name(bro(son(son(son(first))))) == null_tag) ||
142 
		     (name(son(son(first))) == ident_tag &&
143 
		      is_tester(bro(son(son(son(first)))), 1) &&
144 
		      pt(bro(son(son(son(first))))) == alt &&
145 
			name(bro(son(bro(son(son(son(first))))))) ==
146 
				 null_tag )
147 
		     ))
148 
	    extract = 1;
149 
  if (!extract &&
150 
		    name(first) == seq_tag &&
151 
		    no(son(alt)) == 1 &&
152 
		    name(son(son(first))) == ident_tag &&
153 
		    is_tester(bro(son(son(son(first)))), 0) &&
154 
		    pt(bro(son(son(son(first))))) == alt &&
155 
		    no(bro(son(son(son(first))))) < 29)
156 
	    extract = 1;
157 
  if (!extract &&
158 
		    name(first) == seq_tag &&
159 
		    no(son(alt)) == 1 &&
160 
		    (is_tester(son(son(first)), 0) &&
161 
		      pt(son(son(first))) == alt)) {
162 
    exp q = bro(son(son(first)));
163 
    exp p = nilexp;
164 
    if (name(q) == prof_tag)
165 
      p = q;
166 
    if (name(q) == 0 && name(bro(q)) == seq_tag &&
167 
	name(son(son(bro(q)))) == prof_tag)
168 
      p = son(son(bro(q)));
169 
 
170 
    if (p != nilexp && (double)(no(p)) < (0.29 * scale))
171 
      extract = 1;
172 
  };
173 
  return extract;
174 
}
175 
 
176 
int take_out_by_prob
177 
    PROTO_N ( (first, alt) )
178 
    PROTO_T ( exp first X exp alt )
179 
{
180 
  int extract = 0;
181 
  if (!extract &&
182 
		    name(first) == seq_tag &&
183 
		    no(son(alt)) == 1 &&
184 
		    (is_tester(son(son(first)), 0) &&
185 
		      pt(son(son(first))) == alt &&
186 
			no(son(son(first))) < 29))
187 
	    extract = 1;
188 
  if (!extract &&
189 
		    name(first) == seq_tag &&
190 
		    no(son(alt)) == 1 &&
191 
		    name(son(son(first))) == ident_tag &&
192 
		    is_tester(bro(son(son(son(first)))), 0) &&
193 
		    pt(bro(son(son(son(first))))) == alt &&
194 
		    no(bro(son(son(son(first))))) < 29)
195 
	    extract = 1;
196 
  return extract;
197 
}
198 
/* looks for things like
199 
	(a ~ b) ? a: b
200 
	puts test in t - can make use of delay-slot
201 
*/
202 
int is_maxop
203 
    PROTO_N ( (x, t) )
204 
    PROTO_T ( exp x X exp *t )
205 
{
206 
  exp op1, op2, z, l, w;
207 
  if (name(x) != cond_tag) goto flab0;
208 
  { exp xC = son(x);
209 
    if (name(xC) != seq_tag) goto flab0;
210 
    { exp xCC = son(xC);
211 
      { exp xCCC = son(xCC);
212 
        *t = xCCC;
213 
        if (name(xCCC) != test_tag) goto flab0;
214 
        l=pt(*t);
215 
        { exp xCCCC = son(xCCC);
216 
          op1 = xCCCC;
217 
          if (!(!is_floating(name(sh(op1))))) goto flab0;
218 
          if (last(xCCCC)) goto flab0;
219 
          xCCCC = bro(xCCCC);
220 
          op2 = xCCCC;
221 
          if(!last(xCCCC)) goto flab0;
222 
        }
223 
        if(!last(xCCC)) goto flab0;
224 
      }
225 
      if (last(xCC)) goto flab0;
226 
      xCC = bro(xCC);
227 
      z = xCC;
228 
      if (!(complex_eq_exp(z, op1, nilexp,nilexp))) goto flab0;
229 
      if(!last(xCC)) goto flab0;
230 
    }
231 
    if (last(xC)) goto flab0;
232 
    xC = bro(xC);
233 
    if (l != xC) goto flab0;
234 
    { exp xCC = son(xC);
235 
      z = xCC;
236 
      if (!(no(z)==1)) goto flab0;
237 
      if (last(xCC)) goto flab0;
238 
      xCC = bro(xCC);
239 
      w = xCC;
240 
      if (!(complex_eq_exp(w, op2,nilexp,nilexp))) goto flab0;
241 
      if(!last(xCC)) goto flab0;
242 
    }
243 
    if(!last(xC)) goto flab0;
244 
  }
245 
  return 1;
246 
  flab0: return 0;
247 
}
248 
 
249 
/* looks for things like
250 
	(a ~ b) ? b: a
251 
	puts test in t - can make use of delay-slot
252 
*/
253 
int is_minop
254 
    PROTO_N ( (x, t) )
255 
    PROTO_T ( exp x X exp *t )
256 
{
257 
  exp op1, op2, z, l, w;
258 
  if (name(x) != cond_tag) goto flab0;
259 
  { exp xC = son(x);
260 
    if (name(xC) != seq_tag) goto flab0;
261 
    { exp xCC = son(xC);
262 
      { exp xCCC = son(xCC);
263 
        *t = xCCC;
264 
        if (name(xCCC) != test_tag) goto flab0;
265 
        l=pt(*t);
266 
        { exp xCCCC = son(xCCC);
267 
          op1 = xCCCC;
268 
          if (!(!is_floating(name(sh(op1))))) goto flab0;
269 
          if (last(xCCCC)) goto flab0;
270 
          xCCCC = bro(xCCCC);
271 
          op2 = xCCCC;
272 
          if(!last(xCCCC)) goto flab0;
273 
        }
274 
        if(!last(xCCC)) goto flab0;
275 
      }
276 
      if (last(xCC)) goto flab0;
277 
      xCC = bro(xCC);
278 
      z = xCC;
279 
      if (!(complex_eq_exp(z, op2,nilexp,nilexp))) goto flab0;
280 
      if(!last(xCC)) goto flab0;
281 
    }
282 
    if (last(xC)) goto flab0;
283 
    xC = bro(xC);
284 
    if (l != xC) goto flab0;
285 
    { exp xCC = son(xC);
286 
      z = xCC;
287 
      if (!(no(z)==1)) goto flab0;
288 
      if (last(xCC)) goto flab0;
289 
      xCC = bro(xCC);
290 
      w = xCC;
291 
      if (!(complex_eq_exp(w, op1,nilexp,nilexp))) goto flab0;
292 
      if(!last(xCC)) goto flab0;
293 
    }
294 
    if(!last(xC)) goto flab0;
295 
  }
296 
  return 1;
297 
  flab0: return 0;
298 
}
299 
 
300 
#if condassign_implemented
301 
 
302 
int is_condassign
303 
    PROTO_N ( (e, to_test, to_ass) )
304 
    PROTO_T ( exp e X exp * to_test X exp * to_ass )
305 
{
306 
  exp arg1 = son(e);
307 
  exp arg2 = bro(arg1);
308 
  exp z;
309 
  exp st;
310 
  exp ass;
311 
  exp val;
312 
  if (name(arg1) != seq_tag)
313 
    return 0;
314 
 
315 
  z = son(arg1);
316 
  st = son(z);
317 
  ass = bro(z);
318 
 
319 
  if (no(son(arg2)) != 1 || name(bro(son(arg2))) != top_tag)
320 
    return 0;
321 
  if (name(st) != test_tag && name(st) != testbit_tag)
322 
    return 0;
323 
  if (!last(st))
324 
    return 0;
325 
  if (name(ass) != ass_tag)
326 
    return 0;
327 
  if (name(son(ass)) != name_tag || !isvar(son(son(ass))))
328 
    return 0;
329 
 
330 
  val = bro(son(ass));
331 
  *to_test = st;
332 
  *to_ass = ass;
333 
  if (name(val) == val_tag)
334 
    return 1;
335 
 
336 
  return 0;
337 
}
338 
#endif
339 
 
340