Subversion Repositories tendra.SVN

Rev

Rev 2 | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

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