WebSVN – tendra.SVN – Blame – /branches/tendra4/src/utilities/calculus/output.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	`#if FS_STDARG`
		33	`#include <stdarg.h>`
		34	`#else`
		35	`#include <varargs.h>`
		36	`#endif`
		37	`#include <ctype.h>`
		38	`#include "calculus.h"`
		39	`#include "common.h"`
		40	`#include "error.h"`
		41	`#include "lex.h"`
		42	`#include "output.h"`
		43	`#include "suffix.h"`
		44	`#include "type_ops.h"`
		45
		46
		47	`/*`
		48	`FIND BINARY LOG OF A NUMBER`
		49
		50	`This routine calculates the binary log of n (i.e. the smallest number`
		51	`r such that n <= 2**r).`
		52	`*/`
		53
		54	`number log2`
		55	`PROTO_N ( ( n ) )`
		56	`PROTO_T ( number n )`
		57	`{`
		58	`number r ;`
		59	`number m ;`
		60	`for ( r = 0, m = 1 ; n > m && m ; r++, m = 2 ) / empty */ ;`
		61	`return ( r ) ;`
		62	`}`
		63
		64
		65	`/*`
		66	`LOOP VARIABLES`
		67
		68	`These are the counter variables used in the LOOP macros defined in`
		69	`output.h.`
		70	`*/`
		71
		72	`LIST ( ECONST_P ) crt_ec = NULL_list ( ECONST_P ) ;`
		73	`LIST ( ENUM_P ) crt_en = NULL_list ( ENUM_P ) ;`
		74	`LIST ( IDENTITY_P ) crt_id = NULL_list ( IDENTITY_P ) ;`
		75	`LIST ( PRIMITIVE_P ) crt_prim = NULL_list ( PRIMITIVE_P ) ;`
		76	`LIST ( STRUCTURE_P ) crt_str = NULL_list ( STRUCTURE_P ) ;`
		77	`LIST ( UNION_P ) crt_union = NULL_list ( UNION_P ) ;`
		78	`LIST ( COMPONENT_P ) crt_cmp = NULL_list ( COMPONENT_P ) ;`
		79	`LIST ( FIELD_P ) crt_fld = NULL_list ( FIELD_P ) ;`
		80	`LIST ( MAP_P ) crt_map = NULL_list ( MAP_P ) ;`
		81	`LIST ( ARGUMENT_P ) crt_arg = NULL_list ( ARGUMENT_P ) ;`
		82	`LIST ( TYPE_P ) crt_type = NULL_list ( TYPE_P ) ;`
		83	`int unique = 0 ;`
		84
		85
		86	`/*`
		87	`CURRENT OUTPUT FILE`
		88
		89	`This gives the file which is currently being used for output.`
		90	`*/`
		91
		92	`FILE *output_file = NULL ;`
		93	`static int output_posn = 0 ;`
		94	`static char output_buff [256] ;`
		95	`static FILE *output_file_old = NULL ;`
		96	`static int column = 0 ;`
		97	`int verbose_output = 1 ;`
		98	`int const_tokens = 1 ;`
		99	`int have_varargs = 1 ;`
		100
		101
		102	`/*`
		103	`PRINT A CHARACTER`
		104
		105	`This routine prints the single character c.`
		106	`*/`
		107
		108	`static void output_char`
		109	`PROTO_N ( ( c ) )`
		110	`PROTO_T ( int c )`
		111	`{`
		112	`int i = output_posn ;`
		113	`output_buff [i] = ( char ) c ;`
		114	`if ( ++i >= 250 \|\| c == '\n' ) {`
		115	`output_buff [i] = 0 ;`
		116	`IGNORE fputs ( output_buff, output_file ) ;`
		117	`i = 0 ;`
		118	`}`
		119	`if ( c == '\n' ) {`
		120	`column = 0 ;`
		121	`} else if ( c == '\t' ) {`
		122	`column = 8 * ( ( column + 8 ) / 8 ) ;`
		123	`} else {`
		124	`column++ ;`
		125	`}`
		126	`output_posn = i ;`
		127	`return ;`
		128	`}`
		129
		130
		131	`/*`
		132	`PRINT A STRING`
		133
		134	`This routine prints the string s.`
		135	`*/`
		136
		137	`static void output_string`
		138	`PROTO_N ( ( s ) )`
		139	`PROTO_T ( CONST char *s )`
		140	`{`
		141	`for ( ; s ; s++ ) output_char ( s ) ;`
		142	`return ;`
		143	`}`
		144
		145
		146	`/*`
		147	`FLUSH OUTPUT FILE`
		148
		149	`This routine flushes the output file buffer by printing a newline`
		150	`character.`
		151	`*/`
		152
		153	`void flush_output`
		154	`PROTO_Z ()`
		155	`{`
		156	`if ( output_posn ) output_char ( '\n' ) ;`
		157	`return ;`
		158	`}`
		159
		160
		161	`/*`
		162	`PRINT A TYPE`
		163
		164	`This routine prints the type t.`
		165	`*/`
		166
		167	`void output_type`
		168	`PROTO_N ( ( t ) )`
		169	`PROTO_T ( TYPE_P t )`
		170	`{`
		171	`TYPE t0 = DEREF_type ( t ) ;`
		172	`switch ( TAG_type ( t0 ) ) {`
		173	`case type_vec_tag : {`
		174	`TYPE_P_P s = type_vec_sub ( t0 ) ;`
		175	`output_string ( "VEC ( " ) ;`
		176	`output_type ( DEREF_ptr ( s ) ) ;`
		177	`output_string ( " )" ) ;`
		178	`break ;`
		179	`}`
		180	`case type_ptr_tag : {`
		181	`TYPE_P_P s = type_ptr_sub ( t0 ) ;`
		182	`output_string ( "PTR ( " ) ;`
		183	`output_type ( DEREF_ptr ( s ) ) ;`
		184	`output_string ( " )" ) ;`
		185	`break ;`
		186	`}`
		187	`case type_list_tag : {`
		188	`TYPE_P_P s = type_list_sub ( t0 ) ;`
		189	`output_string ( "LIST ( " ) ;`
		190	`output_type ( DEREF_ptr ( s ) ) ;`
		191	`output_string ( " )" ) ;`
		192	`break ;`
		193	`}`
		194	`case type_stack_tag : {`
		195	`TYPE_P_P s = type_stack_sub ( t0 ) ;`
		196	`output_string ( "STACK ( " ) ;`
		197	`output_type ( DEREF_ptr ( s ) ) ;`
		198	`output_string ( " )" ) ;`
		199	`break ;`
		200	`}`
		201	`case type_vec_ptr_tag : {`
		202	`TYPE_P_P s = type_vec_ptr_sub ( t0 ) ;`
		203	`output_string ( "VEC_PTR ( " ) ;`
		204	`output_type ( DEREF_ptr ( s ) ) ;`
		205	`output_string ( " )" ) ;`
		206	`break ;`
		207	`}`
		208	`default : {`
		209	`output_string ( name_type ( t ) ) ;`
		210	`break ;`
		211	`}`
		212	`}`
		213	`return ;`
		214	`}`
		215
		216
		217	`/*`
		218	`PRINT A TYPE IDENTIFIER`
		219
		220	`This routine prints an identifier derived from the type t. depth`
		221	`determines the depth to which identities are to be expanded.`
		222	`*/`
		223
		224	`static void output_type_id`
		225	`PROTO_N ( ( t, depth ) )`
		226	`PROTO_T ( TYPE_P t X int depth )`
		227	`{`
		228	`TYPE t0 = DEREF_type ( t ) ;`
		229	`switch ( TAG_type ( t0 ) ) {`
		230	`case type_vec_tag : {`
		231	`TYPE_P_P s = type_vec_sub ( t0 ) ;`
		232	`output_string ( "vec_" ) ;`
		233	`output_type_id ( DEREF_ptr ( s ), depth ) ;`
		234	`break ;`
		235	`}`
		236	`case type_ptr_tag : {`
		237	`TYPE_P_P s = type_ptr_sub ( t0 ) ;`
		238	`output_string ( "ptr_" ) ;`
		239	`output_type_id ( DEREF_ptr ( s ), depth ) ;`
		240	`break ;`
		241	`}`
		242	`case type_list_tag : {`
		243	`TYPE_P_P s = type_list_sub ( t0 ) ;`
		244	`output_string ( "list_" ) ;`
		245	`output_type_id ( DEREF_ptr ( s ), depth ) ;`
		246	`break ;`
		247	`}`
		248	`case type_stack_tag : {`
		249	`TYPE_P_P s = type_stack_sub ( t0 ) ;`
		250	`output_string ( "stack_" ) ;`
		251	`output_type_id ( DEREF_ptr ( s ), depth ) ;`
		252	`break ;`
		253	`}`
		254	`case type_vec_ptr_tag : {`
		255	`TYPE_P_P s = type_vec_ptr_sub ( t0 ) ;`
		256	`output_string ( "vptr_" ) ;`
		257	`output_type_id ( DEREF_ptr ( s ), depth ) ;`
		258	`break ;`
		259	`}`
		260	`case type_ident_tag : {`
		261	`IDENTITY_P id = DEREF_ptr ( type_ident_id ( t0 ) ) ;`
		262	`if ( depth ) {`
		263	`TYPE_P_P s = ident_defn ( id ) ;`
		264	`output_type_id ( DEREF_ptr ( s ), depth - 1 ) ;`
		265	`} else {`
		266	`CLASS_ID_P nm = DEREF_ptr ( ident_id ( id ) ) ;`
		267	`output_string ( DEREF_string ( cid_name ( nm ) ) ) ;`
		268	`}`
		269	`break ;`
		270	`}`
		271	`default : {`
		272	`output_string ( name_aux_type ( t ) ) ;`
		273	`break ;`
		274	`}`
		275	`}`
		276	`return ;`
		277	`}`
		278
		279
		280	`/*`
		281	`PRINT A TYPE SIZE`
		282
		283	`This routine print the size of the type t.`
		284	`*/`
		285
		286	`static void output_type_size`
		287	`PROTO_N ( ( t ) )`
		288	`PROTO_T ( TYPE_P t )`
		289	`{`
		290	`TYPE t0 = DEREF_type ( t ) ;`
		291	`switch ( TAG_type ( t0 ) ) {`
		292	`case type_vec_tag : {`
		293	`TYPE_P_P s = type_vec_sub ( t0 ) ;`
		294	`output ( "SIZE_vec ( %TT )", DEREF_ptr ( s ) ) ;`
		295	`break ;`
		296	`}`
		297	`case type_ptr_tag : {`
		298	`TYPE_P_P s = type_ptr_sub ( t0 ) ;`
		299	`output ( "SIZE_ptr ( %TT )", DEREF_ptr ( s ) ) ;`
		300	`break ;`
		301	`}`
		302	`case type_list_tag : {`
		303	`TYPE_P_P s = type_list_sub ( t0 ) ;`
		304	`output ( "SIZE_list ( %TT )", DEREF_ptr ( s ) ) ;`
		305	`break ;`
		306	`}`
		307	`case type_stack_tag : {`
		308	`TYPE_P_P s = type_stack_sub ( t0 ) ;`
		309	`output ( "SIZE_stack ( %TT )", DEREF_ptr ( s ) ) ;`
		310	`break ;`
		311	`}`
		312	`case type_vec_ptr_tag : {`
		313	`TYPE_P_P s = type_vec_ptr_sub ( t0 ) ;`
		314	`output ( "SIZE_vec_ptr ( %TT )", DEREF_ptr ( s ) ) ;`
		315	`break ;`
		316	`}`
		317	`case type_ident_tag : {`
		318	`IDENTITY_P id = DEREF_ptr ( type_ident_id ( t0 ) ) ;`
		319	`output_type_size ( DEREF_ptr ( ident_defn ( id ) ) ) ;`
		320	`break ;`
		321	`}`
		322	`default : {`
		323	`output_string ( "SIZE_" ) ;`
		324	`output_string ( name_aux_type ( t ) ) ;`
		325	`break ;`
		326	`}`
		327	`}`
		328	`return ;`
		329	`}`
		330
		331
		332	`/*`
		333	`PRINT A FORMAT STRING`
		334
		335	`This routine prints the string s, taking any formatting characters`
		336	`into account. These formatting characters have the form %X or %XY`
		337	`for characters X and Y. Each is commented within the body of the`
		338	`procedure in the form "%XY -> ....".`
		339	`*/`
		340
		341	`void output`
		342	`PROTO_V ( ( char *s, ... ) )`
		343	`/VARARGS/`
		344	`{`
		345	`char c ;`
		346	`va_list args ;`
		347	`char nbuff [100] ;`
		348
		349	`#if FS_STDARG`
		350	`va_start ( args, s ) ;`
		351	`#else`
		352	`char *s ;`
		353	`va_start ( args ) ;`
		354	`s = va_arg ( args, char * ) ;`
		355	`#endif`
		356
		357	`while ( c = *( s++ ), c != 0 ) {`
		358	`if ( c == '%' ) {`
		359	`char *s0 = s ;`
		360	`c = *( s++ ) ;`
		361	`switch ( c ) {`
		362
		363	`case 'A' : {`
		364	`/* Arguments */`
		365	`c = *( s++ ) ;`
		366	`if ( c == 'N' ) {`
		367	`/* %AN -> argument name */`
		368	`if ( HAVE_ARGUMENT ) {`
		369	`string_P ps = arg_name ( CRT_ARGUMENT ) ;`
		370	`output_string ( DEREF_string ( ps ) ) ;`
		371	`} else {`
		372	`goto misplaced_arg ;`
		373	`}`
		374	`} else if ( c == 'T' ) {`
		375	`/* %AT -> argument type */`
		376	`if ( HAVE_ARGUMENT ) {`
		377	`TYPE_P_P pt = arg_type ( CRT_ARGUMENT ) ;`
		378	`output_type ( DEREF_ptr ( pt ) ) ;`
		379	`} else {`
		380	`goto misplaced_arg ;`
		381	`}`
		382	`} else {`
		383	`goto bad_format ;`
		384	`}`
		385	`break ;`
		386	`}`
		387
		388	`case 'C' : {`
		389	`/* Components */`
		390	`c = *( s++ ) ;`
		391	`if ( c == 'N' ) {`
		392	`/* %CN -> component name */`
		393	`if ( HAVE_COMPONENT ) {`
		394	`string_P ps = cmp_name ( CRT_COMPONENT ) ;`
		395	`output_string ( DEREF_string ( ps ) ) ;`
		396	`} else {`
		397	`goto misplaced_arg ;`
		398	`}`
		399	`} else if ( c == 'T' ) {`
		400	`/* %CT -> component type */`
		401	`if ( HAVE_COMPONENT ) {`
		402	`TYPE_P_P pt = cmp_type ( CRT_COMPONENT ) ;`
		403	`output_type ( DEREF_ptr ( pt ) ) ;`
		404	`} else {`
		405	`goto misplaced_arg ;`
		406	`}`
		407	`} else if ( c == 'U' ) {`
		408	`/* %CU -> short component type */`
		409	`if ( HAVE_COMPONENT ) {`
		410	`TYPE_P_P pt = cmp_type ( CRT_COMPONENT ) ;`
		411	`TYPE_P ta = DEREF_ptr ( pt ) ;`
		412	`char *tn = name_aux_type ( ta ) ;`
		413	`output_string ( tn ) ;`
		414	`} else {`
		415	`goto misplaced_arg ;`
		416	`}`
		417	`} else if ( c == 'V' ) {`
		418	`/* %CV -> component default value */`
		419	`if ( HAVE_COMPONENT ) {`
		420	`string_P ps = cmp_name ( CRT_COMPONENT ) ;`
		421	`string s1 = DEREF_string ( ps ) ;`
		422	`if ( s1 ) output_string ( s1 ) ;`
		423	`} else {`
		424	`goto misplaced_arg ;`
		425	`}`
		426	`} else {`
		427	`goto bad_format ;`
		428	`}`
		429	`break ;`
		430	`}`
		431
		432	`case 'E' : {`
		433	`/* Enumerations */`
		434	`c = *( s++ ) ;`
		435	`if ( c == 'N' ) {`
		436	`/* %EN -> enumeration name */`
		437	`if ( HAVE_ENUM ) {`
		438	`CLASS_ID_P_P pi = en_id ( CRT_ENUM ) ;`
		439	`string_P ps = cid_name ( DEREF_ptr ( pi ) ) ;`
		440	`output_string ( DEREF_string ( ps ) ) ;`
		441	`} else {`
		442	`goto misplaced_arg ;`
		443	`}`
		444	`} else if ( c == 'M' ) {`
		445	`/* %EM -> short enumeration name */`
		446	`if ( HAVE_ENUM ) {`
		447	`CLASS_ID_P_P pi = en_id ( CRT_ENUM ) ;`
		448	`string_P ps = cid_name_aux ( DEREF_ptr ( pi ) ) ;`
		449	`output_string ( DEREF_string ( ps ) ) ;`
		450	`} else {`
		451	`goto misplaced_arg ;`
		452	`}`
		453	`} else if ( c == 'O' ) {`
		454	`/* %EO -> enumeration order */`
		455	`if ( HAVE_ENUM ) {`
		456	`number_P pn = en_order ( CRT_ENUM ) ;`
		457	`number n = DEREF_number ( pn ) ;`
		458	`if ( *s == '2' ) {`
		459	`n = log2 ( n ) ;`
		460	`s++ ;`
		461	`}`
		462	`sprintf_v ( nbuff, "%lu", n ) ;`
		463	`output_string ( nbuff ) ;`
		464	`} else {`
		465	`goto misplaced_arg ;`
		466	`}`
		467	`} else if ( c == 'S' ) {`
		468	`/* %ES -> enumerator name */`
		469	`if ( HAVE_ECONST ) {`
		470	`string_P ps = ec_name ( CRT_ECONST ) ;`
		471	`output_string ( DEREF_string ( ps ) ) ;`
		472	`} else {`
		473	`goto misplaced_arg ;`
		474	`}`
		475	`} else if ( c == 'V' ) {`
		476	`/* %EV -> enumerator value */`
		477	`if ( HAVE_ECONST ) {`
		478	`number_P pn = ec_value ( CRT_ECONST ) ;`
		479	`number n = DEREF_number ( pn ) ;`
		480	`sprintf_v ( nbuff, "%lu", n ) ;`
		481	`output_string ( nbuff ) ;`
		482	`} else {`
		483	`goto misplaced_arg ;`
		484	`}`
		485	`} else {`
		486	`goto bad_format ;`
		487	`}`
		488	`break ;`
		489	`}`
		490
		491	`case 'F' : {`
		492	`/* Fields */`
		493	`c = *( s++ ) ;`
		494	`if ( c == 'N' ) {`
		495	`/* %FN -> field name */`
		496	`if ( HAVE_FIELD ) {`
		497	`string_P ps = fld_name ( CRT_FIELD ) ;`
		498	`output_string ( DEREF_string ( ps ) ) ;`
		499	`} else {`
		500	`goto misplaced_arg ;`
		501	`}`
		502	`} else if ( c == ',' ) {`
		503	`/* %F, -> ',' (if not the last field) */`
		504	`if ( HAVE_FIELD ) {`
		505	`LIST ( FIELD_P ) nf = TAIL_list ( crt_fld ) ;`
		506	`if ( !IS_NULL_list ( nf ) ) output_string ( "," ) ;`
		507	`} else {`
		508	`goto misplaced_arg ;`
		509	`}`
		510	`} else {`
		511	`goto bad_format ;`
		512	`}`
		513	`break ;`
		514	`}`
		515
		516	`case 'I' : {`
		517	`/* Identities */`
		518	`c = *( s++ ) ;`
		519	`if ( c == 'N' ) {`
		520	`/* %IN -> identity name */`
		521	`if ( HAVE_IDENTITY ) {`
		522	`CLASS_ID_P_P pi = ident_id ( CRT_IDENTITY ) ;`
		523	`string_P ps = cid_name ( DEREF_ptr ( pi ) ) ;`
		524	`output_string ( DEREF_string ( ps ) ) ;`
		525	`} else {`
		526	`goto misplaced_arg ;`
		527	`}`
		528	`} else if ( c == 'M' ) {`
		529	`/* %IM -> short identity name */`
		530	`if ( HAVE_IDENTITY ) {`
		531	`CLASS_ID_P_P pi = ident_id ( CRT_IDENTITY ) ;`
		532	`string_P ps = cid_name_aux ( DEREF_ptr ( pi ) ) ;`
		533	`output_string ( DEREF_string ( ps ) ) ;`
		534	`} else {`
		535	`goto misplaced_arg ;`
		536	`}`
		537	`} else if ( c == 'T' ) {`
		538	`/* %IT -> identity type definition */`
		539	`if ( HAVE_IDENTITY ) {`
		540	`TYPE_P_P pt = ident_defn ( CRT_IDENTITY ) ;`
		541	`output_type ( DEREF_ptr ( pt ) ) ;`
		542	`} else {`
		543	`goto misplaced_arg ;`
		544	`}`
		545	`} else {`
		546	`goto bad_format ;`
		547	`}`
		548	`break ;`
		549	`}`
		550
		551	`case 'M' : {`
		552	`/* Maps */`
		553	`c = *( s++ ) ;`
		554	`if ( c == 'N' ) {`
		555	`/* %MN -> map name */`
		556	`if ( HAVE_MAP ) {`
		557	`string_P ps = map_name ( CRT_MAP ) ;`
		558	`output_string ( DEREF_string ( ps ) ) ;`
		559	`} else {`
		560	`goto misplaced_arg ;`
		561	`}`
		562	`} else if ( c == 'R' ) {`
		563	`/* %MR -> map return type */`
		564	`if ( HAVE_MAP ) {`
		565	`TYPE_P_P pt = map_ret_type ( CRT_MAP ) ;`
		566	`output_type ( DEREF_ptr ( pt ) ) ;`
		567	`} else {`
		568	`goto misplaced_arg ;`
		569	`}`
		570	`} else {`
		571	`goto bad_format ;`
		572	`}`
		573	`break ;`
		574	`}`
		575
		576	`case 'P' : {`
		577	`/* Primitives */`
		578	`c = *( s++ ) ;`
		579	`if ( c == 'N' ) {`
		580	`/* %PN -> primitive name */`
		581	`if ( HAVE_PRIMITIVE ) {`
		582	`CLASS_ID_P_P pi = prim_id ( CRT_PRIMITIVE ) ;`
		583	`string_P ps = cid_name ( DEREF_ptr ( pi ) ) ;`
		584	`output_string ( DEREF_string ( ps ) ) ;`
		585	`} else {`
		586	`goto misplaced_arg ;`
		587	`}`
		588	`} else if ( c == 'M' ) {`
		589	`/* %PM -> short primitive name */`
		590	`if ( HAVE_PRIMITIVE ) {`
		591	`CLASS_ID_P_P pi = prim_id ( CRT_PRIMITIVE ) ;`
		592	`string_P ps = cid_name_aux ( DEREF_ptr ( pi ) ) ;`
		593	`output_string ( DEREF_string ( ps ) ) ;`
		594	`} else {`
		595	`goto misplaced_arg ;`
		596	`}`
		597	`} else if ( c == 'D' ) {`
		598	`/* %PD -> primitive definition */`
		599	`if ( HAVE_PRIMITIVE ) {`
		600	`string_P ps = prim_defn ( CRT_PRIMITIVE ) ;`
		601	`output_string ( DEREF_string ( ps ) ) ;`
		602	`} else {`
		603	`goto misplaced_arg ;`
		604	`}`
		605	`} else {`
		606	`goto bad_format ;`
		607	`}`
		608	`break ;`
		609	`}`
		610
		611	`case 'S' : {`
		612	`/* Structures */`
		613	`c = *( s++ ) ;`
		614	`if ( c == 'N' ) {`
		615	`/* %SN -> structure name */`
		616	`if ( HAVE_STRUCTURE ) {`
		617	`CLASS_ID_P_P pi = str_id ( CRT_STRUCTURE ) ;`
		618	`string_P ps = cid_name ( DEREF_ptr ( pi ) ) ;`
		619	`output_string ( DEREF_string ( ps ) ) ;`
		620	`} else {`
		621	`goto misplaced_arg ;`
		622	`}`
		623	`} else if ( c == 'M' ) {`
		624	`/* %SM -> short structure name */`
		625	`if ( HAVE_STRUCTURE ) {`
		626	`CLASS_ID_P_P pi = str_id ( CRT_STRUCTURE ) ;`
		627	`string_P ps = cid_name_aux ( DEREF_ptr ( pi ) ) ;`
		628	`output_string ( DEREF_string ( ps ) ) ;`
		629	`} else {`
		630	`goto misplaced_arg ;`
		631	`}`
		632	`} else {`
		633	`goto bad_format ;`
		634	`}`
		635	`break ;`
		636	`}`
		637
		638	`case 'T' : {`
		639	`/* Types */`
		640	`c = *( s++ ) ;`
		641	`if ( have_varargs ) {`
		642	`TYPE_P ta = va_arg ( args, TYPE_P ) ;`
		643	`if ( c == 'N' ) {`
		644	`/* %TN -> type name */`
		645	`char *tn = name_type ( ta ) ;`
		646	`output_string ( tn ) ;`
		647	`} else if ( c == 'M' ) {`
		648	`/* %TM -> short type name */`
		649	`char *tn = name_aux_type ( ta ) ;`
		650	`output_string ( tn ) ;`
		651	`} else if ( c == 'I' ) {`
		652	`/* %TI -> type identifier */`
		653	`output_type_id ( ta, 0 ) ;`
		654	`} else if ( c == 'J' ) {`
		655	`/* %TJ -> type identifier */`
		656	`output_type_id ( ta, 1 ) ;`
		657	`} else if ( c == 'S' ) {`
		658	`/* %TS -> type size */`
		659	`output_type_size ( ta ) ;`
		660	`} else if ( c == 'T' ) {`
		661	`/* %TT -> type definition */`
		662	`output_type ( ta ) ;`
		663	`} else {`
		664	`goto bad_format ;`
		665	`}`
		666	`break ;`
		667	`}`
		668	`goto bad_format ;`
		669	`}`
		670
		671	`case 'U' : {`
		672	`/* Unions */`
		673	`c = *( s++ ) ;`
		674	`if ( c == 'N' ) {`
		675	`/* %UN -> union name */`
		676	`if ( HAVE_UNION ) {`
		677	`CLASS_ID_P_P pi = un_id ( CRT_UNION ) ;`
		678	`string_P ps = cid_name ( DEREF_ptr ( pi ) ) ;`
		679	`output_string ( DEREF_string ( ps ) ) ;`
		680	`} else {`
		681	`goto misplaced_arg ;`
		682	`}`
		683	`} else if ( c == 'M' ) {`
		684	`/* %UM -> short union name */`
		685	`if ( HAVE_UNION ) {`
		686	`CLASS_ID_P_P pi = un_id ( CRT_UNION ) ;`
		687	`string_P ps = cid_name_aux ( DEREF_ptr ( pi ) ) ;`
		688	`output_string ( DEREF_string ( ps ) ) ;`
		689	`} else {`
		690	`goto misplaced_arg ;`
		691	`}`
		692	`} else if ( c == 'O' ) {`
		693	`/* %UO -> union order */`
		694	`if ( HAVE_UNION ) {`
		695	`int_P pi = un_no_fields ( CRT_UNION ) ;`
		696	`number n = ( number ) DEREF_int ( pi ) ;`
		697	`c = *s ;`
		698	`if ( c == '2' ) {`
		699	`n = log2 ( n ) ;`
		700	`s++ ;`
		701	`} else if ( c == '3' ) {`
		702	`n = log2 ( n + 1 ) ;`
		703	`s++ ;`
		704	`}`
		705	`sprintf_v ( nbuff, "%lu", n ) ;`
		706	`output_string ( nbuff ) ;`
		707	`} else {`
		708	`goto misplaced_arg ;`
		709	`}`
		710	`} else {`
		711	`goto bad_format ;`
		712	`}`
		713	`break ;`
		714	`}`
		715
		716	`case 'V' : {`
		717	`/* %V -> overall version */`
		718	`int v1 = algebra->major_no ;`
		719	`int v2 = algebra->minor_no ;`
		720	`sprintf_v ( nbuff, "%d.%d", v1, v2 ) ;`
		721	`output_string ( nbuff ) ;`
		722	`break ;`
		723	`}`
		724
		725	`case 'X' : {`
		726	`/* %X -> overall name */`
		727	`output_string ( algebra->name ) ;`
		728	`break ;`
		729	`}`
		730
		731	`case 'Z' : {`
		732	`c = *( s++ ) ;`
		733	`if ( c == 'V' ) {`
		734	`/* %ZV -> program version */`
		735	`output_string ( progvers ) ;`
		736	`} else if ( c == 'X' ) {`
		737	`/* %ZX -> program name */`
		738	`output_string ( progname ) ;`
		739	`} else {`
		740	`goto bad_format ;`
		741	`}`
		742	`break ;`
		743	`}`
		744
		745	`case 'b' : {`
		746	`/* %b -> backspace */`
		747	`if ( output_posn ) output_posn-- ;`
		748	`break ;`
		749	`}`
		750
		751	`case 'd' : {`
		752	`/* %d -> integer (extra argument) */`
		753	`if ( have_varargs ) {`
		754	`int da = va_arg ( args, int ) ;`
		755	`sprintf_v ( nbuff, "%d", da ) ;`
		756	`output_string ( nbuff ) ;`
		757	`break ;`
		758	`}`
		759	`goto bad_format ;`
		760	`}`
		761
		762	`case 'e' : {`
		763	`/* %e -> evaluated string (extra argument) */`
		764	`if ( have_varargs ) {`
		765	`char ea = va_arg ( args, char ) ;`
		766	`if ( ea ) output ( ea ) ;`
		767	`break ;`
		768	`}`
		769	`goto bad_format ;`
		770	`}`
		771
		772	`case 'n' : {`
		773	`/* %n -> number (extra argument) */`
		774	`if ( have_varargs ) {`
		775	`number na = va_arg ( args, number ) ;`
		776	`sprintf_v ( nbuff, "%lu", na ) ;`
		777	`output_string ( nbuff ) ;`
		778	`break ;`
		779	`}`
		780	`goto bad_format ;`
		781	`}`
		782
		783	`case 'p' : {`
		784	`/* Pragmas */`
		785	`c = *( s++ ) ;`
		786	`if ( c == 't' ) {`
		787	`/* %pt -> '#pragma token' */`
		788	`output_string ( "#pragma token" ) ;`
		789	`} else if ( c == 'i' ) {`
		790	`/* %pi -> '#pragma interface' */`
		791	`output_string ( "#pragma interface" ) ;`
		792	`} else {`
		793	`goto bad_format ;`
		794	`}`
		795	`break ;`
		796	`}`
		797
		798	`case 's' : {`
		799	`/* %s -> string (extra argument) */`
		800	`if ( have_varargs ) {`
		801	`char sa = va_arg ( args, char ) ;`
		802	`if ( sa ) output_string ( sa ) ;`
		803	`break ;`
		804	`}`
		805	`goto bad_format ;`
		806	`}`
		807
		808	`case 't' : {`
		809	`/* %t[0-9]* -> tab */`
		810	`int t = 0 ;`
		811	`while ( c = *s, ( c >= '0' && c <= '9' ) ) {`
		812	`t = 10 * t + ( c - '0' ) ;`
		813	`s++ ;`
		814	`}`
		815	`while ( column < t ) output_char ( '\t' ) ;`
		816	`break ;`
		817	`}`
		818
		819	`case 'u' : {`
		820	`/* %u -> unique */`
		821	`sprintf_v ( nbuff, "%d", unique ) ;`
		822	`output_string ( nbuff ) ;`
		823	`break ;`
		824	`}`
		825
		826	`case 'x' : {`
		827	`/* Expression tokens */`
		828	`c = *( s++ ) ;`
		829	`if ( c == 'r' ) {`
		830	`/* %xr -> 'EXP rvalue' */`
		831	`output_string ( "EXP" ) ;`
		832	`} else if ( c == 'l' ) {`
		833	`/* %xl -> 'EXP lvalue' */`
		834	`output_string ( "EXP lvalue" ) ;`
		835	`} else if ( c == 'c' ) {`
		836	`/* %xc -> 'EXP const' */`
		837	`output_string ( "EXP" ) ;`
		838	`if ( const_tokens ) output_string ( " const" ) ;`
		839	`} else {`
		840	`goto bad_format ;`
		841	`}`
		842	`break ;`
		843	`}`
		844
		845	`case '0' : {`
		846	`/* %0 -> x<unique>_ */`
		847	`sprintf_v ( nbuff, "x%d_", unique ) ;`
		848	`output_string ( nbuff ) ;`
		849	`break ;`
		850	`}`
		851
		852	`case '%' : {`
		853	`/* %% -> '%' */`
		854	`output_string ( "%" ) ;`
		855	`break ;`
		856	`}`
		857
		858	`case '@' : {`
		859	`/* %@ -> '@' */`
		860	`output_string ( "@" ) ;`
		861	`break ;`
		862	`}`
		863
		864	`case '\n' : {`
		865	`/* %\n -> ignored newline */`
		866	`break ;`
		867	`}`
		868
		869	`misplaced_arg : {`
		870	`error ( ERROR_SERIOUS,`
		871	`"Misplaced formatting string '%%%.2s'", s0 ) ;`
		872	`break ;`
		873	`}`
		874
		875	`default :`
		876	`bad_format : {`
		877	`error ( ERROR_SERIOUS,`
		878	`"Unknown formatting string '%%%.2s'", s0 ) ;`
		879	`s = s0 ;`
		880	`break ;`
		881	`}`
		882	`}`
		883	`} else {`
		884	`output_char ( c ) ;`
		885	`}`
		886	`}`
		887	`va_end ( args ) ;`
		888	`return ;`
		889	`}`
		890
		891
		892	`/*`
		893	`PRINT INITIAL COMMENT`
		894
		895	`This comment is printed at the start of each output file to indicate`
		896	`that it is automatically generated.`
		897	`*/`
		898
		899	`static void print_comment`
		900	`PROTO_Z ()`
		901	`{`
		902	`if ( first_comment ) {`
		903	`/* Print copyright comment, if present */`
		904	`output ( "%s\n\n", first_comment ) ;`
		905	`}`
		906	`output ( "/*\n" ) ;`
		907	`output ( " AUTOMATICALLY GENERATED FROM ALGEBRA %X (VERSION %V)\n" ) ;`
		908	`output ( " BY %ZX (VERSION %ZV)\n" ) ;`
		909	`output ( "*/\n\n" ) ;`
		910	`return ;`
		911	`}`
		912
		913
		914	`/*`
		915	`C CODE FLAG`
		916
		917	`This flag is true if C code is being output.`
		918	`*/`
		919
		920	`int output_c_code = 1 ;`
		921
		922
		923	`/*`
		924	`OPEN AN OUTPUT FILE`
		925
		926	`This routine opens the output file formed by concatenating nm and suff.`
		927	`Two files can be open at once.`
		928	`*/`
		929
		930	`void open_file`
		931	`PROTO_N ( ( dir, nm, suff ) )`
		932	`PROTO_T ( char dir X char nm X char *suff )`
		933	`{`
		934	`char *p ;`
		935	`char buff [1000] ;`
		936	`flush_output () ;`
		937	`sprintf_v ( buff, "%s/%s%s", dir, nm, suff ) ;`
		938	`output_file_old = output_file ;`
		939	`output_file = fopen ( buff, "w" ) ;`
		940	`if ( output_file == NULL ) {`
		941	`error ( ERROR_FATAL, "Can't open output file, %s", buff ) ;`
		942	`}`
		943	`if ( verbose_output ) {`
		944	`fprintf_v ( stderr, "Creating %s ...\n", buff ) ;`
		945	`}`
		946	`column = 0 ;`
		947
		948	`if ( output_c_code ) {`
		949	`/* Set up protection macro */`
		950	`char *tok = "" ;`
		951	`if ( output_c_code == 2 ) tok = "_TOK" ;`
		952	`sprintf_v ( buff, "%s%s%s_INCLUDED", nm, suff, tok ) ;`
		953	`for ( p = buff ; *p ; p++ ) {`
		954	`char c = *p ;`
		955	`if ( isalpha ( c ) ) {`
		956	`if ( islower ( c ) ) c = ( char ) toupper ( c ) ;`
		957	`} else if ( !isdigit ( c ) ) {`
		958	`c = '_' ;`
		959	`}`
		960	`*p = c ;`
		961	`}`
		962
		963	`/* Print file header */`
		964	`print_comment () ;`
		965	`output ( "#ifndef %s\n", buff ) ;`
		966	`output ( "#define %s\n\n", buff ) ;`
		967	`}`
		968	`return ;`
		969	`}`
		970
		971
		972	`/*`
		973	`CLOSE AN OUTPUT FILE`
		974
		975	`This routine closes the current output file.`
		976	`*/`
		977
		978	`void close_file`
		979	`PROTO_Z ()`
		980	`{`
		981	`if ( output_c_code ) output ( "#endif\n" ) ;`
		982	`flush_output () ;`
		983	`fclose_v ( output_file ) ;`
		984	`output_file = output_file_old ;`
		985	`output_file_old = NULL ;`
		986	`output_c_code = 1 ;`
		987	`return ;`
		988	`}`

Subversion Repositories tendra.SVN

(root)/branches/tendra4/src/utilities/calculus/output.c – Rev 2