/*Language-specific hook definitions for Pascal front end.

  Copyright (C) 1991-2004 Free Software Foundation, Inc.

  Authors: Jukka Virtanen <jtv@hut.fi>
           Jan-Jaap van der Heijden <j.j.vanderheijden@student.utwente.nl>
           Peter Gerwinski <peter@gerwinski.de>
           Frank Heckenbach <frank@pascal.gnu.de>
           Waldek Hebisch <hebisch@math.uni.wroc.pl>

  This file is part of GNU Pascal.

  GNU Pascal is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published
  by the Free Software Foundation; either version 2, or (at your
  option) any later version.

  GNU Pascal is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with GNU Pascal; see the file COPYING. If not, write to the
  Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  02111-1307, USA. */

#include "gpc.h"
#ifdef EGCS97
#include "langhooks.h"
#include "langhooks-def.h"
#endif
#ifdef GCC_3_3
#include "gtype-p.h"
#endif

/* The following functions are not called from GPC, but needed by
   the backend. Depending on the GCC version, they're simply called
   as extern, so we can't make them static (yet). */
extern void print_lang_decl PARAMS ((FILE *, tree, int));
extern void print_lang_type PARAMS ((FILE *, tree, int));
extern void print_lang_identifier PARAMS ((FILE *, tree, int));
extern void lang_print_xnode PARAMS ((FILE *, tree, int));
extern void lang_init_options PARAMS ((void));
extern void add_pascal_tree_codes PARAMS ((void));
#ifdef EGCS97
extern const char *init_parse PARAMS ((const char *));
#else
extern char *init_parse PARAMS ((char *));
#endif
#ifdef EGCS
extern int lang_decode_option PARAMS ((int, char **));
#ifdef EGCS97
extern const char *lang_init PARAMS ((const char *));
#else
extern void lang_init PARAMS ((void));
#endif
void finish_parse PARAMS ((void));
#endif
extern void copy_lang_decl PARAMS ((tree));
extern tree maybe_build_cleanup PARAMS ((tree));
#ifdef GCC_3_3
extern int yyparse PARAMS ((void));
static void pascal_parse PARAMS ((int));
#endif

#ifdef EGCS97
const char *language_string = "GNU Pascal";
#else
/* Declared without `const' in ../config/mips/mips.h */
char *language_string = "GNU Pascal";
#endif

const char *
pascal_decl_name (decl, verbosity)
     tree decl;
     int verbosity ATTRIBUTE_UNUSED;
{
  return IDENTIFIER_NAME (DECL_NAME (decl));
}

void
print_lang_decl (file, node, indent)
     FILE *file;
     tree node;
     int indent;
{
  if (DECL_LANG_SPECIFIC (node))
    {
      print_node (file, TREE_CODE (node) == FUNCTION_DECL ? "pascal_parms" : "pascal_fixuplist",
                        DECL_LANG_INFO1 (node), indent + 4);
      print_node (file, "result_variable", DECL_LANG_INFO2 (node), indent + 4);
      print_node (file, PASCAL_METHOD (node) ? "method_decl" : "operator_decl",
                        DECL_LANG_INFO3 (node), indent + 4);
    }
}

void
print_lang_type (file, node, indent)
     FILE *file;
     tree node;
     int indent;
{
  print_node (file, "main_variant", TYPE_MAIN_VARIANT (node), indent + 4);
  if TYPE_LANG_SPECIFIC (node)
    {
      static const char *const type_lang_codes[12] =
      {
        NULL,
        "pascal_variant_record",
        "pascal_non_text_file",
        "pascal_text_file",
        "pascal_object",
        "pascal_abstract_object",
        "pascal_undiscriminated_string",
        "pascal_prediscriminated_string",
        "pascal_discriminated_string",
        "pascal_undiscriminated_schema",
        "pascal_prediscriminated_schema",
        "pascal_discriminated_schema"
      };
      static const char *const type_lang_infos[12] =
      {
        NULL,
        "pascal_variant_tag",
        "pascal_file_domain",
        "pascal_file_domain",
        "pascal_vmt_field",
        "pascal_vmt_field",
        "pascal_declared_capacity",
        "pascal_declared_capacity",
        "pascal_declared_capacity",
        NULL,
        NULL,
        NULL
      };
      unsigned int code = TYPE_LANG_CODE (node);
      indent_to (file, indent + 3);
      if (code >= ARRAY_SIZE (type_lang_codes))
        fprintf (file, " !!unknown Pascal TYPE_LANG_CODE %i!!", code);
      else
        {
          if (type_lang_codes[code])
            fprintf (file, " %s", type_lang_codes[code]);
          print_node (file, type_lang_infos[code] ? type_lang_infos[code]
                                                  : "!!unknown_pascal_info!!",
                            TYPE_LANG_INFO (node), indent + 4);
        }
      print_node (file, "pascal_vmt_var", TYPE_LANG_INFO2 (node), indent + 4);
      print_node (file, "pascal_base", TYPE_LANG_BASE (node), indent + 4);
      print_node (file, "pascal_iniitalizer", TYPE_LANG_INITIAL (node), indent + 4);
      if (TYPE_LANG_SORTED_FIELDS (node))
        fprintf (file, " %i sorted_fields", TYPE_LANG_FIELD_COUNT (node));
    }
}

void
print_lang_identifier (file, node, indent)
     FILE *file;
     tree node;
     int indent;
{
  struct predef *p = IDENTIFIER_BUILT_IN_VALUE (node);
  if (IDENTIFIER_SPELLING (node))
    {
      indent_to (file, indent + 3);
      fprintf (file, " spelling %s (%s:%i)",
                     IDENTIFIER_SPELLING (node),
                     IDENTIFIER_SPELLING_FILE (node),
                     IDENTIFIER_SPELLING_LINENO (node));
    }
  print_node (file, "value", IDENTIFIER_VALUE (node), indent + 4);
  print_node (file, "error_locus", IDENTIFIER_ERROR_LOCUS (node), indent + 4);
  if (p)
    {
      indent_to (file, indent + 3);
      fprintf (file, " predefined %s #%i",
                     (  p->kind == bk_none ? "no_special_meaning"
                      : p->kind == bk_keyword ? "keyword"
                      : p->kind == bk_const ? "const"
                      : p->kind == bk_type ? "type"
                      : p->kind == bk_var ? "var"
                      : p->kind == bk_routine ? "routine"
                      : p->kind == bk_special_syntax ? "special_syntax"
                      : "!!unknown_kind!!"),
                     p->symbol);
    }
}

void
lang_print_xnode (file, node, indent)
     FILE *file;
     tree node;
     int indent;
{
  if (TREE_CODE (node) == IMPORT_NODE)
    {
      print_node (file, "interface", IMPORT_INTERFACE (node), indent + 4);
      print_node (file, "qualifier", IMPORT_QUALIFIER (node), indent + 4);
      print_node (file, "filename", IMPORT_FILENAME (node), indent + 4);
    }
}

#ifdef GCC_3_3
#define error_function_changed() (last_error_function != current_function_decl)
#define record_last_error_function() (last_error_function = current_function_decl)
static tree last_error_function = NULL;
#endif

/* Our function to print out name of current routine that caused an error. */
#ifdef EGCS97

/* @@ Why is this function static in ../diagnostic.c? */
static void output_buffer_to_stream PARAMS ((output_buffer *));
static void
output_buffer_to_stream (buffer)
     output_buffer *buffer;
{
  const char *text = output_finalize_message (buffer);
  fputs (text, output_buffer_attached_stream (buffer));
  output_clear_message_text (buffer);
}

static void pascal_print_error_function PARAMS ((diagnostic_context *, const char *));
static void
pascal_print_error_function (context, file)
     diagnostic_context *context;
     const char *file;
#else
#define error_function_changed() (last_error_function != current_function_decl)
#define record_last_error_function() (last_error_function = current_function_decl)
#define output_add_string(X, S) fprintf (stderr, S)
#define output_printf(X, S, A, B) fprintf (stderr, S, A, B);
#define output_add_newline(X) fprintf (stderr, "\n")
#ifndef _
#define _(S) S
#endif
static tree last_error_function = NULL;
static void pascal_print_error_function PARAMS ((const char *));
static void
pascal_print_error_function (file)
     const char *file;
#endif
{
  if (error_function_changed ())
    {
#ifdef EGCS97
      char *prefix = file ? ACONCAT ((file, ": ", NULL)) : NULL;
#ifndef GCC_3_3
      output_state os;
      os = output_buffer_state (context);
#endif
      output_set_prefix ((output_buffer *) context, prefix);
#else
      if (file)
        fprintf (stderr, "%s: ", file);
#endif
      if (!current_function_decl || EM (current_function_decl))
        output_add_string ((output_buffer *) context, _("At top level:"));
      else
        {
          const char *name = pascal_decl_name (current_function_decl, 2), *kind;
          if (DECL_ARTIFICIAL (current_function_decl))
            {
              if (!strncmp (name, "init_", strlen ("init_")))
                {
                  kind = "constructor of module/unit";
                  name += strlen ("init_");
                }
              else if (!strncmp (name, "fini_", strlen ("fini_")))
                {
                  kind = "destructor of module/unit";
                  name += strlen ("fini_");
                }
              else
                {
                  kind = "main program";
                  name = NULL;
                }
            }
          else if (PASCAL_METHOD (current_function_decl))
            {
              if (!PASCAL_STRUCTOR_METHOD (current_function_decl))
                kind = "method";
              else if (TREE_CODE (TREE_TYPE (TREE_TYPE (current_function_decl))) == VOID_TYPE)
                kind = "destructor";
              else
                kind = "constructor";
            }
          else if (DECL_LANG_OPERATOR_DECL (current_function_decl))
            kind = "operator";
          else if (TREE_CODE (TREE_TYPE (TREE_TYPE (current_function_decl))) == VOID_TYPE)
            kind = "procedure";
          else
            kind = "function";
          output_printf ((output_buffer *) context, name ? "In %s `%s':" : "In %s:", kind, name);
        }
      output_add_newline ((output_buffer *) context);
      record_last_error_function ();
#ifdef EGCS97
      output_buffer_to_stream ((output_buffer *) context);
#ifndef GCC_3_3
      output_buffer_state (context) = os;
#endif
#endif
    }
}

void
lang_init_options ()
{
  pascal_init_options ();
}

#ifndef GCC_3_3
/* Tree code classes. */

#ifdef EGCS
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
static const char pascal_tree_code_type[] = {
  'x',
#include "p-tree.def"
};
#undef DEFTREECODE
#else
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
static const char *pascal_tree_code_type[] = {
  "x",
#include "p-tree.def"
};
#undef DEFTREECODE
#endif

/* Table indexed by tree code giving number of expression
   operands beyond the fixed part of the node structure.
   Not used for types or decls. */
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
static const int pascal_tree_code_length[] = {
  0,
#include "p-tree.def"
};
#undef DEFTREECODE

/* Names of tree components.
   Used for printing out the tree and error messages. */
#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
static const char *const pascal_tree_code_name[] = {
  "@@dummy",
#include "p-tree.def"
};
#undef DEFTREECODE

void
add_pascal_tree_codes ()
{
#ifndef EGCS
  tree_code_type = (char **) xrealloc (tree_code_type, LAST_AND_UNUSED_TREE_CODE * sizeof (char *) + sizeof (pascal_tree_code_type));
  tree_code_length = (int *) xrealloc (tree_code_length, LAST_AND_UNUSED_TREE_CODE * sizeof (int) + sizeof (pascal_tree_code_length));
  tree_code_name = (char **) xrealloc (tree_code_name, LAST_AND_UNUSED_TREE_CODE * sizeof (char *) + sizeof (pascal_tree_code_name));
#endif
  memcpy (tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE,
          pascal_tree_code_type, sizeof (pascal_tree_code_type));
  memcpy (tree_code_length + (int) LAST_AND_UNUSED_TREE_CODE,
          pascal_tree_code_length, sizeof (pascal_tree_code_length));
  memcpy (tree_code_name + (int) LAST_AND_UNUSED_TREE_CODE,
          pascal_tree_code_name, sizeof (pascal_tree_code_name));
}
#else

/* Tree code classes. */
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,

const char tree_code_type[] = {
#include "tree.def"
  'x',
#include "p-tree.def"
};
#undef DEFTREECODE

/* Table indexed by tree code giving number of expression
   operands beyond the fixed part of the node structure.
   Not used for types or decls. */
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,

const unsigned char tree_code_length[] = {
#include "tree.def"
  0,
#include "p-tree.def"
};
#undef DEFTREECODE

/* Names of tree components.
   Used for printing out the tree and error messages. */
#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,

const char *const tree_code_name[] = {
#include "tree.def"
  "@@dummy",
#include "p-tree.def"
};
#undef DEFTREECODE

#endif

extern int debug_no_type_hash;

#ifdef GCC_3_3
#define builtin_assert(s)
static void builtin_define PARAMS ((const char *)); ATTRIBUTE_UNUSED
static void builtin_define_with_value PARAMS ((const char *, const char *, int)); ATTRIBUTE_UNUSED
static void builtin_define_with_int_value PARAMS ((const char *, HOST_WIDE_INT)); ATTRIBUTE_UNUSED
static void builtin_define_std PARAMS ((const char *)); ATTRIBUTE_UNUSED

static void
builtin_define (s)
     const char *s;
{
  fprintf (stderr, "-D%s ", s);
}

static void
builtin_define_with_value (s1, s2, is_str)
     const char *s1;
     const char *s2;
     int is_str;
{
  fprintf (stderr, is_str ? "-D%s=\"%s\" " : "-D%s=%s ", s1, s2);
}

static void
builtin_define_with_int_value (s1, s2)
     const char *s1;
     HOST_WIDE_INT s2;
{
  fprintf (stderr, "-D%s=" HOST_WIDE_INT_PRINT_DEC " ", s1, s2);
}

static void
builtin_define_std (s)
     const char *s;
{
  fprintf (stderr, "-D%s -D__%s -D__%s__ ", s, s, s);
}

#define preprocessing_asm_p() 0
#define preprocessing_trad_p() 0
/* @@ Backend bug: TARGET_OS_CPP_BUILTINS on some targets uses them
      though they are C specific flags. */
#define c_language (-1)
#define c_dialect_cxx() 0
#define c_dialect_objc() 0
#define clk_c 0
#define clk_objc 0
#define clk_cxx 0
#define clk_objcxx 0
#define clk_cplusplus 0
#define flag_iso 1
#define flag_objc 0
#define flag_isoc99 0
#define rs6000_cpu_cpp_builtins(foo)
#endif

#ifdef EGCS97
const char *
lang_init (filename)
     const char *filename;
#else
void
lang_init ()
#endif
{
  /* What type_hash_canon() does is wrong for Pascal (distinct, but structurally
     identical types are not compatible, fjf834.pas). Also, it's not compatible
     with the end_temporary_allocation() call in build_pascal_array_type
     (gcc-2 only), and it seems to cause a hard to reproduce memory management
     problem (gcc-3 only, reported by David Wood <DJWOOD1@qinetiq.com>).
     So we just turn it off here. */
  debug_no_type_hash = 1;

#ifdef EGCS97
  init_decl_processing ();
  filename = init_parse (filename);
#ifndef GCC_3_3
  decl_printable_name = pascal_decl_name;
#endif
#else
  decl_printable_name = (char *(*) (tree, int)) pascal_decl_name;
  /* dwarf2 with gcc-2 gave some bugs which didn't seem easy to fix
     (this whole stuff is quite hairy and not well documented).
     It doesn't seem worth fixing it since gcc-2 is to be deprecated,
     anyway, and gcc-3 can be used on platforms that require dwarf
     (e.g. IRIX/MIPS). -- Frank */
  if (write_symbols == DWARF_DEBUG || write_symbols == DWARF2_DEBUG)
    {
      error ("dwarf debug info does not work with GPC based on gcc-2.x (try gcc-3.x)");
      exit (FATAL_EXIT_CODE);
    }
#endif
#ifndef GCC_3_3
  print_error_function = pascal_print_error_function;
#endif

  if (co->option_big_endian == 0 && BYTES_BIG_ENDIAN)
    {
      input_filename = NULL;
      lineno = 0;
      error ("`--little-endian' given, but target system is big endian");
      exit (FATAL_EXIT_CODE);
    }
  if (co->option_big_endian > 0 && !BYTES_BIG_ENDIAN)
    {
      input_filename = NULL;
      lineno = 0;
      error ("`--big-endian' given, but target system is little endian");
      exit (FATAL_EXIT_CODE);
    }
  if (co->print_needed_options)
    {
#ifdef GCC_3_3
      if (optimize_size)
        builtin_define ("__OPTIMIZE_SIZE__");
      if (optimize)
        builtin_define ("__OPTIMIZE__");

      TARGET_CPU_CPP_BUILTINS ();
      TARGET_OS_CPP_BUILTINS ();
#endif
      /* The following is no joke! The difference between what the
         preprocessor and the compiler think of BYTES_BIG_ENDIAN is
         exactly the problem we're dealing with here. */
#if BYTES_BIG_ENDIAN
      if (!BYTES_BIG_ENDIAN)
        fputs ("--little-endian", stderr);
#else
      if (BYTES_BIG_ENDIAN)
        fputs ("--big-endian", stderr);
#endif
      fputs ("\n", stderr);
      while (fgetc (finput) != EOF) ;
      exit (1);
    }
#if BYTES_BIG_ENDIAN
  if (!BYTES_BIG_ENDIAN && co->option_big_endian < 0)
    {
      input_filename = NULL;
      lineno = 0;
      error ("you must give the option `--little-endian'");
      exit (FATAL_EXIT_CODE);
    }
#else
  if (BYTES_BIG_ENDIAN && co->option_big_endian < 0)
    {
      input_filename = NULL;
      lineno = 0;
      error ("you must give the option `--big-endian'");
      exit (FATAL_EXIT_CODE);
    }
#endif

#ifdef EGCS
  /* In gcc-2.8.1, init_tree_codes() has not been called yet.
     Do it in init_lex instead. */
#ifndef GCC_3_3
  add_pascal_tree_codes ();
#endif
#endif

  /* With luck, we discover the real source file name from a line directive
     at the beginning of the file and put it in input_filename. */
  peek_token (0);

#ifdef EGCS97
  if (main_input_filename)
    filename = main_input_filename;
  return filename;
#endif
}

/* If DECL has a cleanup, build and return that cleanup here.
   This is a callback called by expand_expr. */
tree
maybe_build_cleanup (decl)
     tree decl ATTRIBUTE_UNUSED;
{
  /* There are no cleanups in Pascal (yet). */
  return NULL_TREE;
}

/* integrate_decl_tree calls this function */
void
copy_lang_decl (decl)
     tree decl;
{
  struct lang_decl *ld;
  if (!DECL_LANG_SPECIFIC (decl))
    return;
  ld = allocate_decl_lang_specific ();
  memcpy ((char *) ld, (char *) DECL_LANG_SPECIFIC (decl), sizeof (struct lang_decl));
  DECL_LANG_SPECIFIC (decl) = ld;
}

#ifndef EGCS97
extern void lang_finish PARAMS ((void));
extern char *lang_identify PARAMS ((void));
extern void print_lang_statistics PARAMS ((void));
extern void GNU_xref_begin PARAMS ((void));
extern void GNU_xref_end PARAMS ((void));

void
lang_finish ()
{
}

char *
lang_identify ()
{
  return "Pascal";
}

void
print_lang_statistics ()
{
}

void
GNU_xref_begin ()
{
  error ("GPC does not yet support XREF");
  exit (FATAL_EXIT_CODE);
}

void
GNU_xref_end ()
{
  error ("GPC does not yet support XREF");
  exit (FATAL_EXIT_CODE);
}
#else
#ifndef GCC_3_3
void
insert_default_attributes (decl)
     tree decl ATTRIBUTE_UNUSED;
{
}
#endif
#endif

#ifdef EGCS
int
lang_decode_option (argc, argv)
     int argc;
     char **argv;
{
  return pascal_decode_option (argc, (const char **) argv);
}
#else
int
lang_decode_option (p)
     char *p;
{
  return pascal_decode_option (1, (const char **) &p);
}
#endif

#ifdef EGCS
#ifdef EGCS97
const char *
init_parse (filename)
     const char *filename;
#else
char *
init_parse (filename)
     char *filename;
#endif
{
#if !USE_CPPLIB
  /* Open input file. */
  if (!filename || !strcmp (filename, "-"))
    {
      finput = stdin;
      filename = "stdin";
    }
  else
    finput = fopen (filename, "r");
  if (!finput)
    {
      fprintf (stderr, "%s: ", progname);
      perror (filename);
      exit (FATAL_EXIT_CODE);
    }
#ifdef IO_BUFFER_SIZE
  setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
#endif
#endif
  init_lex ();
#if USE_CPPLIB
  yy_cur = "\n";
  yy_lim = yy_cur + 1;
  cpp_reader_init (&parse_in);
  parse_in.data = &parse_options;
  cpp_options_init (&parse_options);
  cpp_handle_options (&parse_in, 0, NULL);  /* @@ FIXME, cf. c-lex.c */
  parse_in.show_column = 1;
  assert (cpp_start_read (&parse_in, filename));
#endif
  return filename;
}

void
finish_parse ()
{
#if USE_CPPLIB
  cpp_finish (&parse_in);
#else
  fclose (finput);
#endif
}
#endif

#ifdef EGCS97

/* @@@@@ The following attribute handling code is copied from
   gcc-3.3's c-common.c. There's another attribute handling code for
   gcc-2 below, copied from gcc-2's c-common.c. gcc-3.2 doesn't need
   either, it's done in attribs.c which is provided by the backend.
   This should be checked and resolved. It's not nice to have two
   copies of more or less equivalent code in GPC. Most of these
   attributes are low-level, so it would be nice if we could leave
   their handling to the backend. */
#ifdef GCC_3_3
static tree handle_nocommon_attribute   PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_common_attribute     PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_noreturn_attribute   PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_unused_attribute     PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_const_attribute      PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_section_attribute    PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_aligned_attribute    PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_weak_attribute       PARAMS ((tree *, tree, tree, int,
                                                 bool *));
static tree handle_alias_attribute      PARAMS ((tree *, tree, tree, int,
                                                 bool *));

const struct attribute_spec gpc_attribute_table[] =
{
  { "nocommon",               0, 0, true,  false, false,
                              handle_nocommon_attribute },
  { "common",                 0, 0, true,  false, false,
                              handle_common_attribute },
  /* FIXME: logically, noreturn attributes should be listed as
     "false, true, true" and apply to function types.  But implementing this
     would require all the places in the compiler that use TREE_THIS_VOLATILE
     on a decl to identify non-returning functions to be located and fixed
     to check the function type instead.  */
  { "noreturn",               0, 0, true,  false, false,
                              handle_noreturn_attribute },
  { "unused",                 0, 0, false, false, false,
                              handle_unused_attribute },
  /* The same comments as for noreturn attributes apply to const ones.  */
  { "const",                  0, 0, true,  false, false,
                              handle_const_attribute },
  { "section",                1, 1, true,  false, false,
                              handle_section_attribute },
  { "aligned",                0, 1, false, false, false,
                              handle_aligned_attribute },
  { "weak",                   0, 0, true,  false, false,
                              handle_weak_attribute },
  { "alias",                  1, 1, true,  false, false,
                              handle_alias_attribute },
  { NULL,                     0, 0, false, false, false, NULL }
};

/* Handle a "nocommon" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_nocommon_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name;
     tree args ATTRIBUTE_UNUSED;
     int flags ATTRIBUTE_UNUSED;
     bool *no_add_attrs;
{
  if (TREE_CODE (*node) == VAR_DECL)
    DECL_COMMON (*node) = 0;
  else
    {
      warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
      *no_add_attrs = true;
    }

  return NULL_TREE;
}

/* Handle a "common" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_common_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name;
     tree args ATTRIBUTE_UNUSED;
     int flags ATTRIBUTE_UNUSED;
     bool *no_add_attrs;
{
  if (TREE_CODE (*node) == VAR_DECL)
    DECL_COMMON (*node) = 1;
  else
    {
      warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
      *no_add_attrs = true;
    }

  return NULL_TREE;
}

/* Handle a "noreturn" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_noreturn_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name;
     tree args ATTRIBUTE_UNUSED;
     int flags ATTRIBUTE_UNUSED;
     bool *no_add_attrs;
{
  tree type = TREE_TYPE (*node);

  /* See FIXME comment in c_common_attribute_table.  */
  if (TREE_CODE (*node) == FUNCTION_DECL)
    TREE_THIS_VOLATILE (*node) = 1;
  else if (TREE_CODE (type) == POINTER_TYPE
           && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
    TREE_TYPE (*node)
      = build_pointer_type
        (build_type_variant (TREE_TYPE (type),
                             TREE_READONLY (TREE_TYPE (type)), 1));
  else
    {
      warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
      *no_add_attrs = true;
    }

  return NULL_TREE;
}

/* Handle a "unused" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_unused_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name;
     tree args ATTRIBUTE_UNUSED;
     int flags;
     bool *no_add_attrs;
{
  if (DECL_P (*node))
    {
      tree decl = *node;

      if (TREE_CODE (decl) == PARM_DECL
          || TREE_CODE (decl) == VAR_DECL
          || TREE_CODE (decl) == FUNCTION_DECL
          || TREE_CODE (decl) == LABEL_DECL
          || TREE_CODE (decl) == TYPE_DECL)
        TREE_USED (decl) = 1;
      else
        {
          warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
          *no_add_attrs = true;
        }
    }
  else
    {
      if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE))
        *node = build_type_copy (*node);
      TREE_USED (*node) = 1;
    }

  return NULL_TREE;
}

/* Handle a "const" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_const_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name;
     tree args ATTRIBUTE_UNUSED;
     int flags ATTRIBUTE_UNUSED;
     bool *no_add_attrs;
{
  tree type = TREE_TYPE (*node);

  /* See FIXME comment on noreturn in c_common_attribute_table.  */
  if (TREE_CODE (*node) == FUNCTION_DECL)
    TREE_READONLY (*node) = 1;
  else if (TREE_CODE (type) == POINTER_TYPE
           && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
    TREE_TYPE (*node)
      = build_pointer_type
        (build_type_variant (TREE_TYPE (type), 1,
                             TREE_THIS_VOLATILE (TREE_TYPE (type))));
  else
    {
      warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
      *no_add_attrs = true;
    }

  return NULL_TREE;
}

/* Handle a "section" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_section_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name ATTRIBUTE_UNUSED;
     tree args;
     int flags ATTRIBUTE_UNUSED;
     bool *no_add_attrs;
{
  tree decl = *node;

  if (targetm.have_named_sections)
    {
      if ((TREE_CODE (decl) == FUNCTION_DECL
           || TREE_CODE (decl) == VAR_DECL)
          && TREE_CODE (TREE_VALUE (args)) == STRING_CST)
        {
          if (TREE_CODE (decl) == VAR_DECL
              && current_function_decl != NULL_TREE
              && ! TREE_STATIC (decl))
            {
              error_with_decl (decl,
                               "section attribute cannot be specified for local variables");
              *no_add_attrs = true;
            }

          /* The decl may have already been given a section attribute
             from a previous declaration.  Ensure they match.  */
          else if (DECL_SECTION_NAME (decl) != NULL_TREE
                   && strcmp (TREE_STRING_POINTER (DECL_SECTION_NAME (decl)),
                              TREE_STRING_POINTER (TREE_VALUE (args))) != 0)
            {
              error_with_decl (*node,
                               "section of `%s' conflicts with previous declaration");
              *no_add_attrs = true;
            }
          else
            DECL_SECTION_NAME (decl) = TREE_VALUE (args);
        }
      else
        {
          error_with_decl (*node,
                           "section attribute not allowed for `%s'");
          *no_add_attrs = true;
        }
    }
  else
    {
      error_with_decl (*node,
                       "section attributes are not supported for this target");
      *no_add_attrs = true;
    }

  return NULL_TREE;
}

/* Handle a "aligned" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_aligned_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name ATTRIBUTE_UNUSED;
     tree args;
     int flags;
     bool *no_add_attrs;
{
  tree decl = NULL_TREE;
  tree *type = NULL;
  int is_type = 0;
  tree align_expr = (args ? TREE_VALUE (args)
                     : size_int (BIGGEST_ALIGNMENT / BITS_PER_UNIT));
  int i;

  if (DECL_P (*node))
    {
      decl = *node;
      type = &TREE_TYPE (decl);
      is_type = TREE_CODE (*node) == TYPE_DECL;
    }
  else if (TYPE_P (*node))
    type = node, is_type = 1;

  /* Strip any NOPs of any kind.  */
  while (TREE_CODE (align_expr) == NOP_EXPR
         || TREE_CODE (align_expr) == CONVERT_EXPR
         || TREE_CODE (align_expr) == NON_LVALUE_EXPR)
    align_expr = TREE_OPERAND (align_expr, 0);

  if (TREE_CODE (align_expr) != INTEGER_CST)
    {
      error ("requested alignment is not a constant");
      *no_add_attrs = true;
    }
  else if ((i = tree_log2 (align_expr)) == -1)
    {
      error ("requested alignment is not a power of 2");
      *no_add_attrs = true;
    }
  else if (i > HOST_BITS_PER_INT - 2)
    {
      error ("requested alignment is too large");
      *no_add_attrs = true;
    }
  else if (is_type)
    {
      /* If we have a TYPE_DECL, then copy the type, so that we
         don't accidentally modify a builtin type.  See pushdecl.  */
      if (decl && TREE_TYPE (decl) != error_mark_node
          && DECL_ORIGINAL_TYPE (decl) == NULL_TREE)
        {
          tree tt = TREE_TYPE (decl);
          *type = build_type_copy (*type);
          DECL_ORIGINAL_TYPE (decl) = tt;
          TYPE_NAME (*type) = decl;
          TREE_USED (*type) = TREE_USED (decl);
          TREE_TYPE (decl) = *type;
        }
      else if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE))
        *type = build_type_copy (*type);

      TYPE_ALIGN (*type) = (1 << i) * BITS_PER_UNIT;
      TYPE_USER_ALIGN (*type) = 1;
    }
  else if (TREE_CODE (decl) != VAR_DECL
           && TREE_CODE (decl) != FIELD_DECL)
    {
      error_with_decl (decl, "alignment may not be specified for `%s'");
      *no_add_attrs = true;
    }
  else
    {
      DECL_ALIGN (decl) = (1 << i) * BITS_PER_UNIT;
      DECL_USER_ALIGN (decl) = 1;
    }

  return NULL_TREE;
}

/* Handle a "weak" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_weak_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name ATTRIBUTE_UNUSED;
     tree args ATTRIBUTE_UNUSED;
     int flags ATTRIBUTE_UNUSED;
     bool *no_add_attrs ATTRIBUTE_UNUSED;
{
  declare_weak (*node);

  return NULL_TREE;
}

/* Handle an "alias" attribute; arguments as in
   struct attribute_spec.handler.  */

static tree
handle_alias_attribute (node, name, args, flags, no_add_attrs)
     tree *node;
     tree name;
     tree args;
     int flags ATTRIBUTE_UNUSED;
     bool *no_add_attrs;
{
  tree decl = *node;

  if ((TREE_CODE (decl) == FUNCTION_DECL && DECL_INITIAL (decl))
      || (TREE_CODE (decl) != FUNCTION_DECL && ! DECL_EXTERNAL (decl)))
    {
      error_with_decl (decl,
                       "`%s' defined both normally and as an alias");
      *no_add_attrs = true;
    }
  else if (decl_function_context (decl) == 0)
    {
      tree id;

      id = TREE_VALUE (args);
      if (TREE_CODE (id) != STRING_CST)
        {
          error ("alias arg not a string");
          *no_add_attrs = true;
          return NULL_TREE;
        }
      id = get_identifier (TREE_STRING_POINTER (id));
      /* This counts as a use of the object pointed to.  */
      TREE_USED (id) = 1;

      if (TREE_CODE (decl) == FUNCTION_DECL)
        DECL_INITIAL (decl) = error_mark_node;
      else
        DECL_EXTERNAL (decl) = 0;
    }
  else
    {
      warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
      *no_add_attrs = true;
    }

  return NULL_TREE;
}
#endif

#undef LANG_HOOKS_NAME
#define LANG_HOOKS_NAME "GNU Pascal"
#undef LANG_HOOKS_INIT
#define LANG_HOOKS_INIT lang_init
#undef LANG_HOOKS_DECODE_OPTION
#define LANG_HOOKS_DECODE_OPTION lang_decode_option
#undef LANG_HOOKS_INIT_OPTIONS
#define LANG_HOOKS_INIT_OPTIONS pascal_init_options
#undef LANG_HOOKS_PRINT_DECL
#define LANG_HOOKS_PRINT_DECL print_lang_decl
#undef LANG_HOOKS_PRINT_TYPE
#define LANG_HOOKS_PRINT_TYPE print_lang_type
#undef LANG_HOOKS_PRINT_IDENTIFIER
#define LANG_HOOKS_PRINT_IDENTIFIER print_lang_identifier
#undef LANG_HOOKS_SET_YYDEBUG
#define LANG_HOOKS_SET_YYDEBUG set_yydebug
#undef LANG_HOOKS_GET_ALIAS_SET
#define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
#undef LANG_HOOKS_PRINT_XNODE
#define LANG_HOOKS_PRINT_XNODE lang_print_xnode

#ifdef GCC_3_3
#undef LANG_HOOKS_DECL_PRINTABLE_NAME
#define LANG_HOOKS_DECL_PRINTABLE_NAME pascal_decl_name
#undef LANG_HOOKS_PRINT_ERROR_FUNCTION
#define LANG_HOOKS_PRINT_ERROR_FUNCTION pascal_print_error_function

#define LANG_HOOKS_UNSIGNED_TYPE unsigned_type
#define LANG_HOOKS_SIGNED_TYPE signed_type
#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE signed_or_unsigned_type
#define LANG_HOOKS_TYPE_FOR_SIZE type_for_size
#define LANG_HOOKS_TYPE_FOR_MODE type_for_mode

#define LANG_HOOKS_MARK_ADDRESSABLE mark_addressable
#define LANG_HOOKS_TRUTHVALUE_CONVERSION truthvalue_conversion

#undef LANG_HOOKS_DUP_LANG_SPECIFIC_DECL
#define LANG_HOOKS_DUP_LANG_SPECIFIC_DECL copy_lang_decl

#undef LANG_HOOKS_PARSE_FILE
#define LANG_HOOKS_PARSE_FILE pascal_parse

#undef LANG_HOOKS_COMMON_ATTRIBUTE_TABLE
#define LANG_HOOKS_COMMON_ATTRIBUTE_TABLE gpc_attribute_table

static void
pascal_parse (debug)
     int debug;
{
  set_yydebug (debug);
  yyparse ();
}

#else

void
lang_mark_tree (t)
     tree t;
{
  if (TREE_CODE (t) == IDENTIFIER_NODE)
    {
      struct lang_identifier *i = (struct lang_identifier *) t;
      ggc_mark_tree (i->value);
      ggc_mark_tree (i->error_locus);
    }
  else if (TREE_CODE (t) == IMPORT_NODE)
    {
      ggc_mark_tree (IMPORT_INTERFACE (t));
      ggc_mark_tree (IMPORT_QUALIFIER (t));
      ggc_mark_tree (IMPORT_FILENAME (t));
    }
  else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
    {
      struct lang_type *lt = TYPE_LANG_SPECIFIC (t);
      ggc_mark (lt);
      ggc_mark_tree (lt->info);
      ggc_mark_tree (lt->info2);
      ggc_mark_tree (lt->base);
      ggc_mark_tree (lt->initial);
      if (lt->sorted_fields)
        ggc_mark (lt->sorted_fields);
    }
  else if (DECL_P (t) && DECL_LANG_SPECIFIC (t))
    {
      struct lang_decl *ld = DECL_LANG_SPECIFIC (t);
      ggc_mark (ld);
      ggc_mark_tree (ld->info);
      ggc_mark_tree (ld->info2);
      ggc_mark_tree (ld->info3);
    }
}
#endif

const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
#endif

#ifndef EGCS97
enum attrs { A_NOCOMMON, A_COMMON, A_NORETURN, A_CONST,
             A_SECTION, A_ALIGNED, A_UNUSED, A_WEAK, A_ALIAS };

static struct { enum attrs id; tree name; int min, max, decl_req; } attrtab[50];
static int attrtab_idx = 0;

static void add_attribute PARAMS ((enum attrs, const char *, int, int, int));
static void
add_attribute (id, string, min_len, max_len, decl_req)
     enum attrs id;
     const char *string;
     int min_len, max_len, decl_req;
{
  char buf[100];
  attrtab[attrtab_idx].id = id;
  attrtab[attrtab_idx].name = get_identifier (string);
  attrtab[attrtab_idx].min = min_len;
  attrtab[attrtab_idx].max = max_len;
  attrtab[attrtab_idx++].decl_req = decl_req;
  sprintf (buf, "__%s__", string);
  attrtab[attrtab_idx].id = id;
  attrtab[attrtab_idx].name = get_identifier (buf);
  attrtab[attrtab_idx].min = min_len;
  attrtab[attrtab_idx].max = max_len;
  attrtab[attrtab_idx++].decl_req = decl_req;
}
#endif

/* Process the attributes listed in ATTRIBUTES and install them in NODE,
   which is either a DECL (including a TYPE_DECL) or a TYPE. */
void
pascal_decl_attributes (anode, attributes)
     tree *anode, attributes;
{
#ifndef EGCS97
  tree node = *anode, decl = 0, type = 0;
  int is_type = 0;
#endif
  tree a;
  for (a = attributes; a; a = TREE_CHAIN (a))
    TREE_PURPOSE (a) = de_capitalize (TREE_PURPOSE (a));
#ifdef EGCS97
  decl_attributes (anode, attributes, 0);
#else

  if (!attrtab_idx)
    {
      add_attribute (A_NOCOMMON, "nocommon", 0, 0, 1);
      add_attribute (A_COMMON, "common", 0, 0, 1);
      add_attribute (A_NORETURN, "noreturn", 0, 0, 1);
      add_attribute (A_UNUSED, "unused", 0, 0, 0);
      add_attribute (A_CONST, "const", 0, 0, 1);
      add_attribute (A_SECTION, "section", 1, 1, 1);
      add_attribute (A_ALIGNED, "aligned", 0, 1, 0);
      add_attribute (A_WEAK, "weak", 0, 0, 1);
      add_attribute (A_ALIAS, "alias", 1, 1, 1);
    }

  if (DECL_P (node))
    {
      decl = node;
      type = TREE_TYPE (decl);
      is_type = TREE_CODE (node) == TYPE_DECL;
    }
  else if (TYPE_P (node))
    type = node, is_type = 1;

  for (a = attributes; a; a = TREE_CHAIN (a))
    {
      tree name = TREE_PURPOSE (a);
      tree args = TREE_VALUE (a);
      int i;
      enum attrs id;

      for (i = 0; i < attrtab_idx; i++)
        if (attrtab[i].name == name)
          break;

      if (i == attrtab_idx)
        {
          if (TYPE_P (node))
            *anode = type = build_type_copy (type);
          if (!valid_machine_attribute (name, args, decl, type))
            warning ("`%s' attribute directive ignored", IDENTIFIER_NAME (name));
          else if (decl)
            type = TREE_TYPE (decl);
          continue;
        }
      else if (attrtab[i].decl_req && !decl)
        {
          warning ("`%s' attribute does not apply to types", IDENTIFIER_NAME (name));
          continue;
        }
      else if (list_length (args) < attrtab[i].min || list_length (args) > attrtab[i].max)
        {
          error ("wrong number of arguments specified for `%s' attribute",
                 IDENTIFIER_NAME (name));
          continue;
        }

      id = attrtab[i].id;
      switch (id)
      {
        case A_NOCOMMON:
          if (TREE_CODE (decl) == VAR_DECL)
            DECL_COMMON (decl) = 0;
          else
            warning ("`%s' attribute ignored", IDENTIFIER_NAME (name));
          break;

        case A_COMMON:
          if (TREE_CODE (decl) == VAR_DECL)
            DECL_COMMON (decl) = 1;
          else
            warning ("`%s' attribute ignored", IDENTIFIER_NAME (name));
          break;

        case A_NORETURN:
          if (TREE_CODE (decl) == FUNCTION_DECL)
            TREE_THIS_VOLATILE (decl) = 1;
          else if (TREE_CODE (type) == POINTER_TYPE && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
            TREE_TYPE (decl) = type = build_pointer_type (p_build_type_variant (TREE_TYPE (type),
              TREE_READONLY (TREE_TYPE (type)), 1));
          else
            warning ("`%s' attribute ignored", IDENTIFIER_NAME (name));
          break;

        case A_UNUSED:
          if (TYPE_P (node))
            *anode = type = build_type_copy (type);
          if (is_type)
            TREE_USED (type) = 1;
          else if (TREE_CODE (decl) == PARM_DECL
                   || TREE_CODE (decl) == VAR_DECL
                   || TREE_CODE (decl) == FUNCTION_DECL)
            TREE_USED (decl) = 1;
          else
            warning ("`%s' attribute ignored", IDENTIFIER_NAME (name));
          break;

        case A_CONST:
          if (TREE_CODE (decl) == FUNCTION_DECL)
            TREE_READONLY (decl) = 1;
          else if (TREE_CODE (type) == POINTER_TYPE && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
            TREE_TYPE (decl) = type = build_pointer_type (p_build_type_variant (TREE_TYPE (type),
              1, TREE_THIS_VOLATILE (TREE_TYPE (type))));
          else
            warning ("`%s' attribute ignored", IDENTIFIER_NAME (name));
          break;

        case A_SECTION:
#ifdef ASM_OUTPUT_SECTION_NAME
          if ((TREE_CODE (decl) == FUNCTION_DECL || TREE_CODE (decl) == VAR_DECL)
              && TREE_CODE (TREE_VALUE (args)) == STRING_CST)
            {
              if (TREE_CODE (decl) == VAR_DECL
                  && current_function_decl
                  && !TREE_STATIC (decl))
                error_with_decl (decl, "section attribute cannot be specified for local variables");
              /* The decl may have already been given a section attribute from
                 a previous declaration. Ensure they match. */
              else if (DECL_SECTION_NAME (decl)
                       && strcmp (TREE_STRING_POINTER (DECL_SECTION_NAME (decl)),
                                  TREE_STRING_POINTER (TREE_VALUE (args))) != 0)
                error_with_decl (node, "section of `%s' conflicts with previous declaration");
              else
                DECL_SECTION_NAME (decl) = TREE_VALUE (args);
            }
          else
            error_with_decl (node, "section attribute not allowed for `%s'");
#else
          error_with_decl (node, "section attributes are not supported for this target");
#endif
          break;

        case A_ALIGNED:
          {
            tree align_expr = (args ? TREE_VALUE (args) : size_int (BIGGEST_ALIGNMENT / BITS_PER_UNIT));
            int align;

            /* Strip any NOPs of any kind. */
            while (TREE_CODE (align_expr) == NOP_EXPR
                   || TREE_CODE (align_expr) == CONVERT_EXPR
                   || TREE_CODE (align_expr) == NON_LVALUE_EXPR)
              align_expr = TREE_OPERAND (align_expr, 0);

            if (TREE_CODE (align_expr) != INTEGER_CST)
              {
                error ("requested alignment is not a constant");
                continue;
              }

            align = TREE_INT_CST_LOW (align_expr) * BITS_PER_UNIT;

            if (TYPE_P (node))
              *anode = type = build_type_copy (type);
            if (exact_log2 (align) == -1)
              error ("requested alignment is not a power of 2");
            else if (is_type)
              TYPE_ALIGN (type) = align;
            else if (TREE_CODE (decl) != VAR_DECL && TREE_CODE (decl) != FIELD_DECL)
              error_with_decl (decl, "alignment may not be specified for `%s'");
            else
              DECL_ALIGN (decl) = align;
          }
          break;

        case A_WEAK:
          declare_weak (decl);
          break;

        case A_ALIAS:
          if ((TREE_CODE (decl) == FUNCTION_DECL && DECL_INITIAL (decl))
              || (TREE_CODE (decl) != FUNCTION_DECL && !DECL_EXTERNAL (decl)))
            error_with_decl (decl, "`%s' defined both normally and as an alias");
          else if (!decl_function_context (decl))
            {
              tree id = get_identifier (TREE_STRING_POINTER (TREE_VALUE (args)));
              if (TREE_CODE (decl) == FUNCTION_DECL)
                DECL_INITIAL (decl) = error_mark_node;
              else
                DECL_EXTERNAL (decl) = 0;
              assemble_alias (decl, id);
            }
          else
            warning ("`%s' attribute ignored", IDENTIFIER_NAME (name));
          break;
      }
    }
#endif
}

#ifndef EGCS
char *
concat VPARAMS ((const char *first, ...))
{
  int length;
  char *newstr;
  char *end;
  const char *arg;
  va_list args;
#ifndef __STDC__
  const char *first;
#endif
  /* First compute the size of the result and get sufficient memory. */
  VA_START (args, first);
#ifndef __STDC__
  first = va_arg (args, const char *);
#endif
  arg = first;
  length = 0;
  while (arg)
    {
      length += strlen (arg);
      arg = va_arg (args, const char *);
    }
  newstr = (char *) xmalloc (length + 1);
  va_end (args);
  /* Now copy the individual pieces to the result string. */
  VA_START (args, first);
#ifndef __STDC__
  first = va_arg (args, const char *);
#endif
  end = newstr;
  arg = first;
  while (arg)
    {
      while (*arg)
        *end++ = *arg++;
      arg = va_arg (args, const char *);
    }
  *end = '\000';
  va_end (args);
  return (newstr);
}
#endif

/* For ACONCAT */
#ifndef EGCS97
#if defined (__STDC__) || defined (_AIX) || (defined (__mips) && defined (_SYSTYPE_SVR4)) || defined(_WIN32)
#define VA_OPEN(AP, VAR) { va_list AP; va_start(AP, VAR); { struct Qdmy
#define VA_CLOSE(AP) } va_end(AP); }
#define VA_FIXEDARG(AP, T, N) struct Qdmy
#else
#define VA_OPEN(AP, VAR) { va_list AP; va_start(AP); { struct Qdmy
#define VA_CLOSE(AP) } va_end(AP); }
#define VA_FIXEDARG(AP, TYPE, NAME) TYPE NAME = va_arg(AP, TYPE)
#endif

char *libiberty_concat_ptr;

unsigned long
concat_length VPARAMS ((const char *first, ...))
{
  unsigned long length = 0;
  const char *arg;
  VA_OPEN (args, first);
  VA_FIXEDARG (args, const char *, first);
  for (arg = first; arg ; arg = va_arg (args, const char *))
    length += strlen (arg);
  VA_CLOSE (args);
  return length;
}

char *
concat_copy2 VPARAMS ((const char *first, ...))
{
  char *end = libiberty_concat_ptr;
  const char *arg;
  VA_OPEN (args, first);
  VA_FIXEDARG (args, const char *, first);
  for (arg = first; arg ; arg = va_arg (args, const char *))
    {
      unsigned long length = strlen (arg);
      memcpy (end, arg, length);
      end += length;
    }
  *end = '\000';
  VA_CLOSE (args);
  return libiberty_concat_ptr;
}
#endif

/* Exit compilation as successfully as reasonable. */
void
exit_compilation ()
{
  if (errorcount)
    exit (FATAL_EXIT_CODE);
  if (sorrycount)
    exit (FATAL_EXIT_CODE);
  exit (SUCCESS_EXIT_CODE);
}

void
assert_fail (msg, file, function, line)
     const char *msg, *file, *function;
     int line;
{
  if (function)
    fprintf (stderr, "%s:%i:%s: failed assertion `%s'\n", file, line, function, msg);
  else
    fprintf (stderr, "%s:%i: failed assertion `%s'\n", file, line, msg);
  error ("Internal compiler error.\n\
Please submit a full bug report to the GPC mailing list <gpc@gnu.de>.\n\
See <URL:http://www.gnu-pascal.de/todo.html> for details.");
  exit (FATAL_EXIT_CODE);
}
