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 "c_types.h"
63 
#include "etype_ops.h"
64 
#include "exp_ops.h"
65 
#include "flt_ops.h"
66 
#include "ftype_ops.h"
67 
#include "id_ops.h"
68 
#include "nat_ops.h"
69 
#include "str_ops.h"
70 
#include "type_ops.h"
71 
#include "error.h"
72 
#include "catalog.h"
73 
#include "basetype.h"
74 
#include "cast.h"
75 
#include "char.h"
76 
#include "check.h"
77 
#include "constant.h"
78 
#include "convert.h"
79 
#include "expression.h"
80 
#include "file.h"
81 
#include "inttype.h"
82 
#include "literal.h"
83 
#include "syntax.h"
84 
#include "template.h"
85 
#include "tokdef.h"
86 
#include "ustring.h"
87 
#include "xalloc.h"
88 
 
89 
 
90 
/*
91 
    SMALL LITERALS
92 
 
93 
    These arrays are used to hold the small integer literals to avoid
94 
    duplication.
95 
*/
96 
 
6 7u83 97 
NAT small_nat[SMALL_NAT_SIZE];
98 
NAT small_neg_nat[SMALL_NAT_SIZE];
2 7u83 99 
 
100 
 
101 
/*
102 
    SMALL NUMBERS
103 
 
104 
    These strings are used to hold strings representing the small integer
105 
    literals to avoid duplication.
106 
*/
107 
 
6 7u83 108 
string small_number[SMALL_FLT_SIZE];
2 7u83 109 
 
110 
 
111 
/*
112 
    CREATE A SMALL NUMBER
113 
 
114 
    This routine returns the element of the arrays small_nat or small_neg_nat
115 
    corresponding to the value v, allocating it if necessary.
116 
*/
117 
 
6 7u83 118 
NAT
119 
make_small_nat(int v)
2 7u83 120 
{
6 7u83 121 
	NAT n;
122 
	if (v >= 0) {
123 
		n = small_nat[v];
124 
		if (IS_NULL_nat(n)) {
125 
			MAKE_nat_small((unsigned)v, n);
126 
			small_nat[v] = n;
127 
		}
128 
	} else {
129 
		v = -v;
130 
		n = small_neg_nat[v];
131 
		if (IS_NULL_nat(n)) {
132 
			n = make_small_nat(v);
133 
			MAKE_nat_neg(n, n);
134 
			small_neg_nat[v] = n;
135 
		}
2 7u83 136 
	}
6 7u83 137 
	return(n);
2 7u83 138 
}
139 
 
140 
 
141 
/*
142 
    CONSTANT EVALUATION BUFFERS
143 
 
144 
    These lists are used to hold single digit lists in the constant
145 
    evaluation routines to allow for uniform handling of both small and
146 
    large literals.
147 
*/
148 
 
6 7u83 149 
static LIST(unsigned)small_nat_1;
150 
static LIST(unsigned)small_nat_2;
2 7u83 151 
 
152 
 
153 
/*
154 
    ALLOCATE A DIGIT LIST
155 
 
156 
    This routine allocates a list of digits of length n.  The digits in the
157 
    list are initialised to zero.
158 
*/
159 
 
6 7u83 160 
static LIST(unsigned)
161 
digit_list(unsigned n)
2 7u83 162 
{
6 7u83 163 
	LIST(unsigned)p = NULL_list(unsigned);
164 
	while (n) {
165 
		CONS_unsigned(0, p, p);
166 
		n--;
167 
	}
168 
	return(p);
2 7u83 169 
}
170 
 
171 
 
172 
/*
173 
    MAKE AN EXTENDED VALUE INTO AN INTEGER CONSTANT
174 
 
175 
    This routine creates an integer constant from an extended value, v.
176 
*/
177 
 
6 7u83 178 
NAT
179 
make_nat_value(unsigned long v)
2 7u83 180 
{
6 7u83 181 
	NAT n;
182 
	unsigned lo = LO_HALF(v);
183 
	unsigned hi = HI_HALF(v);
184 
	if (hi) {
185 
		LIST(unsigned)p = NULL_list(unsigned);
186 
		CONS_unsigned(hi, p, p);
187 
		CONS_unsigned(lo, p, p);
188 
		MAKE_nat_large(p, n);
189 
	} else if (lo < SMALL_NAT_SIZE) {
190 
		n = small_nat[lo];
191 
		if (IS_NULL_nat(n))n = make_small_nat((int)lo);
192 
	} else {
193 
		MAKE_nat_small(lo, n);
194 
	}
195 
	return(n);
2 7u83 196 
}
197 
 
198 
 
199 
/*
200 
    MAKE AN INTEGER CONSTANT INTO AN EXTENDED VALUE
201 
 
202 
    This routine finds the extended value corresponding to the integer
203 
    constant n.  If n is the null constant or does not fit into an extended
204 
    value then the maximum extended value is returned.
205 
*/
206 
 
6 7u83 207 
unsigned long
208 
get_nat_value(NAT n)
2 7u83 209 
{
6 7u83 210 
	if (!IS_NULL_nat(n)) {
211 
		unsigned tag = TAG_nat(n);
212 
		if (tag == nat_small_tag) {
213 
			unsigned val = DEREF_unsigned(nat_small_value(n));
214 
			return(EXTEND_VALUE(val));
215 
		} else if (tag == nat_large_tag) {
216 
			LIST(unsigned)p = DEREF_list(nat_large_values(n));
217 
			if (LENGTH_list(p) == 2) {
218 
				unsigned v1, v2;
219 
				v1 = DEREF_unsigned(HEAD_list(p));
220 
				v2 = DEREF_unsigned(HEAD_list(TAIL_list(p)));
221 
				return(COMBINE_VALUES(v1, v2));
222 
			}
223 
		}
2 7u83 224 
	}
6 7u83 225 
	return(EXTENDED_MAX);
2 7u83 226 
}
227 
 
228 
 
229 
/*
230 
    MAKE A LIST OF DIGITS INTO AN INTEGER CONSTANT
231 
 
232 
    This routine creates an integer constant from a list of digits, p.
233 
    This list may contain initial zero digits, which need to be removed.
234 
*/
235 
 
6 7u83 236 
NAT
237 
make_large_nat(LIST(unsigned)p)
2 7u83 238 
{
6 7u83 239 
	NAT n;
240 
	LIST(unsigned)q = p;
241 
	LIST(unsigned)r = p;
2 7u83 242 
 
6 7u83 243 
	/* Scan for last nonzero digit */
244 
	while (!IS_NULL_list(q)) {
245 
		unsigned v = DEREF_unsigned(HEAD_list(q));
246 
		if (v != 0)r = q;
247 
		q = TAIL_list(q);
248 
	}
2 7u83 249 
 
6 7u83 250 
	/* Construct result */
251 
	if (EQ_list(r, p)) {
252 
		/* Small values */
253 
		unsigned v = DEREF_unsigned(HEAD_list(p));
254 
		if (v < SMALL_NAT_SIZE) {
255 
			n = make_small_nat((int)v);
256 
		} else {
257 
			MAKE_nat_small(v, n);
258 
		}
259 
		DESTROY_list(p, SIZE_unsigned);
2 7u83 260 
	} else {
6 7u83 261 
		/* Large values */
262 
		q = TAIL_list(r);
263 
		COPY_list(PTR_TAIL_list(r), NULL_list(unsigned));
264 
		DESTROY_list(q, SIZE_unsigned);
265 
		MAKE_nat_large(p, n);
2 7u83 266 
	}
6 7u83 267 
	return(n);
2 7u83 268 
}
269 
 
270 
 
271 
/*
272 
    BUILD UP AN INTEGER CONSTANT
273 
 
274 
    This routine multiplies the integer constant n by b and adds d.  It is
275 
    used when building up integer constants from strings of digits - b gives
276 
    the base and d the digit being added.  b will not be zero, and n will
277 
    be a simple constant.  Note that the original value of n is overwritten
278 
    with the return value.
279 
*/
280 
 
6 7u83 281 
NAT
282 
make_nat_literal(NAT n, unsigned b, unsigned d)
2 7u83 283 
{
6 7u83 284 
	NAT res;
285 
	unsigned long lb = EXTEND_VALUE(b);
2 7u83 286 
 
6 7u83 287 
	if (IS_NULL_nat(n)) {
288 
		/* Map null integer to zero */
289 
		unsigned long ld = EXTEND_VALUE(d);
290 
		res = make_nat_value(ld);
2 7u83 291 
 
6 7u83 292 
	} else if (IS_nat_small(n)) {
293 
		/* Small integers */
294 
		unsigned val = DEREF_unsigned(nat_small_value(n));
295 
		unsigned long lv = EXTEND_VALUE(val);
296 
		unsigned long ld = EXTEND_VALUE(d);
297 
		unsigned long lr = lv * lb + ld;
298 
		unsigned r1 = LO_HALF(lr);
299 
		unsigned r2 = HI_HALF(lr);
2 7u83 300 
 
6 7u83 301 
		if (r2 == 0) {
302 
			/* Result remains small */
303 
			if (r1 < SMALL_NAT_SIZE) {
304 
				res = small_nat[r1];
305 
				if (IS_NULL_nat(res)) {
306 
					res = make_small_nat((int)r1);
307 
				}
308 
			} else if (val < SMALL_NAT_SIZE) {
309 
				MAKE_nat_small(r1, res);
310 
			} else {
311 
				COPY_unsigned(nat_small_value(n), r1);
312 
				res = n;
313 
			}
314 
		} else {
315 
			/* Overflow - create large integer */
316 
			LIST(unsigned)digits = NULL_list(unsigned);
317 
			if (val >= SMALL_NAT_SIZE) {
318 
				unsigned ign;
319 
				DESTROY_nat_small(destroy, ign, n);
320 
				UNUSED(ign);
321 
			}
322 
			CONS_unsigned(r2, digits, digits);
323 
			CONS_unsigned(r1, digits, digits);
324 
			MAKE_nat_large(digits, res);
2 7u83 325 
		}
6 7u83 326 
 
2 7u83 327 
	} else {
6 7u83 328 
		/* Large integers */
329 
		LIST(unsigned)vals = DEREF_list(nat_large_values(n));
330 
		LIST(unsigned)v = vals;
331 
		unsigned carry = d;
2 7u83 332 
 
6 7u83 333 
		/* Scan through digits */
334 
		while (!IS_NULL_list(v)) {
335 
			unsigned val = DEREF_unsigned(HEAD_list(v));
336 
			unsigned long lv = EXTEND_VALUE(val);
337 
			unsigned long lc = EXTEND_VALUE(carry);
338 
			unsigned long lr = lv * lb + lc;
339 
			COPY_unsigned(HEAD_list(v), LO_HALF(lr));
340 
			carry = HI_HALF(lr);
341 
			v = TAIL_list(v);
342 
		}
2 7u83 343 
 
6 7u83 344 
		if (carry) {
345 
			/* Overflow - add an extra digit */
346 
			CONS_unsigned(carry, NULL_list(unsigned), v);
347 
			IGNORE APPEND_list(vals, v);
348 
		}
349 
		res = n;
2 7u83 350 
	}
6 7u83 351 
	return(res);
2 7u83 352 
}
353 
 
354 
 
355 
/*
356 
    IS AN INTEGER CONSTANT ZERO?
357 
 
358 
    This routine checks whether the integer constant n is zero.
359 
*/
360 
 
6 7u83 361 
int
362 
is_zero_nat(NAT n)
2 7u83 363 
{
6 7u83 364 
	unsigned val;
365 
	if (!IS_nat_small(n)) {
366 
		return(0);
367 
	}
368 
	val = DEREF_unsigned(nat_small_value(n));
369 
	return(val ? 0 : 1);
2 7u83 370 
}
371 
 
372 
 
373 
/*
374 
    IS AN INTEGER CONSTANT NEGATIVE?
375 
 
376 
    This routine checks whether the integer constant n is negative.
377 
*/
378 
 
6 7u83 379 
int
380 
is_negative_nat(NAT n)
2 7u83 381 
{
6 7u83 382 
	return(IS_nat_neg(n));
2 7u83 383 
}
384 
 
385 
 
386 
/*
387 
    IS AN INTEGER CONSTANT AN ERROR EXPRESSION?
388 
 
389 
    This routine checks whether the integer constant n represents an error
390 
    expression.
391 
*/
392 
 
6 7u83 393 
int
394 
is_error_nat(NAT n)
2 7u83 395 
{
6 7u83 396 
	if (IS_nat_calc(n)) {
397 
		EXP e = DEREF_exp(nat_calc_value(n));
398 
		TYPE t = DEREF_type(exp_type(e));
399 
		return(IS_type_error(t));
400 
	}
401 
	return(0);
2 7u83 402 
}
403 
 
404 
 
405 
/*
406 
    IS AN INTEGER CONSTANT A CALCULATED VALUE?
407 
 
408 
    This routine checks whether the integer constant n is a calculated
409 
    value.
410 
*/
411 
 
6 7u83 412 
int
413 
is_calc_nat(NAT n)
2 7u83 414 
{
6 7u83 415 
	unsigned tag = TAG_nat(n);
416 
	if (tag == nat_neg_tag) {
417 
		n = DEREF_nat(nat_neg_arg(n));
418 
		tag = TAG_nat(n);
419 
	}
420 
	if (tag == nat_calc_tag || tag == nat_token_tag) {
421 
		return(1);
422 
	}
423 
	return(0);
2 7u83 424 
}
425 
 
426 
 
427 
/*
428 
    FIND THE VALUE OF A CALCULATED CONSTANT
429 
 
430 
    This routine creates an integer constant expression of type t with
431 
    value n.
432 
*/
433 
 
6 7u83 434 
EXP
435 
calc_nat_value(NAT n, TYPE t)
2 7u83 436 
{
6 7u83 437 
	EXP e;
438 
	TYPE s = t;
439 
	int ch = check_nat_range(s, n);
440 
	if (ch != 0) {
441 
		/* n doesn't fit into t */
442 
		int fit = 0;
443 
		string str = NULL_string;
444 
		s = find_literal_type(n, BASE_OCTAL, SUFFIX_NONE, str, &fit);
445 
	}
446 
	MAKE_exp_int_lit(s, n, exp_token_tag, e);
447 
	if (!EQ_type(s, t)) {
448 
		e = make_cast_nat(t, e, KILL_err, CAST_STATIC);
449 
	}
450 
	return(e);
2 7u83 451 
}
452 
 
453 
 
454 
/*
455 
    SIMPLIFY AN INTEGER CONSTANT EXPRESSION
456 
 
457 
    This routine simplifies the integer constant expression e by replacing
458 
    it by the value of a calculated constant.  This is avoided when this
459 
    constant may be tokenised.
460 
*/
461 
 
6 7u83 462 
static EXP
463 
calc_exp_value(EXP e)
2 7u83 464 
{
6 7u83 465 
	NAT n = DEREF_nat(exp_int_lit_nat(e));
466 
	if (IS_nat_calc(n)) {
467 
		/* Calculated value */
468 
		unsigned etag = DEREF_unsigned(exp_int_lit_etag(e));
469 
		if (etag != exp_identifier_tag) {
470 
			/* Preserve enumerators */
471 
			e = DEREF_exp(nat_calc_value(n));
472 
		}
2 7u83 473 
	}
6 7u83 474 
	return(e);
2 7u83 475 
}
476 
 
477 
 
478 
/*
479 
    NEGATE AN INTEGER CONSTANT
480 
 
481 
    This routine negates the integer constant n.
482 
*/
483 
 
6 7u83 484 
NAT
485 
negate_nat(NAT n)
2 7u83 486 
{
6 7u83 487 
	if (!IS_NULL_nat(n)) {
488 
		switch (TAG_nat(n)) {
489 
		case nat_small_tag: {
490 
			unsigned val = DEREF_unsigned(nat_small_value(n));
491 
			if (val < SMALL_NAT_SIZE) {
492 
				n = small_neg_nat[val];
493 
				if (IS_NULL_nat(n)) {
494 
					int v = (int)val;
495 
					n = make_small_nat(-v);
496 
				}
497 
				break;
498 
			}
499 
			goto default_lab;
2 7u83 500 
		}
6 7u83 501 
		case nat_neg_tag: {
502 
			n = DEREF_nat(nat_neg_arg(n));
503 
			break;
504 
		}
505 
		case nat_calc_tag: {
506 
			EXP e = DEREF_exp(nat_calc_value(n));
507 
			e = make_uminus_exp(lex_minus, e);
508 
			MAKE_nat_calc(e, n);
509 
			break;
510 
		}
511 
		default:
512 
default_lab:
513 
			MAKE_nat_neg(n, n);
514 
			break;
515 
		}
2 7u83 516 
	}
6 7u83 517 
	return(n);
2 7u83 518 
}
519 
 
520 
 
521 
/*
522 
    COMPARE TWO INTEGER CONSTANTS
523 
 
524 
    This routine compares the integer constants n and m.  It returns 0 if
525 
    they are equal, 1 if n > m and -1 if n < m.  A value of 2 or -2 is
526 
    returned if the result is target dependent or otherwise indeterminate.
527 
*/
528 
 
6 7u83 529 
int
530 
compare_nat(NAT n, NAT m)
2 7u83 531 
{
6 7u83 532 
	unsigned tn, tm;
533 
	unsigned vn, vm;
534 
	LIST(unsigned)ln, lm;
2 7u83 535 
 
6 7u83 536 
	/* Check for obvious equality */
537 
	if (EQ_nat(n, m)) {
538 
		return(0);
539 
	}
540 
	if (IS_NULL_nat(n)) {
541 
		return(2);
542 
	}
543 
	if (IS_NULL_nat(m)) {
544 
		return(-2);
545 
	}
546 
	tn = TAG_nat(n);
547 
	tm = TAG_nat(m);
2 7u83 548 
 
6 7u83 549 
	/* Check for tokenised values */
550 
	if (tn == nat_token_tag) {
551 
		if (tm == nat_token_tag) {
552 
			IDENTIFIER in = DEREF_id(nat_token_tok(n));
553 
			IDENTIFIER im = DEREF_id(nat_token_tok(m));
554 
			LIST(TOKEN)pn = DEREF_list(nat_token_args(n));
555 
			LIST(TOKEN)pm = DEREF_list(nat_token_args(m));
556 
			if (eq_token_args(in, im, pn, pm)) {
557 
				return(0);
558 
			}
559 
		}
560 
		return(2);
2 7u83 561 
	}
6 7u83 562 
	if (tm == nat_token_tag) {
563 
		return(2);
564 
	}
2 7u83 565 
 
6 7u83 566 
	/* Check for calculated values */
567 
	if (tn == nat_calc_tag) {
568 
		if (tm == nat_calc_tag) {
569 
			EXP en = DEREF_exp(nat_calc_value(n));
570 
			EXP em = DEREF_exp(nat_calc_value(m));
571 
			if (eq_exp(en, em, 1)) {
572 
				return(0);
573 
			}
574 
		}
575 
		return(2);
2 7u83 576 
	}
6 7u83 577 
	if (tm == nat_calc_tag) {
578 
		return(2);
579 
	}
2 7u83 580 
 
6 7u83 581 
	/* Deal with negation operations */
582 
	if (tn == nat_neg_tag) {
583 
		if (tm == nat_neg_tag) {
584 
			/* Both negative */
585 
			int c;
586 
			n = DEREF_nat(nat_neg_arg(n));
587 
			m = DEREF_nat(nat_neg_arg(m));
588 
			c = compare_nat(n, m);
589 
			return(-c);
590 
		}
591 
		/* n negative, m positive */
592 
		return(-1);
2 7u83 593 
	}
6 7u83 594 
	if (tm == nat_neg_tag) {
595 
		/* m negative, n positive */
596 
		return(1);
597 
	}
2 7u83 598 
 
6 7u83 599 
	/* Now deal with small integers */
600 
	if (tn == nat_small_tag) {
601 
		if (tm == nat_small_tag) {
602 
			/* Both small */
603 
			vn = DEREF_unsigned(nat_small_value(n));
604 
			vm = DEREF_unsigned(nat_small_value(m));
605 
			if (vn == vm) {
606 
				return(0);
607 
			}
608 
			return(vn > vm ? 1 : -1);
609 
		} else {
610 
			/* n small, m large */
611 
			return(-1);
612 
		}
2 7u83 613 
	}
6 7u83 614 
	if (tm == nat_small_tag) {
615 
		/* m small, n large */
616 
		return(1);
617 
	}
2 7u83 618 
 
6 7u83 619 
	/* Now deal with large integers */
620 
	ln = DEREF_list(nat_large_values(n));
621 
	lm = DEREF_list(nat_large_values(m));
622 
	vn = LENGTH_list(ln);
623 
	vm = LENGTH_list(lm);
624 
	if (vn == vm) {
625 
		/* Same length */
626 
		int c = 0;
627 
		while (!IS_NULL_list(ln)) {
628 
			/* Scan through digits */
629 
			vn = DEREF_unsigned(HEAD_list(ln));
630 
			vm = DEREF_unsigned(HEAD_list(lm));
631 
			if (vn != vm) {
632 
				c = (vn > vm ? 1 : -1);
633 
			}
634 
			ln = TAIL_list(ln);
635 
			lm = TAIL_list(lm);
636 
		}
637 
		/* c is set to the most significant difference */
638 
		return(c);
2 7u83 639 
	}
6 7u83 640 
	/* Different lengths */
641 
	return(vn > vm ? 1 : -1);
2 7u83 642 
}
643 
 
644 
 
645 
/*
646 
    UNIFY TWO INTEGER LITERALS
647 
 
648 
    This routine unifies the integer literals n and m by defining tokens
649 
    if possible.  It returns true if the token is assigned a value.
650 
*/
651 
 
6 7u83 652 
static int
653 
unify_nat(NAT n, NAT m)
2 7u83 654 
{
6 7u83 655 
	IDENTIFIER id;
656 
	LIST(TOKEN)args;
657 
	switch (TAG_nat(n)) {
658 
	case nat_token_tag: {
659 
		id = DEREF_id(nat_token_tok(n));
660 
		args = DEREF_list(nat_token_args(n));
661 
		break;
2 7u83 662 
	}
6 7u83 663 
	case nat_calc_tag: {
664 
		EXP e = DEREF_exp(nat_calc_value(n));
665 
		if (!IS_exp_token(e)) {
666 
			return(0);
667 
		}
668 
		id = DEREF_id(exp_token_tok(e));
669 
		args = DEREF_list(exp_token_args(e));
670 
		break;
2 7u83 671 
	}
6 7u83 672 
	default: {
673 
		return(0);
2 7u83 674 
	}
6 7u83 675 
	}
676 
	if (IS_NULL_list(args) && defining_token(id)) {
677 
		return(define_nat_token(id, m));
678 
	}
679 
	return(0);
2 7u83 680 
}
681 
 
682 
 
683 
/*
684 
    ARE TWO INTEGER LITERALS EQUAL?
685 
 
686 
    This routine returns true if the literals n and m are equal.
687 
*/
688 
 
6 7u83 689 
int
690 
eq_nat(NAT n, NAT m)
2 7u83 691 
{
6 7u83 692 
	if (EQ_nat(n, m)) {
693 
		return(1);
694 
	}
695 
	if (IS_NULL_nat(n) || IS_NULL_nat(m)) {
696 
		return(0);
697 
	}
698 
	if (compare_nat(n, m) == 0) {
699 
		return(1);
700 
	}
701 
	if (force_tokdef || force_template || expand_tokdef) {
702 
		if (unify_nat(n, m)) {
703 
			return(1);
704 
		}
705 
		if (unify_nat(m, n)) {
706 
			return(1);
707 
		}
708 
	}
709 
	return(0);
2 7u83 710 
}
711 
 
712 
 
713 
/*
714 
    PERFORM A BINARY INTEGER CONSTANT CALCULATION
715 
 
716 
    This routine is used to evaluate the binary operation indicated by tag
717 
    on the integer constants a and b, which will be simple literals.  The
718 
    permitted operations are '+', '-', '*', '/', '%', '<<', '>>', '&', '|',
719 
    and '^'.  The null literal is returned for undefined or implementation
720 
    dependent calculations.
721 
*/
722 
 
6 7u83 723 
NAT
724 
binary_nat_op(unsigned tag, NAT a, NAT b)
2 7u83 725 
{
6 7u83 726 
	unsigned vn, vm;
727 
	NAT n = a, m = b;
728 
	NAT res = NULL_nat;
729 
	int sn = 0, sm = 0;
730 
	unsigned ln, lm, la;
731 
	LIST(unsigned)p, q;
732 
	LIST(unsigned)pn, pm;
2 7u83 733 
 
6 7u83 734 
	/* Decompose n */
735 
	if (IS_NULL_nat(n)) {
736 
		return(NULL_nat);
737 
	}
738 
	if (IS_NULL_nat(m)) {
739 
		return(NULL_nat);
740 
	}
741 
	if (IS_nat_neg(n)) {
742 
		n = DEREF_nat(nat_neg_arg(n));
743 
		sn = 1;
744 
	}
745 
	if (IS_nat_small(n)) {
746 
		vn = DEREF_unsigned(nat_small_value(n));
747 
		if (vn == 0) {
748 
			/* Find results if a is zero */
749 
			switch (tag) {
750 
			case exp_plus_tag:
751 
			case exp_or_tag:
752 
			case exp_xor_tag:
753 
				/* 0 op b = b */
754 
				return(b);
755 
			case exp_minus_tag:
756 
				/* 0 - b = -b */
757 
				res = negate_nat(b);
758 
				return(res);
759 
			case exp_mult_tag:
760 
			case exp_lshift_tag:
761 
			case exp_rshift_tag:
762 
			case exp_and_tag:
763 
				/* 0 op b = 0 */
764 
				return(a);
765 
			}
2 7u83 766 
		}
6 7u83 767 
		pn = small_nat_1;
768 
		COPY_unsigned(HEAD_list(pn), vn);
769 
		ln = 1;
770 
	} else {
771 
		vn = 0;
772 
		pn = DEREF_list(nat_large_values(n));
773 
		ln = LENGTH_list(pn);
2 7u83 774 
	}
775 
 
6 7u83 776 
	/* Decompose m */
777 
	if (IS_nat_neg(m)) {
778 
		m = DEREF_nat(nat_neg_arg(m));
779 
		sm = 1;
780 
	}
781 
	if (IS_nat_small(m)) {
782 
		vm = DEREF_unsigned(nat_small_value(m));
783 
		if (vm == 0) {
784 
			/* Find results if b is zero */
785 
			switch (tag) {
786 
			case exp_plus_tag:
787 
			case exp_minus_tag:
788 
			case exp_lshift_tag:
789 
			case exp_rshift_tag:
790 
			case exp_or_tag:
791 
			case exp_xor_tag:
792 
				/* a op 0 = a */
793 
				return(a);
794 
			case exp_mult_tag:
795 
			case exp_and_tag:
796 
				/* a op 0 = 0 */
797 
				return(b);
798 
			case exp_div_tag:
799 
			case exp_rem_tag:
800 
				/* a op 0 undefined */
801 
				return(NULL_nat);
802 
			}
2 7u83 803 
		}
6 7u83 804 
		pm = small_nat_2;
805 
		COPY_unsigned(HEAD_list(pm), vm);
806 
		lm = 1;
807 
	} else {
808 
		vm = 0;
809 
		pm = DEREF_list(nat_large_values(m));
810 
		lm = LENGTH_list(pm);
2 7u83 811 
	}
812 
 
6 7u83 813 
	/* Find the larger of ln and lm */
814 
	la = (ln > lm ? ln : lm);
2 7u83 815 
 
6 7u83 816 
	/* Perform the appropriate calculation */
817 
	switch (tag) {
818 
	case exp_plus_tag:
819 
exp_plus_label:
820 
		/* Deal with 'a + b' */
821 
		if (sn == sm) {
822 
			/* Same sign */
823 
			if (la == 1) {
824 
				/* Add two small values */
825 
				unsigned long en = EXTEND_VALUE(vn);
826 
				unsigned long em = EXTEND_VALUE(vm);
827 
				unsigned long er = en + em;
828 
				res = make_nat_value(er);
2 7u83 829 
			} else {
6 7u83 830 
				/* Add two large values */
831 
				unsigned carry = 0;
832 
				p = digit_list(la + 1);
833 
				q = p;
834 
				while (!IS_NULL_list(q)) {
835 
					unsigned long en, em, er;
836 
					unsigned long ec = EXTEND_VALUE(carry);
837 
					if (!IS_NULL_list(pn)) {
838 
						vn = DEREF_unsigned(HEAD_list(pn));
839 
						en = EXTEND_VALUE(vn);
840 
						pn = TAIL_list(pn);
841 
					} else {
842 
						en = 0;
843 
					}
844 
					if (!IS_NULL_list(pm)) {
845 
						vm = DEREF_unsigned(HEAD_list(pm));
846 
						em = EXTEND_VALUE(vm);
847 
						pm = TAIL_list(pm);
848 
					} else {
849 
						em = 0;
850 
					}
851 
					er = en + em + ec;
852 
					COPY_unsigned(HEAD_list(q), LO_HALF(er));
853 
					carry = HI_HALF(er);
854 
					q = TAIL_list(q);
855 
				}
856 
				res = make_large_nat(p);
2 7u83 857 
			}
6 7u83 858 
			if (sn) {
859 
				res = negate_nat(res);
2 7u83 860 
			}
6 7u83 861 
		} else {
862 
			/* Different signs - try 'a - ( -b )' */
863 
			sm = !sm;
864 
			goto exp_minus_label;
2 7u83 865 
		}
6 7u83 866 
		break;
2 7u83 867 
 
6 7u83 868 
	case exp_minus_tag:
869 
exp_minus_label:
870 
		/* Deal with 'a - b' */
871 
		if (sn == sm) {
872 
			/* Same sign */
873 
			int c;
874 
			if (ln == lm) {
875 
				/* Same length */
876 
				c = compare_nat(n, m);
877 
				if (c == 0) {
878 
					/* n - m is zero if n == m */
879 
					res = small_nat[0];
880 
					break;
881 
				}
882 
			} else if (ln < lm) {
883 
				/* Definitely n < m */
884 
				c = -1;
2 7u83 885 
			} else {
6 7u83 886 
				/* Definitely n > m */
887 
				c = 1;
2 7u83 888 
			}
6 7u83 889 
			if (c < 0) {
890 
				/* If n < m, try '( -m ) - ( -n )' */
891 
				unsigned v = vn;
892 
				vn = vm;
893 
				vm = v;
894 
				p = pn;
895 
				pn = pm;
896 
				pm = p;
897 
				sn = !sn;
898 
			}
899 
			/* Now work out n - m */
900 
			if (la == 1) {
901 
				/* Subtract two small values */
902 
				unsigned long en = EXTEND_VALUE(vn);
903 
				unsigned long em = EXTEND_VALUE(vm);
904 
				unsigned long er = en - em;
905 
				res = make_nat_value(er);
2 7u83 906 
			} else {
6 7u83 907 
				/* Subtract two large values */
908 
				int carry = 0;
909 
				p = digit_list(la);
910 
				q = p;
911 
				while (!IS_NULL_list(q)) {
912 
					unsigned v;
913 
					if (!IS_NULL_list(pn)) {
914 
						vn = DEREF_unsigned(HEAD_list(pn));
915 
						pn = TAIL_list(pn);
916 
					} else {
917 
						vn = 0;
918 
					}
919 
					if (!IS_NULL_list(pm)) {
920 
						vm = DEREF_unsigned(HEAD_list(pm));
921 
						pm = TAIL_list(pm);
922 
					} else {
923 
						vm = 0;
924 
					}
925 
					if (carry) {
926 
						if (vn) {
927 
							vn--;
928 
							carry = 0;
929 
						} else {
930 
							vn = NAT_MASK;
931 
						}
932 
					}
933 
					if (vn < vm) {
934 
						carry = 1;
935 
					}
936 
					v = ((vn - vm) & NAT_MASK);
937 
					COPY_unsigned(HEAD_list(q), v);
938 
					q = TAIL_list(q);
939 
				}
940 
				res = make_large_nat(p);
2 7u83 941 
			}
6 7u83 942 
			if (sn) {
943 
				res = negate_nat(res);
2 7u83 944 
			}
6 7u83 945 
		} else {
946 
			/* Different signs - try 'a + ( -b )' */
947 
			sm = !sm;
948 
			goto exp_plus_label;
2 7u83 949 
		}
6 7u83 950 
		break;
2 7u83 951 
 
6 7u83 952 
	case exp_mult_tag: {
953 
		/* Deal with 'a * b' */
954 
		if (ln == 1 && vn == 1) {
955 
			/* Multiply by +/- 1 */
956 
			res = b;
957 
			if (sn) {
958 
				res = negate_nat(res);
2 7u83 959 
			}
6 7u83 960 
			break;
2 7u83 961 
		}
6 7u83 962 
		if (lm == 1 && vm == 1) {
963 
			/* Multiply by +/- 1 */
964 
			res = a;
965 
			if (sm) {
966 
				res = negate_nat(res);
967 
			}
968 
			break;
969 
		}
970 
		if (la == 1) {
971 
			/* Deal with small values */
972 
			unsigned long en = EXTEND_VALUE(vn);
973 
			unsigned long em = EXTEND_VALUE(vm);
974 
			unsigned long er = en * em;
975 
			res = make_nat_value(er);
976 
		} else {
977 
			/* Deal with large values */
978 
			unsigned vs;
979 
			unsigned long en, em, es;
980 
			LIST(unsigned)pr, ps, pt;
981 
			p = digit_list(ln + lm);
982 
			q = p;
983 
			while (!IS_NULL_list(pn)) {
984 
				pr = q;
985 
				vn = DEREF_unsigned(HEAD_list(pn));
986 
				en = EXTEND_VALUE(vn);
987 
				pt = pm;
988 
				while (!IS_NULL_list(pt)) {
989 
					ps = pr;
990 
					vm = DEREF_unsigned(HEAD_list(pt));
991 
					em = en * EXTEND_VALUE(vm);
992 
					while (em) {
993 
						vs = DEREF_unsigned(HEAD_list(ps));
994 
						es = EXTEND_VALUE(vs) + em;
995 
						vs = LO_HALF(es);
996 
						COPY_unsigned(HEAD_list(ps),
997 
							      vs);
998 
						em = EXTEND_VALUE(HI_HALF(es));
999 
						ps = TAIL_list(ps);
1000 
					}
1001 
					pr = TAIL_list(pr);
1002 
					pt = TAIL_list(pt);
1003 
				}
1004 
				pn = TAIL_list(pn);
1005 
				q = TAIL_list(q);
1006 
			}
1007 
			res = make_large_nat(p);
1008 
		}
1009 
		if (sn != sm) {
1010 
			res = negate_nat(res);
1011 
		}
1012 
		break;
2 7u83 1013 
	}
1014 
 
6 7u83 1015 
	case exp_div_tag: {
1016 
		/* Deal with 'a / b' */
1017 
		if (la <= 2) {
1018 
			/* Deal with smallish values */
1019 
			unsigned long en = get_nat_value(n);
1020 
			unsigned long em = get_nat_value(m);
1021 
			unsigned long er = en / em;
1022 
			if (sn || sm) {
1023 
				/* One operand is negative, check remainder */
1024 
				unsigned long es = en % em;
1025 
				if (es) {
1026 
					break;
1027 
				}
1028 
			}
1029 
			res = make_nat_value(er);
1030 
			if (sn != sm) {
1031 
				res = negate_nat(res);
1032 
			}
2 7u83 1033 
		}
6 7u83 1034 
		/* NOT YET IMPLEMENTED */
1035 
		break;
2 7u83 1036 
	}
1037 
 
6 7u83 1038 
	case exp_rem_tag: {
1039 
		/* Deal with a % b' */
1040 
		if (la <= 2) {
1041 
			/* Deal with smallish values */
1042 
			unsigned long en = get_nat_value(n);
1043 
			unsigned long em = get_nat_value(m);
1044 
			unsigned long es = en % em;
1045 
			if (sn || sm) {
1046 
				/* One operand is negative, check remainder */
1047 
				if (es) {
1048 
					break;
1049 
				}
1050 
			}
1051 
			res = make_nat_value(es);
2 7u83 1052 
		}
6 7u83 1053 
		/* NOT YET IMPLEMENTED */
1054 
		break;
2 7u83 1055 
	}
1056 
 
6 7u83 1057 
	case exp_lshift_tag: {
1058 
		/* Deal with 'a << b' */
1059 
		unsigned carry = 0;
1060 
		unsigned long en, em;
1061 
		if (sn || sm) {
1062 
			break;
2 7u83 1063 
		}
6 7u83 1064 
		em = get_nat_value(m);
1065 
		if (em > 4096) {
1066 
			/* Only attempt smallish values */
1067 
			break;
1068 
		}
1069 
		lm = (unsigned)(em / NAT_DIGITS);
1070 
		em %= NAT_DIGITS;
1071 
		la = ln + lm + 1;
1072 
		p = digit_list(la);
1073 
		q = p;
1074 
		while (lm) {
1075 
			/* Step over zero digits */
1076 
			q = TAIL_list(q);
1077 
			lm--;
1078 
		}
1079 
		while (!IS_NULL_list(pn)) {
1080 
			/* Copy remaining digits */
1081 
			vn = DEREF_unsigned(HEAD_list(pn));
1082 
			if (em) {
1083 
				en = EXTEND_VALUE(vn);
1084 
				en <<= em;
1085 
				vn = (LO_HALF(en) | carry);
1086 
				carry = HI_HALF(en);
1087 
			}
1088 
			COPY_unsigned(HEAD_list(q), vn);
1089 
			pn = TAIL_list(pn);
1090 
			q = TAIL_list(q);
1091 
		}
1092 
		/* Copy carry flag */
1093 
		COPY_unsigned(HEAD_list(q), carry);
1094 
		res = make_large_nat(p);
1095 
		break;
2 7u83 1096 
	}
1097 
 
6 7u83 1098 
	case exp_rshift_tag: {
1099 
		/* Deal with 'a >> b' */
1100 
		unsigned long en, em;
1101 
		if (sn || sm) {
1102 
			break;
2 7u83 1103 
		}
6 7u83 1104 
		em = get_nat_value(m);
1105 
		while (em >= NAT_DIGITS && ln) {
1106 
			/* Shift right one nat digit */
1107 
			em -= NAT_DIGITS;
1108 
			pn = TAIL_list(pn);
1109 
			ln--;
2 7u83 1110 
		}
6 7u83 1111 
		if (ln == 0) {
1112 
			/* Shifted off end */
1113 
			res = small_nat[0];
1114 
		} else if (ln == 1) {
1115 
			/* Remainder fits into a single digit */
1116 
			vn = DEREF_unsigned(HEAD_list(pn));
1117 
			vn >>= em;
1118 
			if (vn < SMALL_NAT_SIZE) {
1119 
				res = make_small_nat((int)vn);
1120 
			} else {
1121 
				MAKE_nat_small(vn, res);
1122 
			}
1123 
		} else {
1124 
			/* More than one digit left */
1125 
			p = digit_list(ln);
1126 
			q = p;
1127 
			while (!IS_NULL_list(pn)) {
1128 
				/* Copy remaining digits */
1129 
				vn = DEREF_unsigned(HEAD_list(pn));
1130 
				COPY_unsigned(HEAD_list(q), vn);
1131 
				pn = TAIL_list(pn);
1132 
				q = TAIL_list(q);
1133 
			}
1134 
			/* Shift further if required */
1135 
			if (em) {
1136 
				unsigned carry = 0;
1137 
				p = REVERSE_list(p);
1138 
				q = p;
1139 
				while (!IS_NULL_list(q)) {
1140 
					vn = DEREF_unsigned(HEAD_list(q));
1141 
					en = COMBINE_VALUES(0, vn);
1142 
					en >>= em;
1143 
					vn = (HI_HALF(en) | carry);
1144 
					COPY_unsigned(HEAD_list(q), vn);
1145 
					carry = LO_HALF(en);
1146 
					q = TAIL_list(q);
1147 
				}
1148 
				p = REVERSE_list(p);
1149 
			}
1150 
			res = make_large_nat(p);
2 7u83 1151 
		}
6 7u83 1152 
		break;
2 7u83 1153 
	}
1154 
 
6 7u83 1155 
	case exp_and_tag:
1156 
	case exp_or_tag:
1157 
	case exp_xor_tag: {
1158 
		/* Deal with 'a & b', 'a | b' and 'a ^ b' */
1159 
		if (sn || sm) {
1160 
			break;
1161 
		}
1162 
		if (la <= 2) {
1163 
			/* Deal with smallish values */
1164 
			unsigned long er;
1165 
			unsigned long en = get_nat_value(n);
1166 
			unsigned long em = get_nat_value(m);
1167 
			if (tag == exp_and_tag) {
1168 
				er = (en & em);
1169 
			} else if (tag == exp_or_tag) {
1170 
				er = (en | em);
1171 
			} else {
1172 
				er = (en ^ em);
1173 
			}
1174 
			res = make_nat_value(er);
2 7u83 1175 
		} else {
6 7u83 1176 
			/* Deal with large values */
1177 
			p = digit_list(la);
1178 
			q = p;
1179 
			while (!IS_NULL_list(q)) {
1180 
				unsigned vr;
1181 
				if (!IS_NULL_list(pn)) {
1182 
					vn = DEREF_unsigned(HEAD_list(pn));
1183 
					pn = TAIL_list(pn);
1184 
				} else {
1185 
					vn = 0;
1186 
				}
1187 
				if (!IS_NULL_list(pm)) {
1188 
					vm = DEREF_unsigned(HEAD_list(pm));
1189 
					pm = TAIL_list(pm);
1190 
				} else {
1191 
					vm = 0;
1192 
				}
1193 
				if (tag == exp_and_tag) {
1194 
					vr = (vn & vm);
1195 
				} else if (tag == exp_or_tag) {
1196 
					vr = (vn | vm);
1197 
				} else {
1198 
					vr = (vn ^ vm);
1199 
				}
1200 
				COPY_unsigned(HEAD_list(q), vr);
1201 
				q = TAIL_list(q);
1202 
			}
1203 
			res = make_large_nat(p);
2 7u83 1204 
		}
6 7u83 1205 
		break;
2 7u83 1206 
	}
6 7u83 1207 
	}
1208 
	return(res);
2 7u83 1209 
}
1210 
 
1211 
 
1212 
/*
1213 
    EVALUATE A CONSTANT EXPRESSION
1214 
 
1215 
    This routine transforms the integer constant expression e into an
1216 
    integer constant.  Any errors arising are added to the position
1217 
    indicated by err.
1218 
*/
1219 
 
6 7u83 1220 
NAT
1221 
make_nat_exp(EXP e, ERROR *err)
2 7u83 1222 
{
6 7u83 1223 
	NAT n;
1224 
	TYPE t;
2 7u83 1225 
 
6 7u83 1226 
	/* Remove any parentheses round e */
1227 
	unsigned tag = TAG_exp(e);
1228 
	while (tag == exp_paren_tag) {
1229 
		e = DEREF_exp(exp_paren_arg(e));
1230 
		tag = TAG_exp(e);
1231 
	}
2 7u83 1232 
 
6 7u83 1233 
	/* The result should now be an integer constant */
1234 
	if (tag == exp_int_lit_tag) {
1235 
		n = DEREF_nat(exp_int_lit_nat(e));
1236 
		return(n);
1237 
	}
2 7u83 1238 
 
6 7u83 1239 
	/* Check expression type */
1240 
	t = DEREF_type(exp_type(e));
1241 
	switch (TAG_type(t)) {
1242 
	case type_integer_tag:
1243 
	case type_enumerate_tag:
1244 
	case type_bitfield_tag: {
1245 
		/* Double check for integer constants */
1246 
		if (!is_const_exp(e, 0)) {
1247 
			add_error(err, ERR_expr_const_bad());
1248 
		}
1249 
		break;
2 7u83 1250 
	}
6 7u83 1251 
	case type_token_tag: {
1252 
		/* Allow template types */
1253 
		if (!is_templ_type(t)) {
1254 
			goto default_lab;
1255 
		}
1256 
		break;
2 7u83 1257 
	}
6 7u83 1258 
	case type_error_tag: {
1259 
		/* Allow for error propagation */
1260 
		break;
2 7u83 1261 
	}
1262 
	default :
6 7u83 1263 
default_lab:
1264 
		/* Otherwise report an error */
1265 
		add_error(err, ERR_expr_const_int(t));
1266 
		if (IS_exp_float_lit(e)) {
1267 
			/* Evaluate floating point literals */
1268 
			FLOAT f = DEREF_flt(exp_float_lit_flt(e));
1269 
			n = round_float_lit(f, crt_round_mode);
1270 
			if (!IS_NULL_nat(n)) {
1271 
				return(n);
1272 
			}
1273 
		}
1274 
		e = make_error_exp(0);
1275 
		break;
2 7u83 1276 
	}
6 7u83 1277 
	MAKE_nat_calc(e, n);
1278 
	return(n);
2 7u83 1279 
}
1280 
 
1281 
 
1282 
/*
1283 
    FIND THE NUMBER OF BITS IN AN INTEGER
1284 
 
1285 
    This routine returns the number of bits in the integer n from the
6 7u83 1286 
    range [0, 0xffff].
2 7u83 1287 
*/
1288 
 
6 7u83 1289 
unsigned
1290 
no_bits(unsigned n)
2 7u83 1291 
{
6 7u83 1292 
	unsigned bits = 0;
1293 
	static unsigned char small_bits[16] = {
1294 
		0, 1, 2, 2, 3, 3, 3, 3,
1295 
		4, 4, 4, 4, 4, 4, 4, 4
1296 
	};
1297 
	if (n & ((unsigned)0xfff0)) {
1298 
		n >>= 4;
1299 
		bits += 4;
1300 
		if (n & 0x0ff0) {
1301 
			n >>= 4;
1302 
			bits += 4;
1303 
			if (n & 0x00f0) {
1304 
				n >>= 4;
1305 
				bits += 4;
1306 
			}
1307 
		}
2 7u83 1308 
	}
6 7u83 1309 
	bits += (unsigned)small_bits[n];
1310 
	return(bits);
2 7u83 1311 
}
1312 
 
1313 
 
1314 
/*
1315 
    FIND THE NUMBER OF BITS IN AN INTEGER CONSTANT
1316 
 
1317 
    This routine calculates the number of bits in the representation of
1318 
    the simple integer constant n.  The flag eq is set to false unless
1319 
    n is exactly a power of 2.
1320 
*/
1321 
 
6 7u83 1322 
static unsigned
1323 
get_nat_bits(NAT n, int *eq)
2 7u83 1324 
{
6 7u83 1325 
	unsigned val;
1326 
	unsigned bits = 0;
1327 
	if (IS_nat_small(n)) {
1328 
		val = DEREF_unsigned(nat_small_value(n));
1329 
	} else {
1330 
		LIST(unsigned)vals = DEREF_list(nat_large_values(n));
1331 
		for (;;) {
1332 
			val = DEREF_unsigned(HEAD_list(vals));
1333 
			vals = TAIL_list(vals);
1334 
			if (IS_NULL_list(vals))break;
1335 
			if (val)*eq = 0;
1336 
			bits += NAT_DIGITS;
1337 
		}
2 7u83 1338 
	}
6 7u83 1339 
	if (val) {
1340 
		/* Check the most significant digit */
1341 
		if (val & (val - 1))*eq = 0;
1342 
		bits += no_bits(val);
1343 
	}
1344 
	return(bits);
2 7u83 1345 
}
1346 
 
1347 
 
1348 
/*
1349 
    CHECK WHETHER AN INTEGER CONSTANT FITS INTO A TYPE
1350 
 
1351 
    This routine checks whether the integer constant n fits into the range
1352 
    of values of the integral, enumeration or bitfield type t.  The value
1353 
    returned is:
1354 
 
1355 
 
1356 
	1 if n may fit into t and t is not unsigned,
1357 
	2 if n may fit into t and t is unsigned,
1358 
	3 if n definitely does not fit into t and t is not unsigned,
1359 
	4 if n definitely does not fit into t and t is unsigned,
1360 
	5 if n definitely does not fit into any type and t is not unsigned,
1361 
	6 if n definitely does not fit into any type and t is unsigned.
1362 
*/
1363 
 
6 7u83 1364 
int
1365 
check_nat_range(TYPE t, NAT n)
2 7u83 1366 
{
6 7u83 1367 
	int eq = 1;
1368 
	int neg = 0;
1369 
	unsigned msz;
1370 
	unsigned bits;
1371 
	BASE_TYPE sign;
2 7u83 1372 
 
6 7u83 1373 
	/* Find type information */
1374 
	unsigned sz = find_type_size(t, &msz, &sign);
1375 
	int u = (sign == btype_unsigned ? 1 : 0);
2 7u83 1376 
 
6 7u83 1377 
	/* Deal with complex constants */
1378 
	unsigned tag = TAG_nat(n);
1379 
	if (tag == nat_neg_tag) {
1380 
		n = DEREF_nat(nat_neg_arg(n));
1381 
		tag = TAG_nat(n);
1382 
		neg = 1;
1383 
	}
1384 
	if (tag == nat_calc_tag || tag == nat_token_tag) {
1385 
		return(1 + u);
1386 
	}
2 7u83 1387 
 
6 7u83 1388 
	/* Find the number of bits in the representation of n */
1389 
	bits = get_nat_bits(n, &eq);
1390 
	if (bits > basetype_info[ntype_ellipsis].max_bits) {
1391 
		return(5 + u);
1392 
	}
2 7u83 1393 
 
6 7u83 1394 
	/* Check the type range */
1395 
	if (sign == btype_unsigned) {
1396 
		/* Unsigned types (eg [0-255]) */
1397 
		if (neg) {
1398 
			return(4);
1399 
		}
1400 
		if (bits <= sz) {
1401 
			return(0);
1402 
		}
1403 
		if (bits > msz) {
1404 
			return(4);
1405 
		}
1406 
	} else if (sign == btype_signed) {
1407 
		/* Symmetric signed types (eg [-127, 127]) */
1408 
		if (bits < sz) {
1409 
			return(0);
1410 
		}
1411 
		if (bits >= msz) {
1412 
			return(3);
1413 
		}
1414 
	} else if (sign == (btype_signed | btype_long)) {
1415 
		/* Asymmetric signed types (eg [-128, 127]) */
1416 
		if (bits < sz) {
1417 
			return(0);
1418 
		}
1419 
		if (bits == sz && neg && eq) {
1420 
			return(0);
1421 
		}
1422 
		if (bits >= msz) {
1423 
			return(3);
1424 
		}
1425 
	} else {
1426 
		/* Unspecified types */
1427 
		if (neg) {
1428 
			return(3);
1429 
		}
1430 
		if (bits < sz) {
1431 
			return(0);
1432 
		}
1433 
		if (bits >= msz) {
1434 
			return(3);
1435 
		}
1436 
	}
1437 
	return(1 + u);
2 7u83 1438 
}
1439 
 
1440 
 
1441 
/*
1442 
    CHECK A TYPE SIZE
1443 
 
1444 
    This routine checks whether the integer literal n exceeds the number
1445 
    of bits in the integral, enumeration or bitfield type t.  It is used,
1446 
    for example, in checking for overlarge shifts and bitfield sizes.
1447 
    It returns -1 if n is less than the minimum number of bits, 0 if it
1448 
    is equal, and 1 otherwise.
1449 
*/
1450 
 
6 7u83 1451 
int
1452 
check_type_size(TYPE t, NAT n)
2 7u83 1453 
{
6 7u83 1454 
	unsigned sz;
1455 
	unsigned msz;
1456 
	BASE_TYPE sign;
1457 
	unsigned long st, sn;
1458 
	switch (TAG_nat(n)) {
1459 
	case nat_neg_tag:
1460 
	case nat_calc_tag:
1461 
	case nat_token_tag:
1462 
		/* Negative and calculated values are alright */
1463 
		return(-1);
2 7u83 1464 
	}
6 7u83 1465 
	sn = get_nat_value(n);
1466 
	if (sn == EXTENDED_MAX) {
1467 
		return(1);
1468 
	}
1469 
	sz = find_type_size(t, &msz, &sign);
1470 
	UNUSED(sign);
1471 
	UNUSED(msz);
1472 
	st = EXTEND_VALUE(sz);
1473 
	if (sn < st) {
1474 
		return(-1);
1475 
	}
1476 
	if (sn == st) {
1477 
		return(0);
1478 
	}
1479 
	return(1);
2 7u83 1480 
}
1481 
 
1482 
 
1483 
/*
1484 
    FIND THE MAXIMUM VALUE FOR A TYPE
1485 
 
1486 
    This routine returns the maximum value (or the minimum value if neg is
1487 
    true) which is guaranteed to fit into the type t.  The null constant
1488 
    is returned if the value can't be determined.  If t is the null type
1489 
    the maximum value which can fit into any type is returned.
1490 
*/
1491 
 
6 7u83 1492 
NAT
1493 
max_type_value(TYPE t, int neg)
2 7u83 1494 
{
6 7u83 1495 
	NAT n;
1496 
	unsigned sz;
1497 
	unsigned msz;
1498 
	int zero = 0;
1499 
	BASE_TYPE sign;
1500 
	if (!IS_NULL_type(t)) {
1501 
		sz = find_type_size(t, &msz, &sign);
1502 
	} else {
1503 
		sz = basetype_info[ntype_ellipsis].max_bits;
1504 
		sign = btype_unsigned;
2 7u83 1505 
	}
6 7u83 1506 
	if (!(sign & btype_signed)) {
1507 
		zero = neg;
1508 
	}
1509 
	if (!(sign & btype_unsigned)) {
1510 
		if (sz == 0) {
1511 
			zero = 1;
1512 
		}
1513 
		sz--;
1514 
	}
1515 
	if (zero) {
1516 
		n = small_nat[0];
1517 
	} else {
1518 
		n = make_nat_value((unsigned long)sz);
1519 
		n = binary_nat_op(exp_lshift_tag, small_nat[1], n);
1520 
		if (!IS_NULL_nat(n)) {
1521 
			if (!neg || !(sign & btype_long)) {
1522 
				n = binary_nat_op(exp_minus_tag, n,
1523 
						  small_nat[1]);
1524 
			}
1525 
			if (neg)n = negate_nat(n);
1526 
		}
1527 
	}
1528 
	return(n);
2 7u83 1529 
}
1530 
 
1531 
 
1532 
 
1533 
 
1534 
/*
1535 
    CONSTRUCT A CONSTANT INTEGRAL EXPRESSION
1536 
 
1537 
    This routine constructs an integer literal expression of type t from
1538 
    the literal n, performing any appropriate bounds checks.  tag indicates
1539 
    the operation used to form this result.  The null expression is returned
1540 
    to indicate that n may not fit into t.
1541 
*/
1542 
 
6 7u83 1543 
EXP
1544 
make_int_exp(TYPE t, unsigned tag, NAT n)
2 7u83 1545 
{
6 7u83 1546 
	EXP e;
1547 
	int ch = check_nat_range(t, n);
1548 
	if (ch == 0) {
1549 
		MAKE_exp_int_lit(t, n, tag, e);
1550 
	} else {
1551 
		e = NULL_exp;
1552 
	}
1553 
	return(e);
2 7u83 1554 
}
1555 
 
1556 
 
1557 
/*
1558 
    CHECK ARRAY BOUNDS
1559 
 
1560 
    This routine checks an array index operation indicated by op (which
1561 
    can be '[]', '+' or '-') for the array type t and the constant integer
1562 
    index expression a.  Note that a must be less than the array bound for
1563 
    '[]', but may be equal to the bound for the other operations (this is
1564 
    the 'one past the end' rule).
1565 
*/
1566 
 
6 7u83 1567 
void
1568 
check_bounds(int op, TYPE t, EXP a)
2 7u83 1569 
{
6 7u83 1570 
	if (IS_exp_int_lit(a)) {
1571 
		int ok = 0;
1572 
		NAT n = DEREF_nat(type_array_size(t));
1573 
		NAT m = DEREF_nat(exp_int_lit_nat(a));
2 7u83 1574 
 
6 7u83 1575 
		/* Unbound arrays do not give an error */
1576 
		if (IS_NULL_nat(n)) return;
2 7u83 1577 
 
6 7u83 1578 
		/* Calculated indexes are alright */
1579 
		if (is_calc_nat(m)) return;
2 7u83 1580 
 
6 7u83 1581 
		/* Check the bounds */
1582 
		if (op == lex_minus) {
1583 
			m = negate_nat(m);
1584 
		}
1585 
		if (!IS_nat_neg(m)) {
1586 
			if (!is_calc_nat(n)) {
1587 
				int c = compare_nat(m, n);
1588 
				if (c < 0) {
1589 
					ok = 1;
1590 
				}
1591 
				if (c == 0 && op != lex_array_Hop) {
1592 
					ok = 1;
1593 
				}
1594 
			}
1595 
		}
1596 
 
1597 
		/* Report the error */
1598 
		if (!ok) {
1599 
			report(crt_loc, ERR_expr_add_array(m, t, op));
1600 
		}
2 7u83 1601 
	}
6 7u83 1602 
	return;
2 7u83 1603 
}
1604 
 
1605 
 
1606 
/*
1607 
    EVALUATE A CONSTANT CAST OPERATION
1608 
 
1609 
    This routine is used to cast the integer constant expression a to the
1610 
    integral, bitfield, or enumeration type t.  The argument cast indicated
1611 
    whether the cast used is implicit or explicit (see cast.h).  Any errors
1612 
    arising are added to err.
1613 
*/
1614 
 
6 7u83 1615 
EXP
1616 
make_cast_nat(TYPE t, EXP a, ERROR *err, unsigned cast)
2 7u83 1617 
{
6 7u83 1618 
	EXP e;
1619 
	int ch;
1620 
	unsigned etag = exp_cast_tag;
1621 
	NAT n = DEREF_nat(exp_int_lit_nat(a));
1622 
	if (cast == CAST_IMPLICIT) {
1623 
		etag = DEREF_unsigned(exp_int_lit_etag(a));
1624 
	}
1625 
	ch = check_nat_range(t, n);
1626 
	if (ch != 0) {
1627 
		/* n may not fit into t */
1628 
		a = calc_exp_value(a);
1629 
		MAKE_exp_cast(t, CONV_INT_INT, a, e);
1630 
		MAKE_nat_calc(e, n);
1631 
	}
1632 
	MAKE_exp_int_lit(t, n, etag, e);
1633 
	UNUSED(err);
1634 
	return(e);
2 7u83 1635 
}
1636 
 
1637 
 
1638 
/*
1639 
    EVALUATE A CONSTANT UNARY OPERATION
1640 
 
1641 
    This routine is used to evaluate the unary operation indicated by tag
1642 
    on the integer constant expression a.  Any necessary operand conversions
1643 
    and arithmetic type conversions have already been performed on a.  The
1644 
    permitted operations are '!', '-' and '~'.
1645 
*/
1646 
 
6 7u83 1647 
EXP
1648 
make_unary_nat(unsigned tag, EXP a)
2 7u83 1649 
{
6 7u83 1650 
	EXP e;
1651 
	TYPE t = DEREF_type(exp_type(a));
1652 
	NAT n = DEREF_nat(exp_int_lit_nat(a));
2 7u83 1653 
 
6 7u83 1654 
	/* Can only evaluate result if n is not calculated */
1655 
	if (!is_calc_nat(n)) {
1656 
		switch (tag) {
1657 
		case exp_not_tag: {
1658 
			/* Deal with '!a' */
1659 
			unsigned p = test_bool_exp(a);
1660 
			if (p == BOOL_UNKNOWN) {
1661 
				break;
1662 
			}
1663 
			e = make_bool_exp(BOOL_NEGATE(p), tag);
1664 
			return(e);
1665 
		}
1666 
		case exp_abs_tag: {
1667 
			/* Deal with 'abs ( a )' */
1668 
			int c = compare_nat(n, small_nat[0]);
1669 
			if (c == 0 || c == 1) {
1670 
				return(a);
1671 
			}
1672 
			if (c == -1) {
1673 
				goto negate_lab;
1674 
			}
1675 
			break;
1676 
		}
1677 
		case exp_negate_tag:
1678 
negate_lab:
1679 
			/* Deal with '-a' */
1680 
			n = negate_nat(n);
1681 
			e = make_int_exp(t, tag, n);
1682 
			if (!IS_NULL_exp(e))  {
1683 
				return(e);
1684 
			}
1685 
			break;
1686 
		case exp_compl_tag:
1687 
			/* Deal with '~a' */
1688 
			/* NOT YET IMPLEMENTED */
1689 
			break;
1690 
		}
2 7u83 1691 
	}
1692 
 
6 7u83 1693 
	/* Calculated case */
1694 
	a = calc_exp_value(a);
1695 
	MAKE_exp_negate_etc(tag, t, a, e);
1696 
	MAKE_nat_calc(e, n);
1697 
	MAKE_exp_int_lit(t, n, tag, e);
1698 
	return(e);
2 7u83 1699 
}
1700 
 
1701 
 
1702 
/*
1703 
    CHECK A CHARACTER LITERAL CONSTANT
1704 
 
1705 
    This routine checks whether the integer constant expression a represents
1706 
    one of the decimal character literals, '0', '1', ..., '9'.  If so it
6 7u83 1707 
    returns the corresponding value in the range [0, 9].  Otherwise it
2 7u83 1708 
    returns -1.
1709 
*/
1710 
 
6 7u83 1711 
static int
1712 
eval_char_nat(EXP a, unsigned *k)
2 7u83 1713 
{
6 7u83 1714 
	unsigned tag = TAG_exp(a);
1715 
	if (tag == exp_int_lit_tag) {
1716 
		NAT n = DEREF_nat(exp_int_lit_nat(a));
1717 
		if (IS_nat_calc(n)) {
1718 
			a = DEREF_exp(nat_calc_value(n));
1719 
			tag = TAG_exp(a);
1720 
		}
2 7u83 1721 
	}
6 7u83 1722 
	if (tag == exp_char_lit_tag) {
1723 
		int d = DEREF_int(exp_char_lit_digit(a));
1724 
		STRING str = DEREF_str(exp_char_lit_str(a));
1725 
		*k = DEREF_unsigned(str_simple_kind(str));
1726 
		return(d);
1727 
	}
1728 
	if (tag == exp_cast_tag) {
1729 
		a = DEREF_exp(exp_cast_arg(a));
1730 
		return(eval_char_nat(a, k));
1731 
	}
1732 
	return(-1);
2 7u83 1733 
}
1734 
 
1735 
 
1736 
/*
1737 
    ADD A VALUE TO A CHARACTER LITERAL CONSTANT
1738 
 
1739 
    This routine adds or subtracts (depending on the value of tag) the
1740 
    value n to the decimal character literal d, casting the result to
1741 
    type t.  The null expression is returned if the result is not a
1742 
    character literal.  For example, this routine is used to evaluate
1743 
    '4' + 3 as '7' regardless of the underlying character set.  This
1744 
    wouldn't be terribly important, but certain validation set suites
1745 
    use 6 + '0' - '6' as a null pointer constant!
1746 
*/
1747 
 
6 7u83 1748 
static EXP
1749 
make_char_nat(TYPE t, unsigned tag, int d, unsigned kind, NAT n)
2 7u83 1750 
{
6 7u83 1751 
	int neg = (tag == exp_minus_tag ? 1 : 0);
1752 
	if (IS_nat_neg(n)) {
1753 
		/* Negate if necessary */
1754 
		n = DEREF_nat(nat_neg_arg(n));
1755 
		neg = !neg;
2 7u83 1756 
	}
6 7u83 1757 
	if (IS_nat_small(n)) {
1758 
		unsigned v = DEREF_unsigned(nat_small_value(n));
1759 
		if (v < 10) {
1760 
			int m = (int)v;
1761 
			if (neg) {
1762 
				m = -m;
1763 
			}
1764 
			d += m;
1765 
			if (d >= 0 && d < 10) {
1766 
				/* Construct the result */
1767 
				EXP e;
1768 
				STRING str;
1769 
				character s[2];
1770 
				ERROR err = NULL_err;
1771 
				s[0] = (character)(d + char_zero);
1772 
				s[1] = 0;
1773 
				MAKE_str_simple(1, xustrcpy(s), kind, str);
1774 
				e = make_string_exp(str);
1775 
				e = make_cast_nat(t, e, &err, CAST_STATIC);
1776 
				if (!IS_NULL_err(err)) {
1777 
					report(crt_loc, err);
1778 
				}
1779 
				return(e);
1780 
			}
1781 
		}
1782 
	}
1783 
	return(NULL_exp);
2 7u83 1784 
}
1785 
 
1786 
 
1787 
/*
1788 
    EVALUATE A CONSTANT BINARY OPERATION
1789 
 
1790 
    This routine is used to evaluate the binary operation indicated by tag
1791 
    on the integer constant expressions a and b.  Any necessary operand
1792 
    conversions and arithmetic type conversions have already been performed
1793 
    on a and b.  The permitted operations are '+', '-', '*', '/', '%', '<<',
1794 
    '>>', '&', '|', '^', '&&' and '||'.
1795 
*/
1796 
 
6 7u83 1797 
EXP
1798 
make_binary_nat(unsigned tag, EXP a, EXP b)
2 7u83 1799 
{
6 7u83 1800 
	EXP e;
1801 
	int calc = 1;
1802 
	NAT res = NULL_nat;
1803 
	TYPE t = DEREF_type(exp_type(a));
1804 
	NAT n = DEREF_nat(exp_int_lit_nat(a));
1805 
	NAT m = DEREF_nat(exp_int_lit_nat(b));
2 7u83 1806 
 
6 7u83 1807 
	/* Examine simple cases */
1808 
	switch (tag) {
1809 
	case exp_plus_tag:
1810 
		/* Deal with 'a + b' */
1811 
		if (is_zero_nat(n)) {
1812 
			res = m;
1813 
		} else if (is_zero_nat(m)) {
1814 
			res = n;
1815 
		}
1816 
		break;
1817 
	case exp_minus_tag: {
1818 
		/* Deal with 'a - b' */
1819 
		int c = compare_nat(n, m);
1820 
		if (c == 0 && !overflow_exp(a)) {
1821 
			res = small_nat[0];
1822 
		} else if (is_zero_nat(n)) {
1823 
			e = make_unary_nat(exp_negate_tag, b);
1824 
			return(e);
1825 
		} else if (is_zero_nat(m)) {
1826 
			res = n;
1827 
		}
1828 
		break;
2 7u83 1829 
	}
6 7u83 1830 
	case exp_mult_tag:
1831 
		/* Deal with 'a * b' */
1832 
		if (is_zero_nat(n) && !overflow_exp(b)) {
1833 
			res = n;
1834 
		} else if (is_zero_nat(m) && !overflow_exp(a)) {
1835 
			res = m;
1836 
		}
1837 
		if (EQ_nat(n, small_nat[1])) {
1838 
			res = m;
1839 
		} else if (EQ_nat(m, small_nat[1])) {
1840 
			res = n;
1841 
		}
1842 
		break;
1843 
	case exp_max_tag: {
1844 
		/* Deal with 'max ( a, b )' */
1845 
		int c = compare_nat(n, m);
1846 
		if ((c == 0 || c == 1) && !overflow_exp(b)) {
1847 
			res = n;
1848 
		} else if (c == -1 && !overflow_exp(a)) {
1849 
			res = m;
1850 
		}
1851 
		calc = 0;
1852 
		break;
2 7u83 1853 
	}
6 7u83 1854 
	case exp_min_tag: {
1855 
		/* Deal with 'min ( a, b )' */
1856 
		int c = compare_nat(n, m);
1857 
		if ((c == 0 || c == 1) && !overflow_exp(a)) {
1858 
			res = m;
1859 
		} else if (c == -1 && !overflow_exp(b)) {
1860 
			res = n;
1861 
		}
1862 
		calc = 0;
1863 
		break;
2 7u83 1864 
	}
6 7u83 1865 
	case exp_log_and_tag: {
1866 
		/* Deal with 'a && b' */
1867 
		unsigned p = test_bool_exp(a);
1868 
		unsigned q = test_bool_exp(b);
1869 
		if (p == BOOL_TRUE && q == BOOL_TRUE) {
1870 
			/* EMPTY */
1871 
		} else if (p == BOOL_FALSE && !overflow_exp(b)) {
1872 
			/* EMPTY */
1873 
		} else if (q == BOOL_FALSE && !overflow_exp(a)) {
1874 
			p = BOOL_FALSE;
1875 
		} else {
1876 
			calc = 0;
1877 
			break;
1878 
		}
1879 
		e = make_bool_exp(p, tag);
1880 
		return(e);
2 7u83 1881 
	}
6 7u83 1882 
	case exp_log_or_tag: {
1883 
		/* Deal with 'a || b' */
1884 
		unsigned p = test_bool_exp(a);
1885 
		unsigned q = test_bool_exp(b);
1886 
		if (p == BOOL_FALSE && q == BOOL_FALSE) {
1887 
			/* EMPTY */
1888 
		} else if (p == BOOL_TRUE && !overflow_exp(b)) {
1889 
			/* EMPTY */
1890 
		} else if (q == BOOL_TRUE && !overflow_exp(a)) {
1891 
			p = BOOL_TRUE;
1892 
		} else {
1893 
			calc = 0;
1894 
			break;
1895 
		}
1896 
		e = make_bool_exp(p, tag);
1897 
		return(e);
2 7u83 1898 
	}
1899 
	}
6 7u83 1900 
 
1901 
	/* Return result if known (either n, m or 0) */
1902 
	if (!IS_NULL_nat(res)) {
1903 
		MAKE_exp_int_lit(t, res, tag, e);
1904 
		return(e);
2 7u83 1905 
	}
1906 
 
6 7u83 1907 
	/* Can only evaluate result if n and m are not calculated */
1908 
	if (calc && !is_calc_nat(n) && !is_calc_nat(m)) {
1909 
		res = binary_nat_op(tag, n, m);
1910 
		if (!IS_NULL_nat(res)) {
1911 
			e = make_int_exp(t, tag, res);
1912 
			if (!IS_NULL_exp(e)) {
1913 
				return(e);
1914 
			}
1915 
		}
2 7u83 1916 
	}
1917 
 
6 7u83 1918 
	/* Check for digit characters */
1919 
	if (tag == exp_plus_tag || tag == exp_minus_tag) {
1920 
		unsigned ka, kb;
1921 
		int da = eval_char_nat(a, &ka);
1922 
		int db = eval_char_nat(b, &kb);
1923 
		if (da >= 0) {
1924 
			if (db >= 0 && tag == exp_minus_tag) {
1925 
				/* Difference of two digits */
1926 
				res = make_small_nat(da - db);
1927 
				e = make_int_exp(t, tag, res);
1928 
				if (!IS_NULL_exp(e)) {
1929 
					return(e);
1930 
				}
1931 
			} else {
1932 
				/* Digit plus or minus value */
1933 
				e = make_char_nat(t, tag, da, ka, m);
1934 
				if (!IS_NULL_exp(e)) {
1935 
					return(e);
1936 
				}
1937 
			}
1938 
		} else if (db >= 0 && tag == exp_plus_tag) {
1939 
			/* Digit plus value */
1940 
			e = make_char_nat(t, tag, db, kb, n);
1941 
			if (!IS_NULL_exp(e)) {
1942 
				return(e);
1943 
			}
1944 
		}
2 7u83 1945 
	}
1946 
 
6 7u83 1947 
	/* Calculated case */
1948 
	a = calc_exp_value(a);
1949 
	b = calc_exp_value(b);
1950 
	MAKE_exp_plus_etc(tag, t, a, b, e);
1951 
	MAKE_nat_calc(e, res);
1952 
	MAKE_exp_int_lit(t, res, tag, e);
1953 
	return(e);
2 7u83 1954 
}
1955 
 
1956 
 
1957 
/*
1958 
    EVALUATE A CONSTANT TEST OPERATION
1959 
 
1960 
    This routine is used to convert the integer constant expression a to
1961 
    a boolean.
1962 
*/
1963 
 
6 7u83 1964 
EXP
1965 
make_test_nat(EXP a)
2 7u83 1966 
{
6 7u83 1967 
	EXP e;
1968 
	NAT n = DEREF_nat(exp_int_lit_nat(a));
1969 
	if (!is_calc_nat(n)) {
1970 
		/* Zero is false, non-zero is true */
1971 
		unsigned tag = DEREF_unsigned(exp_int_lit_etag(a));
1972 
		unsigned b = BOOL_NEGATE(is_zero_nat(n));
1973 
		e = make_bool_exp(b, tag);
2 7u83 1974 
	} else {
6 7u83 1975 
		/* Calculated case */
1976 
		TYPE t = DEREF_type(exp_type(a));
1977 
		if (check_int_type(t, btype_bool)) {
1978 
			e = a;
1979 
		} else {
1980 
			a = calc_exp_value(a);
1981 
			MAKE_exp_test(type_bool, ntest_not_eq, a, e);
1982 
			MAKE_nat_calc(e, n);
1983 
			MAKE_exp_int_lit(type_bool, n, exp_test_tag, e);
1984 
		}
2 7u83 1985 
	}
6 7u83 1986 
	return(e);
2 7u83 1987 
}
1988 
 
1989 
 
1990 
/*
1991 
    EVALUATE A CONSTANT COMPARISON OPERATION
1992 
 
1993 
    This routine is used to evaluate the comparison operation indicated by
1994 
    op on the integer constant expressions a and b.  Any necessary operand
1995 
    conversions and arithmetic type conversions have already been performed
1996 
    on a and b.
1997 
*/
1998 
 
6 7u83 1999 
EXP
2000 
make_compare_nat(NTEST op, EXP a, EXP b)
2 7u83 2001 
{
6 7u83 2002 
	EXP e;
2003 
	NAT n = DEREF_nat(exp_int_lit_nat(a));
2004 
	NAT m = DEREF_nat(exp_int_lit_nat(b));
2005 
	int c = compare_nat(n, m);
2006 
	if (c == 0) {
2007 
		/* n and m are definitely equal */
2008 
		if (!overflow_exp(a)) {
2009 
			unsigned cond = BOOL_FALSE;
2010 
			switch (op) {
2011 
			case ntest_eq:
2012 
			case ntest_less_eq:
2013 
			case ntest_greater_eq:
2014 
				cond = BOOL_TRUE;
2015 
				break;
2016 
			}
2017 
			e = make_bool_exp(cond, exp_compare_tag);
2018 
			return(e);
2 7u83 2019 
		}
6 7u83 2020 
	} else if (c == 1) {
2021 
		/* n is definitely greater than m */
2022 
		if (!overflow_exp(a) && !overflow_exp(b)) {
2023 
			unsigned cond = BOOL_FALSE;
2024 
			switch (op) {
2025 
			case ntest_not_eq:
2026 
			case ntest_greater:
2027 
			case ntest_greater_eq:
2028 
				cond = BOOL_TRUE;
2029 
				break;
2030 
			}
2031 
			e = make_bool_exp(cond, exp_compare_tag);
2032 
			return(e);
2 7u83 2033 
		}
6 7u83 2034 
	} else if (c == -1) {
2035 
		/* n is definitely less than m */
2036 
		if (!overflow_exp(a) && !overflow_exp(b)) {
2037 
			unsigned cond = BOOL_FALSE;
2038 
			switch (op) {
2039 
			case ntest_not_eq:
2040 
			case ntest_less:
2041 
			case ntest_less_eq:
2042 
				cond = BOOL_TRUE;
2043 
				break;
2044 
			}
2045 
			e = make_bool_exp(cond, exp_compare_tag);
2046 
			return(e);
2 7u83 2047 
		}
2048 
	}
2049 
 
6 7u83 2050 
	/* Calculated values require further calculation */
2051 
	a = calc_exp_value(a);
2052 
	b = calc_exp_value(b);
2053 
	MAKE_exp_compare(type_bool, op, a, b, e);
2054 
	MAKE_nat_calc(e, n);
2055 
	MAKE_exp_int_lit(type_bool, n, exp_compare_tag, e);
2056 
	return(e);
2 7u83 2057 
}
2058 
 
2059 
 
2060 
/*
2061 
    EVALUATE A CONSTANT CONDITIONAL OPERATION
2062 
 
2063 
    This routine is used to evaluate the conditional operation 'a ? b : c'
2064 
    when a, b and c are all integer constant expressions.  Any necessary
2065 
    operand conversions and arithmetic type conversions have already been
2066 
    performed on a, b and c.
2067 
*/
2068 
 
6 7u83 2069 
EXP
2070 
make_cond_nat(EXP a, EXP b, EXP c)
2 7u83 2071 
{
6 7u83 2072 
	EXP e;
2073 
	TYPE t = DEREF_type(exp_type(b));
2074 
	NAT n = DEREF_nat(exp_int_lit_nat(b));
2075 
	NAT m = DEREF_nat(exp_int_lit_nat(c));
2076 
	unsigned p = test_bool_exp(a);
2077 
	if (p == BOOL_TRUE && !overflow_exp(c)) {
2078 
		/* EMPTY */
2079 
	} else if (p == BOOL_FALSE && !overflow_exp(b)) {
2080 
		n = m;
2081 
	} else {
2082 
		/* Calculated case */
2083 
		b = calc_exp_value(b);
2084 
		c = calc_exp_value(c);
2085 
		MAKE_exp_if_stmt(t, a, b, c, NULL_id, e);
2086 
		MAKE_nat_calc(e, n);
2087 
	}
2088 
	MAKE_exp_int_lit(t, n, exp_if_stmt_tag, e);
2089 
	return(e);
2 7u83 2090 
}
2091 
 
2092 
 
2093 
/*
2094 
    DOES ONE EXPRESSION DIVIDE ANOTHER?
2095 
 
2096 
    This routine returns true if a and b are both integer constant
2097 
    expressions and b divides a.
2098 
*/
2099 
 
6 7u83 2100 
int
2101 
divides_nat(EXP a, EXP b)
2 7u83 2102 
{
6 7u83 2103 
	if (IS_exp_int_lit(a) && IS_exp_int_lit(b)) {
2104 
		unsigned long vn, vm;
2105 
		NAT n = DEREF_nat(exp_int_lit_nat(a));
2106 
		NAT m = DEREF_nat(exp_int_lit_nat(b));
2107 
		if (IS_nat_neg(n)) {
2108 
			n = DEREF_nat(nat_neg_arg(n));
2109 
		}
2110 
		if (IS_nat_neg(m)) {
2111 
			m = DEREF_nat(nat_neg_arg(m));
2112 
		}
2113 
		vn = get_nat_value(n);
2114 
		vm = get_nat_value(m);
2115 
		if (vm == 0) {
2116 
			return(1);
2117 
		}
2118 
		if (vn == EXTENDED_MAX || vm == EXTENDED_MAX) {
2119 
			return(0);
2120 
		}
2121 
		if ((vn % vm) == 0) {
2122 
			return(1);
2123 
		}
2124 
	}
2125 
	return(0);
2 7u83 2126 
}
2127 
 
2128 
 
2129 
/*
2130 
    EVALUATE A CONSTANT CONDITION
2131 
 
2132 
    This routine evaluates the boolean expression e, returning BOOL_FALSE,
2133 
    BOOL_TRUE or BOOL_UNKNOWN depending on whether it is always false,
2134 
    always true, or constant, but indeterminant.  BOOL_INVALID is returned
2135 
    for non-constant expressions.
2136 
*/
2137 
 
6 7u83 2138 
unsigned
2139 
eval_const_cond(EXP e)
2 7u83 2140 
{
6 7u83 2141 
	if (!IS_NULL_exp(e)) {
2142 
		switch (TAG_exp(e)) {
2143 
		case exp_int_lit_tag: {
2144 
			/* Boolean constants */
2145 
			unsigned b = test_bool_exp(e);
2146 
			return(b);
2 7u83 2147 
		}
6 7u83 2148 
		case exp_not_tag: {
2149 
			/* Logical negation */
2150 
			EXP a = DEREF_exp(exp_not_arg(e));
2151 
			unsigned b = eval_const_cond(a);
2152 
			if (b == BOOL_FALSE) {
2153 
				return(BOOL_TRUE);
2154 
			}
2155 
			if (b == BOOL_TRUE) {
2156 
				return(BOOL_FALSE);
2157 
			}
2158 
			return(b);
2 7u83 2159 
		}
6 7u83 2160 
		case exp_log_and_tag: {
2161 
			/* Logical and */
2162 
			EXP a1 = DEREF_exp(exp_log_and_arg1(e));
2163 
			EXP a2 = DEREF_exp(exp_log_and_arg2(e));
2164 
			unsigned b1 = eval_const_cond(a1);
2165 
			unsigned b2 = eval_const_cond(a2);
2166 
			if (b1 == BOOL_FALSE || b2 == BOOL_FALSE) {
2167 
				return(BOOL_FALSE);
2168 
			}
2169 
			if (b1 == BOOL_TRUE && b2 == BOOL_TRUE) {
2170 
				return(BOOL_TRUE);
2171 
			}
2172 
			if (b1 == BOOL_INVALID) {
2173 
				return(BOOL_INVALID);
2174 
			}
2175 
			if (b2 == BOOL_INVALID) {
2176 
				return(BOOL_INVALID);
2177 
			}
2178 
			return(BOOL_UNKNOWN);
2 7u83 2179 
		}
6 7u83 2180 
		case exp_log_or_tag: {
2181 
			/* Logical or */
2182 
			EXP a1 = DEREF_exp(exp_log_or_arg1(e));
2183 
			EXP a2 = DEREF_exp(exp_log_or_arg2(e));
2184 
			unsigned b1 = eval_const_cond(a1);
2185 
			unsigned b2 = eval_const_cond(a2);
2186 
			if (b1 == BOOL_TRUE || b2 == BOOL_TRUE) {
2187 
				return(BOOL_TRUE);
2188 
			}
2189 
			if (b1 == BOOL_FALSE && b2 == BOOL_FALSE) {
2190 
				return(BOOL_FALSE);
2191 
			}
2192 
			if (b1 == BOOL_INVALID) {
2193 
				return(BOOL_INVALID);
2194 
			}
2195 
			if (b2 == BOOL_INVALID) {
2196 
				return(BOOL_INVALID);
2197 
			}
2198 
			return(BOOL_UNKNOWN);
2 7u83 2199 
		}
6 7u83 2200 
		case exp_test_tag: {
2201 
			/* Test against zero */
2202 
			EXP a = DEREF_exp(exp_test_arg(e));
2203 
			NTEST op = DEREF_ntest(exp_test_tst(e));
2204 
			if (IS_exp_null(a)) {
2205 
				/* Null pointers */
2206 
				if (op == ntest_eq) {
2207 
					return(BOOL_TRUE);
2208 
				}
2209 
				if (op == ntest_not_eq) {
2210 
					return(BOOL_FALSE);
2211 
				}
2212 
			}
2213 
			break;
2 7u83 2214 
		}
6 7u83 2215 
		case exp_location_tag: {
2216 
			/* Conditions can contain locations */
2217 
			EXP a = DEREF_exp(exp_location_arg(e));
2218 
			return(eval_const_cond(a));
2219 
		}
2220 
		}
2221 
		if (is_const_exp(e, -1)) {
2222 
			return(BOOL_UNKNOWN);
2223 
		}
2 7u83 2224 
	}
6 7u83 2225 
	return(BOOL_INVALID);
2 7u83 2226 
}
2227 
 
2228 
 
2229 
/*
2230 
    IS AN INTEGER CONSTANT EXPRESSION ZERO?
2231 
 
2232 
    This routine checks whether the expression a is a zero integer constant.
2233 
    It is used to identify circumstances when zero is actually the null
2234 
    pointer etc.
2235 
*/
2236 
 
6 7u83 2237 
int
2238 
is_zero_exp(EXP a)
2 7u83 2239 
{
6 7u83 2240 
	if (!IS_NULL_exp(a) && IS_exp_int_lit(a)) {
2241 
		NAT n = DEREF_nat(exp_int_lit_nat(a));
2242 
		return(is_zero_nat(n));
2243 
	}
2244 
	return(0);
2 7u83 2245 
}
2246 
 
2247 
 
2248 
/*
2249 
    IS AN INTEGER CONSTANT A LITERAL?
2250 
 
2251 
    This routine checks whether the integer constant expression a is an
2252 
    integer literal or is the result of a constant evaluation.  This
2253 
    information is recorded in the etag field of the expression.  It
2254 
    returns 2 if the literal was precisely '0'.
2255 
*/
2256 
 
6 7u83 2257 
int
2258 
is_literal(EXP a)
2 7u83 2259 
{
6 7u83 2260 
	if (IS_exp_int_lit(a)) {
2261 
		unsigned etag = DEREF_unsigned(exp_int_lit_etag(a));
2262 
		if (etag == exp_int_lit_tag) {
2263 
			return(1);
2264 
		}
2265 
		if (etag == exp_null_tag) {
2266 
			return(2);
2267 
		}
2268 
		if (etag == exp_identifier_tag) {
2269 
			return(1);
2270 
		}
2271 
	}
2272 
	return(0);
2 7u83 2273 
}
2274 
 
2275 
 
2276 
/*
2277 
    FIND A SMALL FLOATING POINT LITERAL
2278 
 
2279 
    This routine returns the nth literal associated with the floating point
2280 
    type t.  The null literal is returned if n is too large.
2281 
*/
2282 
 
6 7u83 2283 
FLOAT
2284 
get_float(TYPE t, int n)
2 7u83 2285 
{
6 7u83 2286 
	FLOAT_TYPE ft = DEREF_ftype(type_floating_rep(t));
2287 
	LIST(FLOAT)fp = DEREF_list(ftype_small(ft));
2288 
	while (!IS_NULL_list(fp)) {
2289 
		if (n == 0) {
2290 
			FLOAT flt = DEREF_flt(HEAD_list(fp));
2291 
			return(flt);
2292 
		}
2293 
		n--;
2294 
		fp = TAIL_list(fp);
2 7u83 2295 
	}
6 7u83 2296 
	return(NULL_flt);
2 7u83 2297 
}
2298 
 
2299 
 
2300 
/*
2301 
    INITIALISE A FLOATING POINT TYPE
2302 
 
2303 
    This routine initialises the floating point type ft by creating its
2304 
    list of small literal values.
2305 
*/
2306 
 
6 7u83 2307 
void
2308 
init_float(FLOAT_TYPE ft)
2 7u83 2309 
{
6 7u83 2310 
	int n;
2311 
	NAT z = small_nat[0];
2312 
	string fp = small_number[0];
2313 
	LIST(FLOAT)p = NULL_list(FLOAT);
2314 
	for (n = SMALL_FLT_SIZE - 1; n >= 0; n--) {
2315 
		FLOAT f;
2316 
		string ip = small_number[n];
2317 
		MAKE_flt_simple(ip, fp, z, f);
2318 
		CONS_flt(f, p, p);
2319 
	}
2320 
	COPY_list(ftype_small(ft), p);
2321 
	return;
2 7u83 2322 
}
2323 
 
2324 
 
2325 
/*
2326 
    INITIALISE CONSTANT EVALUATION ROUTINES
2327 
 
2328 
    This routine initialises the small_nat array and the buffers used in
2329 
    the constant evaluation routines.
2330 
*/
2331 
 
6 7u83 2332 
void
2333 
init_constant(void)
2 7u83 2334 
{
6 7u83 2335 
	int n = 0;
2336 
	while (n < SMALL_NAT_ALLOC) {
2337 
		IGNORE make_small_nat(n);
2338 
		IGNORE make_small_nat(-n);
2339 
		n++;
2340 
	}
2341 
	while (n < SMALL_NAT_SIZE) {
2342 
		small_nat[n] = NULL_nat;
2343 
		small_neg_nat[n] = NULL_nat;
2344 
		n++;
2345 
	}
2346 
	small_neg_nat[0] = small_nat[0];
2347 
	CONS_unsigned(0, NULL_list(unsigned), small_nat_1);
2348 
	CONS_unsigned(0, NULL_list(unsigned), small_nat_2);
2349 
	small_number[0] = ustrlit("0");
2350 
	small_number[1] = ustrlit("1");
2351 
	return;
2 7u83 2352 
}