Subversion Repositories tendra.SVN

Rev

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

Rev Author Line No. Line
2 7u83 1 
/*
6 7u83 2 
 * Copyright (c) 2002-2005 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
6 7u83 33 
 
2 7u83 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:-
6 7u83 42 
 
2 7u83 43 
        (1) Its Recipients shall ensure that this Notice is
44 
        reproduced upon any copies or amended versions of it;
6 7u83 45 
 
2 7u83 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;
6 7u83 49 
 
2 7u83 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;
6 7u83 53 
 
2 7u83 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 
#include "config.h"
62 
#include "types.h"
63 
#include "eval.h"
64 
#include "node.h"
65 
#include "shape.h"
66 
#include "table.h"
67 
#include "tdf.h"
68 
#include "utility.h"
69 
 
70 
 
71 
/*
72 
    CREATE A NAT CORRESPONDING TO THE VALUE n
73 
 
74 
    This routine creates a node corresponding to the nat with value n.
75 
*/
76 
 
6 7u83 77 
node *
78 
make_nat(long n)
2 7u83 79 
{
6 7u83 80 
    node *p = new_node();
81 
    p->cons = cons_no(SORT_nat, ENC_make_nat);
82 
    p->son = new_node();
83 
    p->son->cons = make_construct(SORT_small_tdfint);
84 
    p->son->cons->encoding = n;
85 
    return(p);
2 7u83 86 
}
87 
 
88 
 
89 
/*
90 
    CREATE AN INTEGER CORRESPONDING TO THE VALUE n
91 
 
92 
    This routine creates a node corresponding to the sign bit and the
93 
    value of n.
94 
*/
95 
 
6 7u83 96 
node *
97 
make_int(long n)
2 7u83 98 
{
6 7u83 99 
    node *p = new_node();
100 
    if (n < 0) {
101 
	p->cons = &true_cons;
102 
	n = -n;
2 7u83 103 
    } else {
6 7u83 104 
	p->cons = &false_cons;
2 7u83 105 
    }
6 7u83 106 
    p->bro = new_node();
107 
    p->bro->cons = make_construct(SORT_small_tdfint);
108 
    p->bro->cons->encoding = n;
109 
    return(p);
2 7u83 110 
}
111 
 
112 
 
113 
/*
114 
    CREATE A SIGNED_NAT CORRESPONDING TO THE VALUE n
115 
 
116 
    This routine creates a node corresponding to the signed_nat with value n.
117 
*/
118 
 
6 7u83 119 
static node *
120 
make_signed_nat(long n)
2 7u83 121 
{
6 7u83 122 
    node *p = new_node();
123 
    p->cons = cons_no(SORT_signed_nat, ENC_make_signed_nat);
124 
    p->son = make_int(n);
125 
    return(p);
2 7u83 126 
}
127 
 
128 
 
129 
/*
130 
    CREATE A MAKE_INT EXPRESSION CORRESPONDING TO THE VALUE n
131 
 
132 
    This routine creates a node corresponding to a make_int expression of
133 
    shape sh and value n or val.
134 
*/
135 
 
6 7u83 136 
static node *
137 
make_int_exp(node *sh, long n, char *val)
2 7u83 138 
{
6 7u83 139 
    node *p = new_node();
140 
    p->cons = cons_no(SORT_exp, ENC_make_int);
141 
    p->son = copy_node(sh->son);
142 
    p->son->bro = make_signed_nat(n);
143 
    if (val) {
2 7u83 144 
	/* Assign large values */
6 7u83 145 
	node *r = p->son->bro->son->bro;
146 
	r->cons = make_construct(SORT_tdfint);
147 
	r->cons->name = val;
2 7u83 148 
    }
6 7u83 149 
    p->shape = sh;
150 
    return(p);
2 7u83 151 
}
152 
 
153 
 
154 
/*
155 
    IS A NODE A CONSTANT?
156 
 
157 
    This routine checks whether the node p represents a small integer
158 
    constant.  If so it returns the value of the constant via pn.
159 
*/
160 
 
6 7u83 161 
static boolean
162 
is_constant(node *p, long *pn)
2 7u83 163 
{
6 7u83 164 
    if (p) {
165 
	sortname s = p->cons->sortnum;
166 
	long n = p->cons->encoding;
167 
	if (s == SORT_exp && n == ENC_make_int) {
168 
	    p = p->son->bro;
169 
	    s = p->cons->sortnum;
170 
	    n = p->cons->encoding;
2 7u83 171 
	}
6 7u83 172 
	if (s == SORT_signed_nat && n == ENC_make_signed_nat) {
2 7u83 173 
	    /* Allow signed integer literals */
6 7u83 174 
	    long negate = p->son->cons->encoding;
175 
	    p = p->son->bro;
176 
	    s = p->cons->sortnum;
177 
	    n = p->cons->encoding;
178 
	    if (negate)n = -n;
179 
	} else if (s == SORT_nat && n == ENC_make_nat) {
2 7u83 180 
	    /* Allow integer literals */
6 7u83 181 
	    p = p->son;
182 
	    s = p->cons->sortnum;
183 
	    n = p->cons->encoding;
184 
	} else if (s == SORT_bool) {
2 7u83 185 
	    /* Allow boolean literals */
6 7u83 186 
	    if (n == ENC_false) {
187 
		*pn = 0;
188 
		return(1);
2 7u83 189 
	    }
6 7u83 190 
	    if (n == ENC_true) {
191 
		*pn = 1;
192 
		return(1);
2 7u83 193 
	    }
194 
	}
6 7u83 195 
	if (s == SORT_small_tdfint) {
2 7u83 196 
	    /* Small constant found */
6 7u83 197 
	    *pn = n;
198 
	    return(1);
2 7u83 199 
	}
200 
    }
6 7u83 201 
    return(0);
2 7u83 202 
}
203 
 
204 
 
205 
/*
206 
    INTEGER TYPE MASKS
207 
 
208 
    These values give the maximum values for the various known integral
209 
    types.
210 
*/
211 
 
6 7u83 212 
static long var_max = 32;
213 
static unsigned long *var_mask;
2 7u83 214 
 
215 
 
216 
/*
217 
    IS A SHAPE A KNOWN INTEGRAL TYPE?
218 
 
219 
    This routine checks whether the shape sh represents a known integral
220 
    type.  If so it returns the sign via pn and the size via pm.
221 
*/
222 
 
6 7u83 223 
static boolean
224 
is_var_width(node *sh, long *pn, long *pm)
2 7u83 225 
{
6 7u83 226 
    if (sh && sh->cons->encoding == ENC_integer) {
227 
	if (sh->son->cons->encoding == ENC_var_width) {
228 
	    node *q = sh->son->son;
229 
	    if (is_constant(q, pn)) {
230 
		if (is_constant(q->bro, pm)) {
231 
		    return(1);
2 7u83 232 
		}
233 
	    }
234 
	}
235 
    }
6 7u83 236 
    return(0);
2 7u83 237 
}
238 
 
239 
 
240 
/*
241 
    CALCULATE 1 << n
242 
 
243 
    This routine calculates '1 << n' as a string of octal digits.
244 
*/
245 
 
6 7u83 246 
static char *
247 
shift_one(long n)
2 7u83 248 
{
6 7u83 249 
    long i;
250 
    char buff[100];
251 
    switch (n % 3) {
252 
	case 0: buff[0] = '1'; break;
253 
	case 1: buff[0] = '2'; break;
254 
	case 2: buff[0] = '4'; break;
2 7u83 255 
    }
6 7u83 256 
    for (i = 0; i < n / 3; i++) {
257 
	buff[i + 1] = '0';
2 7u83 258 
    }
6 7u83 259 
    return(string_copy(buff,(int)(i + 1)));
2 7u83 260 
}
261 
 
262 
 
263 
/*
264 
    CALCULATE val - 1
265 
 
266 
    This routine calculates 'val - 1' for the string of octal digits val,
267 
    returning the result as a string of octal digits.
268 
*/
269 
 
6 7u83 270 
static char *
271 
minus_one(char *val)
2 7u83 272 
{
6 7u83 273 
    int i, n = (int)strlen(val);
274 
    char *res = string_copy(val, n);
275 
    for (i = n - 1; i >= 0; i--) {
276 
	char c = res[i];
277 
	if (c != '0') {
278 
	    res[i] = c - 1;
279 
	    break;
2 7u83 280 
	}
6 7u83 281 
	res[i] = '7';
2 7u83 282 
    }
6 7u83 283 
    if (res[0] == '0')res++;
284 
    return(res);
2 7u83 285 
}
286 
 
287 
 
288 
/*
289 
    EVALUATE A CONSTANT EXPRESSION
290 
 
291 
    This routine evaluates the constant expression given by the operation
292 
    op applied to the operands a and b in the type indicated by the shape
293 
    sh.  err gives the associated overflow error treatment, if any.  The
294 
    routine returns null if the value cannot be calculated.
295 
*/
296 
 
6 7u83 297 
static node *
298 
eval_exp(long op, long err, node *sh, long a, long b)
2 7u83 299 
{
6 7u83 300 
    long c = 0;
301 
    long sz = 0;
302 
    long sgn = 0;
303 
    char *val = null;
2 7u83 304 
 
305 
    /* Check result shape */
6 7u83 306 
    if (!is_var_width(sh, &sgn, &sz)) return(null);
307 
    if (!sgn && (a < 0 || b < 0)) return(null);
308 
    if (sz < 1) return(null);
309 
    if (sz > var_max) {
310 
	if (sz < 256) {
2 7u83 311 
	    /* Evaluate some special cases */
6 7u83 312 
	    if (op == ENC_shift_left && a == 1) {
313 
		if (!sgn && b < sz)val = shift_one(b);
314 
	    } else if (op == ENC_negate && a == 1) {
315 
		if (!sgn && err == ENC_wrap) {
316 
		    val = shift_one(sz);
317 
		    val = minus_one(val);
2 7u83 318 
		}
6 7u83 319 
	    } else if (op == ENC_minus && a == 0 && b == 1) {
320 
		if (!sgn && err == ENC_wrap) {
321 
		    val = shift_one(sz);
322 
		    val = minus_one(val);
2 7u83 323 
		}
324 
	    }
6 7u83 325 
	    if (val) return(make_int_exp(sh, c, val));
2 7u83 326 
	}
6 7u83 327 
	return(null);
2 7u83 328 
    }
329 
 
330 
    /* Evaluate result */
6 7u83 331 
    switch (op) {
332 
	case ENC_abs: {
333 
	    c = a;
334 
	    if (c < 0)c = -a;
335 
	    break;
2 7u83 336 
	}
6 7u83 337 
	case ENC_and: {
338 
	    if (a < 0 || b < 0) return(null);
339 
	    c = (a & b);
340 
	    break;
2 7u83 341 
	}
6 7u83 342 
	case ENC_change_variety: {
343 
	    c = a;
344 
	    break;
2 7u83 345 
	}
6 7u83 346 
	case ENC_div0:
347 
	case ENC_div1:
348 
	case ENC_div2: {
349 
	    if (a < 0 || b <= 0) return(null);
350 
	    c = a / b;
351 
	    break;
2 7u83 352 
	}
6 7u83 353 
	case ENC_maximum: {
354 
	    c = (a >= b ? a : b);
355 
	    break;
2 7u83 356 
	}
6 7u83 357 
	case ENC_minimum: {
358 
	    c = (a < b ? a : b);
359 
	    break;
2 7u83 360 
	}
6 7u83 361 
	case ENC_minus: {
362 
	    c = a - b;
363 
	    break;
2 7u83 364 
	}
6 7u83 365 
	case ENC_mult: {
366 
	    c = a * b;
367 
	    break;
2 7u83 368 
	}
6 7u83 369 
	case ENC_negate: {
370 
	    c = -a;
371 
	    break;
2 7u83 372 
	}
6 7u83 373 
	case ENC_not: {
374 
	    if (sgn || err != ENC_wrap) return(null);
375 
	    c = ~a;
376 
	    break;
2 7u83 377 
	}
6 7u83 378 
	case ENC_or: {
379 
	    if (a < 0 || b < 0) return(null);
380 
	    c = (a | b);
381 
	    break;
2 7u83 382 
	}
6 7u83 383 
	case ENC_plus: {
384 
	    c = a + b;
385 
	    break;
2 7u83 386 
	}
6 7u83 387 
	case ENC_rem0:
388 
	case ENC_rem1:
389 
	case ENC_rem2: {
390 
	    if (a < 0 || b <= 0) return(null);
391 
	    c = a % b;
392 
	    break;
2 7u83 393 
	}
6 7u83 394 
	case ENC_shift_left: {
395 
	    if (sgn || err != ENC_wrap) return(null);
396 
	    if (b < var_max) {
397 
		unsigned long ua = (unsigned long)a;
398 
		unsigned long ub = (unsigned long)b;
399 
		c = (long)(ua << ub);
2 7u83 400 
	    } else {
6 7u83 401 
		c = 0;
2 7u83 402 
	    }
6 7u83 403 
	    break;
2 7u83 404 
	}
6 7u83 405 
	case ENC_shift_right: {
406 
	    if (sgn || err != ENC_wrap) return(null);
407 
	    if (b < var_max) {
408 
		unsigned long ua = (unsigned long)a;
409 
		unsigned long ub = (unsigned long)b;
410 
		c = (long)(ua >> ub);
2 7u83 411 
	    } else {
6 7u83 412 
		c = 0;
2 7u83 413 
	    }
6 7u83 414 
	    break;
2 7u83 415 
	}
6 7u83 416 
	case ENC_xor: {
417 
	    if (a < 0 || b < 0) return(null);
418 
	    c = (a ^ b);
419 
	    break;
2 7u83 420 
	}
6 7u83 421 
	case ENC_power:
422 
	case ENC_rotate_left:
423 
	case ENC_rotate_right:
2 7u83 424 
	default : {
425 
	    /* NOT YET IMPLEMENTED */
6 7u83 426 
	    return(null);
2 7u83 427 
	}
428 
    }
429 
 
430 
    /* Check for overflow */
6 7u83 431 
    if (sgn) {
432 
	long v = (long)var_mask[sz - 1];
433 
	if (c < - (v + 1) || c > v) return(null);
2 7u83 434 
    } else {
6 7u83 435 
	unsigned long uc;
436 
	unsigned long uv = var_mask[sz];
437 
	if (c < 0) {
438 
	    if (err != ENC_wrap) return(null);
439 
	    uc = (unsigned long) -c;
440 
	    uc = ((uv - uc + 1) & uv);
441 
	    if (uc > var_mask[var_max - 1]) {
442 
		val = ulong_to_octal(uc);
443 
		uc = 0;
2 7u83 444 
	    }
445 
	} else {
6 7u83 446 
	    uc = (unsigned long)c;
447 
	    if (uc > uv) {
448 
		if (err != ENC_wrap) return(null);
449 
		uc &= uv;
2 7u83 450 
	    }
451 
	}
6 7u83 452 
	c = (long)uc;
2 7u83 453 
    }
454 
 
455 
    /* Create the result */
6 7u83 456 
    return(make_int_exp(sh, c, val));
2 7u83 457 
}
458 
 
459 
 
460 
/*
461 
    EVALUATE A CONSTANT CONDITION
462 
 
463 
    This routine evaluates the condition tst for the values a and b.  It
464 
    returns 0 if the test is false, 1 if it is true and -1 if it cannot
465 
    be evaluated.
466 
*/
467 
 
6 7u83 468 
static int
469 
eval_test(long tst, long a, long b)
2 7u83 470 
{
6 7u83 471 
    int res = 0;
472 
    switch (tst) {
473 
	case ENC_equal:
474 
	case ENC_not_less_than_and_not_great: {
475 
	    if (a == b)res = 1;
476 
	    break;
2 7u83 477 
	}
6 7u83 478 
	case ENC_not_equal:
479 
	case ENC_less_than_or_greater_than: {
480 
	    if (a != b)res = 1;
481 
	    break;
2 7u83 482 
	}
6 7u83 483 
	case ENC_greater_than:
484 
	case ENC_not_less_than_or_equal: {
485 
	    if (a > b)res = 1;
486 
	    break;
2 7u83 487 
	}
6 7u83 488 
	case ENC_greater_than_or_equal:
489 
	case ENC_not_less_than: {
490 
	    if (a >= b)res = 1;
491 
	    break;
2 7u83 492 
	}
6 7u83 493 
	case ENC_less_than:
494 
	case ENC_not_greater_than_or_equal: {
495 
	    if (a < b)res = 1;
496 
	    break;
2 7u83 497 
	}
6 7u83 498 
	case ENC_less_than_or_equal:
499 
	case ENC_not_greater_than: {
500 
	    if (a <= b)res = 1;
501 
	    break;
2 7u83 502 
	}
503 
	default : {
6 7u83 504 
	    res = -1;
505 
	    break;
2 7u83 506 
	}
507 
    }
6 7u83 508 
    return(res);
2 7u83 509 
}
510 
 
511 
 
512 
/*
513 
    EVALUATE A DECREMENT EXPRESSION
514 
 
515 
    This routine evaluates 'p - 1' for the expression node p.  It returns
516 
    null if the value cannot be evaluated.
517 
*/
518 
 
6 7u83 519 
static node *
520 
eval_decr(node *p)
2 7u83 521 
{
6 7u83 522 
    if (p->cons->encoding == ENC_make_int) {
523 
	node *sh = p->shape;
524 
	if (sh == null)sh = sh_integer(p->son);
525 
	p = p->son->bro;
526 
	if (p->cons->encoding == ENC_make_signed_nat) {
527 
	    if (!p->son->cons->encoding) {
528 
		p = p->son->bro;
529 
		if (p->cons->sortnum == SORT_tdfint) {
530 
		    long c = 0;
531 
		    char *val = minus_one(p->cons->name);
532 
		    if (fits_ulong(val, 1)) {
533 
			c = (long)octal_to_ulong(val);
534 
			val = null;
2 7u83 535 
		    }
6 7u83 536 
		    return(make_int_exp(sh, c, val));
2 7u83 537 
		}
538 
	    }
539 
	}
540 
    }
6 7u83 541 
    return(null);
2 7u83 542 
}
543 
 
544 
 
545 
/*
546 
    EVALUATE A NODE
547 
 
548 
    This routine evaluates the node p.  p will not be null.
549 
*/
550 
 
6 7u83 551 
static node *
552 
eval_node(node *p)
2 7u83 553 
{
6 7u83 554 
    sortname s = p->cons->sortnum;
555 
    long n = p->cons->encoding;
556 
    if (s > 0 && n == sort_conds[s]) {
2 7u83 557 
	/* Conditional constructs */
6 7u83 558 
	long m = 0;
559 
	if (is_constant(p->son, &m)) {
560 
	    p = p->son->bro;
561 
	    if (m == 0)p = p->bro;
562 
	    return(p->son);
2 7u83 563 
	}
564 
    }
6 7u83 565 
    if (s == SORT_exp) {
566 
	long m1 = 0, m2 = 0;
567 
	switch (n) {
568 
	    case ENC_make_int: {
2 7u83 569 
		/* Make sure that constants have a shape */
6 7u83 570 
		if (p->shape == null)p->shape = sh_integer(p->son);
571 
		break;
2 7u83 572 
	    }
6 7u83 573 
	    case ENC_change_variety: {
2 7u83 574 
		/* Allow for change_variety */
6 7u83 575 
		node *r = p->son->bro;
576 
		if (p->shape == null)p->shape = sh_integer(r);
577 
		if (is_constant(r->bro, &m1)) {
578 
		    long err = p->son->cons->encoding;
579 
		    node *q = eval_exp(n, err, p->shape, m1, m2);
580 
		    if (q)p = q;
2 7u83 581 
		}
6 7u83 582 
		break;
2 7u83 583 
	    }
6 7u83 584 
	    case ENC_integer_test: {
2 7u83 585 
		/* Allow for integer_test */
6 7u83 586 
		node *r = p->son->bro->bro->bro;
587 
		if (is_constant(r, &m1)) {
588 
		    if (is_constant(r->bro, &m2)) {
589 
			long tst = p->son->bro->cons->encoding;
590 
			int res = eval_test(tst, m1, m2);
591 
			if (res == 0) {
592 
			    node *q = new_node();
593 
			    q->cons = cons_no(SORT_exp, ENC_goto);
594 
			    q->son = copy_node(p->son->bro->bro);
595 
			    return(q);
2 7u83 596 
			}
6 7u83 597 
			if (res == 1) {
598 
			    node *q = new_node();
599 
			    q->cons = cons_no(SORT_exp, ENC_make_top);
600 
			    return(q);
2 7u83 601 
			}
602 
		    }
603 
		}
6 7u83 604 
		break;
2 7u83 605 
	    }
6 7u83 606 
	    case ENC_conditional: {
2 7u83 607 
		/* Allow for conditional */
6 7u83 608 
		node *r = p->son->bro;
609 
		if (is_constant(r->bro, &m2)) {
610 
		    if (is_constant(r, &m1)) {
2 7u83 611 
			/* First branch terminates */
6 7u83 612 
			return(copy_node(r));
2 7u83 613 
		    }
6 7u83 614 
		    if (r->cons->encoding == ENC_goto) {
615 
			if (eq_node(p->son, r->son)) {
2 7u83 616 
			    /* First branch is a jump */
6 7u83 617 
			    return(copy_node(r->bro));
2 7u83 618 
			}
619 
		    }
620 
		}
6 7u83 621 
		break;
2 7u83 622 
	    }
6 7u83 623 
	    case ENC_sequence: {
2 7u83 624 
		/* Allow for sequence */
6 7u83 625 
		boolean reached = 1;
626 
		node *q = null;
627 
		node *r = p->son->son;
628 
		while (r != null) {
629 
		    if (is_constant(r, &m1)) {
630 
			if (reached)q = r;
631 
		    } else if (r->cons->encoding == ENC_goto) {
632 
			if (reached)q = r;
633 
			reached = 0;
634 
		    } else if (r->cons->encoding == ENC_make_top) {
635 
			if (reached)q = r;
2 7u83 636 
		    } else {
6 7u83 637 
			return(p);
2 7u83 638 
		    }
6 7u83 639 
		    r = r->bro;
2 7u83 640 
		}
6 7u83 641 
		r = p->son->bro;
642 
		if (is_constant(r, &m1)) {
643 
		    if (reached)q = r;
644 
		} else if (r->cons->encoding == ENC_goto) {
645 
		    if (reached)q = r;
646 
		} else if (r->cons->encoding == ENC_make_top) {
647 
		    if (reached)q = r;
2 7u83 648 
		} else {
6 7u83 649 
		    return(p);
2 7u83 650 
		}
6 7u83 651 
		q = copy_node(q);
652 
		return(q);
2 7u83 653 
	    }
6 7u83 654 
	    case ENC_not: {
2 7u83 655 
		/* Unary operations */
6 7u83 656 
		node *r = p->son;
657 
		if (is_constant(r, &m1)) {
658 
		    long err = ENC_wrap;
659 
		    node *q = eval_exp(n, err, r->shape, m1, m2);
660 
		    if (q)p = q;
2 7u83 661 
		}
6 7u83 662 
		break;
2 7u83 663 
	    }
6 7u83 664 
	    case ENC_abs:
665 
	    case ENC_negate: {
2 7u83 666 
		/* Unary operations with error treatment */
6 7u83 667 
		node *r = p->son->bro;
668 
		if (is_constant(r, &m1)) {
669 
		    long err = p->son->cons->encoding;
670 
		    node *q = eval_exp(n, err, r->shape, m1, m2);
671 
		    if (q)p = q;
2 7u83 672 
		}
6 7u83 673 
		break;
2 7u83 674 
	    }
6 7u83 675 
	    case ENC_and:
676 
	    case ENC_maximum:
677 
	    case ENC_minimum:
678 
	    case ENC_or:
679 
	    case ENC_rotate_left:
680 
	    case ENC_rotate_right:
681 
	    case ENC_shift_right:
682 
	    case ENC_xor: {
2 7u83 683 
		/* Binary operations */
6 7u83 684 
		node *r = p->son;
685 
		if (is_constant(r, &m1)) {
686 
		    if (is_constant(r->bro, &m2)) {
687 
			long err = ENC_wrap;
688 
			node *q = eval_exp(n, err, r->shape, m1, m2);
689 
			if (q)p = q;
2 7u83 690 
		    }
691 
		}
6 7u83 692 
		break;
2 7u83 693 
	    }
6 7u83 694 
	    case ENC_minus:
695 
	    case ENC_mult:
696 
	    case ENC_plus:
697 
	    case ENC_power:
698 
	    case ENC_shift_left: {
2 7u83 699 
		/* Binary operations with error treatment */
6 7u83 700 
		node *r = p->son->bro;
701 
		if (is_constant(r->bro, &m2)) {
702 
		    if (is_constant(r, &m1)) {
703 
			long err = p->son->cons->encoding;
704 
			node *q = eval_exp(n, err, r->shape, m1, m2);
705 
			if (q)p = q;
706 
		    } else if (n == ENC_minus && m2 == 1) {
707 
			node *q = eval_decr(r);
708 
			if (q)p = q;
2 7u83 709 
		    }
710 
		}
6 7u83 711 
		break;
2 7u83 712 
	    }
6 7u83 713 
	    case ENC_div0:
714 
	    case ENC_div1:
715 
	    case ENC_div2:
716 
	    case ENC_rem0:
717 
	    case ENC_rem1:
718 
	    case ENC_rem2: {
2 7u83 719 
		/* Binary operations with two error treatments */
6 7u83 720 
		node *r = p->son->bro->bro;
721 
		if (is_constant(r, &m1)) {
722 
		    if (is_constant(r->bro, &m2)) {
723 
			long err = p->son->bro->cons->encoding;
724 
			node *q = eval_exp(n, err, r->shape, m1, m2);
725 
			if (q)p = q;
2 7u83 726 
		    }
727 
		}
6 7u83 728 
		break;
2 7u83 729 
	    }
730 
	}
6 7u83 731 
    } else if (s == SORT_nat) {
732 
	if (n == ENC_computed_nat) {
733 
	    long m = 0;
734 
	    if (is_constant(p->son, &m)) {
735 
		if (m >= 0) return(make_nat(m));
2 7u83 736 
	    }
737 
	}
6 7u83 738 
    } else if (s == SORT_signed_nat) {
739 
	if (n == ENC_computed_signed_nat) {
740 
	    long m = 0;
741 
	    if (is_constant(p->son, &m)) {
742 
		return(make_signed_nat(m));
2 7u83 743 
	    }
6 7u83 744 
	    if (p->son->cons->encoding == ENC_make_int) {
745 
		return(copy_node(p->son->son->bro));
2 7u83 746 
	    }
6 7u83 747 
	} else if (n == ENC_snat_from_nat) {
748 
	    long m1 = 0, m2 = 0;
749 
	    if (is_constant(p->son, &m1)) {
750 
		if (is_constant(p->son->bro, &m2)) {
751 
		    if (m1)m2 = -m2;
752 
		    return(make_signed_nat(m2));
2 7u83 753 
		}
754 
	    }
755 
	}
756 
    }
6 7u83 757 
    return(p);
2 7u83 758 
}
759 
 
760 
 
761 
/*
762 
    RECURSIVELY EVALUATE A NODE
763 
 
764 
    This routine recursively calls eval_node to evaluate the node p and
765 
    all its subnodes.
766 
*/
767 
 
6 7u83 768 
static node *
769 
eval_fully(node *p)
2 7u83 770 
{
6 7u83 771 
    if (p) {
772 
	node *q = p->bro;
773 
	p->son = eval_fully(p->son);
774 
	p = eval_node(p);
775 
	p->bro = eval_fully(q);
2 7u83 776 
    }
6 7u83 777 
    return(p);
2 7u83 778 
}
779 
 
780 
 
781 
/*
782 
    EVALUATE A TOKEN DEFINITION
783 
 
784 
    This routine evaluates the definition of the token p.
785 
*/
786 
 
6 7u83 787 
static void
788 
eval_tokdef(construct *p)
2 7u83 789 
{
6 7u83 790 
    if (p->encoding != -1) {
791 
	tok_info *info = get_tok_info(p);
792 
	info->def = eval_fully(info->def);
2 7u83 793 
    }
6 7u83 794 
    return;
2 7u83 795 
}
796 
 
797 
 
798 
/*
799 
    EVALUATE AN ALIGNMENT TAG DEFINITION
800 
 
801 
    This routine evaluates the definition of the alignment tag p.
802 
*/
803 
 
6 7u83 804 
static void
805 
eval_aldef(construct *p)
2 7u83 806 
{
6 7u83 807 
    if (p->encoding != -1) {
808 
	al_tag_info *info = get_al_tag_info(p);
809 
	info->def = eval_fully(info->def);
2 7u83 810 
    }
6 7u83 811 
    return;
2 7u83 812 
}
813 
 
814 
 
815 
/*
816 
    EVALUATE A TAG DECLARATION AND DEFINITION
817 
 
818 
    This routine evaluates the declaration and definition of the tag p.
819 
*/
820 
 
6 7u83 821 
static void
822 
eval_tagdef(construct *p)
2 7u83 823 
{
6 7u83 824 
    if (p->encoding != -1) {
825 
	tag_info *info = get_tag_info(p);
826 
	info->dec = eval_fully(info->dec);
827 
	info->def = eval_fully(info->def);
2 7u83 828 
    }
6 7u83 829 
    return;
2 7u83 830 
}
831 
 
832 
 
833 
/*
834 
    EVALUATE ALL TOKEN DEFINITIONS
835 
 
836 
    This routine evaluates all token, alignment tag and tag definitions.
837 
*/
838 
 
6 7u83 839 
void
840 
eval_all(void)
2 7u83 841 
{
6 7u83 842 
    long i;
843 
    unsigned long m = 0;
844 
    var_max = BYTESIZE *(long)sizeof(long);
845 
    var_mask = alloc_nof(unsigned long, var_max + 1);
846 
    var_mask[0] = 0;
847 
    for (i = 1; i <= var_max; i++) {
848 
	m = 2 * m + 1;
849 
	var_mask[i] = m;
2 7u83 850 
    }
6 7u83 851 
    init_shapes();
852 
    apply_to_all(eval_tokdef, SORT_token);
853 
    apply_to_all(eval_aldef, SORT_al_tag);
854 
    apply_to_all(eval_tagdef, SORT_tag);
855 
    return;
2 7u83 856 
}