Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
Crown Copyright (c) 1997
This TenDRA(r) Computer Program is subject to Copyright
owned by the United Kingdom Secretary of State for Defence
acting through the Defence Evaluation and Research Agency
(DERA). It is made available to Recipients with a
royalty-free licence for its use, reproduction, transfer
to other parties and amendment for any purpose not excluding
product development provided that any such use et cetera
shall be deemed to be acceptance of the following conditions:-
(1) Its Recipients shall ensure that this Notice is
reproduced upon any copies or amended versions of it;
(2) Any amended version of it shall be clearly marked to
show both the nature of and the organisation responsible
for the relevant amendment or amendments;
(3) Its onward transfer from a recipient to another
party shall be deemed to be that party's acceptance of
these conditions;
(4) DERA gives no warranty or assurance as to its
quality or suitability for any purpose and DERA accepts
no liability whatsoever in relation to any use to which
it may be put.
*/
#include "config.h"
#include <limits.h>
#include "system.h"
#include "version.h"
#include "c_types.h"
#include "err_ext.h"
#include "ctype_ops.h"
#include "etype_ops.h"
#include "exp_ops.h"
#include "ftype_ops.h"
#include "graph_ops.h"
#include "hashid_ops.h"
#include "id_ops.h"
#include "itype_ops.h"
#include "nat_ops.h"
#include "nspace_ops.h"
#include "tok_ops.h"
#include "type_ops.h"
#include "error.h"
#include "catalog.h"
#include "basetype.h"
#include "buffer.h"
#include "char.h"
#include "constant.h"
#include "convert.h"
#include "dump.h"
#include "exception.h"
#include "file.h"
#include "function.h"
#include "lex.h"
#include "literal.h"
#include "macro.h"
#include "mangle.h"
#include "print.h"
#include "statement.h"
#include "token.h"
#include "ustring.h"
#include "xalloc.h"
/*
DUMP FILE OPTIONS
These variables give the various dump file options.
*/
int do_dump = 0 ;
int do_error = 0 ;
int do_header = 0 ;
int do_keyword = 0 ;
int do_local = 0 ;
int do_macro = 0 ;
int do_scope = 0 ;
int do_string = 0 ;
int do_usage = 0 ;
/*
DUMP FILE VARIABLES
These variables give the dump file and the associated dump buffer.
*/
static FILE *dump_file = NULL ;
static BUFFER dump_buff_rep = NULL_buff ;
static BUFFER *dump_buff = &dump_buff_rep ;
/*
DUMP BUFFER TO FILE
This routine adds the contents of the dump buffer to the dump file.
*/
static void dump_string
PROTO_Z ()
{
FILE *f = dump_file ;
BUFFER *bf = dump_buff ;
string s = bf->start ;
size_t n = ( size_t ) ( bf->posn - s ) ;
fprintf_v ( f, "&%lu<", ( unsigned long ) n ) ;
if ( n ) {
IGNORE fwrite ( ( gen_ptr ) s, sizeof ( character ), n, f ) ;
bf->posn = s ;
}
fputc_v ( '>', f ) ;
return ;
}
/*
FORWARD DECLARATIONS
The dump routines defined in this module are defined recursively
so a couple of forward declarations are required.
*/
static void dump_id PROTO_S ( ( IDENTIFIER ) ) ;
static void dump_type PROTO_S ( ( TYPE ) ) ;
static void dump_tok_appl PROTO_S ( ( IDENTIFIER, LIST ( TOKEN ) ) ) ;
static void dump_nat PROTO_S ( ( NAT, int ) ) ;
/*
DUMP FLAGS
The flag dump_implicit can be set to true to indicate that the
following declaration or definition is actually implicit. The flag
dump_anon_class can be set to inhibit type definitions which name
anonymous classes being output twice.
*/
int dump_implicit = 0 ;
int dump_template = 0 ;
int dump_anon_class = 0 ;
/*
FIND AN IDENTIFIER KEY
This routine finds the key corresponding to the identifier id.
This is a sequence of characters giving the type of identifier.
*/
static CONST char *dump_key
PROTO_N ( ( id, def ) )
PROTO_T ( IDENTIFIER id X int def )
{
CONST char *key = NULL ;
if ( do_dump && !IS_NULL_id ( id ) ) {
switch ( TAG_id ( id ) ) {
case id_keyword_tag :
case id_iso_keyword_tag : {
/* Keywords */
key = "K" ;
break ;
}
case id_obj_macro_tag : {
/* Object-like macros */
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( ds & dspec_builtin ) {
key = "MB" ;
} else {
key = "MO" ;
}
break ;
}
case id_func_macro_tag : {
/* Function-like macros */
key = "MF" ;
break ;
}
case id_builtin_tag : {
/* Built-in functions */
key = "FB" ;
break ;
}
case id_class_name_tag : {
/* Classes, structures and unions */
CLASS_TYPE ct ;
CLASS_INFO ci ;
TYPE t = DEREF_type ( id_class_name_defn ( id ) ) ;
while ( IS_type_templ ( t ) ) {
t = DEREF_type ( type_templ_defn ( t ) ) ;
}
ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
ci = DEREF_cinfo ( ctype_info ( ct ) ) ;
if ( ci & cinfo_union ) {
key = "TU" ;
} else if ( ci & cinfo_struct ) {
key = "TS" ;
} else {
key = "TC" ;
}
break ;
}
case id_enum_name_tag : {
/* Enumerations */
key = "TE" ;
break ;
}
case id_class_alias_tag :
case id_enum_alias_tag :
case id_type_alias_tag : {
/* Type aliases */
if ( dump_anon_class ) {
dump_anon_class = 0 ;
} else {
key = "TA" ;
}
break ;
}
case id_nspace_name_tag : {
/* Namespaces */
key = "NN" ;
break ;
}
case id_nspace_alias_tag : {
/* Namespace aliases */
key = "NA" ;
break ;
}
case id_variable_tag : {
/* Variables */
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( ds & dspec_auto ) {
if ( do_local ) key = "VA" ;
} else if ( ds & dspec_static ) {
key = "VS" ;
} else {
key = "VE" ;
}
break ;
}
case id_parameter_tag :
case id_weak_param_tag : {
/* Function parameters */
if ( def && do_local ) key = "VP" ;
break ;
}
case id_function_tag : {
/* Functions */
static char f [10] ;
char *fp = f ;
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
*( fp++ ) = 'F' ;
if ( ds & dspec_static ) {
*( fp++ ) = 'S' ;
} else {
*( fp++ ) = 'E' ;
}
if ( ds & dspec_c ) *( fp++ ) = 'C' ;
if ( ds & dspec_inline ) *( fp++ ) = 'I' ;
*fp = 0 ;
key = f ;
break ;
}
case id_mem_func_tag : {
/* Member functions */
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( !( ds & dspec_trivial ) ) {
if ( ds & dspec_virtual ) {
key = "CV" ;
} else {
key = "CF" ;
}
}
break ;
}
case id_stat_mem_func_tag : {
/* Static member functions */
key = "CS" ;
break ;
}
case id_stat_member_tag : {
/* Static data members */
key = "CD" ;
break ;
}
case id_member_tag : {
/* Data members */
key = "CM" ;
break ;
}
case id_enumerator_tag : {
/* Enumerators */
key = "E" ;
break ;
}
case id_label_tag : {
/* Labels */
key = "L" ;
break ;
}
case id_token_tag : {
/* Tokens */
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( ds & dspec_auto ) {
if ( ds & dspec_template ) {
key = "XT" ;
} else {
key = "XP" ;
}
} else {
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
if ( !IS_NULL_tok ( tok ) && IS_tok_proc ( tok ) ) {
key = "XF" ;
} else {
key = "XO" ;
}
}
break ;
}
}
}
return ( key ) ;
}
/*
DUMP A LEXICAL TOKEN
This routine adds the lexical token t to the dump file.
*/
static void dump_lex
PROTO_N ( ( t ) )
PROTO_T ( int t )
{
FILE *f = dump_file ;
string s = token_name ( t ) ;
if ( s ) {
unsigned n = ( unsigned ) ustrlen ( s ) ;
if ( n > 100 || ustrchr ( s, '>' ) ) fprintf_v ( f, "&%u", n ) ;
fprintf_v ( f, "<%s>", strlit ( s ) ) ;
} else {
fputs_v ( "<>", f ) ;
}
return ;
}
/*
DUMP A HASH TABLE ENTRY
This routine adds the hash table entry nm to the dump file.
*/
static void dump_hashid
PROTO_N ( ( nm ) )
PROTO_T ( HASHID nm )
{
FILE *f = dump_file ;
if ( IS_NULL_hashid ( nm ) ) {
fputs_v ( "<>", f ) ;
return ;
}
switch ( TAG_hashid ( nm ) ) {
case hashid_name_tag :
case hashid_ename_tag : {
/* Simple identifiers */
string s = DEREF_string ( hashid_name_etc_text ( nm ) ) ;
unsigned n = ( unsigned ) ustrlen ( s ) ;
if ( n > 100 || ustrchr ( s, '>' ) ) fprintf_v ( f, "&%u", n ) ;
fprintf_v ( f, "<%s>", strlit ( s ) ) ;
break ;
}
case hashid_constr_tag : {
/* Constructor names */
TYPE t = DEREF_type ( hashid_constr_type ( nm ) ) ;
fputc_v ( 'C', f ) ;
dump_type ( t ) ;
break ;
}
case hashid_destr_tag : {
/* Destructor names */
TYPE t = DEREF_type ( hashid_destr_type ( nm ) ) ;
fputc_v ( 'D', f ) ;
dump_type ( t ) ;
break ;
}
case hashid_conv_tag : {
/* Conversion function names */
TYPE t = DEREF_type ( hashid_conv_type ( nm ) ) ;
fputc_v ( 'T', f ) ;
dump_type ( t ) ;
break ;
}
case hashid_op_tag : {
/* Overloaded operator names */
int t = DEREF_int ( hashid_op_lex ( nm ) ) ;
fputc_v ( 'O', f ) ;
dump_lex ( t ) ;
break ;
}
default : {
/* Other names */
fputs_v ( "<>", f ) ;
break ;
}
}
return ;
}
/*
DUMP A NAMESPACE
This routine adds the namespace ns to the dump file. The current
declaration block is taken into account in blk is true.
*/
static void dump_nspace
PROTO_N ( ( ns, blk ) )
PROTO_T ( NAMESPACE ns X int blk )
{
if ( !IS_NULL_nspace ( ns ) ) {
if ( blk ) {
LIST ( IDENTIFIER ) s ;
s = LIST_stack ( DEREF_stack ( nspace_set ( ns ) ) ) ;
if ( !IS_NULL_list ( s ) ) {
/* Allow for declaration blocks */
IDENTIFIER id = DEREF_id ( HEAD_list ( s ) ) ;
dump_id ( id ) ;
return ;
}
}
if ( !IS_nspace_global ( ns ) ) {
ulong n = DEREF_ulong ( nspace_dump ( ns ) ) ;
if ( n == LINK_NONE ) {
IDENTIFIER id = DEREF_id ( nspace_name ( ns ) ) ;
if ( !IS_NULL_id ( id ) ) {
/* Use namespace name */
dump_id ( id ) ;
n = DEREF_ulong ( id_dump ( id ) ) ;
COPY_ulong ( nspace_dump ( ns ), n ) ;
return ;
}
} else {
/* Already assigned value */
fprintf_v ( dump_file, "%lu", n ) ;
return ;
}
}
}
fputs_v ( "*", dump_file ) ;
return ;
}
/*
DUMP AN ACCESS SPECIFIER
This routine adds the access specifier acc to the dump file.
*/
static void dump_access
PROTO_N ( ( acc ) )
PROTO_T ( DECL_SPEC acc )
{
DECL_SPEC ds = ( acc & dspec_access ) ;
if ( ds == dspec_private ) {
fputc_v ( 'P', dump_file ) ;
} else if ( ds == dspec_protected ) {
fputc_v ( 'B', dump_file ) ;
}
return ;
}
/*
IDENTIFIER DUMP NUMBER
Each identifier dumped is assigned a number in a sequence given
by this variable. The zero value stands for the null identifier.
*/
ulong dump_id_next = 1 ;
/*
DUMP AN IDENTIFIER
This routine adds the identifier id to the dump file.
*/
static void dump_id
PROTO_N ( ( id ) )
PROTO_T ( IDENTIFIER id )
{
if ( IS_NULL_id ( id ) ) {
fputs_v ( "0", dump_file ) ;
} else {
ulong n = DEREF_ulong ( id_dump ( id ) ) ;
if ( n == LINK_NONE || ( n & LINK_EXTERN ) ) {
FILE *f = dump_file ;
HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
NAMESPACE ns = DEREF_nspace ( id_parent ( id ) ) ;
DECL_SPEC acc = DEREF_dspec ( id_storage ( id ) ) ;
if ( n == LINK_NONE ) {
/* Allocate new number */
n = dump_id_next++ ;
} else {
/* Use number from spec file */
n &= ~LINK_EXTERN ;
}
COPY_ulong ( id_dump ( id ), n ) ;
fprintf_v ( f, "%lu = ", n ) ;
dump_hashid ( nm ) ;
fputc_v ( '\t', f ) ;
dump_access ( acc ) ;
dump_nspace ( ns, 1 ) ;
} else {
fprintf_v ( dump_file, "%lu", n ) ;
}
}
return ;
}
/*
LAST DUMP LOCATION
When dumping locations the previous location is stored in these
variables and only items which have changed are output.
*/
static unsigned long last_ln = 0 ;
static unsigned long last_cn = 0 ;
static string last_file = NULL ;
static string last_input = NULL ;
static PTR ( POSITION ) last_posn = NULL_ptr ( POSITION ) ;
/*
DUMP A LOCATION
This routine adds the location loc to the dump file.
*/
static void dump_loc
PROTO_N ( ( loc ) )
PROTO_T ( LOCATION *loc )
{
FILE *f = dump_file ;
unsigned long ln = loc->line ;
unsigned long cn = loc->column ;
PTR ( POSITION ) posn = loc->posn ;
if ( EQ_ptr ( posn, last_posn ) ) {
/* Same file information as previously */
if ( ln == last_ln ) {
if ( cn == last_cn ) {
fputs_v ( "*", f ) ;
} else {
fprintf_v ( f, "%lu\t*", cn ) ;
last_cn = cn ;
}
} else {
fprintf_v ( f, "%lu\t%lu\t*", cn, ln ) ;
last_cn = cn ;
last_ln = ln ;
}
} else {
/* Different file information */
string file = DEREF_string ( posn_file ( posn ) ) ;
string input = DEREF_string ( posn_input ( posn ) ) ;
unsigned long off = DEREF_ulong ( posn_offset ( posn ) ) ;
fprintf_v ( f, "%lu\t%lu\t%lu\t", cn, ln, ln - off ) ;
if ( ustreq ( file, last_file ) && ustreq ( input, last_input ) ) {
/* File names unchanged */
fputc_v ( '*', f ) ;
} else {
unsigned n = ( unsigned ) ustrlen ( file ) ;
fprintf_v ( f, "&%u<%s>\t", n, strlit ( file ) ) ;
if ( ustreq ( file, input ) ) {
/* Current and actual files match */
fputc_v ( '*', f ) ;
} else {
/* Different current and actual files */
n = ( unsigned ) ustrlen ( input ) ;
fprintf_v ( f, "&%u<%s>", n, strlit ( input ) ) ;
}
last_input = input ;
last_file = file ;
}
last_posn = posn ;
last_cn = cn ;
last_ln = ln ;
}
return ;
}
/*
DUMP AN EXPRESSION
This routine adds the expression e to the dump file.
*/
static void dump_exp
PROTO_N ( ( e ) )
PROTO_T ( EXP e )
{
if ( !IS_NULL_exp ( e ) ) {
switch ( TAG_exp ( e ) ) {
case exp_int_lit_tag : {
/* Integer literals */
NAT n = DEREF_nat ( exp_int_lit_nat ( e ) ) ;
dump_nat ( n, 0 ) ;
return ;
}
case exp_token_tag : {
/* Tokenised expressions */
IDENTIFIER id = DEREF_id ( exp_token_tok ( e ) ) ;
LIST ( TOKEN ) args = DEREF_list ( exp_token_args ( e ) ) ;
dump_tok_appl ( id, args ) ;
return ;
}
}
}
IGNORE print_exp ( e, 0, dump_buff, 0 ) ;
dump_string () ;
return ;
}
/*
DUMP AN OFFSET
This routine adds the offset off to the dump file.
*/
static void dump_off
PROTO_N ( ( off ) )
PROTO_T ( OFFSET off )
{
IGNORE print_offset ( off, dump_buff, 0 ) ;
dump_string () ;
return ;
}
/*
DUMP AN INTEGER CONSTANT
This routine adds the integer constant n to the dump file.
*/
static void dump_nat
PROTO_N ( ( n, neg ) )
PROTO_T ( NAT n X int neg )
{
if ( !IS_NULL_nat ( n ) ) {
FILE *f = dump_file ;
ASSERT ( ORDER_nat == 5 ) ;
switch ( TAG_nat ( n ) ) {
case nat_small_tag : {
/* Small literals */
unsigned v = DEREF_unsigned ( nat_small_value ( n ) ) ;
int s = ( neg ? '-' : '+' ) ;
fputc_v ( s, f ) ;
fprintf_v ( f, "%u", v ) ;
break ;
}
case nat_large_tag : {
/* Large literals */
unsigned long v = get_nat_value ( n ) ;
int s = ( neg ? '-' : '+' ) ;
fputc_v ( s, f ) ;
fprintf_v ( f, "%lu", v ) ;
break ;
}
case nat_neg_tag : {
/* Negated literals */
NAT m = DEREF_nat ( nat_neg_arg ( n ) ) ;
dump_nat ( m, !neg ) ;
break ;
}
case nat_calc_tag : {
/* Calculated literals */
EXP e = DEREF_exp ( nat_calc_value ( n ) ) ;
dump_exp ( e ) ;
break ;
}
case nat_token_tag : {
/* Tokenised literals */
IDENTIFIER id = DEREF_id ( nat_token_tok ( n ) ) ;
LIST ( TOKEN ) args = DEREF_list ( nat_token_args ( n ) ) ;
dump_tok_appl ( id, args ) ;
break ;
}
}
}
return ;
}
/*
DUMP A LIST OF TOKEN PARAMETERS
This routine adds the list of token parameters pids to the dump file.
*/
static void dump_params
PROTO_N ( ( pids ) )
PROTO_T ( LIST ( IDENTIFIER ) pids )
{
int started = 0 ;
FILE *f = dump_file ;
while ( !IS_NULL_list ( pids ) ) {
IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
if ( !IS_NULL_id ( pid ) ) {
if ( IS_id_token ( pid ) ) {
pid = DEREF_id ( id_token_alt ( pid ) ) ;
}
if ( started ) fputc_v ( MANGLE_comma, f ) ;
dump_id ( pid ) ;
started = 1 ;
}
pids = TAIL_list ( pids ) ;
}
return ;
}
/*
DUMP A TOKEN SORT
This routine adds the token sort tok to the dump file.
*/
static void dump_sort
PROTO_N ( ( tok ) )
PROTO_T ( TOKEN tok )
{
FILE *f = dump_file ;
ASSERT ( ORDER_tok == 10 ) ;
switch ( TAG_tok ( tok ) ) {
case tok_exp_tag : {
/* Expression tokens */
TYPE t = DEREF_type ( tok_exp_type ( tok ) ) ;
int c = DEREF_int ( tok_exp_constant ( tok ) ) ;
if ( c ) {
fputs_v ( "ZEC", f ) ;
} else {
CV_SPEC cv = DEREF_cv ( type_qual ( t ) ) ;
if ( cv & cv_lvalue ) {
fputs_v ( "ZEL", f ) ;
} else {
fputs_v ( "ZER", f ) ;
}
}
dump_type ( t ) ;
break ;
}
case tok_stmt_tag : {
/* Statement tokens */
fputs_v ( "ZS", f ) ;
break ;
}
case tok_nat_tag : {
/* Integer constant tokens */
fputs_v ( "ZN", f ) ;
break ;
}
case tok_snat_tag : {
/* Integer constant tokens */
fputs_v ( "ZI", f ) ;
break ;
}
case tok_type_tag : {
/* Type tokens */
int c ;
BASE_TYPE bt = DEREF_btype ( tok_type_kind ( tok ) ) ;
if ( bt & btype_float ) {
if ( bt & btype_int ) {
c = 'A' ;
} else {
c = 'F' ;
}
} else if ( bt & btype_int ) {
c = 'I' ;
} else if ( bt & btype_class ) {
c = 'S' ;
} else if ( bt & btype_struct ) {
c = 'S' ;
} else if ( bt & btype_union ) {
c = 'U' ;
} else {
c = 'O' ;
}
fputs_v ( "ZT", f ) ;
fputc_v ( c, f ) ;
break ;
}
case tok_func_tag : {
/* Function tokens */
TYPE t = DEREF_type ( tok_func_type ( tok ) ) ;
fputs_v ( "ZF", f ) ;
dump_type ( t ) ;
break ;
}
case tok_member_tag : {
/* Member tokens */
TYPE t = DEREF_type ( tok_member_type ( tok ) ) ;
TYPE s = DEREF_type ( tok_member_of ( tok ) ) ;
fputs_v ( "ZM", f ) ;
dump_type ( t ) ;
fputc_v ( MANGLE_colon, f ) ;
dump_type ( s ) ;
break ;
}
case tok_class_tag : {
/* Template parameter tokens */
TYPE t = DEREF_type ( tok_class_type ( tok ) ) ;
TOKEN sort = DEREF_tok ( type_templ_sort ( t ) ) ;
fputs_v ( "ZT", f ) ;
dump_sort ( sort ) ;
break ;
}
case tok_proc_tag : {
/* Procedure tokens */
TOKEN res = DEREF_tok ( tok_proc_res ( tok ) ) ;
LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
LIST ( IDENTIFIER ) pids = DEREF_list ( tok_proc_pids ( tok ) ) ;
if ( EQ_list ( bids, pids ) ) {
fputs_v ( "ZPS", f ) ;
dump_params ( bids ) ;
} else {
fputs_v ( "ZPG", f ) ;
dump_params ( bids ) ;
fputs_v ( ";", f ) ;
dump_params ( pids ) ;
}
fputc_v ( MANGLE_colon, f ) ;
dump_sort ( res ) ;
break ;
}
case tok_templ_tag : {
/* Template tokens */
LIST ( IDENTIFIER ) pids = DEREF_list ( tok_templ_pids ( tok ) ) ;
fputc_v ( MANGLE_template, f ) ;
dump_params ( pids ) ;
fputc_v ( MANGLE_colon, f ) ;
break ;
}
}
return ;
}
/*
DUMP AN INTEGRAL TYPE
This routine adds the integral type it to the dump file. Note that
for this and the other type dumping routines the representation
chosen bears a marked resemblance to the C++ name mangling scheme,
and uses the same MANGLE_* macros. This is primarily to avoid having
to think up two different forms.
*/
static void dump_itype
PROTO_N ( ( it ) )
PROTO_T ( INT_TYPE it )
{
FILE *f = dump_file ;
ASSERT ( ORDER_itype == 6 ) ;
switch ( TAG_itype ( it ) ) {
case itype_basic_tag : {
/* Basic integral types */
BUILTIN_TYPE n = DEREF_ntype ( itype_basic_no ( it ) ) ;
fputs_v ( mangle_ntype [n], f ) ;
break ;
}
case itype_bitfield_tag : {
/* Bitfield types */
NAT n = DEREF_nat ( itype_bitfield_size ( it ) ) ;
TYPE s = DEREF_type ( itype_bitfield_sub ( it ) ) ;
fputc_v ( MANGLE_bitfield, f ) ;
dump_nat ( n, 0 ) ;
fputc_v ( MANGLE_colon, f ) ;
dump_type ( s ) ;
break ;
}
case itype_promote_tag : {
/* Promotion types */
INT_TYPE is = DEREF_itype ( itype_promote_arg ( it ) ) ;
fputc_v ( MANGLE_promote, f ) ;
dump_itype ( is ) ;
break ;
}
case itype_arith_tag : {
/* Arithmetic types */
INT_TYPE is = DEREF_itype ( itype_arith_arg1 ( it ) ) ;
INT_TYPE ir = DEREF_itype ( itype_arith_arg2 ( it ) ) ;
fputc_v ( MANGLE_arith, f ) ;
dump_itype ( is ) ;
fputc_v ( MANGLE_colon, f ) ;
dump_itype ( ir ) ;
break ;
}
case itype_literal_tag : {
/* Literal types */
NAT n = DEREF_nat ( itype_literal_nat ( it ) ) ;
string s = mangle_literal ( it ) ;
fputs_v ( strlit ( s ), f ) ;
dump_nat ( n, 0 ) ;
break ;
}
case itype_token_tag : {
/* Tokenised types */
BUILTIN_TYPE n = DEREF_ntype ( itype_unprom ( it ) ) ;
if ( n == ntype_none || n == ntype_ellipsis ) {
IDENTIFIER id ;
LIST ( TOKEN ) args ;
id = DEREF_id ( itype_token_tok ( it ) ) ;
args = DEREF_list ( itype_token_args ( it ) ) ;
dump_tok_appl ( id, args ) ;
} else {
fputc_v ( MANGLE_promote, f ) ;
fputs_v ( mangle_ntype [n], f ) ;
}
break ;
}
}
return ;
}
/*
DUMP A FLOATING POINT TYPE
This routine adds the floating point type ft to the dump file.
*/
static void dump_ftype
PROTO_N ( ( ft ) )
PROTO_T ( FLOAT_TYPE ft )
{
FILE *f = dump_file ;
ASSERT ( ORDER_ftype == 4 ) ;
switch ( TAG_ftype ( ft ) ) {
case ftype_basic_tag : {
/* Basic floating types */
BUILTIN_TYPE n = DEREF_ntype ( ftype_basic_no ( ft ) ) ;
fputs_v ( mangle_ntype [n], f ) ;
break ;
}
case ftype_arg_promote_tag : {
/* Promotion types */
FLOAT_TYPE fs = DEREF_ftype ( ftype_arg_promote_arg ( ft ) ) ;
fputc_v ( MANGLE_promote, f ) ;
dump_ftype ( fs ) ;
break ;
}
case ftype_arith_tag : {
/* Arithmetic types */
FLOAT_TYPE fs = DEREF_ftype ( ftype_arith_arg1 ( ft ) ) ;
FLOAT_TYPE fr = DEREF_ftype ( ftype_arith_arg2 ( ft ) ) ;
fputc_v ( MANGLE_arith, f ) ;
dump_ftype ( fs ) ;
fputc_v ( MANGLE_colon, f ) ;
dump_ftype ( fr ) ;
break ;
}
case ftype_token_tag : {
/* Tokenised types */
IDENTIFIER id = DEREF_id ( ftype_token_tok ( ft ) ) ;
LIST ( TOKEN ) args = DEREF_list ( ftype_token_args ( ft ) ) ;
dump_tok_appl ( id, args ) ;
break ;
}
}
return ;
}
/*
DUMP A CLASS TYPE
This routine adds the class type ct to the dump file.
*/
static void dump_ctype
PROTO_N ( ( ct ) )
PROTO_T ( CLASS_TYPE ct )
{
IDENTIFIER cid = DEREF_id ( ctype_name ( ct ) ) ;
dump_id ( cid ) ;
return ;
}
/*
DUMP AN ENUMERATION TYPE
This routine adds the enumeration type et to the dump file.
*/
static void dump_etype
PROTO_N ( ( et ) )
PROTO_T ( ENUM_TYPE et )
{
IDENTIFIER eid = DEREF_id ( etype_name ( et ) ) ;
dump_id ( eid ) ;
return ;
}
/*
DUMP A CONST-VOLATILE QUALIFIER
This routine adds the const-volatile qualifier cv to the dump file.
*/
static void dump_cv
PROTO_N ( ( cv ) )
PROTO_T ( CV_SPEC cv )
{
if ( cv & cv_const ) fputc_v ( MANGLE_const, dump_file ) ;
if ( cv & cv_volatile ) fputc_v ( MANGLE_volatile, dump_file ) ;
return ;
}
/*
DUMP A LIST OF TYPES
This routine adds the list of types p to the dump file.
*/
static void dump_type_list
PROTO_N ( ( p, ell, started ) )
PROTO_T ( LIST ( TYPE ) p X int ell X int started )
{
while ( !IS_NULL_list ( p ) ) {
TYPE t = DEREF_type ( HEAD_list ( p ) ) ;
if ( !IS_NULL_type ( t ) ) {
if ( started ) fputc_v ( MANGLE_comma, dump_file ) ;
if ( ell & FUNC_PARAMS ) t = unpromote_type ( t ) ;
dump_type ( t ) ;
started = 1 ;
}
p = TAIL_list ( p ) ;
}
return ;
}
/*
DUMP A TYPE
This routine adds the type t to the dump file.
*/
static void dump_type
PROTO_N ( ( t ) )
PROTO_T ( TYPE t )
{
CV_SPEC qual = DEREF_cv ( type_qual ( t ) ) ;
IDENTIFIER tid = DEREF_id ( type_name ( t ) ) ;
dump_cv ( qual ) ;
if ( !IS_NULL_id ( tid ) ) {
switch ( TAG_id ( tid ) ) {
case id_class_alias_tag :
case id_enum_alias_tag :
case id_type_alias_tag : {
dump_id ( tid ) ;
return ;
}
}
}
ASSERT ( ORDER_type == 18 ) ;
switch ( TAG_type ( t ) ) {
case type_pre_tag : {
/* Pre-types */
if ( !IS_NULL_id ( tid ) ) {
dump_id ( tid ) ;
} else {
BASE_TYPE bt = DEREF_btype ( type_pre_rep ( t ) ) ;
if ( bt == btype_ellipsis ) {
fputs_v ( "Q<...>", dump_file ) ;
} else {
fputc_v ( MANGLE_error, dump_file ) ;
}
}
break ;
}
case type_integer_tag : {
/* Integral types */
INT_TYPE it = DEREF_itype ( type_integer_rep ( t ) ) ;
dump_itype ( it ) ;
break ;
}
case type_floating_tag : {
/* Floating point types */
FLOAT_TYPE ft = DEREF_ftype ( type_floating_rep ( t ) ) ;
dump_ftype ( ft ) ;
break ;
}
case type_top_tag : {
/* Top type */
fputc_v ( MANGLE_void, dump_file ) ;
break ;
}
case type_bottom_tag : {
/* Bottom type */
fputc_v ( MANGLE_bottom, dump_file ) ;
break ;
}
case type_ptr_tag : {
/* Pointer types */
TYPE s = DEREF_type ( type_ptr_sub ( t ) ) ;
fputc_v ( MANGLE_ptr, dump_file ) ;
dump_type ( s ) ;
break ;
}
case type_ref_tag : {
/* Reference types */
TYPE s = DEREF_type ( type_ref_sub ( t ) ) ;
fputc_v ( MANGLE_ref, dump_file ) ;
dump_type ( s ) ;
break ;
}
case type_ptr_mem_tag : {
/* Pointer to member types */
CLASS_TYPE ct = DEREF_ctype ( type_ptr_mem_of ( t ) ) ;
TYPE s = DEREF_type ( type_ptr_mem_sub ( t ) ) ;
fputc_v ( MANGLE_ptr_mem, dump_file ) ;
dump_ctype ( ct ) ;
fputc_v ( MANGLE_colon, dump_file ) ;
dump_type ( s ) ;
break ;
}
case type_func_tag : {
/* Function types */
FILE *f = dump_file ;
TYPE r = DEREF_type ( type_func_ret ( t ) ) ;
LIST ( TYPE ) p = DEREF_list ( type_func_ptypes ( t ) ) ;
LIST ( TYPE ) e = DEREF_list ( type_func_except ( t ) ) ;
int ell = DEREF_int ( type_func_ellipsis ( t ) ) ;
CV_SPEC mqual = DEREF_cv ( type_func_mqual ( t ) ) ;
if ( ell & FUNC_WEAK ) {
fputc_v ( MANGLE_weak, f ) ;
} else {
fputc_v ( MANGLE_func, f ) ;
}
dump_type ( r ) ;
dump_type_list ( p, ell, 1 ) ;
if ( ell & FUNC_VAR_PARAMS ) {
fputc_v ( MANGLE_dot, f ) ;
} else {
fputc_v ( MANGLE_colon, f ) ;
}
if ( !EQ_list ( e, univ_type_set ) ) {
/* Output exception specifiers */
fputc_v ( '(', f ) ;
dump_type_list ( e, FUNC_NONE, 0 ) ;
fputc_v ( ')', f ) ;
}
dump_cv ( mqual ) ;
if ( ell & FUNC_NO_PARAMS ) {
fputc_v ( MANGLE_dot, f ) ;
} else {
fputc_v ( MANGLE_colon, f ) ;
}
break ;
}
case type_array_tag : {
/* Array types */
TYPE s = DEREF_type ( type_array_sub ( t ) ) ;
NAT n = DEREF_nat ( type_array_size ( t ) ) ;
fputc_v ( MANGLE_array, dump_file ) ;
if ( !IS_NULL_nat ( n ) ) dump_nat ( n, 0 ) ;
fputc_v ( MANGLE_colon, dump_file ) ;
dump_type ( s ) ;
break ;
}
case type_bitfield_tag : {
/* Bitfield types */
INT_TYPE it = DEREF_itype ( type_bitfield_defn ( t ) ) ;
dump_itype ( it ) ;
break ;
}
case type_compound_tag : {
/* Class types */
CLASS_TYPE ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
dump_ctype ( ct ) ;
break ;
}
case type_enumerate_tag : {
/* Enumeration types */
ENUM_TYPE et = DEREF_etype ( type_enumerate_defn ( t ) ) ;
dump_etype ( et ) ;
break ;
}
case type_token_tag : {
/* Tokenised types */
IDENTIFIER id = DEREF_id ( type_token_tok ( t ) ) ;
LIST ( TOKEN ) args = DEREF_list ( type_token_args ( t ) ) ;
dump_tok_appl ( id, args ) ;
break ;
}
case type_templ_tag : {
/* Template types */
TYPE s = DEREF_type ( type_templ_defn ( t ) ) ;
TOKEN sort = DEREF_tok ( type_templ_sort ( t ) ) ;
dump_sort ( sort ) ;
dump_type ( s ) ;
break ;
}
case type_instance_tag : {
/* Template instance types */
IDENTIFIER id = DEREF_id ( type_name ( t ) ) ;
dump_id ( id ) ;
break ;
}
default : {
/* Other types */
fputc_v ( MANGLE_error, dump_file ) ;
break ;
}
}
return ;
}
/*
DUMP A GRAPH
This routine adds the graph gr and all its subgraphs to the dump file.
*/
static void dump_graph
PROTO_N ( ( gr ) )
PROTO_T ( GRAPH gr )
{
FILE *f = dump_file ;
unsigned n = DEREF_unsigned ( graph_no ( gr ) ) ;
DECL_SPEC ds = DEREF_dspec ( graph_access ( gr ) ) ;
if ( ds & dspec_main ) {
/* First instance of base */
DECL_SPEC acc = ( ds & dspec_access ) ;
CLASS_TYPE ct = DEREF_ctype ( graph_head ( gr ) ) ;
LIST ( GRAPH ) br = DEREF_list ( graph_tails ( gr ) ) ;
fprintf_v ( f, "%u=", n ) ;
/* Dump access */
if ( ds & dspec_virtual ) fputc_v ( 'V', f ) ;
if ( acc != dspec_public ) {
gr = DEREF_graph ( graph_equal ( gr ) ) ;
while ( !IS_NULL_graph ( gr ) ) {
ds = DEREF_dspec ( graph_access ( gr ) ) ;
ds &= dspec_access ;
if ( ds < acc ) acc = ds ;
if ( acc == dspec_public ) break ;
gr = DEREF_graph ( graph_equal ( gr ) ) ;
}
}
dump_access ( acc ) ;
/* Dump base classes */
dump_ctype ( ct ) ;
if ( !IS_NULL_list ( br ) ) {
fputs_v ( " ( ", f ) ;
while ( !IS_NULL_list ( br ) ) {
GRAPH gs = DEREF_graph ( HEAD_list ( br ) ) ;
dump_graph ( gs ) ;
fputc_v ( ' ', f ) ;
br = TAIL_list ( br ) ;
}
fputc_v ( ')', f ) ;
}
} else {
/* Subsequent instances of base */
fprintf_v ( f, "%u:", n ) ;
}
return ;
}
/*
DUMP A TOKEN APPLICATION
This routine adds the token application id ( args ) to the dump file.
*/
static void dump_tok_appl
PROTO_N ( ( id, args ) )
PROTO_T ( IDENTIFIER id X LIST ( TOKEN ) args )
{
if ( IS_id_token ( id ) ) {
IDENTIFIER alt = DEREF_id ( id_token_alt ( id ) ) ;
if ( !IS_NULL_id ( alt ) ) id = alt ;
}
if ( IS_NULL_list ( args ) ) {
dump_id ( id ) ;
} else {
FILE *f = dump_file ;
fputc_v ( 'T', f ) ;
dump_id ( id ) ;
while ( !IS_NULL_list ( args ) ) {
TOKEN arg = DEREF_tok ( HEAD_list ( args ) ) ;
fputc_v ( MANGLE_comma, f ) ;
if ( !IS_NULL_tok ( arg ) ) {
ASSERT ( ORDER_tok == 10 ) ;
switch ( TAG_tok ( arg ) ) {
case tok_exp_tag : {
EXP e = DEREF_exp ( tok_exp_value ( arg ) ) ;
fputc_v ( 'E', f ) ;
if ( !IS_NULL_exp ( e ) ) dump_exp ( e ) ;
break ;
}
case tok_stmt_tag : {
EXP e = DEREF_exp ( tok_stmt_value ( arg ) ) ;
fputc_v ( 'S', f ) ;
if ( !IS_NULL_exp ( e ) ) dump_exp ( e ) ;
break ;
}
case tok_nat_tag : {
NAT n = DEREF_nat ( tok_nat_value ( arg ) ) ;
fputc_v ( 'N', f ) ;
if ( !IS_NULL_nat ( n ) ) dump_nat ( n, 0 ) ;
break ;
}
case tok_snat_tag : {
NAT n = DEREF_nat ( tok_snat_value ( arg ) ) ;
fputc_v ( 'I', f ) ;
if ( !IS_NULL_nat ( n ) ) dump_nat ( n, 0 ) ;
break ;
}
case tok_type_tag : {
TYPE t = DEREF_type ( tok_type_value ( arg ) ) ;
fputc_v ( 'T', f ) ;
if ( !IS_NULL_type ( t ) ) dump_type ( t ) ;
break ;
}
case tok_func_tag : {
IDENTIFIER fid = DEREF_id ( tok_func_defn ( arg ) ) ;
fputc_v ( 'F', f ) ;
if ( !IS_NULL_id ( fid ) ) dump_id ( fid ) ;
break ;
}
case tok_member_tag : {
OFFSET off = DEREF_off ( tok_member_value ( arg ) ) ;
fputc_v ( 'M', f ) ;
if ( !IS_NULL_off ( off ) ) dump_off ( off ) ;
break ;
}
case tok_class_tag : {
IDENTIFIER tid = DEREF_id ( tok_class_value ( arg ) ) ;
fputc_v ( 'C', f ) ;
if ( !IS_NULL_id ( tid ) ) dump_id ( tid ) ;
break ;
}
}
}
args = TAIL_list ( args ) ;
}
fputc_v ( MANGLE_colon, f ) ;
}
return ;
}
/*
DUMP A BASE CLASS GRAPH
This routine adds the base class graph associated with the class type
ct to the dump file.
*/
void dump_base
PROTO_N ( ( ct ) )
PROTO_T ( CLASS_TYPE ct )
{
unsigned n = DEREF_unsigned ( ctype_no_bases ( ct ) ) ;
if ( n > 1 ) {
FILE *f = dump_file ;
if ( f ) {
CONST char *key ;
GRAPH gr = DEREF_graph ( ctype_base ( ct ) ) ;
CLASS_INFO ci = DEREF_cinfo ( ctype_info ( ct ) ) ;
if ( ci & cinfo_union ) {
key = "TU" ;
} else if ( ci & cinfo_struct ) {
key = "TS" ;
} else {
key = "TC" ;
}
fprintf_v ( f, "B%s\t%u\t", key, n ) ;
dump_graph ( gr ) ;
fputc_v ( '\n', f ) ;
}
}
return ;
}
/*
DUMP AN OVERRIDING VIRTUAL FUNCTION
This routine dumps the fact that the virtual function id overrides
the virtual function fid.
*/
void dump_override
PROTO_N ( ( id, fid ) )
PROTO_T ( IDENTIFIER id X IDENTIFIER fid )
{
FILE *f = dump_file ;
if ( f ) {
fputs_v ( "O\t", f ) ;
dump_id ( id ) ;
fputc_v ( '\t', f ) ;
dump_id ( fid ) ;
fputc_v ( '\n', f ) ;
}
return ;
}
/*
DUMP A USING DECLARATION
This routine dumps the fact that a using declaration has been used to
set up the alias id for cid.
*/
void dump_alias
PROTO_N ( ( id, cid, loc ) )
PROTO_T ( IDENTIFIER id X IDENTIFIER cid X LOCATION *loc )
{
ulong n = DEREF_ulong ( id_dump ( cid ) ) ;
COPY_ulong ( id_dump ( id ), n ) ;
/* NOT YET IMPLEMENTED */
UNUSED ( loc ) ;
return ;
}
/*
DUMP A USING DIRECTIVE
This routine dumps the fact that the namespace ns has been the subject
of a using directive in the namespace cns.
*/
void dump_using
PROTO_N ( ( ns, cns, loc ) )
PROTO_T ( NAMESPACE ns X NAMESPACE cns X LOCATION *loc )
{
/* NOT YET IMPLEMENTED */
UNUSED ( ns ) ;
UNUSED ( cns ) ;
UNUSED ( loc ) ;
return ;
}
/*
TABLE OF ERROR NUMBERS
This array contains a table of flags indicating whether each error
has been output or not.
*/
static char *err_output = NULL ;
/*
DUMP AN ERROR
This routine adds the error e of severity sev to the dump file. It
returns false if the dump has already been closed or e is an internal
compiler error.
*/
int dump_error
PROTO_N ( ( e, loc, sev, cnt ) )
PROTO_T ( ERROR e X LOCATION *loc X int sev X int cnt )
{
if ( IS_err_simple ( e ) ) {
/* Simple error message */
FILE *f = dump_file ;
int n = DEREF_int ( err_simple_number ( e ) ) ;
ERR_DATA *msg = ERR_CATALOG + n ;
CONST char *sig = msg->signature ;
ERR_PROPS props = msg->props ;
/* Dump start of error */
if ( f == NULL ) return ( 0 ) ;
if ( props & ERR_PROP_compiler ) return ( 0 ) ;
if ( loc ) {
/* First error component */
CONST char *err ;
switch ( sev ) {
case ERROR_FATAL : err = "EF" ; break ;
case ERROR_INTERNAL : err = "EI" ; break ;
case ERROR_WARNING : err = "EW" ; break ;
default : err = "ES" ; break ;
}
fprintf_v ( f, "%s\t", err ) ;
dump_loc ( loc ) ;
fputc_v ( '\t', f ) ;
} else {
/* Subsequent error component */
fputs_v ( "EC\t", f ) ;
}
/* Dump error number */
if ( err_output [n] ) {
fprintf_v ( f, "%d", n ) ;
} else {
CONST char *name = msg->name ;
fprintf_v ( f, "%d = <%s.%s>", n, ERR_NAME, name ) ;
err_output [n] = 1 ;
}
/* Dump error arguments */
if ( sig == NULL ) {
fprintf_v ( f, "\t0\t%d\n", cnt ) ;
} else {
unsigned a ;
unsigned na = ( unsigned ) strlen ( sig ) ;
fprintf_v ( f, "\t%u\t%d\n", na, cnt ) ;
for ( a = 0 ; a < na ; a++ ) {
switch ( sig [a] ) {
case ERR_KEY_ACCESS : {
ACCESS acc ;
acc = DEREF_dspec ( err_arg ( e, a, ACCESS ) ) ;
IGNORE print_access ( acc, dump_buff, 0 ) ;
fputs_v ( "EAS\t", f ) ;
dump_string () ;
break ;
}
case ERR_KEY_BASE_TYPE : {
BASE_TYPE bt ;
bt = DEREF_btype ( err_arg ( e, a, BASE_TYPE ) ) ;
IGNORE print_btype ( bt, dump_buff, 0 ) ;
fputs_v ( "EAS\t", f ) ;
dump_string () ;
break ;
}
case ERR_KEY_CLASS_TYPE : {
CLASS_TYPE ct ;
ct = DEREF_ctype ( err_arg ( e, a, CLASS_TYPE ) ) ;
fputs_v ( "EAT\t", f ) ;
dump_ctype ( ct ) ;
break ;
}
case ERR_KEY_CV_SPEC : {
CV_SPEC cv = DEREF_cv ( err_arg ( e, a, CV_SPEC ) ) ;
IGNORE print_cv ( cv, dump_buff, 0 ) ;
fputs_v ( "EAS\t", f ) ;
dump_string () ;
break ;
}
case ERR_KEY_DECL_SPEC : {
DECL_SPEC ds ;
ds = DEREF_dspec ( err_arg ( e, a, DECL_SPEC ) ) ;
IGNORE print_dspec ( ds, dump_buff, 0 ) ;
fputs_v ( "EAS\t", f ) ;
dump_string () ;
break ;
}
case ERR_KEY_FLOAT : {
FLOAT flt = DEREF_flt ( err_arg ( e, a, FLOAT ) ) ;
IGNORE print_flt ( flt, dump_buff, 0 ) ;
fputs_v ( "EAS\t", f ) ;
dump_string () ;
break ;
}
case ERR_KEY_HASHID : {
HASHID nm ;
nm = DEREF_hashid ( err_arg ( e, a, HASHID ) ) ;
fputs_v ( "EAH\t", f ) ;
dump_hashid ( nm ) ;
break ;
}
case ERR_KEY_IDENTIFIER :
case ERR_KEY_LONG_ID : {
IDENTIFIER id ;
id = DEREF_id ( err_arg ( e, a, IDENTIFIER ) ) ;
fputs_v ( "EAI\t", f ) ;
dump_id ( id ) ;
break ;
}
case ERR_KEY_LEX : {
LEX t = DEREF_int ( err_arg ( e, a, LEX ) ) ;
fputs_v ( "EAS\t", f ) ;
dump_lex ( t ) ;
break ;
}
case ERR_KEY_NAMESPACE : {
NAMESPACE ns ;
ns = DEREF_nspace ( err_arg ( e, a, NAMESPACE ) ) ;
fputs_v ( "EAC\t", f ) ;
dump_nspace ( ns, 0 ) ;
break ;
}
case ERR_KEY_NAT : {
NAT nat = DEREF_nat ( err_arg ( e, a, NAT ) ) ;
fputs_v ( "EAN\t", f ) ;
dump_nat ( nat, 0 ) ;
break ;
}
case ERR_KEY_PPTOKEN_P : {
PPTOKEN_P tok ;
tok = DEREF_pptok ( err_arg ( e, a, PPTOKEN_P ) ) ;
IGNORE print_pptok ( tok, dump_buff, 0 ) ;
fputs_v ( "EAS\t", f ) ;
dump_string () ;
break ;
}
case ERR_KEY_PTR_LOC : {
PTR_LOC ploc ;
LOCATION aloc ;
ploc = DEREF_ptr ( err_arg ( e, a, PTR_LOC ) ) ;
DEREF_loc ( ploc, aloc ) ;
fputs_v ( "EAL\t", f ) ;
dump_loc ( &aloc ) ;
break ;
}
case ERR_KEY_QUALIFIER : {
CONST char *s ;
QUALIFIER qual ;
qual = DEREF_qual ( err_arg ( e, a, QUALIFIER ) ) ;
if ( qual == qual_full || qual == qual_top ) {
s = "::" ;
} else {
s = "" ;
}
fprintf_v ( f, "EAS\t<%s>", s ) ;
break ;
}
case ERR_KEY_STRING : {
STRING str = DEREF_str ( err_arg ( e, a, STRING ) ) ;
IGNORE print_str ( str, dump_buff, 0 ) ;
fputs_v ( "EAS\t", f ) ;
dump_string () ;
break ;
}
case ERR_KEY_TYPE : {
TYPE t = DEREF_type ( err_arg ( e, a, TYPE ) ) ;
fputs_v ( "EAT\t", f ) ;
dump_type ( t ) ;
break ;
}
case ERR_KEY_cint : {
cint i = DEREF_int ( err_arg ( e, a, cint ) ) ;
fprintf_v ( f, "EAV\t%d", i ) ;
break ;
}
case ERR_KEY_plural : {
plural i ;
i = DEREF_unsigned ( err_arg ( e, a, plural ) ) ;
if ( i == 1 ) {
fputs_v ( "EAS\t<>", f ) ;
} else {
fputs_v ( "EAS\t<s>", f ) ;
}
break ;
}
case ERR_KEY_cstring :
case ERR_KEY_string : {
string s ;
s = DEREF_string ( err_arg ( e, a, string ) ) ;
if ( s ) {
unsigned d = ( unsigned ) ustrlen ( s ) ;
fprintf_v ( f, "EAS\t&%u<%s>", d, strlit ( s ) ) ;
} else {
fputs_v ( "EAS\t<>", f ) ;
}
break ;
}
case ERR_KEY_ulong :
case ERR_KEY_ucint : {
ulong u = DEREF_ulong ( err_arg ( e, a, ulong ) ) ;
fprintf_v ( f, "EAV\t%lu", u ) ;
break ;
}
case ERR_KEY_unsigned : {
unsigned u ;
u = DEREF_unsigned ( err_arg ( e, a, unsigned ) ) ;
fprintf_v ( f, "EAV\t%u", u ) ;
break ;
}
default : {
fputs_v ( "EAS\t<>", f ) ;
break ;
}
}
fputc_v ( '\n', f ) ;
}
}
} else {
/* Composite error message */
ERROR e1 = DEREF_err ( err_compound_head ( e ) ) ;
ERROR e2 = DEREF_err ( err_compound_tail ( e ) ) ;
if ( !dump_error ( e1, loc, sev, 1 ) ) return ( 0 ) ;
if ( !dump_error ( e2, NIL ( LOCATION ), sev, cnt ) ) return ( 0 ) ;
}
return ( 1 ) ;
}
/*
DUMP A VARIABLE DESTRUCTOR CALL
This routine adds the call of the destructor for the variable id to
the dump file.
*/
void dump_destr
PROTO_N ( ( id, loc ) )
PROTO_T ( IDENTIFIER id X LOCATION *loc )
{
EXP d = DEREF_exp ( id_variable_etc_term ( id ) ) ;
if ( !IS_NULL_exp ( d ) ) {
unsigned tag = TAG_exp ( d ) ;
while ( tag == exp_paren_tag ) {
d = DEREF_exp ( exp_paren_arg ( d ) ) ;
if ( IS_NULL_exp ( d ) ) return ;
tag = TAG_exp ( d ) ;
}
while ( tag == exp_nof_tag ) {
d = DEREF_exp ( exp_nof_pad ( d ) ) ;
tag = TAG_exp ( d ) ;
}
while ( tag == exp_destr_tag ) {
d = DEREF_exp ( exp_destr_call ( d ) ) ;
tag = TAG_exp ( d ) ;
}
if ( tag == exp_func_id_tag ) {
IDENTIFIER fn = DEREF_id ( exp_func_id_id ( d ) ) ;
dump_use ( id, loc, 0 ) ;
dump_call ( fn, loc, 0 ) ;
}
}
return ;
}
/*
DUMP AN IDENTIFIER DECLARATION
This routine adds the declaration of the identifier id to the dump
file. The parameter def is 1 for a definition, 2 for a tentative
definition, and 0 for a declaration.
*/
void dump_declare
PROTO_N ( ( id, loc, def ) )
PROTO_T ( IDENTIFIER id X LOCATION *loc X int def )
{
FILE *f = dump_file ;
CONST char *key = dump_key ( id, def ) ;
if ( key && f ) {
/* Dump identifier key */
char d = 'M' ;
int destr = 0 ;
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( dump_implicit || dump_template ) fputc_v ( 'I', f ) ;
switch ( def ) {
case 1 : d = 'D' ; break ;
case 2 : d = 'T' ; break ;
}
/* Dump location and identifier information */
fprintf_v ( f, "%c%s\t", d, key ) ;
dump_loc ( loc ) ;
fputc_v ( '\t', f ) ;
dump_id ( id ) ;
fputc_v ( '\t', f ) ;
/* Dump identifier specific information */
switch ( TAG_id ( id ) ) {
case id_obj_macro_tag : {
/* Object-like macros */
fputs_v ( "ZUO", f ) ;
break ;
}
case id_func_macro_tag : {
/* Function-like macros */
unsigned n ;
n = DEREF_unsigned ( id_func_macro_no_params ( id ) ) ;
fprintf_v ( f, "ZUF%u", n ) ;
break ;
}
case id_builtin_tag : {
/* Built-in operators */
TYPE r = DEREF_type ( id_builtin_ret ( id ) ) ;
LIST ( TYPE ) p = DEREF_list ( id_builtin_ptypes ( id ) ) ;
fputc_v ( MANGLE_func, f ) ;
dump_type ( r ) ;
dump_type_list ( p, FUNC_NONE, 1 ) ;
fputc_v ( MANGLE_colon, f ) ;
fputc_v ( MANGLE_colon, f ) ;
break ;
}
case id_class_name_tag :
case id_enum_name_tag :
case id_class_alias_tag :
case id_enum_alias_tag :
case id_type_alias_tag : {
/* Type aliases */
TYPE t = DEREF_type ( id_class_name_etc_defn ( id ) ) ;
if ( ds & dspec_token ) {
/* Tokenised types */
IDENTIFIER tid = find_token ( id ) ;
if ( IS_id_token ( tid ) ) {
TOKEN tok = DEREF_tok ( id_token_sort ( tid ) ) ;
dump_sort ( tok ) ;
break ;
}
}
dump_type ( t ) ;
break ;
}
case id_nspace_name_tag : {
/* Namespace names */
fputc_v ( '*', f ) ;
break ;
}
case id_nspace_alias_tag : {
/* Namespace aliases */
NAMESPACE ns = DEREF_nspace ( id_nspace_alias_defn ( id ) ) ;
dump_nspace ( ns, 0 ) ;
break ;
}
case id_variable_tag :
case id_parameter_tag :
case id_stat_member_tag : {
/* Variables */
TYPE t = DEREF_type ( id_variable_etc_type ( id ) ) ;
dump_type ( t ) ;
if ( !( ds & dspec_auto ) ) destr = def ;
break ;
}
case id_weak_param_tag : {
/* Non-prototype function parameters */
dump_type ( type_sint ) ;
break ;
}
case id_function_tag :
case id_mem_func_tag :
case id_stat_mem_func_tag : {
/* Functions */
TYPE t = DEREF_type ( id_function_etc_type ( id ) ) ;
IDENTIFIER over = DEREF_id ( id_function_etc_over ( id ) ) ;
dump_type ( t ) ;
if ( !IS_NULL_id ( over ) ) {
fputc_v ( '\t', f ) ;
dump_id ( over ) ;
}
break ;
}
case id_member_tag : {
/* Data members */
TYPE t = DEREF_type ( id_member_type ( id ) ) ;
dump_type ( t ) ;
break ;
}
case id_enumerator_tag : {
/* Enumerators */
TYPE t = DEREF_type ( id_enumerator_etype ( id ) ) ;
dump_type ( t ) ;
break ;
}
case id_token_tag : {
/* Tokens */
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
dump_sort ( tok ) ;
break ;
}
default : {
/* Other identifiers */
fputc_v ( '*', f ) ;
break ;
}
}
fputc_v ( '\n', f ) ;
/* Deal with destructors */
if ( destr && do_usage ) dump_destr ( id, loc ) ;
}
dump_implicit = 0 ;
return ;
}
/*
DUMP AN IDENTIFIER UNDEFINITION
This routine adds the undefinition (indicating the end of a scope)
of the identifier id to the dump file.
*/
void dump_undefine
PROTO_N ( ( id, loc, def ) )
PROTO_T ( IDENTIFIER id X LOCATION *loc X int def )
{
FILE *f = dump_file ;
CONST char *key = dump_key ( id, def ) ;
if ( key && f ) {
if ( def ) {
fprintf_v ( f, "U%s\t", key ) ;
} else {
fprintf_v ( f, "Q%s\t", key ) ;
}
dump_loc ( loc ) ;
fputc_v ( '\t', f ) ;
dump_id ( id ) ;
fputc_v ( '\n', f ) ;
}
return ;
}
/*
DUMP AN IDENTIFIER USE
This routine adds the use of the identifier id to the dump file.
expl is true for an explicit use.
*/
void dump_use
PROTO_N ( ( id, loc, expl ) )
PROTO_T ( IDENTIFIER id X LOCATION *loc X int expl )
{
FILE *f = dump_file ;
CONST char *key = dump_key ( id, 1 ) ;
if ( key && f ) {
if ( !expl ) fputc_v ( 'I', f ) ;
fprintf_v ( f, "L%s\t", key ) ;
dump_loc ( loc ) ;
fputc_v ( '\t', f ) ;
dump_id ( id ) ;
fputc_v ( '\n', f ) ;
}
return ;
}
/*
DUMP AN IDENTIFIER CALL
This routine adds the call of the identifier id to the dump file.
expl is true for an explicit call.
*/
void dump_call
PROTO_N ( ( id, loc, expl ) )
PROTO_T ( IDENTIFIER id X LOCATION *loc X int expl )
{
FILE *f = dump_file ;
CONST char *key = dump_key ( id, 1 ) ;
if ( key && f ) {
if ( !expl ) fputc_v ( 'I', f ) ;
fprintf_v ( f, "C%s\t", key ) ;
dump_loc ( loc ) ;
fputc_v ( '\t', f ) ;
dump_id ( id ) ;
fputc_v ( '\n', f ) ;
}
return ;
}
/*
DUMP A TEMPLATE INSTANCE
This routine adds the association of the identifier id and the
template instance form to the dump file.
*/
void dump_instance
PROTO_N ( ( id, form, spec ) )
PROTO_T ( IDENTIFIER id X TYPE form X TYPE spec )
{
FILE *f = dump_file ;
CONST char *key = dump_key ( id, 1 ) ;
if ( key && f ) {
fprintf_v ( f, "Z%s\t", key ) ;
dump_id ( id ) ;
fputc_v ( '\t', f ) ;
dump_type ( form ) ;
if ( !EQ_type ( form, spec ) ) {
fputc_v ( '\t', f ) ;
dump_type ( spec ) ;
fputc_v ( '\n', f ) ;
} else {
fputs_v ( "\t*\n", f ) ;
}
}
return ;
}
/*
DUMP A TOKEN NAME
This routine adds the association of the identifier id and the external
token name tok to the dump file.
*/
void dump_token
PROTO_N ( ( id, tok ) )
PROTO_T ( IDENTIFIER id X IDENTIFIER tok )
{
FILE *f = dump_file ;
CONST char *key = dump_key ( id, 1 ) ;
if ( key && f ) {
HASHID nm = DEREF_hashid ( id_name ( tok ) ) ;
if ( IS_hashid_name_etc ( nm ) ) {
string s = DEREF_string ( hashid_name_etc_text ( nm ) ) ;
unsigned n = ( unsigned ) ustrlen ( s ) ;
fprintf_v ( f, "X%s\t", key ) ;
dump_id ( id ) ;
fprintf_v ( f, "\t&%u<%s>\n", n, strlit ( s ) ) ;
}
}
return ;
}
/*
DUMP A TOKEN PARAMETER
This routine adds the declaration of the token or template parameter
id to the dump file.
*/
void dump_token_param
PROTO_N ( ( id ) )
PROTO_T ( IDENTIFIER id )
{
dump_declare ( id, &crt_loc, 0 ) ;
if ( IS_id_token ( id ) ) {
IDENTIFIER alt = DEREF_id ( id_token_alt ( id ) ) ;
ulong n = DEREF_ulong ( id_dump ( id ) ) ;
COPY_ulong ( id_dump ( alt ), n ) ;
}
return ;
}
/*
DUMP A BUILT-IN OPERATOR
This routine adds the declaration of the built-in operator id to the
dump file.
*/
void dump_builtin
PROTO_N ( ( id ) )
PROTO_T ( IDENTIFIER id )
{
if ( IS_id_builtin ( id ) ) {
dump_implicit = 1 ;
dump_declare ( id, &crt_loc, 0 ) ;
}
return ;
}
/*
DUMP A PROMOTION TYPE
This routine adds the fact that the promotion of the integral type
it is ip to the dump file.
*/
void dump_promote
PROTO_N ( ( it, ip ) )
PROTO_T ( INT_TYPE it X INT_TYPE ip )
{
FILE *f = dump_file ;
if ( f ) {
fputs_v ( "P\t", f ) ;
dump_itype ( it ) ;
fputc_v ( MANGLE_colon, f ) ;
dump_itype ( ip ) ;
fputc_v ( '\n', f ) ;
}
return ;
}
/*
DUMP THE START OF A SCOPE
This routine adds the start of the scope ns (which may have an associated
name, id) to the dump file. pns gives the enclosing scope, if known.
*/
void dump_begin_scope
PROTO_N ( ( id, ns, pns, loc ) )
PROTO_T ( IDENTIFIER id X NAMESPACE ns X NAMESPACE pns X LOCATION *loc )
{
FILE *f = dump_file ;
if ( !IS_NULL_nspace ( ns ) && f ) {
ulong n ;
HASHID nm ;
if ( !IS_NULL_id ( id ) ) {
/* Named scope */
fputs_v ( "SSH\t", f ) ;
n = DEREF_ulong ( id_dump ( id ) ) ;
if ( n != LINK_NONE ) {
/* Already used */
dump_loc ( loc ) ;
fprintf_v ( f, "\t%lu\n", n ) ;
return ;
}
n = dump_id_next++ ;
COPY_ulong ( id_dump ( id ), n ) ;
nm = DEREF_hashid ( id_name ( id ) ) ;
} else {
/* Unnamed scope */
fputs_v ( "SSB\t", f ) ;
n = dump_id_next++ ;
nm = NULL_hashid ;
}
dump_loc ( loc ) ;
fprintf_v ( f, "\t%lu = ", n ) ;
dump_hashid ( nm ) ;
fputc_v ( '\t', f ) ;
dump_nspace ( pns, 1 ) ;
fputc_v ( '\n', f ) ;
COPY_ulong ( nspace_dump ( ns ), n ) ;
}
return ;
}
/*
DUMP THE END OF A SCOPE
This routine adds the end of the scope ns (which may have an associated
name, id) to the dump file.
*/
void dump_end_scope
PROTO_N ( ( id, ns, loc ) )
PROTO_T ( IDENTIFIER id X NAMESPACE ns X LOCATION *loc )
{
FILE *f = dump_file ;
if ( !IS_NULL_nspace ( ns ) && f ) {
ulong n = DEREF_ulong ( nspace_dump ( ns ) ) ;
if ( !IS_NULL_id ( id ) ) {
fputs_v ( "SEH\t", f ) ;
} else {
fputs_v ( "SEB\t", f ) ;
}
dump_loc ( loc ) ;
fprintf_v ( f, "\t%lu\n", n ) ;
}
return ;
}
/*
DUMP A STRING LITERAL
This routine adds the string literal of type kind given by the start
and end points s and e to the dump file.
*/
void dump_string_lit
PROTO_N ( ( s, e, kind ) )
PROTO_T ( string s X string e X unsigned kind )
{
FILE *f = dump_file ;
if ( f ) {
unsigned long n = ( unsigned long ) ( e - s ) ;
fputc_v ( 'A', f ) ;
if ( kind & STRING_CHAR ) fputc_v ( 'C', f ) ;
if ( kind & STRING_WIDE ) fputc_v ( 'L', f ) ;
fputc_v ( '\t', f ) ;
dump_loc ( &crt_loc ) ;
fprintf_v ( f, "\t&%lu<", n ) ;
while ( s != e ) {
int c = ( int ) *( s++ ) ;
fputc_v ( c, f ) ;
}
fputs_v ( ">\n", f ) ;
}
return ;
}
/*
DUMP THE START OF A FILE
This routine adds the start of the file loc to the dump file. dir
gives the directory in which the file was found.
*/
void dump_start
PROTO_N ( ( loc, dir ) )
PROTO_T ( LOCATION *loc X INCL_DIR *dir )
{
FILE *f = dump_file ;
if ( f ) {
fputs_v ( "FS\t", f ) ;
dump_loc ( loc ) ;
if ( dir ) {
fprintf_v ( f, "\t%lu\n", dir->no ) ;
} else {
fputs_v ( "\t*\n", f ) ;
}
}
return ;
}
/*
DUMP THE END OF A FILE
This routine adds the end of the file loc to the dump file.
*/
void dump_end
PROTO_N ( ( loc ) )
PROTO_T ( LOCATION *loc )
{
FILE *f = dump_file ;
if ( f ) {
fputs_v ( "FE\t", f ) ;
dump_loc ( loc ) ;
fputc_v ( '\n', f ) ;
}
return ;
}
/*
DUMP A FILE INCLUSION
This routine adds a file inclusion to the dump file. loc gives the
location of the '#include' directive, the following file start gives
the file included. st is as in start_include, plus 4 for the
resumption of a file after a file has been included. q is either '"',
'>' or ']' depending on the type of inclusion.
*/
void dump_include
PROTO_N ( ( loc, nm, st, q ) )
PROTO_T ( LOCATION *loc X string nm X int st X int q )
{
FILE *f = dump_file ;
if ( f ) {
CONST char *incl ;
switch ( st ) {
case 2 : incl = "FIS" ; break ;
case 3 : incl = "FIE" ; break ;
case 4 : incl = "FIR" ; nm = NULL ; break ;
default : {
if ( q == char_quote ) {
incl = "FIQ" ;
} else if ( q == char_close_square ) {
incl = "FIN" ;
} else {
incl = "FIA" ;
}
break ;
}
}
fprintf_v ( f, "%s\t", incl ) ;
dump_loc ( loc ) ;
if ( nm ) {
/* Output included name */
unsigned n = ( unsigned ) ustrlen ( nm ) ;
fprintf_v ( f, "\t&%u<%s>", n, strlit ( nm ) ) ;
}
fputc_v ( '\n', f ) ;
}
return ;
}
/*
OPEN DUMP FILE
This routine opens the dump file nm with dump options given by opt.
This corresponds to the command-line option '-dopt=nm'.
*/
void init_dump
PROTO_N ( ( nm, opt ) )
PROTO_T ( string nm X string opt )
{
if ( nm ) {
/* Open dump file */
FILE *f ;
char *p ;
character c ;
unsigned i, n ;
int do_all = 0 ;
output_name [ OUTPUT_DUMP ] = nm ;
if ( !open_output ( OUTPUT_DUMP, text_mode ) ) {
fail ( ERR_fail_dump ( nm ) ) ;
term_error ( 0 ) ;
return ;
}
f = output_file [ OUTPUT_DUMP ] ;
fprintf_v ( f, "# Dump file for %s %s\n", progname, progvers ) ;
fprintf_v ( f, "V\t%lu\t%lu\t", DUMP_major, DUMP_minor ) ;
fprintf_v ( f, "<%s>\n", LANGUAGE_NAME ) ;
dump_file = f ;
/* Set dump options */
do_dump = 1 ;
while ( c = *( opt++ ), ( c && c != '=' ) ) {
switch ( c ) {
case 'a' : do_all = 1 ; break ;
case 'c' : do_string = 1 ; break ;
case 'e' : do_error = 1 ; break ;
case 'h' : do_header = 1 ; break ;
case 'k' : do_keyword = 1 ; break ;
case 'l' : do_local = 1 ; break ;
case 'm' : do_macro = 1 ; break ;
case 'p' : break ;
case 's' : do_scope = 1 ; break ;
case 'u' : do_usage = 1 ; break ;
default : {
/* Unknown dump options */
CONST char *err = "Unknown dump option, '%c'" ;
error ( ERROR_WARNING, err, ( int ) c ) ;
break ;
}
}
}
if ( do_all ) {
/* Enable all dump options */
do_error = 1 ;
do_header = 1 ;
do_local = 1 ;
do_macro = 1 ;
do_usage = 1 ;
}
/* Allocate table of error numbers */
n = catalog_size ;
p = xmalloc_nof ( char, n ) ;
for ( i = 0 ; i < n ; i++ ) p [i] = 0 ;
err_output = p ;
last_input = ustrlit ( "" ) ;
last_file = ustrlit ( "" ) ;
/* Output file inclusion directories */
if ( do_header ) {
ulong r = 0 ;
INCL_DIR *d = dir_path ;
while ( d != NULL ) {
string s = d->path ;
if ( s ) {
unsigned m = ( unsigned ) ustrlen ( s ) ;
fprintf_v ( f, "FD\t%lu = &%u<%s>", r, m, strlit ( s ) ) ;
s = d->name ;
if ( s ) {
m = ( unsigned ) ustrlen ( s ) ;
fprintf_v ( f, "\t&%u<%s>", m, strlit ( s ) ) ;
}
fputc_v ( '\n', f ) ;
}
d->no = r++ ;
d = d->next ;
}
}
if ( do_usage || do_scope ) record_location = 1 ;
if ( do_error ) max_errors = ULONG_MAX ;
}
return ;
}
/*
CLOSE DUMP FILE
This routine closes the dump file.
*/
void term_dump
PROTO_Z ()
{
if ( do_dump ) {
FILE *f = dump_file ;
if ( f ) {
dump_file = NULL ;
fputs_v ( "# End of dump file\n", f ) ;
close_output ( OUTPUT_DUMP ) ;
}
do_dump = 0 ;
}
return ;
}