WebSVN – tendra.SVN – Blame – /branches/tendra5/src/producers/common/parse/constant.c

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

Subversion Repositories tendra.SVN

(root)/branches/tendra5/src/producers/common/parse/constant.c – Rev 2