Logo Search packages:      
Sourcecode: tendra version File versions  Download package

diag2.c

/*
             Crown Copyright (c) 1997, 1998
    
    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 "version.h"
#include "system.h"
#include "c_types.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 "member_ops.h"
#include "nspace_ops.h"
#include "tok_ops.h"
#include "type_ops.h"
#include "virt_ops.h"
#include "error.h"
#include "tdf.h"
#include "access.h"
#include "basetype.h"
#include "buffer.h"
#include "capsule.h"
#include "check.h"
#include "class.h"
#include "compile.h"
#include "constant.h"
#include "convert.h"
#include "destroy.h"
#include "diag.h"
#include "diag2.h"
#include "encode.h"
#include "exception.h"
#include "exp.h"
#include "file.h"
#include "function.h"
#include "hash.h"
#include "mangle.h"
#include "namespace.h"
#include "print.h"
#include "shape.h"
#include "stmt.h"
#include "struct.h"
#include "syntax.h"
#include "throw.h"
#include "tok.h"
#include "typeid.h"
#include "ustring.h"
#include "virtual.h"
#if ( TDF_OUTPUT && TDF_NEW_DIAG )


/*
    DWARF TAG VALUES

    Certain values used within the diagnostic format are actually DWARF
    tag values.  These macros give the values used.
*/

#define DWARF_LANG_TRAD_C           1
#define DWARF_LANG_ANSI_C           2
#define DWARF_LANG_CPP              4

#if LANGUAGE_C
#define DWARF_LANG                  DWARF_LANG_ANSI_C
#define DWARF_LANG_NOT              DWARF_LANG_CPP
#else
#define DWARF_LANG                  DWARF_LANG_CPP
#define DWARF_LANG_NOT              DWARF_LANG_ANSI_C
#endif

#define DWARF_EXPLICIT              1
#define DWARF_IMPLICIT              2
#define DWARF_VIRT_EXPL             3
#define DWARF_VIRT_IMPL             4
#define DWARF_CONSTR                5
#define DWARF_VIRT_CONSTR           6
#define DWARF_DESTR                 7
#define DWARF_VIRT_DESTR            8

#define DWARF_USING_DIR             3
#define DWARF_USING_DECL            5

#define DWARF_ORDINARY              1
#define DWARF_NO_CALL               2
#define DWARF_RUN_TIME              3

#define DWARF_CASE_SENSITIVE        0


/*
    ENCODE A DIAGNOSTIC FILE NAME

    This routine adds the diagnostic file name given by posn to the
    bitstream bs.
*/

static BITSTREAM *enc_dg_filename
    PROTO_N ( ( bs, posn ) )
    PROTO_T ( BITSTREAM *bs X PTR ( POSITION ) posn )
{
    ulong n = DEREF_ulong ( posn_tok ( posn ) ) ;
    if ( n == LINK_NONE ) {
      BITSTREAM *ts ;
      string bn = DEREF_string ( posn_base ( posn ) ) ;
      string mn = ustrlit ( find_machine () ) ;
      ulong date = DEREF_ulong ( posn_datestamp ( posn ) ) ;
      n = capsule_no ( NULL_string, VAR_token ) ;
      COPY_ulong ( posn_tok ( posn ), n ) ;
      if ( !output_date ) date = 0 ;
      ts = enc_tokdef_start ( n, "Q", NIL ( ulong ), 0 ) ;
      ENC_make_dg_filename ( ts ) ;
      ENC_make_nat ( ts ) ;
      ENC_INT ( ts, date ) ;
      ENC_make_string ( ts ) ;
      ts = enc_ustring ( ts, mn ) ;
      ENC_make_string ( ts ) ;
      if ( is_full_pathname ( bn ) ) {
          ts = enc_ustring ( ts, ustrlit ( "" ) ) ;
      } else {
          string dn = DEREF_string ( posn_dir ( posn ) ) ;
          if ( dn == NULL ) {
            string en = ustrlit ( find_cwd () ) ;
            ts = enc_ustring ( ts, en ) ;
          } else if ( is_full_pathname ( dn ) ) {
            ts = enc_ustring ( ts, dn ) ;
          } else {
            string en = ustrlit ( find_cwd () ) ;
            BUFFER *bf = clear_buffer ( &incl_buff, NIL ( FILE ) ) ;
            bfprintf ( bf, "%s/%s", en, dn ) ;
            ts = enc_ustring ( ts, bf->start ) ;
          }
      }
      ENC_make_string ( ts ) ;
      ts = enc_ustring ( ts, bn ) ;
      enc_tokdef_end ( n, ts ) ;
    }

    /* Encode token application */
    ENC_dg_filename_apply_token ( bs ) ;
    n = link_no ( bs, n, VAR_token ) ;
    ENC_make_tok ( bs, n ) ;
    ENC_LEN_SMALL ( bs, 0 ) ;
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC SOURCE POSITION

    This routine adds the source position given by the span from p to q
    to the bitstream bs.
*/

static BITSTREAM *enc_dg_loc
    PROTO_N ( ( bs, p, q ) )
    PROTO_T ( BITSTREAM *bs X PTR ( LOCATION ) p X PTR ( LOCATION ) q )
{
    if ( IS_NULL_ptr ( p ) || IS_NULL_ptr ( q ) ) {
      ENC_dg_null_sourcepos ( bs ) ;
    } else {
      ulong lp = DEREF_ulong ( loc_line ( p ) ) ;
      ulong lq = DEREF_ulong ( loc_line ( q ) ) ;
      ulong cp = DEREF_ulong ( loc_column ( p ) ) ;
      ulong cq = DEREF_ulong ( loc_column ( q ) ) ;
      PTR ( POSITION ) fp = DEREF_ptr ( loc_posn ( p ) ) ;
      PTR ( POSITION ) fq = DEREF_ptr ( loc_posn ( q ) ) ;
      if ( EQ_ptr ( p, q ) ) {
          ENC_dg_mark_sourcepos ( bs ) ;
      } else if ( lp == lq && cp == cq && EQ_ptr ( fp, fq ) ) {
          ENC_dg_mark_sourcepos ( bs ) ;
          q = p ;
      } else {
          ENC_dg_span_sourcepos ( bs ) ;
      }
      bs = enc_dg_filename ( bs, fp ) ;
      ENC_make_nat ( bs ) ;
      ENC_INT ( bs, lp ) ;
      ENC_make_nat ( bs ) ;
      ENC_INT ( bs, cp ) ;
      if ( !EQ_ptr ( p, q ) ) {
          if ( EQ_ptr ( fp, fq ) ) {
            ENC_OFF ( bs ) ;
          } else {
            ENC_ON ( bs ) ;
            bs = enc_dg_filename ( bs, fq ) ;
          }
          ENC_make_nat ( bs ) ;
          ENC_INT ( bs, lq ) ;
          ENC_make_nat ( bs ) ;
          ENC_INT ( bs, cq ) ;
      }
    }
    return ( bs ) ;
}


/*
    FIND THE START OR END OF A BLOCK

    This routine returns the location of the start or end of the block e.
*/

static PTR ( LOCATION ) block_loc
    PROTO_N ( ( e, end ) )
    PROTO_T ( EXP e X int end )
{
    PTR ( LOCATION ) loc = NULL_ptr ( LOCATION ) ;
    if ( !IS_NULL_exp ( e ) ) {
      if ( IS_exp_solve_stmt ( e ) ) {
          e = DEREF_exp ( exp_solve_stmt_body ( e ) ) ;
      }
      if ( IS_exp_sequence ( e ) ) {
          EXP a ;
          LIST ( EXP ) p ;
          if ( end ) {
            p = DEREF_list ( exp_sequence_last ( e ) ) ;
          } else {
            p = DEREF_list ( exp_sequence_first ( e ) ) ;
          }
          a = DEREF_exp ( HEAD_list ( p ) ) ;
          if ( !IS_NULL_exp ( a ) && IS_exp_location ( a ) ) {
            loc = exp_location_end ( a ) ;
          }
      }
    }
    return ( loc ) ;
}


/*
    ENCODE THE START OF A NAMESPACE

    This routine adds the start of a list of names derived from the
    namespace ns to the bitstream bs.
*/

static BITSTREAM *enc_dg_namelist
    PROTO_N ( ( bs, ns ) )
    PROTO_T ( BITSTREAM *bs X NAMESPACE ns )
{
    ulong n = capsule_no ( NULL_string, VAR_dgtag ) ;
    IDENTIFIER id = DEREF_id ( nspace_name ( ns ) ) ;
    if ( !IS_NULL_id ( id ) ) COPY_ulong ( id_no ( id ), n ) ;
    record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
    ENC_dg_tag_namelist ( bs ) ;
    n = link_no ( bs, n, VAR_dgtag ) ;
    ENC_make_dg_tag ( bs, n ) ;
    ENC_make_dg_namelist ( bs ) ;
    ENC_LIST_SMALL ( bs, 0 ) ;
    return ( bs ) ;
}


/*
    ENCODE COMMAND-LINE OPTIONS

    This routine adds the revelant command-line options as a list of
    strings to the bitstream bs.
*/

static BITSTREAM *enc_dg_options
    PROTO_N ( ( bs ) )
    PROTO_T ( BITSTREAM *bs )
{
    unsigned n = 0 ;
    INCL_DIR *d = dir_path ;
    while ( d != NULL ) {
      n++ ;
      d = d->next ;
    }
    ENC_LIST ( bs, n ) ;
    d = dir_path ;
    while ( d != NULL ) {
      BUFFER *bf = clear_buffer ( &incl_buff, NIL ( FILE ) ) ;
      ENC_make_string ( bs ) ;
      bfprintf ( bf, "-I%s", d->path ) ;
      bs = enc_ustring ( bs, bf->start ) ;
      d = d->next ;
    }
    return ( bs ) ;
}


/*
    ENCODE A COMPILATION UNIT

    This routine adds the top-level compilation unit information to the
    bitstream bs.  The current location gives information about the
    primary source file.
*/

BITSTREAM *enc_dg_compilation
    PROTO_N ( ( bs ) )
    PROTO_T ( BITSTREAM *bs )
{
    LOCATION loc ;
    ulong date = crt_time ;
    string vers = report_version ( 0 ) ;
    ENC_make_dg_compilation ( bs ) ;
    bs = enc_dg_filename ( bs, crt_loc.posn ) ;
    ENC_LIST_SMALL ( bs, 0 ) ;
    ENC_LIST_SMALL ( bs, 0 ) ;
    loc = crt_loc ;
    IGNORE set_crt_loc ( ustrlit ( "" ), 0 ) ;
    bs = enc_dg_filename ( bs, crt_loc.posn ) ;
    crt_loc = loc ;
    if ( !output_date ) date = 0 ;
    ENC_make_nat ( bs ) ;
    ENC_INT ( bs, date ) ;
    ENC_make_nat ( bs ) ;
    ENC_INT ( bs, DWARF_LANG ) ;
    ENC_make_nat ( bs ) ;
    ENC_INT ( bs, DWARF_CASE_SENSITIVE ) ;
    ENC_make_string ( bs ) ;
    bs = enc_ustring ( bs, vers ) ;
    bs = enc_dg_options ( bs ) ;
    bs = enc_dg_namelist ( bs, global_namespace ) ;

    /* Output basic type definitions */
    if ( output_builtin ) {
      CV_SPEC cv ;
      BUILTIN_TYPE n ;
      for ( n = ntype_char ; n < ntype_ellipsis ; n++ ) {
          TYPE t = type_builtin [n] ;
          switch ( TAG_type ( t ) ) {
            case type_integer_tag :
            case type_floating_tag : {
                IGNORE enc_dg_basetype ( t, 1 ) ;
                break ;
            }
          }
      }
      for ( cv = cv_none ; cv <= cv_qual ; cv++ ) {
          TYPE t = qualify_type ( type_void, cv, 0 ) ;
          MAKE_type_ptr ( cv_none, t, t ) ;
          IGNORE enc_dg_basetype ( t, 1 ) ;
      }
    }
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC ACCESS SPECIFIER

    This routine adds the access specifier component of ds to the bitstream
    bs.  All access specifiers are optional, the default being public.
*/

static BITSTREAM *enc_dg_access
    PROTO_N ( ( bs, ds ) )
    PROTO_T ( BITSTREAM *bs X DECL_SPEC ds )
{
    DECL_SPEC acc = ( ds & dspec_access ) ;
    if ( acc == dspec_private ) {
      ENC_ON ( bs ) ;
      ENC_dg_private_accessibility ( bs ) ;
    } else if ( acc == dspec_protected ) {
      ENC_ON ( bs ) ;
      ENC_dg_protected_accessibility ( bs ) ;
    } else {
      ENC_OFF ( bs ) ;
    }
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC VIRTUAL SPECIFIER

    This routine adds the virtual specifier component of ds to the bitstream
    bs.  All virtual specifiers are optional, the default being non-virtual.
*/

static BITSTREAM *enc_dg_virtual
    PROTO_N ( ( bs, ds ) )
    PROTO_T ( BITSTREAM *bs X DECL_SPEC ds )
{
    if ( ds & dspec_virtual ) {
      ENC_ON ( bs ) ;
      if ( ds & dspec_pure ) {
          ENC_dg_abstract_virtuality ( bs ) ;
      } else {
          ENC_dg_virtual_virtuality ( bs ) ;
      }
    } else {
      ENC_OFF ( bs ) ;
    }
    return ( bs ) ;
}


/*
    ENCODE A TEMPLATE ARGUMENT

    Template arguments are encoded as dummy object or type names.
*/

static BITSTREAM *enc_dg_token_arg
    PROTO_N ( ( bs, tok ) )
    PROTO_T ( BITSTREAM *bs X TOKEN tok )
{
    int is_type = 0 ;
    EXP e = NULL_exp ;
    TYPE t = NULL_type ;
    if ( !IS_NULL_tok ( tok ) ) {
      switch ( TAG_tok ( tok ) ) {
          case tok_exp_tag : {
            int c = DEREF_int ( tok_exp_constant ( tok ) ) ;
            if ( c ) e = DEREF_exp ( tok_exp_value ( tok ) ) ;
            break ;
          }
          case tok_nat_tag :
          case tok_snat_tag : {
            NAT n = DEREF_nat ( tok_nat_etc_value ( tok ) ) ;
            e = calc_nat_value ( n, type_sint ) ;
            break ;
          }
          case tok_type_tag : {
            t = DEREF_type ( tok_type_value ( tok ) ) ;
            is_type = 1 ;
            break ;
          }
          case tok_class_tag : {
            is_type = 1 ;
            break ;
          }
      }
    }
    if ( is_type ) {
      /* Type name */
      ENC_dg_type_name ( bs ) ;
      ENC_OFF ( bs ) ;
      ENC_dg_null_sourcepos ( bs ) ;
      ENC_OFF ( bs ) ;
      if ( !IS_NULL_type ( t ) ) {
          ENC_ON ( bs ) ;
          bs = enc_dg_type ( bs, t, 0 ) ;
      } else {
          ENC_OFF ( bs ) ;
      }
      ENC_false ( bs ) ;
      ENC_OFFS ( bs, 2 ) ;
    } else {
      /* Object name */
      ENC_dg_object_name ( bs ) ;
      bs = enc_dg_name ( bs, NULL_id, NULL_type ) ;
      ENC_dg_null_sourcepos ( bs ) ;
      if ( !IS_NULL_exp ( e ) ) {
          t = DEREF_type ( exp_type ( e ) ) ;
          bs = enc_dg_type ( bs, t, 0 ) ;
          ENC_ON ( bs ) ;
          bs = enc_exp ( bs, e ) ;
      } else {
          bs = enc_dg_type ( bs, t, 0 ) ;
          ENC_OFF ( bs ) ;
      }
      ENC_OFF ( bs ) ;
    }
    return ( bs ) ;
}


/*
    ENCODE AN ARTIFICIAL IDENTIFIER NAME

    This routine adds the artificial identifier name s to the bitstream bs.
*/

static BITSTREAM *enc_dg_artificial
    PROTO_N ( ( bs, s ) )
    PROTO_T ( BITSTREAM *bs X CONST char *s )
{
    ENC_dg_artificial_idname ( bs ) ;
    ENC_ON ( bs ) ;
    ENC_make_string ( bs ) ;
    bs = enc_ustring ( bs, ustrlit ( s ) ) ;
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC IDENTIFIER NAME

    This routine adds the name of the identifier id to the bitstream bs.
*/

BITSTREAM *enc_dg_name
    PROTO_N ( ( bs, id, form ) )
    PROTO_T ( BITSTREAM *bs X IDENTIFIER id X TYPE form )
{
    if ( !IS_NULL_type ( form ) && IS_type_token ( form ) ) {
      /* Template instance name */
      IDENTIFIER tid = DEREF_id ( type_token_tok ( form ) ) ;
      LIST ( TOKEN ) args = DEREF_list ( type_token_args ( form ) ) ;
      if ( !IS_id_token ( tid ) ) {
          ENC_dg_instance_idname ( bs ) ;
          ENC_OFF ( bs ) ;
          bs = enc_dg_name ( bs, tid, NULL_type ) ;
          bs = enc_dg_loc ( bs, id_loc ( tid ), id_loc ( tid ) ) ;
          ENC_LIST ( bs, LENGTH_list ( args ) ) ;
          while ( !IS_NULL_list ( args ) ) {
            TOKEN arg = DEREF_tok ( HEAD_list ( args ) ) ;
            bs = enc_dg_token_arg ( bs, arg ) ;
            args = TAIL_list ( args ) ;
          }
          return ( bs ) ;
      }
    }
    if ( !IS_NULL_id ( id ) ) {
      string s ;
      HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
      switch ( TAG_hashid ( nm ) ) {
          case hashid_name_tag : {
            /* Simple case */
            s = DEREF_string ( hashid_name_text ( nm ) ) ;
            break ;
          }
          case hashid_ename_tag : {
            /* Extended case */
            if ( EQ_KEYWORD ( nm, lex_this_Hname ) ) {
                bs = enc_dg_artificial ( bs, "this" ) ;
                return ( bs ) ;
            }
            s = DEREF_string ( hashid_ename_text ( nm ) ) ;
            break ;
          }
          case hashid_anon_tag : {
            /* Anonymous case */
            ENC_dg_anonymous_idname ( bs ) ;
            ENC_OFF ( bs ) ;
            return ( bs ) ;
          }
          default : {
            /* Other cases */
            BUFFER *bf ;
            bf = clear_buffer ( &mangle_buff, NIL ( FILE ) ) ;
            IGNORE print_hashid ( nm, 0, 0, bf, 0 ) ;
            s = bf->start ;
            break ;
          }
      }
      if ( has_linkage ( id ) ) {
          ENC_dg_external_idname ( bs ) ;
      } else {
          ENC_dg_sourcestring_idname ( bs ) ;
      }
      ENC_make_string ( bs ) ;
      bs = enc_ustring ( bs, s ) ;
    } else {
      ENC_dg_anonymous_idname ( bs ) ;
      ENC_OFF ( bs ) ;
    }
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC IDENTIFIER

    This routine adds the diagnostics for the identifier id to the
    bitstream bs.  use indicates whether a declaration or a definition
    should be output.
*/

static BITSTREAM *enc_dg_decl
    PROTO_N ( ( bs, id, n, use ) )
    PROTO_T ( BITSTREAM *bs X IDENTIFIER id X ulong n X unsigned use )
{
    int spec = 0 ;
    int force = 1 ;
    int tagged = 0 ;
    unsigned tag = TAG_id ( id ) ;
    DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
    switch ( tag ) {
      case id_class_name_tag :
      case id_enum_name_tag : {
          /* Class and enumeration names */
          tagged = LANGUAGE_C ;
          force = 2 ;
          break ;
      }
    }
    if ( n != LINK_NONE && !tagged ) {
      /* Declare diagnostic tag if required */
      if ( use & USAGE_DECL ) {
          ulong m = link_no ( bs, n, VAR_dgtag ) ;
          if ( use & USAGE_USE ) {
            ENC_dg_spec_ref_name ( bs ) ;
          } else {
            ENC_dg_tag_name ( bs ) ;
          }
          ENC_make_dg_tag ( bs, m ) ;
          if ( use & USAGE_DEFN ) {
            record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
          } else {
            record_usage ( n, VAR_dgtag, USAGE_DECL ) ;
            ENC_dg_is_spec_name ( bs ) ;
            spec = 1 ;
          }
      }
    }
    switch ( tag ) {

      case id_variable_tag :
      case id_parameter_tag :
      case id_stat_member_tag : {
          /* Object names */
          TYPE t = DEREF_type ( id_variable_etc_type ( id ) ) ;
          ENC_dg_object_name ( bs ) ;
          bs = enc_dg_name ( bs, id, NULL_type ) ;
          bs = enc_dg_loc ( bs, id_loc ( id ), id_loc ( id ) ) ;
          bs = enc_dg_type ( bs, t, 0 ) ;
          if ( use & USAGE_DEFN ) {
            EXP e ;
            int et = error_threshold ;
            error_threshold = ERROR_SERIOUS ;
            ENC_ON ( bs ) ;
            MAKE_exp_identifier ( t, id, qual_none, e ) ;
            e = convert_reference ( e, REF_NORMAL ) ;
            e = convert_lvalue ( e ) ;
            if ( IS_type_array ( t ) ) {
                /* Do really want contents of array */
                MAKE_exp_contents ( t, e, e ) ;
            }
            bs = enc_exp ( bs, e ) ;
            free_exp ( e, 1 ) ;
            error_threshold = et ;
          } else {
            ENC_OFF ( bs ) ;
          }
          bs = enc_dg_access ( bs, ds ) ;
          break ;
      }

      case id_function_tag :
      case id_mem_func_tag :
      case id_stat_mem_func_tag : {
          /* Function names */
          PTR ( LOCATION ) end_loc = id_loc ( id ) ;
          TYPE t = DEREF_type ( id_function_etc_type ( id ) ) ;
          TYPE form = DEREF_type ( id_function_etc_form ( id ) ) ;
          if ( use & USAGE_DEFN ) {
            EXP e = DEREF_exp ( id_function_etc_defn ( id ) ) ;
            end_loc = block_loc ( e, 1 ) ;
            if ( IS_NULL_ptr ( end_loc ) ) end_loc = id_loc ( id ) ;
          }
          ENC_dg_proc_name ( bs ) ;
          bs = enc_dg_name ( bs, id, form ) ;
          if ( ds & dspec_implicit ) {
            /* Implicitly declared function */
            ENC_dg_null_sourcepos ( bs ) ;
          } else {
            bs = enc_dg_loc ( bs, id_loc ( id ), end_loc ) ;
          }
          bs = enc_dg_type ( bs, t, 0 ) ;
          if ( use & USAGE_DEFN ) {
            ulong m = DEREF_ulong ( id_no ( id ) ) ;
            ENC_ON ( bs ) ;
            if ( m == LINK_NONE ) {
                ENC_make_top ( bs ) ;
            } else {
                ENC_obtain_tag ( bs ) ;
                m = unit_no ( bs, id, VAR_tag, 0 ) ;
                ENC_make_tag ( bs, m ) ;
            }
          } else {
            ENC_OFF ( bs ) ;
          }
          bs = enc_dg_access ( bs, ds ) ;
          bs = enc_dg_virtual ( bs, ds ) ;
          bs = enc_bool ( bs, ( ( ds & dspec_inline ) ? 1 : 0 ) ) ;
          if ( IS_type_func ( t ) ) {
            LIST ( TYPE ) ex = DEREF_list ( type_func_except ( t ) ) ;
            if ( EQ_list ( ex, univ_type_set ) ) {
                ENC_OFF ( bs ) ;
            } else {
                ENC_ON ( bs ) ;
                ENC_LIST ( bs, LENGTH_list ( ex ) ) ;
                while ( !IS_NULL_list ( ex ) ) {
                  TYPE s = DEREF_type ( HEAD_list ( ex ) ) ;
                  bs = enc_dg_type ( bs, s, 0 ) ;
                  ex = TAIL_list ( ex ) ;
                }
            }
          } else {
            ENC_OFF ( bs ) ;
          }
          ENC_OFF ( bs ) ;
          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 names */
          TYPE t = DEREF_type ( id_class_name_etc_defn ( id ) ) ;
          ENC_dg_type_name ( bs ) ;
          if ( tagged ) {
            ENC_OFF ( bs ) ;
          } else {
            TYPE form = NULL_type ;
            if ( IS_type_compound ( t ) ) {
                CLASS_TYPE ct ;
                ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
                form = DEREF_type ( ctype_form ( ct ) ) ;
            }
            ENC_ON ( bs ) ;
            bs = enc_dg_name ( bs, id, form ) ;
          }
          bs = enc_dg_loc ( bs, id_loc ( id ), id_loc ( id ) ) ;
          bs = enc_dg_access ( bs, ds ) ;
          ENC_ON ( bs ) ;
          if ( tagged ) {
            ulong m = link_no ( bs, n, VAR_dgtag ) ;
            if ( use & USAGE_USE ) {
                ENC_dg_spec_ref_type ( bs ) ;
            } else {
                ENC_dg_tag_type ( bs ) ;
            }
            ENC_make_dg_tag ( bs, m ) ;
            if ( use & USAGE_DEFN ) {
                record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
            } else {
                record_usage ( n, VAR_dgtag, USAGE_DECL ) ;
            }
          }
          bs = enc_dg_type ( bs, t, force ) ;
          ENC_false ( bs ) ;
          ENC_OFFS ( bs, 2 ) ;
          break ;
      }

      case id_nspace_name_tag : {
          /* Namespace names */
          IDENTIFIER nid = id ;
          NAMESPACE ns = DEREF_nspace ( id_nspace_name_defn ( id ) ) ;
          if ( IS_nspace_unnamed ( ns ) ) nid = NULL_id ;
          ENC_dg_namespace_name ( bs ) ;
          bs = enc_dg_name ( bs, nid, NULL_type ) ;
          bs = enc_dg_loc ( bs, id_loc ( id ), id_loc ( id ) ) ;
          bs = enc_dg_namelist ( bs, ns ) ;
          break ;
      }
    }
    if ( spec ) ENC_OFF ( bs ) ;
    return ( bs ) ;
}


/*
    ENCODE DIAGNOSTICS FOR A TOKEN DEFINITION

    This routine outputs any diagnostic information for the token id
    to the appropriate diagnostic units.  It is only called if id is
    defined.  The type t may be used to override the type of id.
*/

void enc_dg_token
    PROTO_N ( ( id, t ) )
    PROTO_T ( IDENTIFIER id X TYPE t )
{
    UNUSED ( id ) ;
    UNUSED ( t ) ;
    return ;
}


/*
    LIST OF INCOMPLETE CLASSES

    This list is used to hold all the classes which are used while they
    are incomplete.  A diagnostic tag is introduced for each such class
    which may be defined later if the class is completed.
*/

static LIST ( IDENTIFIER ) dg_classes = NULL_list ( IDENTIFIER ) ;


/*
    DEFINE INCOMPLETE CLASSES

    This routine defines the diagnostic tags for the incomplete classes
    in the list above.
*/

int enc_dg_pending
    PROTO_Z ()
{
    int changed = 0 ;
    LIST ( IDENTIFIER ) p ;
    while ( p = dg_classes, !IS_NULL_list ( p ) ) {
      dg_classes = NULL_list ( IDENTIFIER ) ;
      while ( !IS_NULL_list ( p ) ) {
          IDENTIFIER id ;
          DESTROY_CONS_id ( destroy, id, p, p ) ;
          enc_dg_id ( id, 2 ) ;
          changed = 1 ;
      }
    }
    return ( changed ) ;
}


/*
    FIND A DIAGNOSTIC TAG USAGE

    This routine determines the usage for the diagnostic tag associated
    with the identifier id in the context given by def (true for
    definitions, false for declarations).  The value returned indicates
    whether the diagnostic tag should be declared or defined.
*/

static unsigned find_dg_usage
    PROTO_N ( ( id, pn, def ) )
    PROTO_T ( IDENTIFIER id X ulong *pn X int def )
{
    unsigned use = USAGE_NONE ;
    switch ( TAG_id ( id ) ) {
      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 names */
          TYPE t ;
          ulong n = DEREF_ulong ( id_no ( id ) ) ;
          if ( n == LINK_NONE ) {
            /* Introduce diagnostic tag for type */
            NAMESPACE ns ;
            string s = NULL ;
            if ( def == 0 ) return ( USAGE_NONE ) ;
            t = DEREF_type ( id_class_name_etc_defn ( id ) ) ;
            if ( IS_type_top_etc ( t ) ) {
                /* Ignore 'void' types */
                return ( USAGE_NONE ) ;
            }
            ns = DEREF_nspace ( id_parent ( id ) ) ;
            if ( is_local_nspace ( ns ) == 2 ) return ( USAGE_NONE ) ;
            if ( output_all ) s = mangle_tname ( "__dg__", t ) ;
            n = capsule_no ( s, VAR_dgtag ) ;
            COPY_ulong ( id_no ( id ), n ) ;
          } else {
            use = USAGE_USE ;
          }
          if ( is_defined ( id, &t, 0 ) ) {
            /* Only define each type once */
            unsigned prev = find_usage ( n, VAR_dgtag ) ;
            if ( prev & USAGE_DEFN ) {
                use = USAGE_NONE ;
            } else {
                use |= ( USAGE_DECL | USAGE_DEFN ) ;
            }
          } else {
            /* Only declare each type once */
            if ( use == USAGE_USE ) {
                use = USAGE_NONE ;
            } else {
                CONS_id ( id, dg_classes, dg_classes ) ;
                use = USAGE_DECL ;
            }
          }
          *pn = n ;
          break ;
      }
      case id_variable_tag :
      case id_stat_member_tag :
      case id_function_tag :
      case id_mem_func_tag :
      case id_stat_mem_func_tag : {
          /* Tag names */
          ulong n = get_diag_tag ( id, VAR_tag ) ;
          if ( n == LINK_NONE ) {
            /* Introduce diagnostic tag for tag */
            string s = NULL ;
            if ( output_all ) s = mangle_name ( id, VAR_dgtag, 0 ) ;
            n = capsule_no ( s, VAR_dgtag ) ;
            set_diag_tag ( id, VAR_tag, n ) ;
            use = USAGE_DECL ;
            if ( def ) use |= USAGE_DEFN ;
          } else {
            /* Only declare each tag once */
            if ( def ) {
                unsigned prev = find_usage ( n, VAR_dgtag ) ;
                if ( prev & USAGE_DEFN ) {
                  use = USAGE_NONE ;
                } else {
                  use = ( USAGE_USE | USAGE_DECL | USAGE_DEFN ) ;
                }
            }
          }
          *pn = n ;
          break ;
      }
      case id_nspace_name_tag : {
          /* Namespace names */
          use = USAGE_DEFN ;
          break ;
      }
    }
    return ( use ) ;
}


/*
    ENCODE A GLOBAL DIAGNOSTIC IDENTIFIER

    This routine adds the diagnostic information for the global identifier
    id to the diagnostic definition unit.  def is true for a definition.
*/

void enc_dg_id
    PROTO_N ( ( id, def ) )
    PROTO_T ( IDENTIFIER id X int def )
{
    ulong n ;
    NAMESPACE ns ;
    BITSTREAM *bs ;
    IDENTIFIER pid ;

    /* Check the identifier */
    ulong m = LINK_NONE ;
    unsigned use = find_dg_usage ( id, &m, def ) ;
    if ( use == USAGE_NONE ) return ;

    /* Find the parent namespace */
    ns = DEREF_nspace ( id_parent ( id ) ) ;
    while ( !IS_NULL_nspace ( ns ) && IS_nspace_ctype ( ns ) ) {
      pid = DEREF_id ( nspace_name ( ns ) ) ;
      enc_dg_id ( pid, 1 ) ;
      if ( m != LINK_NONE ) {
          /* Check for inline definitions */
          unsigned prev = find_usage ( m, VAR_dgtag ) ;
          if ( prev & USAGE_DEFN ) return ;
      }
      ns = DEREF_nspace ( id_parent ( pid ) ) ;
    }
    if ( IS_NULL_nspace ( ns ) || !IS_nspace_named_etc ( ns ) ) {
      /* Ignore local identifiers */
      return ;
    }
    pid = DEREF_id ( nspace_name ( ns ) ) ;
    if ( IS_NULL_id ( pid ) ) return ;
    n = DEREF_ulong ( id_no ( pid ) ) ;
    if ( n == LINK_NONE ) {
      /* Allocate namespace list number */
      enc_dg_id ( pid, 1 ) ;
      n = DEREF_ulong ( id_no ( pid ) ) ;
      if ( n == LINK_NONE ) return ;
    }

    /* Add the identifier to the namespace */
    bs = start_bitstream ( NIL ( FILE ), diagcomp_unit->link ) ;
    ENC_dg_name_append ( bs ) ;
    n = link_no ( bs, n, VAR_dgtag ) ;
    ENC_make_dg_tag ( bs, n ) ;
    bs = enc_dg_decl ( bs, id, m, use ) ;
    count_item ( bs ) ;
    diagcomp_unit = join_bitstreams ( diagcomp_unit, bs ) ;
    return ;
}


/*
    DIAGNOSTICS FOR POINTER TO VOID

    This table gives the diagnostic tag numbers used to represent the types
    'cv void *'  for the various cv-qualifiers, cv.
*/

static ulong diag_ptr_void [4] = {
    LINK_NONE, LINK_NONE, LINK_NONE, LINK_NONE
} ;


/*
    ENCODE A BUILT-IN DIAGNOSTIC TYPE

    This routine adds the diagnostics for the definition of the built-in
    type t to the diagnostic  bs.  This includes 'void *' as well as the
    more obvious integer and floating point types.
*/

ulong enc_dg_basetype
    PROTO_N ( ( t, def ) )
    PROTO_T ( TYPE t X int def )
{
    BITSTREAM *bs = NULL ;
    CV_SPEC cv = cv_none ;
    BASE_TYPE bt = btype_none ;
    unsigned tag = TAG_type ( t ) ;
    string nm = mangle_tname ( "__dg__", t ) ;
    ulong n = capsule_no ( nm, VAR_dgtag ) ;

    /* Introduce dummy type name */
    if ( def ) {
      IDENTIFIER gid = DEREF_id ( nspace_name ( global_namespace ) ) ;
      ulong m = DEREF_ulong ( id_no ( gid ) ) ;
      record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
      bs = start_bitstream ( NIL ( FILE ), diagcomp_unit->link ) ;
      ENC_dg_name_append ( bs ) ;
      m = link_no ( bs, m, VAR_dgtag ) ;
      ENC_make_dg_tag ( bs, m ) ;
      ENC_dg_type_name ( bs ) ;
      ENC_OFF ( bs ) ;
      ENC_dg_global_sourcepos ( bs ) ;
      ENC_OFF ( bs ) ;
      ENC_ON ( bs ) ;
      ENC_dg_tag_type ( bs ) ;
      m = link_no ( bs, n, VAR_dgtag ) ;
      ENC_make_dg_tag ( bs, m ) ;
    }

    /* Encode type definition */
    switch ( tag ) {
      case type_integer_tag : {
          INT_TYPE it = DEREF_itype ( type_integer_rep ( t ) ) ;
          COPY_ulong ( itype_diag ( it ), n ) ;
          if ( IS_itype_basic ( it ) ) {
            bt = DEREF_btype ( itype_basic_rep ( it ) ) ;
          }
          if ( def ) {
            if ( bt & ( btype_char | btype_wchar_t ) ) {
                ENC_dg_char_type ( bs ) ;
            } else if ( bt & btype_bool ) {
                ENC_dg_boolean_type ( bs ) ;
            } else {
                ENC_dg_integer_type ( bs ) ;
            }
          }
          break ;
      }
      case type_floating_tag : {
          FLOAT_TYPE ft = DEREF_ftype ( type_floating_rep ( t ) ) ;
          COPY_ulong ( ftype_diag ( ft ), n ) ;
          if ( IS_ftype_basic ( ft ) ) {
            bt = DEREF_btype ( ftype_basic_rep ( ft ) ) ;
          }
          if ( def ) ENC_dg_float_type ( bs ) ;
          break ;
      }
      case type_ptr_tag : {
          TYPE s = DEREF_type ( type_ptr_sub ( t ) ) ;
          cv = DEREF_cv ( type_qual ( s ) ) ;
          cv &= cv_qual ;
          diag_ptr_void [ cv ] = n ;
          bt = ( btype_void | btype_star ) ;
          if ( def ) ENC_dg_address_type ( bs ) ;
          break ;
      }
    }
    if ( def ) {
      if ( bt == btype_none ) {
          bs = enc_dg_name ( bs, NULL_id, NULL_type ) ;
      } else {
          int sp = 0 ;
          BUFFER *bf = clear_buffer ( &mangle_buff, NIL ( FILE ) ) ;
          ENC_dg_external_idname ( bs ) ;
          ENC_make_string ( bs ) ;
          if ( cv ) sp = print_cv ( cv, bf, sp ) ;
          IGNORE print_btype ( bt, bf, sp ) ;
          bs = enc_ustring ( bs, bf->start ) ;
      }
      switch ( tag ) {
          case type_integer_tag : {
            bs = enc_variety ( bs, t ) ;
            break ;
          }
          case type_floating_tag : {
            bs = enc_flvar ( bs, t ) ;
            break ;
          }
          case type_ptr_tag : {
            bs = enc_shape ( bs, t ) ;
            break ;
          }
      }
      ENC_true ( bs ) ;
      ENC_OFFS ( bs, 2 ) ;
      count_item ( bs ) ;
      diagcomp_unit = join_bitstreams ( diagcomp_unit, bs ) ;
    }
    return ( n ) ;
}


/*
    ENCODE A DIAGNOSTIC CLASS TAG

    This routine adds the diagnostic tag corresponding to the class ct
    to the bitstream bs.
*/

static BITSTREAM *enc_dg_ctype
    PROTO_N ( ( bs, ct ) )
    PROTO_T ( BITSTREAM *bs X CLASS_TYPE ct )
{
    ulong n ;
    IDENTIFIER cid = DEREF_id ( ctype_name ( ct ) ) ;
    cid = DEREF_id ( id_alias ( cid ) ) ;
    n = DEREF_ulong ( id_no ( cid ) ) ;
    if ( n == LINK_NONE ) {
      enc_dg_id ( cid, 1 ) ;
      n = DEREF_ulong ( id_no ( cid ) ) ;
    }
    n = link_no ( bs, n, VAR_dgtag ) ;
    ENC_make_dg_tag ( bs, n ) ;
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC OFFSET TOKEN

    This routine adds the offset off plus the offset token tok to the
    bitstream bs in the form of a token with one expression parameter
    which returns the parameter plus the offset (allowing for virtual
    indirections etc.).
*/

static BITSTREAM *enc_dg_offset
    PROTO_N ( ( bs, off, tok, spec ) )
    PROTO_T ( BITSTREAM *bs X OFFSET off X ulong tok X int spec )
{
    BITSTREAM *ts, *us ;
    ulong m = LINK_NONE ;
    ulong n = capsule_no ( NULL_string, VAR_token ) ;
    ts = enc_tokdef_start ( n, "EE", &m, 1 ) ;
    if ( spec == -1 ) {
      us = ts ;
    } else {
      ts = enc_special ( ts, spec ) ;
      us = start_bitstream ( NIL ( FILE ), ts->link ) ;
    }
    if ( tok == LINK_NONE ) {
      us = enc_add_ptr ( us, NULL_exp, m, off, 1 ) ;
    } else {
      ENC_add_to_ptr ( us ) ;
      us = enc_add_ptr ( us, NULL_exp, m, off, 1 ) ;
      tok = link_no ( us, tok, VAR_token ) ;
      ENC_exp_apply_token ( us ) ;
      ENC_make_tok ( us, tok ) ;
      ENC_LEN_SMALL ( us, 0 ) ;
    }
    if ( spec == -1 ) {
      ts = us ;
    } else {
      ts = enc_bitstream ( ts, us ) ;
    }
    enc_tokdef_end ( n, ts ) ;
    n = link_no ( bs, n, VAR_token ) ;
    ENC_make_tok ( bs, n ) ;
    return ( bs ) ;
}


/*
    ENCODE A LIST OF DIAGNOSTIC BASE CLASSES

    This routine adds the list of diagnostic base classes given by br
    to the bitstream bs.
*/

static BITSTREAM *enc_dg_bases
    PROTO_N ( ( bs, br ) )
    PROTO_T ( BITSTREAM *bs X LIST ( GRAPH ) br )
{
    ENC_LIST ( bs, LENGTH_list ( br ) ) ;
    while ( !IS_NULL_list ( br ) ) {
      GRAPH gs = DEREF_graph ( HEAD_list ( br ) ) ;
      OFFSET off = DEREF_off ( graph_off ( gs ) ) ;
      CLASS_TYPE cs = DEREF_ctype ( graph_head ( gs ) ) ;
      DECL_SPEC acc = DEREF_dspec ( graph_access ( gs ) ) ;
      ENC_make_dg_class_base ( bs ) ;
      bs = enc_dg_ctype ( bs, cs ) ;
      ENC_OFF ( bs ) ;
      if ( is_zero_offset ( off ) ) {
          ENC_OFF ( bs ) ;
      } else {
          /* Base class offset */
          ENC_ON ( bs ) ;
          bs = enc_dg_offset ( bs, off, LINK_NONE, -1 ) ;
      }
      bs = enc_dg_access ( bs, acc ) ;
      bs = enc_dg_virtual ( bs, acc ) ;
      br = TAIL_list ( br ) ;
    }
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC CLASS MEMBER

    This routine adds the class member id to the bitstream bs as a
    DG_CLASSMEM if ct is not null, or as a DG_FIELD otherwise.  The
    number of members is recorded in pm.  The routine is also used to
    handle type members of blocks when blk is true.
*/

static BITSTREAM *enc_dg_member
    PROTO_N ( ( bs, id, pm, ct, blk ) )
    PROTO_T ( BITSTREAM *bs X IDENTIFIER id X unsigned *pm X
            CLASS_TYPE ct X int blk )
{
    int def = 0 ;
    unsigned done = 0 ;
    DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
    if ( IS_id_function_etc ( id ) ) {
      /* Allow for overloaded functions */
      IDENTIFIER fid = DEREF_id ( id_function_etc_over ( id ) ) ;
      if ( !IS_NULL_id ( fid ) ) {
          bs = enc_dg_member ( bs, fid, pm, ct, blk ) ;
      }
    }
    if ( ds & ( dspec_alias | dspec_inherit | dspec_token ) ) {
      /* Ignore inherited members */
      return ( bs ) ;
    }
    if ( ds & dspec_defn ) def = 1 ;
    switch ( TAG_id ( id ) ) {
      case id_member_tag : {
          /* Data members */
          HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
          if ( !IS_hashid_anon ( nm ) ) {
            TYPE t = DEREF_type ( id_member_type ( id ) ) ;
            OFFSET off = DEREF_off ( id_member_off ( id ) ) ;
            ENC_dg_field_classmem ( bs ) ;
            bs = enc_dg_name ( bs, id, NULL_type ) ;
            bs = enc_dg_loc ( bs, id_loc ( id ), id_loc ( id ) ) ;
            bs = enc_offset ( bs, off ) ;
            bs = enc_dg_type ( bs, t, 0 ) ;
            bs = enc_dg_access ( bs, ds ) ;
            ENC_OFFS ( bs, 2 ) ;
            done = 1 ;
          }
          break ;
      }
      case id_stat_member_tag : {
          /* Static data members */
          if ( !IS_NULL_ctype ( ct ) ) {
            ulong m = LINK_NONE ;
            unsigned use = find_dg_usage ( id, &m, def ) ;
            ENC_dg_name_classmem ( bs ) ;
            bs = enc_dg_decl ( bs, id, m, ( use | USAGE_DECL ) ) ;
            done = 1 ;
          }
          break ;
      }
      case id_mem_func_tag : {
          /* Member functions */
          if ( !IS_NULL_ctype ( ct ) && !( ds & dspec_trivial ) ) {
            ulong m = LINK_NONE ;
            unsigned use = find_dg_usage ( id, &m, def ) ;
            ENC_dg_function_classmem ( bs ) ;
            bs = enc_dg_decl ( bs, id, m, ( use | USAGE_DECL ) ) ;
            if ( ds & dspec_virtual ) {
                /* Offset from start of virtual function table */
                BITSTREAM *ts ;
                VIRTUAL vt = DEREF_virt ( ctype_virt ( ct ) ) ;
                ulong n = virtual_no ( id, vt ) ;
                ENC_ON ( bs ) ;
                ts = start_bitstream ( NIL ( FILE ), bs->link ) ;
                bs = enc_special ( bs, TOK_vtab_off ) ;
                ts = enc_make_snat ( ts, ( int ) n ) ;
                bs = enc_bitstream ( bs, ts ) ;
            } else {
                ENC_OFF ( bs ) ;
            }
            done = 1 ;
          }
          break ;
      }
      case id_stat_mem_func_tag : {
          /* Static member functions */
          if ( !IS_NULL_ctype ( ct ) ) {
            ulong m = LINK_NONE ;
            unsigned use = find_dg_usage ( id, &m, def ) ;
            ENC_dg_name_classmem ( bs ) ;
            bs = enc_dg_decl ( bs, id, m, ( use | USAGE_DECL ) ) ;
            done = 1 ;
          }
          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 : {
          /* Nested types */
          if ( !IS_NULL_ctype ( ct ) || blk ) {
            ulong m = LINK_NONE ;
            unsigned use = find_dg_usage ( id, &m, 1 ) ;
            if ( blk ) {
                use = ( ( use & USAGE_DEFN ) | USAGE_DECL ) ;
                ENC_name_decl_dg ( bs ) ;
            } else {
                ENC_dg_name_classmem ( bs ) ;
            }
            bs = enc_dg_decl ( bs, id, m, use ) ;
            done = 1 ;
          }
          break ;
      }
    }
    *pm += done ;
    return ( bs ) ;
}


/*
    ENCODE A LIST OF DIAGNOSTIC MEMBERS

    This routine calls enc_dg_member for all the members of the
    namespace ns.
*/

static BITSTREAM *enc_dg_namespace
    PROTO_N ( ( bs, ns, pm, ct ) )
    PROTO_T ( BITSTREAM *bs X NAMESPACE ns X unsigned *pm X CLASS_TYPE ct )
{
    MEMBER mem ;
    int blk = 0 ;
    if ( IS_nspace_ctype ( ns ) ) {
      mem = DEREF_member ( nspace_ctype_first ( ns ) ) ;
    } else {
      mem = DEREF_member ( nspace_last ( ns ) ) ;
      blk = 1 ;
    }
    while ( !IS_NULL_member ( mem ) ) {
      /* Class members */
      IDENTIFIER mid = DEREF_id ( member_id ( mem ) ) ;
      IDENTIFIER nid = DEREF_id ( member_alt ( mem ) ) ;
      if ( !IS_NULL_id ( mid ) ) {
          bs = enc_dg_member ( bs, mid, pm, ct, blk ) ;
      }
      if ( !IS_NULL_id ( nid ) && !EQ_id ( nid, mid ) ) {
          bs = enc_dg_member ( bs, nid, pm, ct, blk ) ;
      }
      mem = DEREF_member ( member_next ( mem ) ) ;
    }
    return ( bs ) ;
}


/*
    ENCODE VIRTUAL FUNCTION TABLE INFORMATION

    This routine adds the information for the virtual function table
    and run-time type information associated with the polymorphic class
    t to the bitstream bs in the form of a number of dummy class members.
    Information on these members is returned via vtags.
*/

#if LANGUAGE_CPP

static BITSTREAM *enc_dg_vtable
    PROTO_N ( ( bs, t, vtags ) )
    PROTO_T ( BITSTREAM *bs X TYPE t X ulong *vtags )
{
    ulong n, m ;
    IDENTIFIER tid = dummy_type_name ;
    TYPE ti = get_type_info ( lex_typeid, t, 0 ) ;
    TYPE tv  = get_type_info ( lex_vtable, t, 0 ) ;
    TYPE pv = DEREF_type ( type_array_sub ( tv ) ) ;
    CLASS_TYPE ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
    VIRTUAL vt = DEREF_virt ( ctype_virt ( ct ) ) ;
    ulong tok = DEREF_ulong ( virt_table_tok ( vt ) ) ;
    OFFSET off = DEREF_off ( virt_table_off ( vt ) ) ;
    ulong tbl = DEREF_ulong ( virt_table_tbl ( vt ) ) ;

    /* Make tag for slot type */
    m = capsule_no ( NULL_string, VAR_dgtag ) ;
    COPY_ulong ( id_no ( tid ), m ) ;
    COPY_id ( type_name ( pv ), tid ) ;
    record_usage ( m, VAR_dgtag, USAGE_DEFN ) ;

    /* Virtual function table pointer */
    n = capsule_no ( NULL_string, VAR_dgtag ) ;
    record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
    vtags [0] = n ;
    ENC_dg_tag_classmem ( bs ) ;
    n = link_no ( bs, n, VAR_dgtag ) ;
    ENC_make_dg_tag ( bs, n ) ;
    ENC_dg_indirect_classmem ( bs ) ;
    bs = enc_dg_artificial ( bs, "__vptr" ) ;
    ENC_dg_null_sourcepos ( bs ) ;
    bs = enc_dg_offset ( bs, off, tok, -1 ) ;
    ENC_dg_pointer_type ( bs ) ;
    ENC_dg_tag_type ( bs ) ;
    m = link_no ( bs, m, VAR_dgtag ) ;
    ENC_make_dg_tag ( bs, m ) ;
    bs = enc_dg_type ( bs, pv, 1 ) ;
    ENC_OFF ( bs ) ;

    /* Run-time type information pointer */
    if ( output_rtti ) {
      n = capsule_no ( NULL_string, VAR_dgtag ) ;
      record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
      vtags [1] = n ;
      ENC_dg_tag_classmem ( bs ) ;
      n = link_no ( bs, n, VAR_dgtag ) ;
      ENC_make_dg_tag ( bs, n ) ;
      ENC_dg_indirect_classmem ( bs ) ;
      bs = enc_dg_artificial ( bs, "__tptr" ) ;
      ENC_dg_null_sourcepos ( bs ) ;
      bs = enc_dg_offset ( bs, off, tok, TOK_typeid_ref ) ;
      ENC_dg_pointer_type ( bs ) ;
      bs = enc_dg_type ( bs, ti, 0 ) ;
      ENC_OFF ( bs ) ;
    }

    /* Virtual function table */
    n = capsule_no ( NULL_string, VAR_dgtag ) ;
    record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
    vtags [2] = n ;
    record_usage ( tbl, VAR_tag, USAGE_USE ) ;
    ENC_dg_name_classmem ( bs ) ;
    ENC_dg_tag_name ( bs ) ;
    n = link_no ( bs, n, VAR_dgtag ) ;
    ENC_make_dg_tag ( bs, n ) ;
    ENC_dg_object_name ( bs ) ;
    bs = enc_dg_artificial ( bs, "__vtbl" ) ;
    ENC_dg_null_sourcepos ( bs ) ;
    bs = enc_dg_type ( bs, tv, 0 ) ;
    ENC_ON ( bs ) ;
    ENC_contents ( bs ) ;
    bs = enc_shape ( bs, tv ) ;
    ENC_obtain_tag ( bs ) ;
    tbl = link_no ( bs, tbl, VAR_tag ) ;
    ENC_make_tag ( bs, tbl ) ;
    ENC_OFF ( bs ) ;

    /* Run-time type information structure */
    if ( output_rtti ) {
      n = capsule_no ( NULL_string, VAR_dgtag ) ;
      record_usage ( n, VAR_dgtag, USAGE_DEFN ) ;
      vtags [3] = n ;
      ENC_dg_name_classmem ( bs ) ;
      ENC_dg_tag_name ( bs ) ;
      n = link_no ( bs, n, VAR_dgtag ) ;
      ENC_make_dg_tag ( bs, n ) ;
      ENC_dg_object_name ( bs ) ;
      bs = enc_dg_artificial ( bs, "__typeid" ) ;
      ENC_dg_null_sourcepos ( bs ) ;
      bs = enc_dg_type ( bs, ti, 0 ) ;
      ENC_ON ( bs ) ;
      ENC_contents ( bs ) ;
      bs = enc_shape ( bs, ti ) ;
      bs = enc_rtti_type ( bs, t, lex_typeid ) ;
      ENC_OFF ( bs ) ;
    }

    /* Clear slot type */
    COPY_ulong ( id_no ( tid ), LINK_NONE ) ;
    COPY_id ( type_name ( pv ), NULL_id ) ;
    return ( bs ) ;
}

#endif


/*
    ENCODE A DIAGNOSTIC CLASS

    This routine adds the definition of the class type t to the bitstream
    bs.  force is 2 to indicate that a tag name should be output for this
    class.
*/

static BITSTREAM *enc_dg_class
    PROTO_N ( ( bs, t, force ) )
    PROTO_T ( BITSTREAM *bs X TYPE t X int force )
{
    BITSTREAM *ts ;
    unsigned m = 0 ;
    ulong vtags [4] ;
    CLASS_TYPE cs = NULL_ctype ;
    CLASS_TYPE ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
    CLASS_INFO ci = DEREF_cinfo ( ctype_info ( ct ) ) ;
    NAMESPACE ns = DEREF_nspace ( ctype_member ( ct ) ) ;
    if ( force == 0 ) {
      ENC_dg_unknown_type ( bs ) ;
      bs = enc_shape ( bs, t ) ;
      return ( bs ) ;
    }
    if ( ( ci & cinfo_complete ) && ( ci & cinfo_defined ) ) {
      /* Complete class */
      IGNORE compile_class ( ct ) ;
      if ( ci & ( cinfo_static | cinfo_function | cinfo_base ) ) {
          cs = ct ;
      } else if ( ( ci & cinfo_trivial ) != cinfo_trivial ) {
          cs = ct ;
      } else {
          LIST ( IDENTIFIER ) ft ;
          ft = DEREF_list ( ctype_nest ( ct ) ) ;
          if ( !IS_NULL_list ( ft ) ) cs = ct ;
          ft = DEREF_list ( ctype_pals ( ct ) ) ;
          if ( !IS_NULL_list ( ft ) ) cs = ct ;
      }
    } else {
      /* Incomplete class */
      ENC_dg_is_spec_type ( bs ) ;
      t = NULL_type ;
    }
    if ( !IS_NULL_ctype ( cs ) ) {
      /* Class type */
      GRAPH gr = DEREF_graph ( ctype_base ( ct ) ) ;
      LIST ( GRAPH ) br = DEREF_list ( graph_tails ( gr ) ) ;
      ENC_dg_class_type ( bs ) ;
      bs = enc_dg_bases ( bs, br ) ;
    } else {
      /* Structure type */
      ENC_dg_struct_type ( bs ) ;
    }
    vtags [0] = LINK_NONE ;
    vtags [1] = LINK_NONE ;
    vtags [2] = LINK_NONE ;
    vtags [3] = LINK_NONE ;
    ts = start_bitstream ( NIL ( FILE ), bs->link ) ;
    ts = enc_dg_namespace ( ts, ns, &m, cs ) ;
#if LANGUAGE_CPP
    if ( !IS_NULL_ctype ( cs ) ) {
      if ( ci & cinfo_polymorphic ) {
          ts = enc_dg_vtable ( ts, t, vtags ) ;
          if ( output_rtti ) m += 2 ;
          m += 2 ;
      }
    }
#endif
    ENC_LIST ( bs, m ) ;
    bs = join_bitstreams ( bs, ts ) ;
    if ( !IS_NULL_ctype ( cs ) ) {
      /* Friends */
      ENC_OFF ( bs ) ;
      ENC_LIST_SMALL ( bs, 0 ) ;
    }
    if ( !IS_NULL_type ( t ) ) {
      /* Class shape */
      ENC_ON ( bs ) ;
      bs = enc_shape ( bs, t ) ;
    } else {
      ENC_OFF ( bs ) ;
    }
    if ( !IS_NULL_ctype ( cs ) ) {
      /* Virtual function table information */
      if ( vtags [0] == LINK_NONE ) {
          ENC_OFFS ( bs, 2 ) ;
      } else {
          ENC_ON ( bs ) ;
          vtags [2] = link_no ( bs, vtags [2], VAR_dgtag ) ;
          ENC_make_dg_tag ( bs, vtags [2] ) ;
          ENC_ON ( bs ) ;
          vtags [0] = link_no ( bs, vtags [0], VAR_dgtag ) ;
          ENC_make_dg_tag ( bs, vtags [0] ) ;
      }
    }
    if ( force == 2 ) {
      /* Output tag name */
      IDENTIFIER cid = DEREF_id ( ctype_name ( ct ) ) ;
      TYPE form = DEREF_type ( ctype_form ( ct ) ) ;
      ENC_ON ( bs ) ;
      bs = enc_dg_name ( bs, cid, form ) ;
      ENC_ON ( bs ) ;
      bs = enc_dg_loc ( bs, id_loc ( cid ), id_loc ( cid ) ) ;
    } else {
      ENC_OFFS ( bs, 2 ) ;
    }
    if ( IS_NULL_ctype ( cs ) ) ENC_OFF ( bs ) ;
    bs = enc_bool ( bs, ( ( ci & cinfo_union ) ? 1 : 0 ) ) ;
    if ( !IS_NULL_ctype ( cs ) ) {
      /* Run-time type information */
      if ( vtags [1] == LINK_NONE ) {
          ENC_OFFS ( bs, 2 ) ;
      } else {
          ENC_ON ( bs ) ;
          vtags [3] = link_no ( bs, vtags [3], VAR_dgtag ) ;
          ENC_make_dg_tag ( bs, vtags [3] ) ;
          ENC_ON ( bs ) ;
          vtags [1] = link_no ( bs, vtags [1], VAR_dgtag ) ;
          ENC_make_dg_tag ( bs, vtags [1] ) ;
      }
    }
    bs = enc_bool ( bs, LANGUAGE_CPP ) ;
    if ( !IS_NULL_ctype ( cs ) ) ENC_OFF ( bs ) ;
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC ENUMERATION TYPE

    This routine adds the definition of the enumeration type t to the
    bitstream bs.  force is 2 to indicate that a tag name should be
    output for this enumeration type.
*/

static BITSTREAM *enc_dg_etype
    PROTO_N ( ( bs, t, force ) )
    PROTO_T ( BITSTREAM *bs X TYPE t X int force )
{
    ENUM_TYPE et = DEREF_etype ( type_enumerate_defn ( t ) ) ;
    LIST ( IDENTIFIER ) p = DEREF_list ( etype_values ( et ) ) ;
    CLASS_INFO ei = DEREF_cinfo ( etype_info ( et ) ) ;
    if ( !( ei & cinfo_complete ) || force == 0 ) {
      t = DEREF_type ( etype_rep ( et ) ) ;
      bs = enc_dg_type ( bs, t, 0 ) ;
      return ( bs ) ;
    }
    ENC_dg_enum_type ( bs ) ;
    ENC_LIST ( bs, LENGTH_list ( p ) ) ;
    while ( !IS_NULL_list ( p ) ) {
      IDENTIFIER pid = DEREF_id ( HEAD_list ( p ) ) ;
      EXP e = DEREF_exp ( id_enumerator_value ( pid ) ) ;
      ENC_make_dg_enum ( bs ) ;
      bs = enc_exp ( bs, e ) ;
      bs = enc_dg_name ( bs, pid, NULL_type ) ;
      bs = enc_dg_loc ( bs, id_loc ( pid ), id_loc ( pid ) ) ;
      p = TAIL_list ( p ) ;
    }
    if ( force == 2 ) {
      /* Output tag name */
      IDENTIFIER eid = DEREF_id ( etype_name ( et ) ) ;
      ENC_ON ( bs ) ;
      bs = enc_dg_name ( bs, eid, NULL_type ) ;
      ENC_ON ( bs ) ;
      bs = enc_dg_loc ( bs, id_loc ( eid ), id_loc ( eid ) ) ;
    } else {
      ENC_OFFS ( bs, 2 ) ;
    }
    bs = enc_shape ( bs, t ) ;
    bs = enc_bool ( bs, LANGUAGE_CPP ) ;
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC TYPE

    This routine adds the diagnostic information for the type t to the
    bitstream bs.
*/

BITSTREAM *enc_dg_type
    PROTO_N ( ( bs, t, force ) )
    PROTO_T ( BITSTREAM *bs X TYPE t X int force )
{
    ulong n ;
    CV_SPEC cv ;
    if ( IS_NULL_type ( t ) ) {
      ENC_dg_void_type ( bs ) ;
      return ( bs ) ;
    }
    cv = DEREF_cv ( type_qual ( t ) ) ;
    if ( cv & cv_const ) {
      /* Allow for const qualifier */
      ENC_dg_qualified_type ( bs ) ;
      ENC_dg_const_qualifier ( bs ) ;
    }
    if ( cv & cv_volatile ) {
      /* Allow for volatile qualifier */
      ENC_dg_qualified_type ( bs ) ;
      ENC_dg_volatile_qualifier ( bs ) ;
    }

    /* Check type name */
    if ( !force ) {
      IDENTIFIER tid = DEREF_id ( type_name ( t ) ) ;
      if ( !IS_NULL_id ( tid ) ) {
          tid = DEREF_id ( id_alias ( tid ) ) ;
          n = DEREF_ulong ( id_no ( tid ) ) ;
          if ( n == LINK_NONE ) {
            enc_dg_id ( tid, 1 ) ;
            n = DEREF_ulong ( id_no ( tid ) ) ;
            if ( n == LINK_NONE ) goto type_label ;
          }
          ENC_dg_named_type ( bs ) ;
          n = link_no ( bs, n, VAR_dgtag ) ;
          ENC_make_dg_tag ( bs, n ) ;
          return ( bs ) ;
      }
    }

    /* Encode type definition */
    type_label : {
      ASSERT ( ORDER_type == 18 ) ;
      switch ( TAG_type ( t ) ) {
          case type_integer_tag : {
            /* Integral types */
            INT_TYPE it = DEREF_itype ( type_integer_rep ( t ) ) ;
            n = DEREF_ulong ( itype_diag ( it ) ) ;
            goto basetype_lab ;
          }
          basetype_lab : {
            if ( n == LINK_NONE ) {
                if ( cv & cv_qual ) t = qualify_type ( t, cv_none, 0 ) ;
                n = enc_dg_basetype ( t, 1 ) ;
            }
            ENC_dg_named_type ( bs ) ;
            n = link_no ( bs, n, VAR_dgtag ) ;
            ENC_make_dg_tag ( bs, n ) ;
            break ;
          }
          case type_floating_tag : {
            /* Floating point types */
            FLOAT_TYPE ft = DEREF_ftype ( type_floating_rep ( t ) ) ;
            n = DEREF_ulong ( ftype_diag ( ft ) ) ;
            goto basetype_lab ;
          }
          case type_top_tag :
          case type_bottom_tag : {
            /* Void types */
            ENC_dg_void_type ( bs ) ;
            break ;
          }
          case type_ptr_tag : {
            /* Pointer types */
            TYPE s = DEREF_type ( type_ptr_sub ( t ) ) ;
            if ( IS_type_top_etc ( s ) ) {
                /* Pointer void types */
                cv = DEREF_cv ( type_qual ( s ) ) ;
                cv &= cv_qual ;
                n = diag_ptr_void [ cv ] ;
                goto basetype_lab ;
            }
            ENC_dg_pointer_type ( bs ) ;
            bs = enc_dg_type ( bs, s, 0 ) ;
            ENC_OFF ( bs ) ;
            break ;
          }
          case type_ref_tag : {
            /* Reference types */
            TYPE s = DEREF_type ( type_ref_sub ( t ) ) ;
            ENC_dg_reference_type ( bs ) ;
            bs = enc_dg_type ( bs, s, 0 ) ;
            break ;
          }
          case type_ptr_mem_tag : {
            /* Pointer to member types */
            CLASS_TYPE cs = DEREF_ctype ( type_ptr_mem_of ( t ) ) ;
            TYPE s = DEREF_type ( type_ptr_mem_sub ( t ) ) ;
            if ( IS_type_func ( s ) ) {
                ENC_dg_ptr_memfn_type ( bs ) ;
            } else {
                ENC_dg_ptr_memdata_type ( bs ) ;
            }
            bs = enc_dg_ctype ( bs, cs ) ;
            bs = enc_dg_type ( bs, s, 0 ) ;
            bs = enc_shape ( bs, t ) ;
            ENC_OFF ( bs ) ;
            break ;
          }
          case type_func_tag : {
            /* Function types */
            TYPE r = DEREF_type ( type_func_ret ( t ) ) ;
            int ell = DEREF_int ( type_func_ellipsis ( t ) ) ;
            CV_SPEC mqual = DEREF_cv ( type_func_mqual ( t ) ) ;
            LIST ( TYPE ) p = DEREF_list ( type_func_ptypes ( t ) ) ;
            LIST ( TYPE ) q = DEREF_list ( type_func_mtypes ( t ) ) ;
            unsigned nq = LENGTH_list ( q ) ;
            ENC_dg_proc_type ( bs ) ;
            ENC_LIST ( bs, nq ) ;
            if ( !EQ_list ( p, q ) && !IS_NULL_list ( q ) ) {
                /* Allow for 'this' parameter */
                TYPE s = DEREF_type ( HEAD_list ( q ) ) ;
                ENC_dg_object_param ( bs ) ;
                ENC_ON ( bs ) ;
                bs = enc_dg_artificial ( bs, "this" ) ;
                ENC_OFFS ( bs, 2 ) ;
                bs = enc_dg_type ( bs, s, 0 ) ;
                ENC_OFF ( bs ) ;
                q = TAIL_list ( q ) ;
            }
            while ( !IS_NULL_list ( q ) ) {
                /* Real function parameters */
                TYPE s = DEREF_type ( HEAD_list ( q ) ) ;
                if ( ell & FUNC_PARAMS ) s = unpromote_type ( s ) ;
                ENC_dg_object_param ( bs ) ;
                ENC_OFFS ( bs, 3 ) ;
                bs = enc_dg_type ( bs, s, 0 ) ;
                ENC_OFF ( bs ) ;
                q = TAIL_list ( q ) ;
            }
            bs = enc_dg_type ( bs, r, 0 ) ;
            if ( ell & FUNC_NON_PROTO ) {
                /* Non-prototype function */
                ENC_ON ( bs ) ;
                ENC_false ( bs ) ;
            } else {
                /* Prototype function */
                ENC_OFF ( bs ) ;
            }
            ENC_OFF ( bs ) ;
            if ( mqual & cv_lang ) {
                /* Default language linkage */
                ENC_OFF ( bs ) ;
            } else {
                /* Non-default language linkage */
                ENC_ON ( bs ) ;
                ENC_make_nat ( bs ) ;
                ENC_INT ( bs, DWARF_LANG_NOT ) ;
            }
            if ( ell & FUNC_ELLIPSIS ) {
                /* Ellipsis function */
                ENC_ON ( bs ) ;
                ENC_var_callers ( bs ) ;
            } else {
                /* Non-ellipsis function */
                ENC_OFF ( bs ) ;
            }
            break ;
          }
          case type_array_tag : {
            /* Array types */
            TYPE s = DEREF_type ( type_array_sub ( t ) ) ;
            NAT m = DEREF_nat ( type_array_size ( t ) ) ;
            ENC_dg_array_type ( bs ) ;
            bs = enc_dg_type ( bs, s, 0 ) ;
            bs = enc_shape_offset ( bs, s ) ;
            ENC_OFF ( bs ) ;
            ENC_LIST_SMALL ( bs, 1 ) ;
            if ( IS_NULL_nat ( m ) ) {
                ENC_dg_unspecified_dim ( bs ) ;
            } else {
                TYPE i = type_sint ;
                unsigned long v = get_nat_value ( m ) ;
                ENC_dg_bounds_dim ( bs ) ;
                ENC_dg_static_bound ( bs ) ;
                bs = enc_make_int ( bs, i, 0 ) ;
                ENC_dg_static_bound ( bs ) ;
                if ( v < SMALL_ARRAY_BOUND ) {
                  /* Small value */
                  if ( v ) v-- ;
                  bs = enc_make_int ( bs, i, ( int ) v ) ;
                } else {
                  ENC_minus ( bs ) ;
                  bs = enc_error_treatment ( bs, i ) ;
                  ENC_make_int ( bs ) ;
                  bs = enc_variety ( bs, i ) ;
                  bs = enc_snat ( bs, m, 0, 1 ) ;
                  bs = enc_make_int ( bs, i, 1 ) ;
                }
                bs = enc_dg_type ( bs, i, 0 ) ;
            }
            break ;
          }
          case type_bitfield_tag : {
            /* Bitfield types */
            INT_TYPE bf = DEREF_itype ( type_bitfield_defn ( t ) ) ;
            TYPE s = DEREF_type ( itype_bitfield_sub ( bf ) ) ;
            ENC_dg_bitfield_type ( bs ) ;
            bs = enc_dg_type ( bs, s, 0 ) ;
            bs = enc_bfvar ( bs, t ) ;
            bs = enc_shape ( bs, s ) ;
            break ;
          }
          case type_compound_tag : {
            /* Class types */
            bs = enc_dg_class ( bs, t, force ) ;
            break ;
          }
          case type_enumerate_tag : {
            /* Enumeration types */
            bs = enc_dg_etype ( bs, t, force ) ;
            break ;
          }
          default : {
            /* Other types */
            ENC_dg_unknown_type ( bs ) ;
            bs = enc_shape ( bs, t ) ;
            break ;
          }
      }
    }
    return ( bs ) ;
}


/*
    ENCODE A LOCAL DIAGNOSTIC IDENTIFIER

    This routine adds the diagnostic information for the local identifier
    id to the bitstream bs.  ts gives the encoding of the scope of id.
*/

BITSTREAM *enc_dg_local
    PROTO_N ( ( bs, id, ts ) )
    PROTO_T ( BITSTREAM *bs X IDENTIFIER id X BITSTREAM *ts )
{
    bs = enc_diag_start ( bs ) ;
    ENC_name_decl_dg ( ts ) ;
    ts = enc_dg_decl ( ts, id, LINK_NONE, USAGE_DEFN ) ;
    bs = enc_bitstream ( bs, ts ) ;
    return ( bs ) ;
}


/*
    ENCODE A LIST OF DIAGNOSTIC PARAMETERS

    This routine adds the diagnostic information for the list of function
    parameters p to the bitstream bs.  ts and e give the function body.
*/

BITSTREAM *enc_dg_params
    PROTO_N ( ( bs, p, ts, e ) )
    PROTO_T ( BITSTREAM *bs X LIST ( IDENTIFIER ) p X BITSTREAM *ts X EXP e )
{
    bs = enc_diag_start ( bs ) ;
    ENC_list_dg ( ts ) ;
    ENC_LIST_SMALL ( ts, 2 ) ;
    ENC_params_dg ( ts ) ;
    ENC_LIST ( ts, LENGTH_list ( p ) ) ;
    while ( !IS_NULL_list ( p ) ) {
      IDENTIFIER pid = DEREF_id ( HEAD_list ( p ) ) ;
      ts = enc_dg_decl ( ts, pid, LINK_NONE, USAGE_DEFN ) ;
      p = TAIL_list ( p ) ;
    }
    ENC_OFF ( ts ) ;
    ts = enc_dg_stmt ( ts, e, 1 ) ;
    bs = enc_bitstream ( bs, ts ) ;
    return ( bs ) ;
}


/*
    ENCODE A DIAGNOSTIC STATEMENT

    This routine adds the diagnostic information associated with the
    statement e to the bitstream bs.
*/

BITSTREAM *enc_dg_stmt
    PROTO_N ( ( bs, e, stmt ) )
    PROTO_T ( BITSTREAM *bs X EXP e X int stmt )
{
    PTR ( LOCATION ) loc = crt_enc_loc ;
    if ( !IS_NULL_exp ( e ) ) {
      switch ( TAG_exp ( e ) ) {
          case exp_sequence_tag : {
            /* Lexical block */
            int blk = DEREF_int ( exp_sequence_block ( e ) ) ;
            NAMESPACE ns = DEREF_nspace ( exp_sequence_decl ( e ) ) ;
            if ( blk ) {
                BITSTREAM *ts ;
                unsigned m = 0 ;
                PTR ( LOCATION ) start_loc = block_loc ( e, 0 ) ;
                ts = start_bitstream ( NIL ( FILE ), bs->link ) ;
                ts = enc_dg_namespace ( ts, ns, &m, NULL_ctype ) ;
                if ( blk > 1 ) m++ ;
                if ( m != 1 ) {
                  ENC_list_dg ( bs ) ;
                  ENC_LIST ( bs, m ) ;
                }
                if ( blk > 1 ) {
                  ENC_lexical_block_dg ( bs ) ;
                  ENC_OFF ( bs ) ;
                  bs = enc_dg_loc ( bs, start_loc, loc ) ;
                }
                bs = join_bitstreams ( bs, ts ) ;
                return ( bs ) ;
            }
            break ;
          }
          case exp_solve_stmt_tag : {
            EXP a = DEREF_exp ( exp_solve_stmt_body ( e ) ) ;
            bs = enc_dg_stmt ( bs, a, stmt ) ;
            return ( bs ) ;
          }
          case exp_decl_stmt_tag : {
            IDENTIFIER id = DEREF_id ( exp_decl_stmt_id ( e ) ) ;
            loc = id_loc ( id ) ;
            break ;
          }
          case exp_label_stmt_tag : {
            IDENTIFIER id = DEREF_id ( exp_label_stmt_label ( e ) ) ;
            HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
            loc = id_loc ( id ) ;
            if ( !IS_hashid_anon ( nm ) ) {
                /* Named label */
                ENC_label_dg ( bs ) ;
                bs = enc_dg_name ( bs, id, NULL_type ) ;
                bs = enc_dg_loc ( bs, loc, loc ) ;
                return ( bs ) ;
            }
            break ;
          }
#if LANGUAGE_CPP
          case exp_try_block_tag : {
            /* Try block */
            EXP a ;
            unsigned np ;
            LIST ( EXP ) p ;
            a = DEREF_exp ( exp_try_block_ellipsis ( e ) ) ;
            p = DEREF_list ( exp_try_block_handlers ( e ) ) ;
            np = LENGTH_list ( p ) ;
            if ( IS_exp_handler ( a ) ) np++ ;
            ENC_list_dg ( bs ) ;
            ENC_LIST_SMALL ( bs, 2 ) ;
            ENC_exception_scope_dg ( bs ) ;
            ENC_LIST ( bs, np ) ;
            while ( !IS_NULL_list ( p ) ) {
                EXP b = DEREF_exp ( HEAD_list ( p ) ) ;
                ulong m = capsule_no ( NULL_string, VAR_dgtag ) ;
                COPY_ulong ( exp_handler_diag ( b ), m ) ;
                m = link_no ( bs, m, VAR_dgtag ) ;
                ENC_make_dg_tag ( bs, m ) ;
                p = TAIL_list ( p ) ;
            }
            if ( IS_exp_handler ( a ) ) {
                ulong m = capsule_no ( NULL_string, VAR_dgtag ) ;
                COPY_ulong ( exp_handler_diag ( a ), m ) ;
                m = link_no ( bs, m, VAR_dgtag ) ;
                ENC_make_dg_tag ( bs, m ) ;
            }
            e = DEREF_exp ( exp_try_block_body ( e ) ) ;
            bs = enc_dg_stmt ( bs, e, stmt ) ;
            return ( bs ) ;
          }
          case exp_handler_tag : {
            /* Exception handler */
            ulong m = DEREF_ulong ( exp_handler_diag ( e ) ) ;
            IDENTIFIER id = DEREF_id ( exp_handler_except ( e ) ) ;
            record_usage ( m, VAR_dgtag, USAGE_DEFN ) ;
            ENC_list_dg ( bs ) ;
            ENC_LIST_SMALL ( bs, 2 ) ;
            ENC_make_tag_dg ( bs ) ;
            m = link_no ( bs, m, VAR_dgtag ) ;
            ENC_make_dg_tag ( bs, m ) ;
            ENC_exception_handler_dg ( bs ) ;
            if ( !IS_NULL_id ( id ) ) {
                ENC_ON ( bs ) ;
                bs = enc_dg_decl ( bs, id, LINK_NONE, USAGE_DEFN ) ;
            } else {
                ENC_OFF ( bs ) ;
            }
            e = DEREF_exp ( exp_handler_body ( e ) ) ;
            bs = enc_dg_stmt ( bs, e, stmt ) ;
            return ( bs ) ;
          }
#endif
      }
    }
    if ( stmt == 2 ) {
      /* Used to mark conditionals */
      ENC_list_dg ( bs ) ;
      ENC_LIST_SMALL ( bs, 2 ) ;
      ENC_branch_dg ( bs ) ;
      bs = enc_dg_loc ( bs, loc, loc ) ;
    }
    ENC_singlestep_dg ( bs ) ;
    bs = enc_dg_loc ( bs, loc, loc ) ;
    return ( bs ) ;
}


#endif /* TDF_OUTPUT && TDF_NEW_DIAG */

Generated by  Doxygen 1.6.0   Back to index