WebSVN – tendra.SVN – Blame – //branches/tendra5/src/installers/680x0/common/evaluate.c

Rev	Author	Line No.	Line
2	7u83	1	`/*`
		2	`Crown Copyright (c) 1996`
		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	`VERSION INFORMATION`
		31	`===================`
		32
		33	`--------------------------------------------------------------------------`
		34	$Header: /u/g/release/CVSROOT/Source/src/installers/680x0/common/evaluate.c,v 1.1.1.1 1998/01/17 15:55:49 release Exp $
		35	`--------------------------------------------------------------------------`
		36	$Log: evaluate.c,v $
		37	`* Revision 1.1.1.1 1998/01/17 15:55:49 release`
		38	`* First version to be checked into rolling release.`
		39	`*`
		40	`Revision 1.3 1997/11/09 14:09:29 ma`
		41	`Fixed init with null_tag.`
		42
		43	`Revision 1.2 1997/10/29 10:22:13 ma`
		44	`Replaced use_alloca with has_alloca.`
		45
		46	`Revision 1.1.1.1 1997/10/13 12:42:50 ma`
		47	`First version.`
		48
		49	`Revision 1.5 1997/10/13 08:49:23 ma`
		50	`Made all pl_tests for general proc & exception handling pass.`
		51
		52	`Revision 1.4 1997/09/25 06:44:57 ma`
		53	`All general_proc tests passed`
		54
		55	`Revision 1.3 1997/06/18 10:09:27 ma`
		56	`Checking in before merging with Input Baseline changes.`
		57
		58	`Revision 1.2 1997/04/20 11:30:24 ma`
		59	`Introduced gcproc.c & general_proc.[ch].`
		60	`Added cases for apply_general_proc next to apply_proc in all files.`
		61
		62	`Revision 1.1.1.1 1997/03/14 07:50:11 ma`
		63	`Imported from DRA`
		64
		65	`* Revision 1.1.1.1 1996/09/20 10:56:53 john`
		66	`*`
		67	`* Revision 1.2 1996/07/05 14:20:08 john`
		68	`* Changes for spec 3.1`
		69	`*`
		70	`* Revision 1.1.1.1 1996/03/26 15:45:11 john`
		71	`*`
		72	`* Revision 1.5 94/06/29 14:20:32 14:20:32 ra (Robert Andrews)`
		73	`* Turn out of range floating point constants to infinity if`
		74	`* flpt_const_overflow_fail is false.`
		75	`*`
		76	`* Revision 1.4 94/02/21 15:58:07 15:58:07 ra (Robert Andrews)`
		77	`* is_comm now returns int, not bool.`
		78	`*`
		79	`* Revision 1.3 93/11/19 16:18:46 16:18:46 ra (Robert Andrews)`
		80	`* Added minptr_tag case. Corrected floating point bit pattern routines`
		81	`* for little endian case.`
		82	`*`
		83	`* Revision 1.2 93/05/24 15:56:15 15:56:15 ra (Robert Andrews)`
		84	`* Added ext_eval_name, which is meant to help in illegal constant error`
		85	`* messages.`
		86	`*`
		87	`* Revision 1.1 93/02/22 17:15:32 17:15:32 ra (Robert Andrews)`
		88	`* Initial revision`
		89	`*`
		90	`--------------------------------------------------------------------------`
		91	`*/`
		92
		93
		94	`#include "config.h"`
		95	`#if FS_NO_ANSI_ENVIRON`
		96	`#include <floatingpoint.h>`
		97	`#else`
		98	`#include <float.h>`
		99	`#endif`
		100	`#include "common_types.h"`
		101	`#include "assembler.h"`
		102	`#include "basicread.h"`
		103	`#include "expmacs.h"`
		104	`#include "instrs.h"`
		105	`#include "shapemacs.h"`
		106	`#include "fbase.h"`
		107	`#include "flpt.h"`
		108	`#include "evaluate.h"`
		109	`#include "mach.h"`
		110	`#include "mach_ins.h"`
		111	`#include "mach_op.h"`
		112	`#include "codex.h"`
		113	`#include "tags.h"`
		114	`#include "translate.h"`
		115	`#include "utility.h"`
		116	`#include "f64.h"`
		117	`#if have_diagnostics`
		118	`#include "xdb_basics.h"`
		119	`#endif`
		120
		121	`extern int is_comm PROTO_S ( ( exp ) ) ;`
		122	`extern char get_pointer_name PROTO_S ( ( void ) ) ;`
		123	`extern int flpt_const_overflow_fail ;`
		124	`extern double atof PROTO_S ( ( CONST char * ) ) ;`
		125	`extern double frexp PROTO_S ( ( double, int * ) ) ;`
		126
		127
		128	`#define par_pl 1 /* On the stack (procedure argument) */`
		129	`#define var_pl 2 /* On the stack (allocated variable) */`
		130
		131	`#ifndef tdf3`
		132	`#define par2_pl 4 /* Caller arguments accessed by use of A5 */`
		133	`#define par3_pl 5 /* Caller arguments accessed by use of SP */`
		134	`#endif`
		135
		136	`/*`
		137	`NAME OF THE CONSTANT BEING EVALUATED`
		138	`*/`
		139
		140	`static char *ext_eval_name = "???" ;`
		141
		142
		143	`/*`
		144	`LIST OF EXTERNAL CONSTANTS`
		145
		146	`All external constants created are formed into a bro-list.`
		147	`*/`
		148
		149	`exp const_list = nilexp ;`
		150
		151
		152	`/*`
		153	`DATA CONSTANTS`
		154
		155	`In outputting data constants, current_op is the list of values currently`
		156	`being built up. These values are all of size current_sz. Values not`
		157	`yet of this size are built up in pvalue, which contains psz bits.`
		158	`*/`
		159
		160	`static mach_op *current_op = null ;`
		161	`static long current_sz = 0 ;`
		162
		163
		164	`/*`
		165	`OUTPUT AN EVALUATION INSTRUCTION`
		166
		167	`An instruction corresponding to current_op is output, and current_op`
		168	`is reset.`
		169	`*/`
		170
		171	`static void eval_instr`
		172	`PROTO_Z ()`
		173	`{`
		174	`if ( current_op ) {`
		175	`int s = ins ( current_sz, m_as_byte, m_as_short, m_as_long ) ;`
		176	`make_instr ( s, current_op, null, 0 ) ;`
		177	`current_op = null ;`
		178	`}`
		179	`current_sz = 0 ;`
		180	`return ;`
		181	`}`
		182
		183
		184	`/*`
		185	`OUTPUT AN OPERAND`
		186
		187	`The operand op of size sz is added to current_op.`
		188	`*/`
		189
		190	`void eval_op`
		191	`PROTO_N ( ( sz, op ) )`
		192	`PROTO_T ( long sz X mach_op *op )`
		193	`{`
		194	`static mach_op *last_op ;`
		195	`if ( sz != current_sz ) {`
		196	`eval_instr () ;`
		197	`current_op = op ;`
		198	`current_sz = sz ;`
		199	`} else {`
		200	`last_op->of = op ;`
		201	`}`
		202	`last_op = op ;`
		203	`return ;`
		204	`}`
		205
		206	`/*`
		207	`EVALUATE AN EXPRESSION`
		208
		209	`The expression e, is evaluated and the integer result is returned.`
		210	`(from trans386)`
		211	`*/`
		212	`extern int PIC_code ;`
		213
		214	`long evalexp`
		215	`PROTO_N ( (e) )`
		216	`PROTO_T ( exp e )`
		217	`{`
		218	`switch (name(e)) {`
		219	`case val_tag:`
		220	`case null_tag:`
		221	`case top_tag:`
		222	`{`
		223	`int k = no ( e ) ;`
		224	`if ( is_offset ( e ) ) k /= 8 ;`
		225	`return ( k );`
		226	`}`
		227	`case bitf_to_int_tag:`
		228	`{`
		229	`return evalexp (son (e));`
		230	`}`
		231	`case int_to_bitf_tag:`
		232	`{`
		233	`long w = evalexp (son (e));`
		234	`if (shape_align(sh(e)) != 1) {`
		235	`failer ("should be align 1");`
		236	`}`
		237	`if (shape_size(sh(e)) != 32) {`
		238	`w &= ((1 << shape_size(sh(e))) - 1);`
		239	`}`
		240	`return w;`
		241	`}`
		242	`case not_tag:`
		243	`{`
		244	`return (~evalexp (son (e)));`
		245	`}`
		246	`case and_tag:`
		247	`{`
		248	`return (evalexp (son (e)) & evalexp (bro (son (e))));`
		249	`}`
		250	`case or_tag:`
		251	`{`
		252	`return (evalexp (son (e)) \| evalexp (bro (son (e))));`
		253	`}`
		254	`case xor_tag:`
		255	`{`
		256	`return (evalexp (son (e)) ^ evalexp (bro (son (e))));`
		257	`}`
		258
		259	`case shr_tag:`
		260	`{`
		261	`return (evalexp (son (e)) >> evalexp (bro (son (e))));`
		262	`}`
		263
		264	`case shl_tag:`
		265	`{`
		266	`return (evalexp (son (e)) << evalexp (bro (son (e))));`
		267	`}`
		268
		269	`case concatnof_tag:`
		270	`{`
		271	`long wd = evalexp (son (e));`
		272	`return (wd \| (evalexp (bro (son (e))) << shape_size(sh(son(e)))));`
		273	`}`
		274
		275	`case clear_tag:`
		276	`{`
		277	`if (shape_size(sh(e)) <= 32)`
		278	`return 0;`
		279	`break;`
		280	`}`
		281	`case env_offset_tag:`
		282	`{`
		283	`exp ident_exp = son(e) ;`
		284
		285	`if (ismarked(ident_exp)) {`
		286	`long offval ;`
		287	`switch (ptno(ident_exp)) {`
		288	`case var_pl:`
		289	`offval = -no(ident_exp)/8;`
		290	`break;`
		291	`case par2_pl:`
		292	`offval = no(ident_exp)/8;`
		293	`break;`
		294	`case par3_pl:`
		295	`case par_pl:`
		296	`default:`
		297	`offval = no(ident_exp)/8 + 8;`
		298	`}`
		299	`return offval ;`
		300	`}`
		301	`break;`
		302	`}`
		303	`case env_size_tag:`
		304	`{`
		305	`dec * et = brog(son(son(e)));`
		306	`if (et -> dec_u.dec_val.processed)`
		307	`return (et -> dec_u.dec_val.index);`
		308	`break;`
		309	`}`
		310	`case offset_add_tag:`
		311	`{`
		312	`return (evalexp(son(e))+evalexp(bro(son(e))));`
		313	`}`
		314	`case offset_max_tag:`
		315	`{`
		316	`long a = evalexp(son(e));`
		317	`long b = evalexp(bro(son(e)));`
		318	`return (a > b ? a : b);`
		319	`}`
		320	`case offset_pad_tag:`
		321	`{`
		322	`return( rounder(evalexp(son(e)), shape_align(sh(e)) / 8));`
		323	`}`
		324	`case offset_mult_tag:`
		325	`{`
		326	`return (evalexp(son(e))*evalexp(bro(son(e))));`
		327	`}`
		328	`case offset_div_tag:`
		329	`case offset_div_by_int_tag:`
		330	`{`
		331	`long n = evalexp(bro(son(e))) ;`
		332	`if ( n == 0 ) {`
		333	`n++;`
		334	`error("evalexp: divide by zero");`
		335	`}`
		336	`return (evalexp(son(e)) / n);`
		337	`}`
		338	`case offset_subtract_tag:`
		339	`{`
		340	`return (evalexp(son(e))-evalexp(bro(son(e))));`
		341	`}`
		342	`case offset_negate_tag:`
		343	`{`
		344	`return (- evalexp(son(e)));`
		345	`}`
		346	`case seq_tag:`
		347	`{`
		348	`if (name(son(son(e))) == prof_tag && last(son(son(e))))`
		349	`return (evalexp(bro(son(e))));`
		350	`break;`
		351	`}`
		352	`case cont_tag:`
		353	`{`
		354	`if (PIC_code && name(son(e)) == name_tag && isglob(son(son(e)))`
		355	`&& son(son(son(e))) != nilexp`
		356	`&& !(brog(son(son(e))) -> dec_u.dec_val.dec_var))`
		357	`return (evalexp(son(son(son(e)))));`
		358	`break;`
		359	`}`
		360	`}`
		361	`error ( "Illegal constant expression in %s", ext_eval_name ) ;`
		362	`return ( 0 ) ;`
		363	`}`
		364
		365	`/*`
		366	`EVALUATE AN INTEGER VALUE`
		367
		368	`The expression e, representing an integer value, is evaluated.`
		369	`*/`
		370
		371	`static void evalno`
		372	`PROTO_N ( ( e ) )`
		373	`PROTO_T ( exp e )`
		374	`{`
		375	`mach_op *op ;`
		376	`long sz = shape_size ( sh ( e ) ) ;`
		377	`long k = evalexp(e);`
		378
		379	`switch ( sz ) {`
		380
		381	`case 8 : {`
		382	`op = make_value ( k & 0xff ) ;`
		383	`eval_op ( L8, op ) ;`
		384	`return ;`
		385	`}`
		386
		387	`case 16 : {`
		388	`op = make_value ( ( k >> 8 ) & 0xff ) ;`
		389	`eval_op ( L8, op ) ;`
		390	`op = make_value ( k & 0xff ) ;`
		391	`eval_op ( L8, op ) ;`
		392	`return ;`
		393	`}`
		394
		395	`case 32 : {`
		396	`op = make_value ( ( k >> 24 ) & 0xff ) ;`
		397	`eval_op ( L8, op ) ;`
		398	`op = make_value ( ( k >> 16 ) & 0xff ) ;`
		399	`eval_op ( L8, op ) ;`
		400	`op = make_value ( ( k >> 8 ) & 0xff ) ;`
		401	`eval_op ( L8, op ) ;`
		402	`op = make_value ( k & 0xff ) ;`
		403	`eval_op ( L8, op ) ;`
		404	`return ;`
		405	`}`
		406	`case 64 : {`
		407	`flt64 bval;`
		408	`bval = exp_to_f64(e);`
		409	`op = make_value((bval.small>>24) & 0xff);`
		410	`eval_op(L8,op);`
		411	`op = make_value((bval.small>>16) & 0xff);`
		412	`eval_op(L8,op);`
		413	`op = make_value((bval.small>>8) & 0xff);`
		414	`eval_op(L8,op);`
		415	`op = make_value(bval.small & 0xff);`
		416	`eval_op(L8,op);`
		417
		418	`op = make_value((bval.big>>24) & 0xff);`
		419	`eval_op(L8,op);`
		420	`op = make_value((bval.big>>16) & 0xff);`
		421	`eval_op(L8,op);`
		422	`op = make_value((bval.big>>8) & 0xff);`
		423	`eval_op(L8,op);`
		424	`op = make_value(bval.big & 0xff);`
		425	`eval_op(L8,op);`
		426	`return;`
		427	`}`
		428	`}`
		429	`error ( "Illegal integer value in %s", ext_eval_name ) ;`
		430	`return ;`
		431	`}`
		432
		433
		434	`/*`
		435	`CONVERT A REAL VALUE TO A BITPATTERN`
		436
		437	`This routine converts the real constant e into an array of longs`
		438	`giving the bitpattern corresponding to this constant. Although`
		439	`care has been taken, this may not work properly on all machines`
		440	`(although it should for all IEEE machines). It returns NULL if`
		441	`it cannot convert the number sufficiently accurately.`
		442	`*/`
		443
		444	`long *realrep`
		445	`PROTO_N ( ( e ) )`
		446	`PROTO_T ( exp e )`
		447	`{`
		448	`int i, n, ex ;`
		449	`double d, m ;`
		450	`char bits [128] ;`
		451	`static long longs [4] ;`
		452	`int exp_bits, mant_bits ;`
		453	`long sz = shape_size ( sh ( e ) ) ;`
		454
		455	`/* Find size of exponent and mantissa */`
		456	`if ( sz == 32 ) {`
		457	`exp_bits = 8 ;`
		458	`mant_bits = 23 ;`
		459	`} else if ( sz == 64 ) {`
		460	`exp_bits = 11 ;`
		461	`mant_bits = 52 ;`
		462	`} else {`
		463	`exp_bits = 15 ;`
		464	`mant_bits = 96 /* or 112? */ ;`
		465	`}`
		466
		467	`#if ( FBASE == 10 )`
		468
		469	`if ( !convert_floats ) return ( NULL ) ;`
		470
		471	`if ( name ( e ) == real_tag ) {`
		472	`/* Calculate value */`
		473	`flt *f = flptnos + no ( e ) ;`
		474	`char fbuff [100] ;`
		475	`char *p = fbuff ;`
		476	`if ( f->exp <= DBL_MIN_10_EXP \|\| f->exp >= DBL_MAX_10_EXP ) {`
		477	`/* Reject anything that won't fit into a double */`
		478	`return ( NULL ) ;`
		479	`}`
		480	`if ( f->sign < 0 ) *( p++ ) = '-' ;`
		481	`*( p++ ) = '0' + f->mant [0] ;`
		482	`*( p++ ) = '.' ;`
		483	`for ( i = 1 ; i < MANT_SIZE ; i++ ) *( p++ ) = '0' + f->mant [i] ;`
		484	`sprintf ( p, "e%d", ( int ) f->exp ) ;`
		485	`d = atof ( fbuff ) ;`
		486	`if ( sz == 32 ) {`
		487	`/* Round floats */`
		488	`static float fd ;`
		489	`fd = ( float ) d ;`
		490	`d = ( double ) fd ;`
		491	`}`
		492	`} else {`
		493	`error ( "Illegal floating-point constant" ) ;`
		494	`return ( NULL ) ;`
		495	`}`
		496
		497	`/* Deal with 0 */`
		498	`if ( d == 0.0 ) {`
		499	`for ( i = 0 ; i < sz / 32 ; i++ ) longs [i] = 0 ;`
		500	`return ( longs ) ;`
		501	`}`
		502
		503	`/* Fill in sign */`
		504	`if ( d < 0.0 ) {`
		505	`bits [0] = 1 ;`
		506	`d = -d ;`
		507	`} else {`
		508	`bits [0] = 0 ;`
		509	`}`
		510
		511	`/* Work out mantissa and exponent */`
		512	`m = frexp ( d, &ex ) ;`
		513	`m = 2.0 * m - 1.0 ;`
		514	`ex-- ;`
		515
		516	`/* Fill in mantissa */`
		517	`for ( i = 1 ; i <= mant_bits ; i++ ) {`
		518	`int j = exp_bits + i ;`
		519	`m *= 2.0 ;`
		520	`if ( m >= 1.0 ) {`
		521	`m -= 1.0 ;`
		522	`bits [j] = 1 ;`
		523	`} else {`
		524	`bits [j] = 0 ;`
		525	`}`
		526	`}`
		527
		528	`#else`
		529
		530	`if ( name ( e ) == real_tag ) {`
		531	`int j, k = -1 ;`
		532	`flt *f = flptnos + no ( e ) ;`
		533
		534	`/* Deal with 0 */`
		535	`if ( f->sign == 0 ) {`
		536	`for ( i = 0 ; i < sz / 32 ; i++ ) longs [i] = 0 ;`
		537	`return ( longs ) ;`
		538	`}`
		539
		540	`/* Fill in sign */`
		541	`bits [0] = ( f->sign < 0 ? 1 : 0 ) ;`
		542
		543	`/* Work out exponent */`
		544	`ex = FBITS * ( f->exp ) + ( FBITS - 1 ) ;`
		545
		546	`/* Fill in mantissa */`
		547	`for ( i = 0 ; i < MANT_SIZE ; i++ ) {`
		548	`for ( j = FBITS - 1 ; j >= 0 ; j-- ) {`
		549	`if ( ( f->mant [i] ) & ( 1 << j ) ) {`
		550	`if ( k >= 0 ) {`
		551	`if ( k < sz ) bits [k] = 1 ;`
		552	`k++ ;`
		553	`} else {`
		554	`/* Ignore first 1 */`
		555	`k = exp_bits + 1 ;`
		556	`}`
		557	`} else {`
		558	`if ( k >= 0 ) {`
		559	`if ( k < sz ) bits [k] = 0 ;`
		560	`k++ ;`
		561	`} else {`
		562	`/* Step over initial zeros */`
		563	`ex-- ;`
		564	`}`
		565	`}`
		566	`}`
		567	`}`
		568
		569	`} else {`
		570	`error ( "Illegal floating-point constant" ) ;`
		571	`return ( NULL ) ;`
		572	`}`
		573
		574	`#endif`
		575
		576	`/* Fill in exponent */`
		577	`ex += ( 1 << ( exp_bits - 1 ) ) - 1 ;`
		578	`if ( ex <= 0 \|\| ex >= ( 1 << exp_bits ) - 1 ) {`
		579	`if ( flpt_const_overflow_fail ) {`
		580	`error ( "Floating point constant out of range" ) ;`
		581	`}`
		582	`if ( sz == 32 ) {`
		583	`if ( bits [0] ) longs [0] = 0x80000000 ;`
		584	`longs [0] += 0x7f800000 ;`
		585	`} else {`
		586	`if ( bits [0] ) longs [0] = 0x80000000 ;`
		587	`longs [0] += 0x7ff00000 ;`
		588	`longs [1] = 0 ;`
		589	`}`
		590	`return ( longs ) ;`
		591	`}`
		592	`for ( i = 0 ; i < exp_bits ; i++ ) {`
		593	`int j = exp_bits - i ;`
		594	`bits [j] = ( ( ex & ( 1 << i ) ) ? 1 : 0 ) ;`
		595	`}`
		596
		597	`/* Convert bits to longs */`
		598	`n = ( sz / 32 ) - 1 ;`
		599	`for ( i = 0 ; i <= n ; i++ ) {`
		600	`int j ;`
		601	`long b0 = 0, b1 = 0, b2 = 0, b3 = 0 ;`
		602	`for ( j = 0 ; j < 8 ; j++ ) b0 = 2 * b0 + bits [ 32 * i + j ] ;`
		603	`for ( j = 8 ; j < 16 ; j++ ) b1 = 2 * b1 + bits [ 32 * i + j ] ;`
		604	`for ( j = 16 ; j < 24 ; j++ ) b2 = 2 * b2 + bits [ 32 * i + j ] ;`
		605	`for ( j = 24 ; j < 32 ; j++ ) b3 = 2 * b3 + bits [ 32 * i + j ] ;`
		606	`#if little_end`
		607	`longs [ n - i ] = ( b0 << 24 ) + ( b1 << 16 ) + ( b2 << 8 ) + b3 ;`
		608	`#else`
		609	`longs [i] = ( b0 << 24 ) + ( b1 << 16 ) + ( b2 << 8 ) + b3 ;`
		610	`#endif`
		611	`}`
		612	`return ( longs ) ;`
		613	`}`
		614
		615
		616	`/*`
		617	`EVALUATE A REAL VALUE`
		618
		619	`The expression e, representing a real value, is evaluated. There`
		620	`are two cases, depending on the macro convert_floats. Either the`
		621	`number itself or its representation in bits is output.`
		622	`*/`
		623
		624	`static void evalreal`
		625	`PROTO_N ( ( e ) )`
		626	`PROTO_T ( exp e )`
		627	`{`
		628	`long *p ;`
		629	`long sz = shape_size ( sh ( e ) ) ;`
		630	`eval_instr () ;`
		631	`p = realrep ( e ) ;`
		632	`if ( p ) {`
		633	`int i ;`
		634	`for ( i = 0 ; i < sz / 32 ; i++ ) {`
		635	`mach_op *op = make_value ( p [i] ) ;`
		636	`eval_op ( L32, op ) ;`
		637	`}`
		638	`} else {`
		639	`flt *f = flptnos + no ( e ) ;`
		640	`mach_op *op = make_float_data ( f ) ;`
		641	`int instr = insf ( sz, m_as_float, m_as_double, m_dont_know ) ;`
		642	`make_instr ( instr, op, null, 0 ) ;`
		643	`current_sz = 0 ;`
		644	`}`
		645	`return ;`
		646	`}`
		647
		648
		649	`/*`
		650	`CLEAR A NUMBER OF BYTES`
		651
		652	`The next n bits are cleared, either by padding with zeros or by`
		653	`using a space instruction.`
		654	`*/`
		655
		656	`static void clear_out`
		657	`PROTO_N ( ( n, isconst, al ) )`
		658	`PROTO_T ( long n X bool isconst X long al )`
		659	`{`
		660	`mach_op *op ;`
		661	`if ( isconst ) {`
		662	`while ( n > 0 ) {`
		663	`op = make_value ( 0 ) ;`
		664	`eval_op ( L8, op ) ;`
		665	`n-- ;`
		666	`}`
		667	`} else {`
		668	`eval_instr () ;`
		669	`current_sz = 0 ;`
		670	`if(n > 0) {`
		671	`op = make_int_data ( n ) ;`
		672	`make_instr ( m_as_space, op, null, 0 ) ;`
		673	`}`
		674	`current_sz = 0 ;`
		675	`}`
		676	`return ;`
		677	`}`
		678
		679
		680	`/*`
		681	`OUTPUT A CONSTANT`
		682
		683	`This is the main constant evaluation routine. The expression e is`
		684	`evaluated. al gives the alignment of e.`
		685	`*/`
		686
		687	`void evalaux`
		688	`PROTO_N ( ( e, isconst, al ) )`
		689	`PROTO_T ( exp e X bool isconst X long al )`
		690	`{`
		691	`switch ( name ( e ) ) {`
		692
		693	`case real_tag : {`
		694	`/* Real values */`
		695	`evalreal ( e ) ;`
		696	`return ;`
		697	`}`
		698
		699	`case compound_tag : {`
		700	`/* Compound values - deal with each component */`
		701	`exp val ;`
		702	`mach_op *op ;`
		703	`exp offe = son ( e ) ;`
		704	`long off ;`
		705	`long work = 0 ;`
		706	`long crt_off = 0 ;`
		707	`long bits_left = 0 ;`
		708	`int pad ;`
		709	`bool param_aligned = 0 ;`
		710
		711	`if ( offe == nilexp ) return ;`
		712
		713	`/* look ahead to determine if it is parameter aligned */`
		714	`val = bro ( offe ) ;`
		715	`if ( ! last ( val ) ) {`
		716	`offe = bro ( val ) ;`
		717	`if ( offe->shf->sonf.ald->al.al_val.al == 32 ) {`
		718	`param_aligned = 1 ;`
		719	`}`
		720	`}`
		721	`offe = son ( e ) ;`
		722
		723	`while ( 1 ) {`
		724	`off = no ( offe ) ;`
		725	`val = bro ( offe ) ;`
		726
		727	`if ( bits_left && off >= ( crt_off + 8 ) ) {`
		728	`op = make_value ( ( work >> 24 ) & 0xff ) ;`
		729	`eval_op ( L8, op ) ;`
		730	`crt_off += 8 ;`
		731	`work = 0 ;`
		732	`bits_left = 0 ;`
		733	`}`
		734
		735	`if ( off < crt_off ) {`
		736	`error ( "Compound constants out of order in %s",`
		737	`ext_eval_name ) ;`
		738	`}`
		739
		740	`if ( off > crt_off && !bits_left ) {`
		741	`clear_out ( ( off - crt_off ) / 8, 1, al ) ;`
		742	`crt_off = off ;`
		743	`}`
		744
		745	`if ( name ( sh ( val ) ) != bitfhd ) {`
		746	`pad = 0 ;`
		747	`if ( param_aligned ) {`
		748	`switch ( name ( sh ( val ) ) ) {`
		749	`case scharhd:`
		750	`case ucharhd:`
		751	`clear_out ( 3, 1, al ) ;`
		752	`crt_off += 3*8 ;`
		753	`break;`
		754	`case swordhd:`
		755	`case uwordhd:`
		756	`clear_out ( 2, 1, al ) ;`
		757	`crt_off += 2*8 ;`
		758	`break;`
		759	`}`
		760	`}`
		761
		762	`evalaux ( val, isconst, ( crt_off + al ) & 56 ) ;`
		763	`crt_off += shape_size ( sh ( val ) ) ;`
		764	`} else {`
		765	`long sz = shape_size ( sh ( val ) ) ;`
		766	`long offn = off - crt_off ;`
		767	`long nx, enx ;`
		768	`long extra_byte = 0 ;`
		769	`if ( name ( val ) == val_tag ) {`
		770	`nx = no ( val ) ;`
		771	`} else {`
		772	`nx = no ( son ( val ) ) ;`
		773	`}`
		774	`if ( sz > 32 - offn ) {`
		775	`enx = ( nx & 0xff ) ;`
		776	`extra_byte = 1 ;`
		777	`nx >>= 8 ;`
		778	`sz -= 8 ;`
		779	`}`
		780	`nx = ( nx & lo_bits [sz] ) << ( 32 - offn - sz ) ;`
		781	`work += nx ;`
		782	`bits_left = offn + sz ;`
		783	`while ( bits_left >= 8 ) {`
		784	`long v ;`
		785	`bits_left -= 8 ;`
		786	`v = ( work >> 24 ) & 0xff ;`
		787	`work <<= 8 ;`
		788	`if ( extra_byte ) {`
		789	`bits_left += 8 ;`
		790	`work += ( enx << ( 32 - bits_left ) ) ;`
		791	`extra_byte = 0 ;`
		792	`}`
		793	`op = make_value ( v ) ;`
		794	`eval_op ( L8, op ) ;`
		795	`crt_off += 8 ;`
		796	`}`
		797	`}`
		798
		799	`if ( last ( val ) ) {`
		800	`long left ;`
		801	`if ( bits_left ) {`
		802	`op = make_value ( ( work >> 24 ) & 0xff ) ;`
		803	`eval_op ( L8, op ) ;`
		804	`crt_off += 8 ;`
		805	`}`
		806	`left = shape_size ( sh ( e ) ) - crt_off ;`
		807	`if ( left > 0 ) clear_out ( left / 8, 1, al ) ;`
		808	`return ;`
		809	`}`
		810	`offe = bro ( val ) ;`
		811	`}`
		812	`/* Not reached */`
		813	`}`
		814
		815	`case name_tag : {`
		816	`/* External names */`
		817	`mach_op *op ;`
		818	`long n = no ( e ) ;`
		819	`long sz = shape_size ( sh ( e ) ) ;`
		820	`char *nm = brog ( son ( e ) )->dec_u.dec_val.dec_id ;`
		821	`op = make_extern_data ( nm, n / 8 ) ;`
		822	`eval_op ( sz, op ) ;`
		823	`return ;`
		824	`}`
		825
		826	`case string_tag : {`
		827	`/* Strings */`
		828	`long i ;`
		829	`long char_size = ( long ) props ( e ) ;`
		830	`long n = shape_size ( sh ( e ) ) / char_size ;`
		831	`switch ( char_size ) {`
		832
		833	`case 8 : {`
		834	`char *s = nostr ( e ) ;`
		835	`for ( i = 0 ; i < n ; i++ ) {`
		836	`long ch = ( long ) s [i] ;`
		837	`eval_op ( char_size, make_value ( ch ) ) ;`
		838	`}`
		839	`break ;`
		840	`}`
		841
		842	`case 16 : {`
		843	`short s = ( short ) nostr ( e ) ;`
		844	`for ( i = 0 ; i < n ; i++ ) {`
		845	`long ch = ( long ) s [i] ;`
		846	`eval_op ( char_size, make_value ( ch ) ) ;`
		847	`}`
		848	`break ;`
		849	`}`
		850
		851	`case 32 : {`
		852	`long s = ( long ) nostr ( e ) ;`
		853	`for ( i = 0 ; i < n ; i++ ) {`
		854	`long ch = s [i] ;`
		855	`eval_op ( char_size, make_value ( ch ) ) ;`
		856	`}`
		857	`break ;`
		858	`}`
		859
		860	`default : {`
		861	`error ( "Illegal string size in %s", ext_eval_name ) ;`
		862	`break ;`
		863	`}`
		864	`}`
		865	`return ;`
		866	`}`
		867
		868	`case res_tag : {`
		869	`/* Result values */`
		870	`shape ss = sh ( son ( e ) ) ;`
		871	`long sz = shape_size ( ss ) / 8 ;`
		872	`long sa = shape_align ( ss ) ;`
		873	`clear_out ( sz, isconst, sa ) ;`
		874	`return ;`
		875	`}`
		876	`case top_tag :`
		877	`case null_tag : {`
		878	`/* Null values */`
		879	`shape ss = sh ( e ) ;`
		880	`long sz = shape_size ( ss ) / 8 ;`
		881	`long sa = shape_align ( ss ) ;`
		882	`clear_out ( sz, isconst, sa ) ;`
		883	`return ;`
		884	`}`
		885
		886	`case ncopies_tag : {`
		887	`/* Multiple copies */`
		888	`long i ;`
		889	`exp t = son ( e ) ;`
		890	`long sa = shape_align ( sh ( t ) ) ;`
		891	`if ( is_comm ( t ) ) {`
		892	`long sz = rounder ( shape_size ( sh ( t ) ), sa ) / 8 ;`
		893	`clear_out ( sz * no ( e ), isconst, sa ) ;`
		894	`return ;`
		895	`}`
		896	`for ( i = 0 ; i < no ( e ) ; i++ ) evalaux ( t, isconst, sa ) ;`
		897	`return ;`
		898	`}`
		899
		900	`case nof_tag : {`
		901	`/* Array values */`
		902	`exp t = son ( e ) ;`
		903	`if ( t == nilexp ) return ;`
		904	`while ( 1 ) {`
		905	`evalaux ( t, isconst, al ) ;`
		906	`if ( last ( t ) ) return ;`
		907	`t = bro ( t ) ;`
		908	`}`
		909	`/* Not reached */`
		910	`}`
		911
		912	`case concatnof_tag : {`
		913	`/* Concatenated arrays */`
		914	`long a2 = ( al + shape_size ( son ( e ) ) ) & 63 ;`
		915	`evalaux ( son ( e ), isconst, al ) ;`
		916	`evalaux ( bro ( son ( e ) ), isconst, a2 ) ;`
		917	`return ;`
		918	`}`
		919
		920	`case chvar_tag :`
		921	`case int_to_bitf_tag : {`
		922	`/* Change variety */`
		923	`if ( name ( son ( e ) ) == val_tag ) {`
		924	`sh ( son ( e ) ) = sh ( e ) ;`
		925	`evalaux ( son ( e ), isconst, al ) ;`
		926	`return ;`
		927	`}`
		928	`error ( "Illegal change variety constant in %s", ext_eval_name ) ;`
		929	`return ;`
		930	`}`
		931
		932	`case chfl_tag : {`
		933	`/* Change floating variety */`
		934	`if ( name ( son ( e ) ) == real_tag ) {`
		935	`sh ( son ( e ) ) = sh ( e ) ;`
		936	`evalaux ( son ( e ), isconst, al ) ;`
		937	`return ;`
		938	`}`
		939	`error ( "Illegal change floating variety constant in %s",`
		940	`ext_eval_name ) ;`
		941	`return ;`
		942	`}`
		943
		944	`case clear_tag : {`
		945	`long sz = shape_size ( sh ( e ) ) / 8 ;`
		946	`clear_out ( sz, isconst, al ) ;`
		947	`return ;`
		948	`}`
		949	`#if 0`
		950	`case env_size_tag: {`
		951	`dec* d = brog(son(son(e)));`
		952	`mach_op* op = make_lab_data ( (long) d, 0 ) ;`
		953	`eval_op(L32,op);`
		954	`return ;`
		955	`}`
		956
		957	`case env_offset_tag : {`
		958	`/* Offsets */`
		959	`long offval;`
		960	`mach_op *op;`
		961	`exp ident_exp = son ( e ) ;`
		962	`op = make_lab_data ( (long) ident_exp, 0 ) ;`
		963	`eval_op(L32,op);`
		964
		965	`return ;`
		966	`}`
		967	`#endif`
		968	`case ident_tag : {`
		969	`/* Simple identifications */`
		970	`exp body = bro ( son ( e ) ) ;`
		971	`if ( name ( body ) == name_tag && son ( body ) == e ) {`
		972	`evalaux ( son ( e ), isconst, al ) ;`
		973	`return ;`
		974	`}`
		975	`break ;`
		976	`}`
		977
		978	`case minptr_tag : {`
		979	`exp p1 = son ( e ) ;`
		980	`exp p2 = bro ( p1 ) ;`
		981	`if ( name ( p1 ) == name_tag && name ( p2 ) == name_tag ) {`
		982	`long n = no ( p1 ) - no ( p2 ) ;`
		983	`long sz = shape_size ( sh ( e ) ) ;`
		984	`char *n1 = brog ( son ( p1 ) )->dec_u.dec_val.dec_id ;`
		985	`char *n2 = brog ( son ( p2 ) )->dec_u.dec_val.dec_id ;`
		986	`mach_op *op1 = new_mach_op () ;`
		987	`mach_op *op2 = new_mach_op () ;`
		988	`mach_op *op3 = new_mach_op () ;`
		989	`op1->type = MACH_EXT ;`
		990	`op1->def.str = n1 ;`
		991	`op1->plus = op2 ;`
		992	`op2->type = MACH_NEG ;`
		993	`op2->plus = op3 ;`
		994	`op3->type = MACH_EXT ;`
		995	`op3->def.str = n2 ;`
		996	`if ( n ) {`
		997	`mach_op *op4 = new_mach_op () ;`
		998	`op4->type = MACH_VAL ;`
		999	`op4->def.num = n ;`
		1000	`op3->plus = op4 ;`
		1001	`}`
		1002	`eval_op ( sz, op1 ) ;`
		1003	`return ;`
		1004	`}`
		1005	`break ;`
		1006	`}`
		1007	`default:`
		1008	`evalno ( e ) ;`
		1009	`}`
		1010	`}`
		1011
		1012
		1013	`#if 0`
		1014
		1015	`/*`
		1016	`IS A VALUE ZERO?`
		1017
		1018	`If so it can be put into the common area.`
		1019	`*/`
		1020
		1021	`static int is_comm`
		1022	`PROTO_N ( ( e ) )`
		1023	`PROTO_T ( exp e )`
		1024	`{`
		1025	`switch ( name ( e ) ) {`
		1026
		1027	`case val_tag : return ( no ( e ) ? 0 : 1 ) ;`
		1028
		1029	`case int_to_bitf_tag :`
		1030	`case chvar_tag : return ( is_comm ( son ( e ) ) ) ;`
		1031
		1032	`case real_tag : {`
		1033	`flpt f = no ( e ) ;`
		1034	`return ( flptnos [f].sign ? 0 : 1 ) ;`
		1035	`}`
		1036
		1037	`case compound_tag : {`
		1038	`exp t = son ( e ) ;`
		1039	`if ( t == nilexp ) return ( 1 ) ;`
		1040	`while ( 1 ) {`
		1041	`t = bro ( t ) ;`
		1042	`if ( name ( sh ( t ) ) != bitfhd ) {`
		1043	`if ( !is_comm ( t ) ) return ( 0 ) ;`
		1044	`} else {`
		1045	`if ( name ( t ) == val_tag ) {`
		1046	`if ( no ( t ) ) return ( 0 ) ;`
		1047	`} else {`
		1048	`if ( no ( son ( t ) ) ) return ( 0 ) ;`
		1049	`}`
		1050	`}`
		1051	`if ( last ( t ) ) return ( 1 ) ;`
		1052	`t = bro ( t ) ;`
		1053	`}`
		1054	`/* Not reached */`
		1055	`}`
		1056
		1057	`case ncopies_tag : return ( is_comm ( son ( e ) ) ) ;`
		1058
		1059	`case nof_tag : {`
		1060	`exp t = son ( e ) ;`
		1061	`if ( t == nilexp ) return ( 1 ) ;`
		1062	`while ( 1 ) {`
		1063	`if ( !is_comm ( t ) ) return ( 0 ) ;`
		1064	`if ( last ( t ) ) return ( 1 ) ;`
		1065	`t = bro ( t ) ;`
		1066	`}`
		1067	`/* Not reached */`
		1068	`}`
		1069
		1070	`case concatnof_tag : {`
		1071	`exp t = son ( e ) ;`
		1072	`return ( is_comm ( t ) && is_comm ( bro ( t ) ) ) ;`
		1073	`}`
		1074
		1075	`case clear_tag :`
		1076	`case res_tag :`
		1077	`case null_tag : return ( 1 ) ;`
		1078	`}`
		1079	`return ( 0 ) ;`
		1080	`}`
		1081
		1082	`#endif`
		1083
		1084
		1085	`/*`
		1086	`OUTPUT A CONSTANT`
		1087	`*/`
		1088
		1089	`void evaluate`
		1090	`PROTO_N ( ( c, cname, s, isconst, global, di ) )`
		1091	`PROTO_T ( exp c X long cname X char s X int isconst X int global X diag_global di )`
		1092	`{`
		1093	`mach_op op1, op2 ;`
		1094	`long al = ( long ) shape_align ( sh ( c ) ) ;`
		1095
		1096	`if ( is_comm ( c ) \|\|`
		1097	`((name(c) == name_tag) && (son(son(c))) && (name(son(son(c))) == null_tag))) {`
		1098
		1099	`long sz = rounder ( shape_size ( sh ( c ) ), 32 ) ;`
		1100
		1101	`/* Common global values */`
		1102	`if ( global && cname == -1 && !is_local ( s ) ) {`
		1103	`op1 = make_extern_data ( s, 0 ) ;`
		1104	`op2 = make_int_data ( sz / 8 ) ;`
		1105	`make_instr ( m_as_common, op1, op2, 0 ) ;`
		1106	`#if have_diagnostics`
		1107	`if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;`
		1108	`#endif`
		1109	`return ;`
		1110	`}`
		1111
		1112	`#ifdef asm_uses_lcomm`
		1113	`/* Common local value */`
		1114	`if ( cname == -1 ) {`
		1115	`op1 = make_extern_data ( s, 0 ) ;`
		1116	`} else {`
		1117	`op1 = make_lab_data ( cname, 0 ) ;`
		1118	`}`
		1119	`op2 = make_int_data ( sz / 8 ) ;`
		1120	`make_instr ( m_as_local, op1, op2, 0 ) ;`
		1121	`#if have_diagnostics`
		1122	`if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;`
		1123	`#endif`
		1124	`#else`
		1125	`/* Common local value */`
		1126	`area ( pbss ) ;`
		1127	`if ( cname == -1 ) {`
		1128	`make_external_label ( s ) ;`
		1129	`} else {`
		1130	`make_label ( cname ) ;`
		1131	`}`
		1132	`#if have_diagnostics`
		1133	`if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;`
		1134	`#endif`
		1135	`op1 = make_int_data ( sz / 8 ) ;`
		1136	`make_instr ( m_as_space, op1, null, 0 ) ;`
		1137	`#endif`
		1138	`return ;`
		1139	`}`
		1140
		1141	`/* Data values */`
		1142	`if ( global && cname == -1 && !is_local ( s ) ) {`
		1143	`op1 = make_extern_data ( s, 0 ) ;`
		1144	`make_instr ( m_as_global, op1, null, 0 ) ;`
		1145	`}`
		1146
		1147	`#if have_diagnostics`
		1148	`if ( di ) xdb_diag_val_begin ( di, s, cname, global ) ;`
		1149	`#endif`
		1150
		1151	`if ( al <= 32 ) al = 32 ;`
		1152
		1153	`ext_eval_name = "statically declared object" ;`
		1154	`if ( cname == -1 ) {`
		1155	`make_external_label ( s ) ;`
		1156	`if ( !is_local ( s ) ) ext_eval_name = s ;`
		1157	`} else {`
		1158	`make_label ( cname ) ;`
		1159	`}`
		1160	`evalaux ( c, ( bool ) isconst, al ) ;`
		1161	`eval_instr () ;`
		1162	`return ;`
		1163	`}`
		1164
		1165

Subversion Repositories tendra.SVN

(root)//branches/tendra5/src/installers/680x0/common/evaluate.c – Rev 5