Subversion Repositories tendra.SVN

Rev

Rev 5 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

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