Subversion Repositories tendra.SVN

Rev

Rev 2 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 7u83 1 
/*
7 7u83 2 
 * Copyright (c) 2002-2006 The TenDRA Project <http://www.tendra.org/>.
3 
 * All rights reserved.
4 
 *
5 
 * Redistribution and use in source and binary forms, with or without
6 
 * modification, are permitted provided that the following conditions are met:
7 
 *
8 
 * 1. Redistributions of source code must retain the above copyright notice,
9 
 *    this list of conditions and the following disclaimer.
10 
 * 2. Redistributions in binary form must reproduce the above copyright notice,
11 
 *    this list of conditions and the following disclaimer in the documentation
12 
 *    and/or other materials provided with the distribution.
13 
 * 3. Neither the name of The TenDRA Project nor the names of its contributors
14 
 *    may be used to endorse or promote products derived from this software
15 
 *    without specific, prior written permission.
16 
 *
17 
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
18 
 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
19 
 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
20 
 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
21 
 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
22 
 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
23 
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
24 
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
26 
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
27 
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 
 *
29 
 * $Id$
30 
 */
31 
/*
2 7u83 32 
    		 Crown Copyright (c) 1997
33 
 
34 
    This TenDRA(r) Computer Program is subject to Copyright
35 
    owned by the United Kingdom Secretary of State for Defence
36 
    acting through the Defence Evaluation and Research Agency
37 
    (DERA).  It is made available to Recipients with a
38 
    royalty-free licence for its use, reproduction, transfer
39 
    to other parties and amendment for any purpose not excluding
40 
    product development provided that any such use et cetera
41 
    shall be deemed to be acceptance of the following conditions:-
42 
 
43 
        (1) Its Recipients shall ensure that this Notice is
44 
        reproduced upon any copies or amended versions of it;
45 
 
46 
        (2) Any amended version of it shall be clearly marked to
47 
        show both the nature of and the organisation responsible
48 
        for the relevant amendment or amendments;
49 
 
50 
        (3) Its onward transfer from a recipient to another
51 
        party shall be deemed to be that party's acceptance of
52 
        these conditions;
53 
 
54 
        (4) DERA gives no warranty or assurance as to its
55 
        quality or suitability for any purpose and DERA accepts
56 
        no liability whatsoever in relation to any use to which
57 
        it may be put.
58 
*/
59 
 
60 
 
61 
/**********************************************************************
62 
$Author: release $
63 
$Date: 1998/01/17 15:55:47 $
64 
$Revision: 1.1.1.1 $
65 
$Log: misc_c.c,v $
66 
 * Revision 1.1.1.1  1998/01/17  15:55:47  release
67 
 * First version to be checked into rolling release.
68 
 *
69 
 * Revision 1.1  1995/04/06  10:44:05  currie
70 
 * Initial revision
71 
 *
72 
***********************************************************************/
73 
 
74 
#include "config.h"
75 
#include "common_types.h"
76 
#include "exp.h"
77 
#include "expmacs.h"
78 
#include "tags.h"
79 
#include "externs.h"
80 
#include "shapemacs.h"
81 
#include "complex_eq.h"
82 
 
83 
#include "misc_c.h"
84 
 
7 7u83 85 
static int
86 
invar_list(exp e)
2 7u83 87 
{
7 7u83 88 
	while (1) {
89 
		if (e==nilexp) {
90 
			return 1;
91 
		}
92 
		if (!invariant_to_apply(e)) {
93 
			return 0;
94 
		}
95 
		if (last(e)) {
96 
			return 1;
97 
		}
98 
		e = bro(e);
99 
	}
2 7u83 100 
}
101 
 
7 7u83 102 
 
2 7u83 103 
/* determines if e has no side effects and the same value
104 
   if evaluated immediately before and after any procedure
105 
   call (including a recursive one). The evaluation of the
106 
   procedure arguments is assumed to to affect the value of e.
107 
   e will not be nilexp.
108 
*/
7 7u83 109 
int
110 
invariant_to_apply(exp e)
2 7u83 111 
{
7 7u83 112 
	if (name(e) == cont_tag) {
113 
		return(name(son(e)) == name_tag && isvar(son(son(e))) &&
114 
		       iscaonly(son(son(e))) && !isglob(son(son(e))));
115 
	}
2 7u83 116 
 
7 7u83 117 
	if (name(e) == seq_tag || name(e) == ident_tag ||
118 
	    (name(e) >= plus_tag && name(e) < cont_tag) ||
119 
	    name(e) == field_tag || name(e) == reff_tag) {
120 
		return invar_list(son(e));
121 
	}
2 7u83 122 
 
7 7u83 123 
	if (name(e) == contvol_tag) {
124 
		return 0;
125 
	}
2 7u83 126 
 
7 7u83 127 
	return 1;
2 7u83 128 
}
129 
 
7 7u83 130 
 
131 
int
132 
is_tester(exp e, int eq)
2 7u83 133 
{
7 7u83 134 
	if (name(e) == test_tag || name(e) == testbit_tag) {
135 
		if (!eq || test_number(e) == f_equal) {
136 
			return 1;
137 
		}
138 
	}
139 
	return 0;
2 7u83 140 
}
141 
 
7 7u83 142 
 
143 
int
144 
take_out_of_line(exp first, exp alt, int in_repeat, double scale)
2 7u83 145 
{
7 7u83 146 
	int extract;
147 
	extract = in_repeat && name(first) == seq_tag &&
148 
	    name(sh(first)) == bothd && no(son(alt)) == 1 &&
149 
	    ((is_tester(son(son(first)), 0) && pt(son(son(first))) == alt) ||
150 
	     (name(son(son(first))) == ident_tag &&
151 
	      is_tester(bro(son(son(son(first)))), 0) &&
152 
	      pt(bro(son(son(son(first))))) == alt));
153 
	if (!extract && name(first) == seq_tag && no(son(alt)) == 1 &&
154 
	    name(bro(son(first))) == apply_tag &&
155 
	    ((is_tester(son(son(first)), 0) && pt(son(son(first))) == alt) ||
156 
	     (name(son(son(first))) == ident_tag &&
157 
	      is_tester(bro(son(son(son(first)))), 0) &&
158 
	      pt(bro(son(son(son(first))))) == alt))) {
159 
		extract = 1;
160 
	}
2 7u83 161 
 
7 7u83 162 
	if (!extract && name(first) == seq_tag && no(son(alt)) == 1 &&
163 
	    ((is_tester(son(son(first)), 1) && pt(son(son(first))) == alt &&
164 
	      name(bro(son(son(son(first))))) == null_tag) ||
165 
	     (name(son(son(first))) == ident_tag &&
166 
	      is_tester(bro(son(son(son(first)))), 1) &&
167 
	      pt(bro(son(son(son(first))))) == alt &&
168 
	      name(bro(son(bro(son(son(son(first))))))) == null_tag))) {
169 
		extract = 1;
170 
	}
171 
	if (!extract && name(first) == seq_tag && no(son(alt)) == 1 &&
172 
	    name(son(son(first))) == ident_tag &&
173 
	    is_tester(bro(son(son(son(first)))), 0) &&
174 
	    pt(bro(son(son(son(first))))) == alt &&
175 
	    no(bro(son(son(son(first))))) < 29) {
176 
		extract = 1;
177 
	}
178 
	if (!extract && name(first) == seq_tag && no(son(alt)) == 1 &&
179 
	    (is_tester(son(son(first)), 0) && pt(son(son(first))) == alt)) {
180 
		exp q = bro(son(son(first)));
181 
		exp p = nilexp;
182 
		if (name(q) == prof_tag) {
183 
			p = q;
184 
		}
185 
		if (name(q) == 0 && name(bro(q)) == seq_tag &&
186 
		    name(son(son(bro(q)))) == prof_tag) {
187 
			p = son(son(bro(q)));
188 
		}
2 7u83 189 
 
7 7u83 190 
		if (p != nilexp && (double)(no(p)) < (0.29 * scale)) {
191 
			extract = 1;
192 
		}
193 
	}
194 
	return extract;
2 7u83 195 
}
196 
 
7 7u83 197 
 
198 
int
199 
take_out_by_prob(exp first, exp alt)
2 7u83 200 
{
7 7u83 201 
	int extract = 0;
202 
	if (!extract && name(first) == seq_tag && no(son(alt)) == 1 &&
203 
	    (is_tester(son(son(first)), 0) && pt(son(son(first))) == alt &&
204 
	     no(son(son(first))) < 29)) {
205 
		extract = 1;
206 
	}
207 
	if (!extract && name(first) == seq_tag && no(son(alt)) == 1 &&
208 
	    name(son(son(first))) == ident_tag &&
209 
	    is_tester(bro(son(son(son(first)))), 0) &&
210 
	    pt(bro(son(son(son(first))))) == alt &&
211 
	    no(bro(son(son(son(first))))) < 29) {
212 
		extract = 1;
213 
	}
214 
	return extract;
2 7u83 215 
}
7 7u83 216 
 
217 
 
2 7u83 218 
/* looks for things like
7 7u83 219 
	(a ~ b) ? a : b
2 7u83 220 
	puts test in t - can make use of delay-slot
221 
*/
7 7u83 222 
int
223 
is_maxop(exp x, exp *t)
2 7u83 224 
{
7 7u83 225 
	exp op1, op2, z, l, w;
226 
	if (name(x) != cond_tag) {
227 
		goto flab0;
228 
	}
229 
	{
230 
		exp xC = son(x);
231 
		if (name(xC) != seq_tag) {
232 
			goto flab0;
233 
		}
234 
		{
235 
			exp xCC = son(xC);
236 
			{
237 
				exp xCCC = son(xCC);
238 
				*t = xCCC;
239 
				if (name(xCCC) != test_tag) {
240 
					goto flab0;
241 
				}
242 
				l=pt(*t);
243 
				{
244 
					exp xCCCC = son(xCCC);
245 
					op1 = xCCCC;
246 
					if (!(!is_floating(name(sh(op1))))) {
247 
						goto flab0;
248 
					}
249 
					if (last(xCCCC)) {
250 
						goto flab0;
251 
					}
252 
					xCCCC = bro(xCCCC);
253 
					op2 = xCCCC;
254 
					if (!last(xCCCC)) {
255 
						goto flab0;
256 
					}
257 
				}
258 
				if (!last(xCCC)) {
259 
					goto flab0;
260 
				}
261 
			}
262 
			if (last(xCC)) {
263 
				goto flab0;
264 
			}
265 
			xCC = bro(xCC);
266 
			z = xCC;
267 
			if (!(complex_eq_exp(z, op1, nilexp,nilexp))) {
268 
				goto flab0;
269 
			}
270 
			if (!last(xCC)) {
271 
				goto flab0;
272 
			}
273 
		}
274 
		if (last(xC)) {
275 
			goto flab0;
276 
		}
277 
		xC = bro(xC);
278 
		if (l != xC) {
279 
			goto flab0;
280 
		}
281 
		{
282 
			exp xCC = son(xC);
283 
			z = xCC;
284 
			if (!(no(z) == 1)) {
285 
				goto flab0;
286 
			}
287 
			if (last(xCC)) {
288 
				goto flab0;
289 
			}
290 
			xCC = bro(xCC);
291 
			w = xCC;
292 
			if (!(complex_eq_exp(w, op2, nilexp, nilexp))) {
293 
				goto flab0;
294 
			}
295 
			if (!last(xCC)) {
296 
				goto flab0;
297 
			}
298 
		}
299 
		if (!last(xC)) {
300 
			goto flab0;
301 
		}
302 
	}
303 
	return 1;
304 
flab0:
305 
	return 0;
2 7u83 306 
}
307 
 
7 7u83 308 
 
2 7u83 309 
/* looks for things like
7 7u83 310 
	(a ~ b) ? b : a
2 7u83 311 
	puts test in t - can make use of delay-slot
312 
*/
7 7u83 313 
int
314 
is_minop(exp x, exp *t)
2 7u83 315 
{
7 7u83 316 
	exp op1, op2, z, l, w;
317 
	if (name(x) != cond_tag) {
318 
		goto flab0;
319 
	}
320 
	{
321 
		exp xC = son(x);
322 
		if (name(xC) != seq_tag) {
323 
			goto flab0;
324 
		}
325 
		{
326 
			exp xCC = son(xC);
327 
			{
328 
				exp xCCC = son(xCC);
329 
				*t = xCCC;
330 
				if (name(xCCC) != test_tag) {
331 
					goto flab0;
332 
				}
333 
				l=pt(*t);
334 
				{
335 
					exp xCCCC = son(xCCC);
336 
					op1 = xCCCC;
337 
					if (!(!is_floating(name(sh(op1))))) {
338 
						goto flab0;
339 
					}
340 
					if (last(xCCCC)) {
341 
						goto flab0;
342 
					}
343 
					xCCCC = bro(xCCCC);
344 
					op2 = xCCCC;
345 
					if (!last(xCCCC)) {
346 
						goto flab0;
347 
					}
348 
				}
349 
				if (!last(xCCC)) {
350 
					goto flab0;
351 
				}
352 
			}
353 
			if (last(xCC)) {
354 
				goto flab0;
355 
			}
356 
			xCC = bro(xCC);
357 
			z = xCC;
358 
			if (!(complex_eq_exp(z, op2,nilexp,nilexp))) {
359 
				goto flab0;
360 
			}
361 
			if (!last(xCC)) {
362 
				goto flab0;
363 
			}
364 
		}
365 
		if (last(xC)) {
366 
			goto flab0;
367 
		}
368 
		xC = bro(xC);
369 
		if (l != xC) {
370 
			goto flab0;
371 
		}
372 
		{
373 
			exp xCC = son(xC);
374 
			z = xCC;
375 
			if (!(no(z) == 1)) {
376 
				goto flab0;
377 
			}
378 
			if (last(xCC)) {
379 
				goto flab0;
380 
			}
381 
			xCC = bro(xCC);
382 
			w = xCC;
383 
			if (!(complex_eq_exp(w, op1,nilexp,nilexp))) {
384 
				goto flab0;
385 
			}
386 
			if (!last(xCC)) {
387 
				goto flab0;
388 
			}
389 
		}
390 
		if (!last(xC)) {
391 
			goto flab0;
392 
		}
393 
	}
394 
	return 1;
395 
flab0:
396 
	return 0;
2 7u83 397 
}
398 
 
7 7u83 399 
 
2 7u83 400 
#if condassign_implemented
401 
 
7 7u83 402 
int
403 
is_condassign(exp e, exp *to_test, exp *to_ass)
2 7u83 404 
{
7 7u83 405 
	exp arg1 = son(e);
406 
	exp arg2 = bro(arg1);
407 
	exp z;
408 
	exp st;
409 
	exp ass;
410 
	exp val;
411 
	if (name(arg1) != seq_tag) {
412 
		return 0;
413 
	}
2 7u83 414 
 
7 7u83 415 
	z = son(arg1);
416 
	st = son(z);
417 
	ass = bro(z);
2 7u83 418 
 
7 7u83 419 
	if (no(son(arg2)) != 1 || name(bro(son(arg2))) != top_tag) {
420 
		return 0;
421 
	}
422 
	if (name(st) != test_tag && name(st) != testbit_tag) {
423 
		return 0;
424 
	}
425 
	if (!last(st)) {
426 
		return 0;
427 
	}
428 
	if (name(ass) != ass_tag) {
429 
		return 0;
430 
	}
431 
	if (name(son(ass)) != name_tag || !isvar(son(son(ass)))) {
432 
		return 0;
433 
	}
2 7u83 434 
 
7 7u83 435 
	val = bro(son(ass));
436 
	*to_test = st;
437 
	*to_ass = ass;
438 
	if (name(val) == val_tag) {
439 
		return 1;
440 
	}
2 7u83 441 
 
7 7u83 442 
	return 0;
2 7u83 443 
}
444 
#endif