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/algol60/src/installers/mips/common/oddtest.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:56:06 $
34 
$Revision: 1.1.1.1 $
35 
$Log: oddtest.c,v $
36 
 * Revision 1.1.1.1  1998/01/17  15:56:06  release
37 
 * First version to be checked into rolling release.
38 
 *
39 
 * Revision 1.1  1995/04/13  09:08:06  currie
40 
 * Initial revision
41 
 *
42 
***********************************************************************/
43 
/*
44 
Pattern in oddtest.pat
45 
this is intended to be the pattern for:
46 
	if (test) fexp 1 else fexp -1
47 
to transform to:
48 
	fexp ( (absbool(test) <<1) -1))
49 
where f is any sequence of unary operators including identity
50 
*/
51 
#include "config.h"
52 
#include "tags.h"
53 
#include "common_types.h"
54 
#include "expmacs.h"
55 
#include "exptypes.h"
56 
#include "shapemacs.h"
57 
#include "comp_eq_exp.h"
58 
#include "check.h"
59 
#include "oddtest.h"
60 
 
61 
 
62 
int oddunary
63 
    PROTO_N ( (x, y, v) )
64 
    PROTO_T ( exp x X exp y X exp *v )
65 
{
66 
  exp z;
67 
  *v = x;
68 
  if (name(x) != val_tag) goto flab1;
69 
  if (!(name(y)==val_tag && ((no(x)==1 && no(y)==-1) || (no(x)==-1 && no(y)==1) ))) goto flab1;
70 
  goto tlab1;
71 
  flab1:
72 
  if (!(name(x)==name(y))) goto flab0;
73 
  { exp xC = son(x);
74 
    z = xC;
75 
    if (!(z!=nilexp && last(z) && son(y) != nilexp && oddunary(z, son(y),v))) goto flab0;
76 
    if(!last(xC)) goto flab0;
77 
  }
78 
  tlab1:
79 
  return 1;
80 
  flab0: return 0;
81 
}
82 
 
83 
int oddtest
84 
    PROTO_N ( (x, t, f, v) )
85 
    PROTO_T ( exp x X exp *t X exp *f X exp *v )
86 
{
87 
  exp l, z, g;
88 
  if (name(x) != cond_tag) goto flab0;
89 
  { exp xC = son(x);
90 
    if (name(xC) != seq_tag) goto flab0;
91 
    { exp xCC = son(xC);
92 
      { exp xCCC = son(xCC);
93 
        *t = xCCC;
94 
        if (name(xCCC) != test_tag) goto flab0;
95 
        l =pt(*t);
96 
        if(!last(xCCC)) goto flab0;
97 
      }
98 
      if (last(xCC)) goto flab0;
99 
      xCC = bro(xCC);
100 
      *f = xCC;
101 
      if(!last(xCC)) goto flab0;
102 
    }
103 
    if (last(xC)) goto flab0;
104 
    xC = bro(xC);
105 
    if (l != xC) goto flab0;
106 
    { exp xCC = son(xC);
107 
      z = xCC;
108 
      if (!(no(z)==1)) goto flab0;
109 
      if (last(xCC)) goto flab0;
110 
      xCC = bro(xCC);
111 
      g = xCC;
112 
      if (!(oddunary(*f,g,v))) goto flab0;
113 
      if(!last(xCC)) goto flab0;
114 
    }
115 
    if(!last(xC)) goto flab0;
116 
  }
117 
  return 1;
118 
  flab0: return 0;
119 
}
120 
 
121 
/* last_statement finds the last obeyed statement of x and puts it in f */
122 
int last_statement
123 
    PROTO_N ( (x, f) )
124 
    PROTO_T ( exp x X exp *f )
125 
{
126 
  exp z;
127 
  if (name(x) != ident_tag) goto flab1;
128 
  { exp xC = son(x);
129 
    if (last(xC)) goto flab1;
130 
    xC = bro(xC);
131 
    z = xC;
132 
    last_statement(z, f);
133 
    if(!last(xC)) goto flab1;
134 
  }
135 
  goto tlab1;
136 
  flab1:
137 
  if (name(x) != seq_tag) goto flab2;
138 
  { exp xC = son(x);
139 
    if (last(xC)) goto flab2;
140 
    xC = bro(xC);
141 
    z = xC;
142 
    last_statement(z, f);
143 
    if(!last(xC)) goto flab2;
144 
  }
145 
  goto tlab1;
146 
  flab2:
147 
  z = x;
148 
   *f = z;
149 
  tlab1:
150 
  return 1;
151 
  flab0: return 0;
152 
}
153 
 
154 
/* looks for things like
155 
	(a ~ b) ? a: b
156 
	puts test in t - can make use of delay-slot
157 
*/
158 
int is_maxlike
159 
    PROTO_N ( (x, t) )
160 
    PROTO_T ( exp x X exp *t )
161 
{
162 
  exp op1, op2, z, l, w;
163 
  if (name(x) != cond_tag) goto flab0;
164 
  { exp xC = son(x);
165 
    if (name(xC) != seq_tag) goto flab0;
166 
    { exp xCC = son(xC);
167 
      { exp xCCC = son(xCC);
168 
        *t = xCCC;
169 
        if (name(xCCC) != test_tag) goto flab0;
170 
        l=pt(*t);
171 
        { exp xCCCC = son(xCCC);
172 
          op1 = xCCCC;
173 
          if (!(!is_floating(name(sh(op1))))) goto flab0;
174 
          if (last(xCCCC)) goto flab0;
175 
          xCCCC = bro(xCCCC);
176 
          op2 = xCCCC;
177 
          if(!last(xCCCC)) goto flab0;
178 
        }
179 
        if(!last(xCCC)) goto flab0;
180 
      }
181 
      if (last(xCC)) goto flab0;
182 
      xCC = bro(xCC);
183 
      z = xCC;
184 
      if (!(comp_eq_exp(z, op1, nilexp,nilexp))) goto flab0;
185 
      if(!last(xCC)) goto flab0;
186 
    }
187 
    if (last(xC)) goto flab0;
188 
    xC = bro(xC);
189 
    if (l != xC) goto flab0;
190 
    { exp xCC = son(xC);
191 
      z = xCC;
192 
      if (!(no(z)==1)) goto flab0;
193 
      if (last(xCC)) goto flab0;
194 
      xCC = bro(xCC);
195 
      w = xCC;
196 
      if (!(comp_eq_exp(w, op2,nilexp,nilexp))) goto flab0;
197 
      if(!last(xCC)) goto flab0;
198 
    }
199 
    if(!last(xC)) goto flab0;
200 
  }
201 
  return 1;
202 
  flab0: return 0;
203 
}
204 
 
205 
/* looks for things like
206 
	(a ~ b) ? b: a
207 
	puts test in t - can make use of delay-slot
208 
*/
209 
int is_minlike
210 
    PROTO_N ( (x, t) )
211 
    PROTO_T ( exp x X exp *t )
212 
{
213 
  exp op1, op2, z, l, w;
214 
  if (name(x) != cond_tag) goto flab0;
215 
  { exp xC = son(x);
216 
    if (name(xC) != seq_tag) goto flab0;
217 
    { exp xCC = son(xC);
218 
      { exp xCCC = son(xCC);
219 
        *t = xCCC;
220 
        if (name(xCCC) != test_tag) goto flab0;
221 
        l=pt(*t);
222 
        { exp xCCCC = son(xCCC);
223 
          op1 = xCCCC;
224 
          if (!(!is_floating(name(sh(op1))))) goto flab0;
225 
          if (last(xCCCC)) goto flab0;
226 
          xCCCC = bro(xCCCC);
227 
          op2 = xCCCC;
228 
          if(!last(xCCCC)) goto flab0;
229 
        }
230 
        if(!last(xCCC)) goto flab0;
231 
      }
232 
      if (last(xCC)) goto flab0;
233 
      xCC = bro(xCC);
234 
      z = xCC;
235 
      if (!(comp_eq_exp(z, op2,nilexp,nilexp))) goto flab0;
236 
      if(!last(xCC)) goto flab0;
237 
    }
238 
    if (last(xC)) goto flab0;
239 
    xC = bro(xC);
240 
    if (l != xC) goto flab0;
241 
    { exp xCC = son(xC);
242 
      z = xCC;
243 
      if (!(no(z)==1)) goto flab0;
244 
      if (last(xCC)) goto flab0;
245 
      xCC = bro(xCC);
246 
      w = xCC;
247 
      if (!(comp_eq_exp(w, op1,nilexp,nilexp))) goto flab0;
248 
      if(!last(xCC)) goto flab0;
249 
    }
250 
    if(!last(xC)) goto flab0;
251 
  }
252 
  return 1;
253 
  flab0: return 0;
254 
}
255 
 
256 
/* looks for things like
257 
	(a~0) ? a:-a
258 
*/
259 
int is_abslike
260 
    PROTO_N ( (x,t) )
261 
    PROTO_T ( exp x X exp *t )
262 
{
263 
  exp op, l, z, w;
264 
  if (name(x) != cond_tag) goto flab0;
265 
  { exp xC = son(x);
266 
    if (name(xC) != seq_tag) goto flab0;
267 
    { exp xCC = son(xC);
268 
      { exp xCCC = son(xCC);
269 
        *t = xCCC;
270 
        if (name(xCCC) != test_tag) goto flab0;
271 
        l=pt(*t);
272 
        { exp xCCCC = son(xCCC);
273 
          op = xCCCC;
274 
          if (last(xCCCC)) goto flab0;
275 
          xCCCC = bro(xCCCC);
276 
          if (name(xCCCC) != val_tag || no(xCCCC) != 0) goto flab0;
277 
          if(!last(xCCCC)) goto flab0;
278 
        }
279 
        if(!last(xCCC)) goto flab0;
280 
      }
281 
      if (last(xCC)) goto flab0;
282 
      xCC = bro(xCC);
283 
      z = xCC;
284 
      if (!(comp_eq_exp(z, op,nilexp,nilexp))) goto flab0;
285 
      if(!last(xCC)) goto flab0;
286 
    }
287 
    if (last(xC)) goto flab0;
288 
    xC = bro(xC);
289 
    if (l != xC) goto flab0;
290 
    { exp xCC = son(xC);
291 
      z = xCC;
292 
      if (!(no(z)==1)) goto flab0;
293 
      if (last(xCC)) goto flab0;
294 
      xCC = bro(xCC);
295 
      if (name(xCC) != neg_tag) goto flab0;
296 
      { exp xCCC = son(xCC);
297 
        w = xCCC;
298 
        if (!(comp_eq_exp(op, w,nilexp,nilexp))) goto flab0;
299 
        if(!last(xCCC)) goto flab0;
300 
      }
301 
      if(!last(xCC)) goto flab0;
302 
    }
303 
    if(!last(xC)) goto flab0;
304 
  }
305 
  return 1;
306 
  flab0: return 0;
307 
}
308 
 
309 
int is_fabs
310 
    PROTO_N ( (x, t) )
311 
    PROTO_T ( exp x X exp *t )
312 
{
313 
  exp op, l, z, w;
314 
  if (name(x) != cond_tag) goto flab0;
315 
  { exp xC = son(x);
316 
    if (name(xC) != seq_tag) goto flab0;
317 
    { exp xCC = son(xC);
318 
      { exp xCCC = son(xCC);
319 
        *t = xCCC;
320 
        if (name(xCCC) != test_tag) goto flab0;
321 
        l=pt(*t);
322 
        { exp xCCCC = son(xCCC);
323 
          op = xCCCC;
324 
          if (last(xCCCC)) goto flab0;
325 
          xCCCC = bro(xCCCC);
326 
          if (name(xCCCC) != val_tag || no(xCCCC) != 0) goto flab0;
327 
          if(!last(xCCCC)) goto flab0;
328 
        }
329 
        if(!last(xCCC)) goto flab0;
330 
      }
331 
      if (last(xCC)) goto flab0;
332 
      xCC = bro(xCC);
333 
      z = xCC;
334 
      if (!(eq_exp(z, op))) goto flab0;
335 
      if(!last(xCC)) goto flab0;
336 
    }
337 
    if (last(xC)) goto flab0;
338 
    xC = bro(xC);
339 
    if (l != xC) goto flab0;
340 
    { exp xCC = son(xC);
341 
      z = xCC;
342 
      if (!(no(z)==1)) goto flab0;
343 
      if (last(xCC)) goto flab0;
344 
      xCC = bro(xCC);
345 
      if (name(xCC) != fneg_tag) goto flab0;
346 
      { exp xCCC = son(xCC);
347 
        w = xCCC;
348 
        if (!(eq_exp(op, w))) goto flab0;
349 
        if(!last(xCCC)) goto flab0;
350 
      }
351 
      if(!last(xCC)) goto flab0;
352 
    }
353 
    if(!last(xC)) goto flab0;
354 
  }
355 
  return 1;
356 
  flab0: return 0;
357 
}