WebSVN – tendra.SVN – Blame – /branches/algol60/src/utilities/calculus/output.c

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

Subversion Repositories tendra.SVN

(root)/branches/algol60/src/utilities/calculus/output.c – Rev 38