[patch] support for -fdump-ada-spec
Arnaud Charlet
charlet@adacore.com
Fri May 7 08:11:00 GMT 2010
> See what c_lex_with_flags does.
I see. I've looked at c_lex_with_flags, and this subprogram uses the
following routines mainly:
for characters: lex_charconst, which uses cpp_interpret_charconst,
this one can be reused
for strings: lex_string
for numbers: interpret_integer and interpret_float
lex_string, interpret_integer and interpret_float are functions local
to c-lex.c, so cannot be reused outside this file.
Duplicating their work would defeat your suggestion, so are you
suggesting that we make interpret_integer/interpret_float/lex_string
global functions instead?
That would actually not work, since e.g. lex_string uses cpp_get_token(),
in other words, will get tokens from the parsers, while in c-ada-spec.c,
we only have access to the MACRO definitions, in other words, we're
working before the preprocessor expansion, not after.
> I'm concerned about having multiple separate implementations of
> processing C tokens that make it unclear what should be updated when a new
> type of constant or string is added, and are liable to get out of sync.
Given that we only process a subset of CPP tokens in c-ada-spec.c, I
doubt this will be an issue, and am of course willing to maintain this part
when such update is needed. In most cases, it will be a no-op (part of
a 'default:' in the switch) anyway.
Here is the updated patch which uses cpp_interpret_charconst for characters
which is indeed an improvement (same ChangeLog).
Tested on i686-pc-linux-gnu, OK for mainline?
Arno
-------------- next part --------------
Index: gcc/doc/invoke.texi
===================================================================
--- gcc/doc/invoke.texi (revision 158721)
+++ gcc/doc/invoke.texi (working copy)
@@ -164,7 +164,8 @@ in the following sections.
@gccoptlist{-c -S -E -o @var{file} -combine -no-canonical-prefixes @gol
-pipe -pass-exit-codes @gol
-x @var{language} -v -### --help@r{[}=@var{class}@r{[},@dots{}@r{]]} --target-help @gol
---version -wrapper@@@var{file} -fplugin=@var{file} -fplugin-arg-@var{name}=@var{arg}}
+--version -wrapper@@@var{file} -fplugin=@var{file} -fplugin-arg-@var{name}=@var{arg} @gol
+-fdump-ada-spec@r{[}-slim@r{]}}
@item C Language Options
@xref{C Dialect Options,,Options Controlling C Dialect}.
@@ -984,7 +985,8 @@ Objective-C++ source code which should n
@item @var{file}.h
C, C++, Objective-C or Objective-C++ header file to be turned into a
-precompiled header.
+precompiled header (default), or C, C++ header file to be turned into an
+Ada spec (via the @option{-fdump-ada-spec} switch).
@item @var{file}.cc
@itemx @var{file}.cp
@@ -1012,7 +1014,7 @@ Objective-C++ source code which should n
@itemx @var{file}.HPP
@itemx @var{file}.h++
@itemx @var{file}.tcc
-C++ header file to be turned into a precompiled header.
+C++ header file to be turned into a precompiled header or Ada spec.
@item @var{file}.f
@itemx @var{file}.for
@@ -1367,6 +1369,11 @@ Plugins API.
Define an argument called @var{key} with a value of @var{value}
for the plugin called @var{name}.
+@item -fdump-ada-spec@r{[}-slim@r{]}
+For C and C++ source and include files, generate corresponding Ada
+specs. @xref{Generating Ada Bindings for C and C++ headers,,, gnat_ugn,
+GNAT User's Guide}, which provides detailed documentation on this feature.
+
@include @value{srcdir}/../libiberty/at-file.texi
@end table
Index: gcc/ada/gnat_ugn.texi
===================================================================
--- gcc/ada/gnat_ugn.texi (revision 158721)
+++ gcc/ada/gnat_ugn.texi (working copy)
@@ -23326,10 +23326,21 @@ Verbose mode: generate version informati
@findex binding
@noindent
-GNAT now comes with a new experimental binding generator for C and C++
-headers which is intended to do 95% of the tedious work of generating
-Ada specs from C or C++ header files. Note that this still is a work in
-progress, not designed to generate 100% correct Ada specs.
+GNAT now comes with a binding generator for C and C++ headers which is
+intended to do 95% of the tedious work of generating Ada specs from C
+or C++ header files.
+
+Note that this capability is not intended to generate 100% correct Ada specs,
+and will is some cases require manual adjustments, although it can often
+be used out of the box in practice.
+
+Some of the known limitations include:
+
+@itemize @bullet
+@item only simple macros are translated into Ada constants
+@item some extensions (e.g. vector types) are not supported
+@item pointers to pointers or complex structures are mapped to System.Address
+@end itemize
The code generated is using the Ada 2005 syntax, which makes it
easier to interface with other languages than previous versions of Ada.
Index: gcc/tree-dump.c
===================================================================
--- gcc/tree-dump.c (revision 158721)
+++ gcc/tree-dump.c (working copy)
@@ -783,7 +783,8 @@ static struct dump_file_info dump_files[
{".gimple", "tree-gimple", NULL, TDF_TREE, 0, 4},
{".nested", "tree-nested", NULL, TDF_TREE, 0, 5},
{".vcg", "tree-vcg", NULL, TDF_TREE, 0, 6},
-#define FIRST_AUTO_NUMBERED_DUMP 7
+ {".ads", "ada-spec", NULL, 0, 0, 7},
+#define FIRST_AUTO_NUMBERED_DUMP 8
{NULL, "tree-all", NULL, TDF_TREE, 0, 0},
{NULL, "rtl-all", NULL, TDF_RTL, 0, 0},
Index: gcc/tree-pass.h
===================================================================
--- gcc/tree-pass.h (revision 158721)
+++ gcc/tree-pass.h (working copy)
@@ -38,6 +38,7 @@ enum tree_dump_index
TDI_nested, /* dump each function after unnesting it */
TDI_vcg, /* create a VCG graph file for each
function's flowgraph. */
+ TDI_ada, /* dump declarations in Ada syntax. */
TDI_tree_all, /* enable all the GENERIC/GIMPLE dumps. */
TDI_rtl_all, /* enable all the RTL dumps. */
TDI_ipa_all, /* enable all the IPA dumps. */
Index: gcc/gcc.c
===================================================================
--- gcc/gcc.c (revision 158721)
+++ gcc/gcc.c (working copy)
@@ -866,8 +866,7 @@ static const char *trad_capable_cpp =
therefore no dependency entry, confuses make into thinking a .o
file that happens to exist is up-to-date. */
static const char *cpp_unique_options =
-"%{C|CC:%{!E:%eGCC does not support -C or -CC without -E}}\
- %{!Q:-quiet} %{nostdinc*} %{C} %{CC} %{v} %{I*&F*} %{P} %I\
+"%{!Q:-quiet} %{nostdinc*} %{C} %{CC} %{v} %{I*&F*} %{P} %I\
%{MD:-MD %{!o:%b.d}%{o*:%.d%*}}\
%{MMD:-MMD %{!o:%b.d}%{o*:%.d%*}}\
%{M} %{MM} %{MF*} %{MG} %{MP} %{MQ*} %{MT*}\
@@ -1101,12 +1100,12 @@ static const struct compiler default_com
%(cpp_options) -o %{save-temps*:%b.i} %{!save-temps*:%g.i} \n\
cc1 -fpreprocessed %{save-temps*:%b.i} %{!save-temps*:%g.i} \
%(cc1_options)\
- -o %g.s %{!o*:--output-pch=%i.gch}\
- %W{o*:--output-pch=%*}%V}\
+ -o %g.s %{!o*:%{!fdump-ada*:--output-pch=%i.gch}}\
+ %W{o*:%{!fdump-ada*:--output-pch=%*}}%V}\
%{!save-temps*:%{!traditional-cpp:%{!no-integrated-cpp:\
cc1 %(cpp_unique_options) %(cc1_options)\
- -o %g.s %{!o*:--output-pch=%i.gch}\
- %W{o*:--output-pch=%*}%V}}}}}}", 0, 0, 0},
+ -o %g.s %{!o*:%{!fdump-ada*:--output-pch=%i.gch}}\
+ %W{o*:%{!fdump-ada*:--output-pch=%*}}%V}}}}}}", 0, 0, 0},
{".i", "@cpp-output", 0, 1, 0},
{"@cpp-output",
"%{!M:%{!MM:%{!E:cc1 -fpreprocessed %i %(cc1_options) %{!fsyntax-only:%(invoke_as)}}}}", 0, 1, 0},
Index: gcc/c-decl.c
===================================================================
--- gcc/c-decl.c (revision 158721)
+++ gcc/c-decl.c (working copy)
@@ -65,6 +65,7 @@ along with GCC; see the file COPYING3.
#include "pointer-set.h"
#include "gimple.h"
#include "plugin.h"
+#include "c-ada-spec.h"
/* In grokdeclarator, distinguish syntactic contexts of declarators. */
enum decl_context
@@ -9507,6 +9508,43 @@ c_write_global_declarations_2 (tree glob
debug_hooks->global_decl (decl);
}
+/* Callback to collect a source_ref from a DECL. */
+
+static void
+collect_source_ref_cb (tree decl)
+{
+ if (!DECL_IS_BUILTIN (decl))
+ collect_source_ref (LOCATION_FILE (decl_sloc (decl, false)));
+}
+
+/* Collect all references relevant to SOURCE_FILE. */
+
+static void
+collect_all_refs (const char *source_file)
+{
+ tree t;
+
+ for (t = all_translation_units; t; t = TREE_CHAIN (t))
+ collect_ada_nodes (BLOCK_VARS (DECL_INITIAL (t)), source_file);
+}
+
+/* Iterate over all global declarations and call CALLBACK. */
+
+static void
+for_each_global_decl (void (*callback) (tree decl))
+{
+ tree t;
+ tree decls;
+ tree decl;
+
+ for (t = all_translation_units; t; t = TREE_CHAIN (t))
+ {
+ decls = DECL_INITIAL (t);
+ for (decl = BLOCK_VARS (decls); decl; decl = TREE_CHAIN (decl))
+ callback (decl);
+ }
+}
+
/* Preserve the external declarations scope across a garbage collect. */
static GTY(()) tree ext_block;
@@ -9529,6 +9567,18 @@ c_write_global_declarations (void)
external_scope = 0;
gcc_assert (!current_scope);
+ /* Handle -fdump-ada-spec[-slim]. */
+ if (dump_enabled_p (TDI_ada))
+ {
+ /* Build a table of files to generate specs for */
+ if (get_dump_file_info (TDI_ada)->flags & TDF_SLIM)
+ collect_source_ref (main_input_filename);
+ else
+ for_each_global_decl (collect_source_ref_cb);
+
+ dump_ada_specs (collect_all_refs, NULL);
+ }
+
if (ext_block)
{
tree tmp = BLOCK_VARS (ext_block);
Index: gcc/c-lex.c
===================================================================
--- gcc/c-lex.c (revision 158721)
+++ gcc/c-lex.c (working copy)
@@ -440,10 +440,14 @@ c_lex_with_flags (tree *value, location_
/* These tokens should not be visible outside cpplib. */
case CPP_HEADER_NAME:
- case CPP_COMMENT:
case CPP_MACRO_ARG:
gcc_unreachable ();
+ /* CPP_COMMENT will appear when compiling with -C and should be
+ ignored. */
+ case CPP_COMMENT:
+ goto retry;
+
default:
*value = NULL_TREE;
break;
Index: gcc/Makefile.in
===================================================================
--- gcc/Makefile.in (revision 158721)
+++ gcc/Makefile.in (working copy)
@@ -1125,7 +1125,7 @@ C_AND_OBJC_OBJS = attribs.o c-errors.o c
c-convert.o c-aux-info.o c-common.o c-opts.o c-format.o c-semantics.o \
c-ppoutput.o c-cppbuiltin.o \
c-objc-common.o c-dump.o c-pch.o c-parser.o $(C_TARGET_OBJS) \
- c-gimplify.o tree-mudflap.o c-pretty-print.o c-omp.o
+ c-gimplify.o tree-mudflap.o c-pretty-print.o c-omp.o c-ada-spec.o
# Language-specific object files for C.
C_OBJS = c-lang.o stub-objc.o $(C_AND_OBJC_OBJS)
@@ -1971,7 +1971,8 @@ c-decl.o : c-decl.c $(CONFIG_H) $(SYSTEM
opts.h $(C_PRAGMA_H) gt-c-decl.h $(CGRAPH_H) $(HASHTAB_H) libfuncs.h \
$(EXCEPT_H) $(LANGHOOKS_DEF_H) $(TREE_DUMP_H) $(C_COMMON_H) $(CPPLIB_H) \
$(DIAGNOSTIC_H) $(INPUT_H) langhooks.h $(GIMPLE_H) tree-mudflap.h \
- pointer-set.h $(BASIC_BLOCK_H) $(GIMPLE_H) tree-iterator.h c-lang.h $(PLUGIN_H)
+ pointer-set.h $(BASIC_BLOCK_H) $(GIMPLE_H) tree-iterator.h c-lang.h $(PLUGIN_H) \
+ c-ada-spec.h
c-typeck.o : c-typeck.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
$(TREE_H) $(C_TREE_H) $(TARGET_H) $(FLAGS_H) intl.h output.h $(EXPR_H) \
$(RTL_H) $(TOPLEV_H) $(TM_P_H) langhooks.h $(GGC_H) $(TREE_FLOW_H) \
@@ -2688,6 +2689,10 @@ tree-pretty-print.o : tree-pretty-print.
$(TREE_H) $(DIAGNOSTIC_H) $(REAL_H) $(HASHTAB_H) $(TREE_FLOW_H) \
$(TM_H) coretypes.h tree-iterator.h $(SCEV_H) langhooks.h \
$(TREE_PASS_H) value-prof.h fixed-value.h output.h
+c-ada-spec.o : c-ada-spec.c c-ada-spec.h $(CONFIG_H) $(SYSTEM_H) \
+ $(TREE_H) $(REAL_H) $(HASHTAB_H) $(TREE_FLOW_H) \
+ $(CPP_ID_DATA_H) $(TM_H) coretypes.h tree-iterator.h tree-pass.h \
+ value-prof.h fixed-value.h output.h
fold-const.o : fold-const.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
$(TREE_H) $(FLAGS_H) $(REAL_H) $(TOPLEV_H) $(HASHTAB_H) $(EXPR_H) $(RTL_H) \
$(GGC_H) $(TM_P_H) langhooks.h $(MD5_H) intl.h fixed-value.h $(TARGET_H) \
Index: gcc/cp/Make-lang.in
===================================================================
--- gcc/cp/Make-lang.in (revision 158721)
+++ gcc/cp/Make-lang.in (working copy)
@@ -74,7 +74,7 @@ g++-cross$(exeext): g++$(exeext)
CXX_C_OBJS = attribs.o c-common.o c-format.o c-pragma.o c-semantics.o c-lex.o \
c-dump.o $(CXX_TARGET_OBJS) c-pretty-print.o c-opts.o c-pch.o \
incpath.o c-ppoutput.o c-cppbuiltin.o prefix.o \
- c-gimplify.o c-omp.o
+ c-gimplify.o c-omp.o c-ada-spec.o
# Language-specific object files for C++ and Objective C++.
CXX_AND_OBJCXX_OBJS = cp/call.o cp/decl.o cp/expr.o cp/pt.o cp/typeck2.o \
@@ -259,7 +259,8 @@ cp/decl.o: cp/decl.c $(CXX_TREE_H) $(TM_
intl.h
cp/decl2.o: cp/decl2.c $(CXX_TREE_H) $(TM_H) $(FLAGS_H) cp/decl.h $(EXPR_H) \
output.h except.h toplev.h $(RTL_H) $(C_COMMON_H) gt-cp-decl2.h $(CGRAPH_H) \
- $(C_PRAGMA_H) $(TREE_DUMP_H) intl.h $(TARGET_H) $(GIMPLE_H) $(POINTER_SET_H)
+ $(C_PRAGMA_H) $(TREE_DUMP_H) intl.h $(TARGET_H) $(GIMPLE_H) $(POINTER_SET_H) \
+ c-ada-spec.h
cp/cp-objcp-common.o : cp/cp-objcp-common.c $(CONFIG_H) $(SYSTEM_H) \
coretypes.h $(TM_H) $(TREE_H) $(CXX_TREE_H) $(C_COMMON_H) toplev.h \
langhooks.h $(LANGHOOKS_DEF_H) $(DIAGNOSTIC_H) debug.h \
Index: gcc/cp/decl2.c
===================================================================
--- gcc/cp/decl2.c (revision 158721)
+++ gcc/cp/decl2.c (working copy)
@@ -1,6 +1,6 @@
/* Process declarations and variables for C++ compiler.
Copyright (C) 1988, 1992, 1993, 1994, 1995, 1996, 1997, 1998,
- 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+ 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Hacked by Michael Tiemann (tiemann@cygnus.com)
@@ -53,6 +53,8 @@ along with GCC; see the file COPYING3.
#include "intl.h"
#include "gimple.h"
#include "pointer-set.h"
+#include "langhooks.h"
+#include "c-ada-spec.h"
extern cpp_reader *parse_in;
@@ -3455,6 +3457,69 @@ build_java_method_aliases (struct pointe
}
}
+/* Return C++ property of T, based on given operation OP. */
+
+static int
+cpp_check (tree t, cpp_operation op)
+{
+ switch (op)
+ {
+ case IS_ABSTRACT:
+ return DECL_PURE_VIRTUAL_P (t);
+ case IS_CONSTRUCTOR:
+ return DECL_CONSTRUCTOR_P (t);
+ case IS_DESTRUCTOR:
+ return DECL_DESTRUCTOR_P (t);
+ case IS_COPY_CONSTRUCTOR:
+ return DECL_COPY_CONSTRUCTOR_P (t);
+ case IS_TEMPLATE:
+ return TREE_CODE (t) == TEMPLATE_DECL;
+ default:
+ return 0;
+ }
+}
+
+/* Collect source file references recursively, starting from NAMESPC. */
+
+static void
+collect_source_refs (tree namespc)
+{
+ tree t;
+
+ if (!namespc)
+ return;
+
+ /* Iterate over names in this name space. */
+ for (t = NAMESPACE_LEVEL (namespc)->names; t; t = TREE_CHAIN (t))
+ if (!DECL_IS_BUILTIN (t) )
+ collect_source_ref (DECL_SOURCE_FILE (t));
+
+ /* Dump siblings, if any */
+ collect_source_refs (TREE_CHAIN (namespc));
+
+ /* Dump children, if any */
+ collect_source_refs (NAMESPACE_LEVEL (namespc)->namespaces);
+}
+
+/* Collect decls relevant to SOURCE_FILE from all namespaces recursively,
+ starting from NAMESPC. */
+
+static void
+collect_ada_namespace (tree namespc, const char *source_file)
+{
+ if (!namespc)
+ return;
+
+ /* Collect decls from this namespace */
+ collect_ada_nodes (NAMESPACE_LEVEL (namespc)->names, source_file);
+
+ /* Collect siblings, if any */
+ collect_ada_namespace (TREE_CHAIN (namespc), source_file);
+
+ /* Collect children, if any */
+ collect_ada_namespace (NAMESPACE_LEVEL (namespc)->namespaces, source_file);
+}
+
/* Returns true iff there is a definition available for variable or
function DECL. */
@@ -3489,6 +3554,14 @@ no_linkage_error (tree decl)
"is used but never defined", decl, t);
}
+/* Collect declarations from all namespaces relevant to SOURCE_FILE. */
+
+static void
+collect_all_refs (const char *source_file)
+{
+ collect_ada_namespace (global_namespace, source_file);
+}
+
/* This routine is called at the end of compilation.
Its job is to create all the code needed to initialize and
destroy the global aggregates. We do the destruction
@@ -3516,6 +3589,17 @@ cp_write_global_declarations (void)
if (pch_file)
c_common_write_pch ();
+ /* Handle -fdump-ada-spec[-slim] */
+ if (dump_enabled_p (TDI_ada))
+ {
+ if (get_dump_file_info (TDI_ada)->flags & TDF_SLIM)
+ collect_source_ref (main_input_filename);
+ else
+ collect_source_refs (global_namespace);
+
+ dump_ada_specs (collect_all_refs, cpp_check);
+ }
+
/* FIXME - huh? was input_line -= 1;*/
/* We now have to write out all the stuff we put off writing out.
Index: gcc/cp/lang-specs.h
===================================================================
--- gcc/cp/lang-specs.h (revision 158721)
+++ gcc/cp/lang-specs.h (working copy)
@@ -48,7 +48,8 @@ along with GCC; see the file COPYING3.
cc1plus %{save-temps|no-integrated-cpp:-fpreprocessed %{save-temps:%b.ii} %{!save-temps:%g.ii}}\
%{!save-temps:%{!no-integrated-cpp:%(cpp_unique_options)}}\
%(cc1_options) %2 %{+e1*}\
- %{!fsyntax-only:-o %g.s %{!o*:--output-pch=%i.gch} %W{o*:--output-pch=%*}%V}}}}",
+ %{!fsyntax-only:-o %g.s %{!o*:%{!fdump-ada*:--output-pch=%i.gch}}\
+ %W{o*:%{!fdump-ada*:--output-pch=%*}}%V}}}}",
CPLUSPLUS_CPP_SPEC, 0, 0},
{"@c++",
"%{E|M|MM:cc1plus -E %(cpp_options) %2 %(cpp_debug_options)}\
Index: gcc/c-ada-spec.h
===================================================================
--- gcc/c-ada-spec.h (revision 0)
+++ gcc/c-ada-spec.h (revision 0)
@@ -0,0 +1,41 @@
+/* Interface for -fdump-ada-spec capability.
+ Copyright (C) 2010, Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC 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 3, or (at your option) any later
+version.
+
+GCC 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 GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#ifndef C_ADA_SPEC_H
+#define C_ADA_SPEC_H
+
+#include "pretty-print.h"
+
+/* In c-ada-spec.c */
+
+typedef enum {
+ IS_ABSTRACT,
+ IS_CONSTRUCTOR,
+ IS_DESTRUCTOR,
+ IS_COPY_CONSTRUCTOR,
+ IS_TEMPLATE
+} cpp_operation;
+
+extern location_t decl_sloc (const_tree, bool);
+extern void collect_ada_nodes (tree, const char *);
+extern void collect_source_ref (const char *);
+extern void dump_ada_specs (void (*)(const char *),
+ int (*)(tree, cpp_operation));
+
+#endif /* ! C_ADA_SPEC_H */
Index: gcc/c-ada-spec.c
===================================================================
--- gcc/c-ada-spec.c (revision 0)
+++ gcc/c-ada-spec.c (revision 0)
@@ -0,0 +1,3370 @@
+/* Print GENERIC declaration (functions, variables, types) trees coming from
+ the C and C++ front-ends as well as macros in Ada syntax.
+ Copyright (C) 2010 Free Software Foundation, Inc.
+ Adapted from tree-pretty-print.c by Arnaud Charlet <charlet@adacore.com>
+
+This file is part of GCC.
+
+GCC 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 3, or (at your option) any later
+version.
+
+GCC 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 GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "output.h"
+#include "c-ada-spec.h"
+#include "real.h"
+#include "hashtab.h"
+#include "tree-flow.h"
+#include "langhooks.h"
+#include "tree-iterator.h"
+#include "tree-chrec.h"
+#include "tree-pass.h"
+#include "fixed-value.h"
+#include "value-prof.h"
+#include "predict.h"
+#include "cpplib.h"
+#include "c-pragma.h"
+#include "cpp-id-data.h"
+
+/* Local functions, macros and variables. */
+static int dump_generic_ada_node (pretty_printer *, tree, tree,
+ int (*)(tree, cpp_operation), int, int, bool);
+static int print_ada_declaration (pretty_printer *, tree, tree,
+ int (*cpp_check)(tree, cpp_operation), int);
+static void print_ada_struct_decl (pretty_printer *, tree, tree,
+ int (*cpp_check)(tree, cpp_operation), int,
+ bool);
+static void dump_sloc (pretty_printer *buffer, tree node);
+static void print_comment (pretty_printer *, const char *);
+static void print_generic_ada_decl (pretty_printer *, tree,
+ int (*)(tree, cpp_operation), const char *);
+static char *get_ada_package (const char *);
+static void dump_ada_nodes (pretty_printer *, const char *,
+ int (*)(tree, cpp_operation));
+static void reset_ada_withs (void);
+static void dump_ada_withs (FILE *);
+static void dump_ads (const char *, void (*)(const char *),
+ int (*)(tree, cpp_operation));
+static char *to_ada_name (const char *, int *);
+
+#define LOCATION_COL(LOC) ((expand_location (LOC)).column)
+
+#define INDENT(SPACE) do { \
+ int i; for (i = 0; i<SPACE; i++) pp_space (buffer); } while (0)
+
+#define INDENT_INCR 3
+
+/* Given a cpp MACRO, compute the max length BUFFER_LEN of the macro, as well
+ as max length PARAM_LEN of arguments for fun_like macros, and also set
+ SUPPORTED to 0 if the macro cannot be mapped to an Ada construct. */
+
+static void
+macro_length (const cpp_macro *macro, int *supported, int *buffer_len,
+ int *param_len)
+{
+ int i;
+ unsigned j;
+
+ *supported = 1;
+ *buffer_len = 0;
+ *param_len = 0;
+
+ if (macro->fun_like)
+ {
+ param_len++;
+ for (i = 0; i < macro->paramc; i++)
+ {
+ cpp_hashnode *param = macro->params[i];
+
+ *param_len += NODE_LEN (param);
+
+ if (i + 1 < macro->paramc)
+ {
+ *param_len += 2; /* ", " */
+ }
+ else if (macro->variadic)
+ {
+ *supported = 0;
+ return;
+ }
+ }
+ *param_len += 2; /* ")\0" */
+ }
+
+ for (j = 0; j < macro->count; j++)
+ {
+ cpp_token *token = ¯o->exp.tokens[j];
+
+ if (token->flags & PREV_WHITE)
+ (*buffer_len)++;
+
+ if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
+ {
+ *supported = 0;
+ return;
+ }
+
+ if (token->type == CPP_MACRO_ARG)
+ *buffer_len +=
+ NODE_LEN (macro->params[token->val.macro_arg.arg_no - 1]);
+ else
+ /* Include enough extra space to handle e.g. special characters as
+ handled by handle_escape_character below. */
+ *buffer_len += (cpp_token_len (token) + 1) * 8;
+ }
+
+ (*buffer_len)++;
+}
+
+/* Dump all digits/hex chars from NUMBER to BUFFER.
+ Returns a pointer to the character after the last character written. */
+
+static unsigned char *
+dump_number (unsigned char *number, unsigned char *buffer)
+{
+ while (*number != '\0' && *number != 'U' && *number != 'u'
+ && *number != 'l' && *number != 'L')
+ *buffer++ = *number++;
+ return buffer;
+}
+
+/* Handle escape character C and convert into an Ada character into BUFFER.
+ Returns a pointer to the character after the last character written, or
+ NULL if the escape character isn't supported. */
+
+static unsigned char *
+handle_escape_character (unsigned char *buffer, char c)
+{
+ switch (c)
+ {
+ case '"':
+ *buffer++ = '"';
+ *buffer++ = '"';
+ break;
+
+ case 'n':
+ strcpy ((char *) buffer, "\" & ASCII.LF & \"");
+ buffer += 16;
+ break;
+
+ case 'r':
+ strcpy ((char *) buffer, "\" & ASCII.CR & \"");
+ buffer += 16;
+ break;
+
+ case 't':
+ strcpy ((char *) buffer, "\" & ASCII.HT & \"");
+ buffer += 16;
+ break;
+
+ default:
+ return NULL;
+ }
+
+ return buffer;
+}
+
+/* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when
+ possible. */
+
+static void
+print_ada_macros (pretty_printer *pp, cpp_hashnode **macros, int max_ada_macros)
+{
+ int j, num_macros = 0, prev_line = -1;
+
+ for (j = 0; j < max_ada_macros; j++)
+ {
+ cpp_hashnode *node = macros [j];
+ const cpp_macro *macro = node->value.macro;
+ unsigned i;
+ int supported = 1, prev_is_one = 0, buffer_len, param_len;
+ int is_string = 0, is_char = 0;
+ char *ada_name;
+ unsigned char *s, *params, *buffer, *buf_param, *char_one = NULL, *tmp;
+
+ macro_length (macro, &supported, &buffer_len, ¶m_len);
+ s = buffer = XALLOCAVEC (unsigned char, buffer_len);
+ params = buf_param = XALLOCAVEC (unsigned char, param_len);
+
+ if (supported)
+ {
+ if (macro->fun_like)
+ {
+ *buf_param++ = '(';
+ for (i = 0; i < macro->paramc; i++)
+ {
+ cpp_hashnode *param = macro->params[i];
+
+ memcpy (buf_param, NODE_NAME (param), NODE_LEN (param));
+ buf_param += NODE_LEN (param);
+
+ if (i + 1 < macro->paramc)
+ {
+ *buf_param++ = ',';
+ *buf_param++ = ' ';
+ }
+ else if (macro->variadic)
+ {
+ supported = 0;
+ break;
+ }
+ }
+ *buf_param++ = ')';
+ *buf_param = '\0';
+ }
+
+ for (i = 0; supported && i < macro->count; i++)
+ {
+ cpp_token *token = ¯o->exp.tokens[i];
+ int is_one = 0;
+
+ if (token->flags & PREV_WHITE)
+ *buffer++ = ' ';
+
+ if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
+ {
+ supported = 0;
+ break;
+ }
+
+ switch (token->type)
+ {
+ case CPP_MACRO_ARG:
+ {
+ cpp_hashnode *param =
+ macro->params[token->val.macro_arg.arg_no - 1];
+ memcpy (buffer, NODE_NAME (param), NODE_LEN (param));
+ buffer += NODE_LEN (param);
+ }
+ break;
+
+ case CPP_EQ_EQ: *buffer++ = '='; break;
+ case CPP_GREATER: *buffer++ = '>'; break;
+ case CPP_LESS: *buffer++ = '<'; break;
+ case CPP_PLUS: *buffer++ = '+'; break;
+ case CPP_MINUS: *buffer++ = '-'; break;
+ case CPP_MULT: *buffer++ = '*'; break;
+ case CPP_DIV: *buffer++ = '/'; break;
+ case CPP_COMMA: *buffer++ = ','; break;
+ case CPP_OPEN_SQUARE:
+ case CPP_OPEN_PAREN: *buffer++ = '('; break;
+ case CPP_CLOSE_SQUARE: /* fallthrough */
+ case CPP_CLOSE_PAREN: *buffer++ = ')'; break;
+ case CPP_DEREF: /* fallthrough */
+ case CPP_SCOPE: /* fallthrough */
+ case CPP_DOT: *buffer++ = '.'; break;
+
+ case CPP_EQ: *buffer++ = ':'; *buffer++ = '='; break;
+ case CPP_NOT_EQ: *buffer++ = '/'; *buffer++ = '='; break;
+ case CPP_GREATER_EQ: *buffer++ = '>'; *buffer++ = '='; break;
+ case CPP_LESS_EQ: *buffer++ = '<'; *buffer++ = '='; break;
+
+ case CPP_NOT:
+ *buffer++ = 'n'; *buffer++ = 'o'; *buffer++ = 't'; break;
+ case CPP_MOD:
+ *buffer++ = 'm'; *buffer++ = 'o'; *buffer++ = 'd'; break;
+ case CPP_AND:
+ *buffer++ = 'a'; *buffer++ = 'n'; *buffer++ = 'd'; break;
+ case CPP_OR:
+ *buffer++ = 'o'; *buffer++ = 'r'; break;
+ case CPP_XOR:
+ *buffer++ = 'x'; *buffer++ = 'o'; *buffer++ = 'r'; break;
+ case CPP_AND_AND:
+ strcpy ((char *) buffer, " and then ");
+ buffer += 10;
+ break;
+ case CPP_OR_OR:
+ strcpy ((char *) buffer, " or else ");
+ buffer += 9;
+ break;
+
+ case CPP_PADDING:
+ *buffer++ = ' ';
+ is_one = prev_is_one;
+ break;
+
+ case CPP_COMMENT: break;
+
+ case CPP_WSTRING:
+ case CPP_STRING16:
+ case CPP_STRING32:
+ case CPP_UTF8STRING:
+ case CPP_WCHAR:
+ case CPP_CHAR16:
+ case CPP_CHAR32:
+ case CPP_NAME:
+ if (!macro->fun_like)
+ supported = 0;
+ else
+ buffer = cpp_spell_token (parse_in, token, buffer, false);
+ break;
+
+ case CPP_STRING:
+ is_string = 1;
+ {
+ const unsigned char *s = token->val.str.text;
+
+ for (; *s; s++)
+ if (*s == '\\')
+ {
+ s++;
+ buffer = handle_escape_character (buffer, *s);
+ if (buffer == NULL)
+ {
+ supported = 0;
+ break;
+ }
+ }
+ else
+ *buffer++ = *s;
+ }
+ break;
+
+ case CPP_CHAR:
+ is_char = 1;
+ {
+ unsigned chars_seen;
+ int ignored;
+ cppchar_t c;
+
+ c = cpp_interpret_charconst (parse_in, token,
+ &chars_seen, &ignored);
+ if (c >= 32 && c <= 126)
+ {
+ *buffer++ = '\'';
+ *buffer++ = (char) c;
+ *buffer++ = '\'';
+ }
+ else
+ {
+ chars_seen = sprintf
+ ((char *) buffer, "Character'Val (%d)", (int) c);
+ buffer += chars_seen;
+ }
+ }
+ break;
+
+ case CPP_NUMBER:
+ tmp = cpp_token_as_text (parse_in, token);
+
+ switch (*tmp)
+ {
+ case '0':
+ switch (tmp[1])
+ {
+ case '\0':
+ case 'l':
+ case 'L':
+ case 'u':
+ case 'U':
+ *buffer++ = '0';
+ break;
+
+ case 'x':
+ case 'X':
+ *buffer++ = '1';
+ *buffer++ = '6';
+ *buffer++ = '#';
+ buffer = dump_number (tmp + 2, buffer);
+ *buffer++ = '#';
+ break;
+
+ case 'b':
+ case 'B':
+ *buffer++ = '2';
+ *buffer++ = '#';
+ buffer = dump_number (tmp + 2, buffer);
+ *buffer++ = '#';
+ break;
+
+ default:
+ *buffer++ = '8';
+ *buffer++ = '#';
+ buffer = dump_number (tmp + 1, buffer);
+ *buffer++ = '#';
+ break;
+ }
+ break;
+
+ case '1':
+ if (tmp[1] == '\0' || tmp[1] == 'l' || tmp[1] == 'u'
+ || tmp[1] == 'L' || tmp [1] == 'U')
+ {
+ is_one = 1;
+ char_one = buffer;
+ *buffer++ = '1';
+ }
+ else
+ buffer = dump_number (tmp, buffer);
+ break;
+
+ default:
+ buffer = dump_number (tmp, buffer);
+ break;
+ }
+ break;
+
+ case CPP_LSHIFT:
+ if (prev_is_one)
+ {
+ /* Replace "1 << N" by "2 ** N" */
+ *char_one = '2';
+ *buffer++ = '*';
+ *buffer++ = '*';
+ break;
+ }
+ /* fallthrough */
+
+ case CPP_RSHIFT:
+ case CPP_COMPL:
+ case CPP_QUERY:
+ case CPP_EOF:
+ case CPP_PLUS_EQ:
+ case CPP_MINUS_EQ:
+ case CPP_MULT_EQ:
+ case CPP_DIV_EQ:
+ case CPP_MOD_EQ:
+ case CPP_AND_EQ:
+ case CPP_OR_EQ:
+ case CPP_XOR_EQ:
+ case CPP_RSHIFT_EQ:
+ case CPP_LSHIFT_EQ:
+ case CPP_PRAGMA:
+ case CPP_PRAGMA_EOL:
+ case CPP_HASH:
+ case CPP_PASTE:
+ case CPP_OPEN_BRACE:
+ case CPP_CLOSE_BRACE:
+ case CPP_SEMICOLON:
+ case CPP_ELLIPSIS:
+ case CPP_PLUS_PLUS:
+ case CPP_MINUS_MINUS:
+ case CPP_DEREF_STAR:
+ case CPP_DOT_STAR:
+ case CPP_ATSIGN:
+ case CPP_HEADER_NAME:
+ case CPP_AT_NAME:
+ case CPP_OTHER:
+ case CPP_OBJC_STRING:
+ default:
+ if (!macro->fun_like)
+ supported = 0;
+ else
+ buffer = cpp_spell_token (parse_in, token, buffer, false);
+ break;
+ }
+
+ prev_is_one = is_one;
+ }
+
+ if (supported)
+ *buffer = '\0';
+ }
+
+ if (macro->fun_like && supported)
+ {
+ char *start = (char *) s;
+ int is_function = 0;
+
+ pp_string (pp, " -- arg-macro: ");
+
+ if (*start == '(' && buffer [-1] == ')')
+ {
+ start++;
+ buffer [-1] = '\0';
+ is_function = 1;
+ pp_string (pp, "function ");
+ }
+ else
+ {
+ pp_string (pp, "procedure ");
+ }
+
+ pp_string (pp, (const char *) NODE_NAME (node));
+ pp_space (pp);
+ pp_string (pp, (char *) params);
+ pp_newline (pp);
+ pp_string (pp, " -- ");
+
+ if (is_function)
+ {
+ pp_string (pp, "return ");
+ pp_string (pp, start);
+ pp_semicolon (pp);
+ }
+ else
+ pp_string (pp, start);
+
+ pp_newline (pp);
+ }
+ else if (supported)
+ {
+ expanded_location sloc = expand_location (macro->line);
+
+ if (sloc.line != prev_line + 1)
+ pp_newline (pp);
+
+ num_macros++;
+ prev_line = sloc.line;
+
+ pp_string (pp, " ");
+ ada_name = to_ada_name ((const char *) NODE_NAME (node), NULL);
+ pp_string (pp, ada_name);
+ free (ada_name);
+ pp_string (pp, " : ");
+
+ if (is_string)
+ pp_string (pp, "aliased constant String");
+ else if (is_char)
+ pp_string (pp, "aliased constant Character");
+ else
+ pp_string (pp, "constant");
+
+ pp_string (pp, " := ");
+ pp_string (pp, (char *) s);
+
+ if (is_string)
+ pp_string (pp, " & ASCII.NUL");
+
+ pp_string (pp, "; -- ");
+ pp_string (pp, sloc.file);
+ pp_character (pp, ':');
+ pp_scalar (pp, "%d", sloc.line);
+ pp_newline (pp);
+ }
+ else
+ {
+ pp_string (pp, " -- unsupported macro: ");
+ pp_string (pp, (const char *) cpp_macro_definition (parse_in, node));
+ pp_newline (pp);
+ }
+ }
+
+ if (num_macros > 0)
+ pp_newline (pp);
+}
+
+static const char *source_file;
+static int max_ada_macros;
+
+/* Callback used to count the number of relevant macros from
+ cpp_forall_identifiers. PFILE and V are not used. NODE is the current macro
+ to consider. */
+
+static int
+count_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *node,
+ void *v ATTRIBUTE_UNUSED)
+{
+ const cpp_macro *macro = node->value.macro;
+
+ if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)
+ && macro->count
+ && *NODE_NAME (node) != '_'
+ && LOCATION_FILE (macro->line) == source_file)
+ max_ada_macros++;
+
+ return 1;
+}
+
+static int store_ada_macro_index;
+
+/* Callback used to store relevant macros from cpp_forall_identifiers.
+ PFILE is not used. NODE is the current macro to store if relevant.
+ MACROS is an array of cpp_hashnode* used to store NODE. */
+
+static int
+store_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED,
+ cpp_hashnode *node, void *macros)
+{
+ const cpp_macro *macro = node->value.macro;
+
+ if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)
+ && macro->count
+ && *NODE_NAME (node) != '_'
+ && LOCATION_FILE (macro->line) == source_file)
+ ((cpp_hashnode **) macros)[store_ada_macro_index++] = node;
+
+ return 1;
+}
+
+/* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the
+ two macro nodes to compare. */
+
+static int
+compare_macro (const void *node1, const void *node2)
+{
+ typedef const cpp_hashnode *const_hnode;
+
+ const_hnode n1 = *(const const_hnode *) node1;
+ const_hnode n2 = *(const const_hnode *) node2;
+
+ return n1->value.macro->line - n2->value.macro->line;
+}
+
+/* Dump in PP all relevant macros appearing in FILE. */
+
+static void
+dump_ada_macros (pretty_printer *pp, const char* file)
+{
+ cpp_hashnode **macros;
+
+ /* Initialize file-scope variables. */
+ max_ada_macros = 0;
+ store_ada_macro_index = 0;
+ source_file = file;
+
+ /* Count all potentially relevant macros, and then sort them by sloc. */
+ cpp_forall_identifiers (parse_in, count_ada_macro, NULL);
+ macros = XALLOCAVEC (cpp_hashnode *, max_ada_macros);
+ cpp_forall_identifiers (parse_in, store_ada_macro, macros);
+ qsort (macros, max_ada_macros, sizeof (cpp_hashnode *), compare_macro);
+
+ print_ada_macros (pp, macros, max_ada_macros);
+}
+
+/* Current source file being handled. */
+
+static const char *source_file_base;
+
+/* Compare the declaration (DECL) of struct-like types based on the sloc of
+ their last field (if LAST is true), so that more nested types collate before
+ less nested ones.
+ If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE. */
+
+static location_t
+decl_sloc_common (const_tree decl, bool last, bool orig_type)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (TREE_CODE (decl) == TYPE_DECL
+ && (orig_type || !DECL_ORIGINAL_TYPE (decl))
+ && RECORD_OR_UNION_TYPE_P (type)
+ && TYPE_FIELDS (type))
+ {
+ tree f = TYPE_FIELDS (type);
+
+ if (last)
+ while (TREE_CHAIN (f))
+ f = TREE_CHAIN (f);
+
+ return DECL_SOURCE_LOCATION (f);
+ }
+ else
+ return DECL_SOURCE_LOCATION (decl);
+}
+
+/* Return sloc of DECL, using sloc of last field if LAST is true. */
+
+location_t
+decl_sloc (const_tree decl, bool last)
+{
+ return decl_sloc_common (decl, last, false);
+}
+
+/* Compare two declarations (LP and RP) by their source location. */
+
+static int
+compare_node (const void *lp, const void *rp)
+{
+ const_tree lhs = *((const tree *) lp);
+ const_tree rhs = *((const tree *) rp);
+
+ return decl_sloc (lhs, true) - decl_sloc (rhs, true);
+}
+
+/* Compare two comments (LP and RP) by their source location. */
+
+static int
+compare_comment (const void *lp, const void *rp)
+{
+ const cpp_comment *lhs = (const cpp_comment *) lp;
+ const cpp_comment *rhs = (const cpp_comment *) rp;
+
+ if (LOCATION_FILE (lhs->sloc) != LOCATION_FILE (rhs->sloc))
+ return strcmp (LOCATION_FILE (lhs->sloc), LOCATION_FILE (rhs->sloc));
+
+ if (LOCATION_LINE (lhs->sloc) != LOCATION_LINE (rhs->sloc))
+ return LOCATION_LINE (lhs->sloc) - LOCATION_LINE (rhs->sloc);
+
+ if (LOCATION_COL (lhs->sloc) != LOCATION_COL (rhs->sloc))
+ return LOCATION_COL (lhs->sloc) - LOCATION_COL (rhs->sloc);
+
+ return 0;
+}
+
+static tree *to_dump = NULL;
+static int to_dump_count = 0;
+
+/* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped
+ by a subsequent call to dump_ada_nodes. */
+
+void
+collect_ada_nodes (tree t, const char *source_file)
+{
+ tree n;
+ int i = to_dump_count;
+
+ /* Count the likely relevant nodes. */
+ for (n = t; n; n = TREE_CHAIN (n))
+ if (!DECL_IS_BUILTIN (n)
+ && LOCATION_FILE (decl_sloc (n, false)) == source_file)
+ to_dump_count++;
+
+ /* Allocate sufficient storage for all nodes. */
+ to_dump = (tree *) xrealloc (to_dump, sizeof (tree) * to_dump_count);
+
+ /* Store the relevant nodes. */
+ for (n = t; n; n = TREE_CHAIN (n))
+ if (!DECL_IS_BUILTIN (n)
+ && LOCATION_FILE (decl_sloc (n, false)) == source_file)
+ to_dump [i++] = n;
+}
+
+/* Call back for walk_tree to clear the TREE_VISITED flag of TP. */
+
+static tree
+unmark_visited_r (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ if (TREE_VISITED (*tp))
+ TREE_VISITED (*tp) = 0;
+ else
+ *walk_subtrees = 0;
+
+ return NULL_TREE;
+}
+
+/* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls
+ to collect_ada_nodes. CPP_CHECK is used to perform C++ queries on nodes. */
+
+static void
+dump_ada_nodes (pretty_printer *pp, const char *source_file,
+ int (*cpp_check)(tree, cpp_operation))
+{
+ int i, j;
+ cpp_comment_table *comments;
+
+ /* Sort the table of declarations to dump by sloc. */
+ qsort (to_dump, to_dump_count, sizeof (tree), compare_node);
+
+ /* Fetch the table of comments. */
+ comments = cpp_get_comments (parse_in);
+
+ /* Sort the comments table by sloc. */
+ qsort (comments->entries, comments->count, sizeof (cpp_comment),
+ compare_comment);
+
+ /* Interleave comments and declarations in line number order. */
+ i = j = 0;
+ do
+ {
+ /* Advance j until comment j is in this file. */
+ while (j != comments->count
+ && LOCATION_FILE (comments->entries[j].sloc) != source_file)
+ j++;
+
+ /* Advance j until comment j is not a duplicate. */
+ while (j < comments->count - 1
+ && !compare_comment (&comments->entries[j],
+ &comments->entries[j + 1]))
+ j++;
+
+ /* Write decls until decl i collates after comment j. */
+ while (i != to_dump_count)
+ {
+ if (j == comments->count
+ || LOCATION_LINE (decl_sloc (to_dump[i], false))
+ < LOCATION_LINE (comments->entries[j].sloc))
+ print_generic_ada_decl (pp, to_dump[i++], cpp_check, source_file);
+ else
+ break;
+ }
+
+ /* Write comment j, if there is one. */
+ if (j != comments->count)
+ print_comment (pp, comments->entries[j++].comment);
+
+ } while (i != to_dump_count || j != comments->count);
+
+ /* Clear the TREE_VISITED flag over each subtree we've dumped. */
+ for (i = 0; i < to_dump_count; i++)
+ walk_tree (&to_dump[i], unmark_visited_r, NULL, NULL);
+
+ /* Finalize the to_dump table. */
+ if (to_dump)
+ {
+ free (to_dump);
+ to_dump = NULL;
+ to_dump_count = 0;
+ }
+}
+
+/* Print a COMMENT to the output stream PP. */
+
+static void
+print_comment (pretty_printer *pp, const char *comment)
+{
+ int len = strlen (comment);
+ char *str = XALLOCAVEC (char, len + 1);
+ char *tok;
+ bool extra_newline = false;
+
+ memcpy (str, comment, len + 1);
+
+ /* Trim C/C++ comment indicators. */
+ if (str[len - 2] == '*' && str[len - 1] == '/')
+ {
+ str[len - 2] = ' ';
+ str[len - 1] = '\0';
+ }
+ str += 2;
+
+ tok = strtok (str, "\n");
+ while (tok) {
+ pp_string (pp, " --");
+ pp_string (pp, tok);
+ pp_newline (pp);
+ tok = strtok (NULL, "\n");
+
+ /* Leave a blank line after multi-line comments. */
+ if (tok)
+ extra_newline = true;
+ }
+
+ if (extra_newline)
+ pp_newline (pp);
+}
+
+/* Prints declaration DECL to PP in Ada syntax. The current source file being
+ handled is SOURCE_FILE, and CPP_CHECK is used to perform C++ queries on
+ nodes. */
+
+static void
+print_generic_ada_decl (pretty_printer *pp, tree decl,
+ int (*cpp_check)(tree, cpp_operation),
+ const char* source_file)
+{
+ source_file_base = source_file;
+
+ if (print_ada_declaration (pp, decl, 0, cpp_check, INDENT_INCR))
+ {
+ pp_newline (pp);
+ pp_newline (pp);
+ }
+}
+
+/* Dump a newline and indent BUFFER by SPC chars. */
+
+static void
+newline_and_indent (pretty_printer *buffer, int spc)
+{
+ pp_newline (buffer);
+ INDENT (spc);
+}
+
+struct with { char *s; const char *in_file; int limited; };
+static struct with *withs = NULL;
+static int withs_max = 4096;
+static int with_len = 0;
+
+/* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is
+ true), if not already done. */
+
+static void
+append_withs (const char *s, int limited_access)
+{
+ int i;
+
+ if (withs == NULL)
+ withs = (struct with *) xmalloc (withs_max * sizeof (struct with));
+
+ if (with_len == withs_max)
+ {
+ withs_max *= 2;
+ withs = (struct with *)
+ xrealloc (withs, withs_max * sizeof (struct with));
+ }
+
+ for (i = 0; i < with_len; i++)
+ if (!strcmp (s, withs [i].s)
+ && source_file_base == withs [i].in_file)
+ {
+ withs [i].limited &= limited_access;
+ return;
+ }
+
+ withs [with_len].s = xstrdup (s);
+ withs [with_len].in_file = source_file_base;
+ withs [with_len].limited = limited_access;
+ with_len++;
+}
+
+/* Reset "with" clauses. */
+
+static void
+reset_ada_withs (void)
+{
+ int i;
+
+ if (!withs)
+ return;
+
+ for (i = 0; i < with_len; i++)
+ free (withs [i].s);
+ free (withs);
+ withs = NULL;
+ withs_max = 4096;
+ with_len = 0;
+}
+
+/* Dump "with" clauses in F. */
+
+static void
+dump_ada_withs (FILE *f)
+{
+ int i;
+
+ fprintf (f, "with Interfaces.C; use Interfaces.C;\n");
+
+ for (i = 0; i < with_len; i++)
+ fprintf
+ (f, "%swith %s;\n", withs [i].limited ? "limited " : "", withs [i].s);
+}
+
+/* Return suitable Ada package name from FILE. */
+
+static char *
+get_ada_package (const char *file)
+{
+ const char *base;
+ char *res;
+ const char *s;
+ int i;
+
+ s = strstr (file, "/include/");
+ if (s)
+ base = s + 9;
+ else
+ base = lbasename (file);
+ res = (char *) xmalloc (strlen (base) + 1);
+
+ for (i = 0; *base; base++, i++)
+ switch (*base)
+ {
+ case '+':
+ res [i] = 'p';
+ break;
+
+ case '.':
+ case '-':
+ case '_':
+ case '/':
+ case '\\':
+ res [i] = (i == 0 || res [i - 1] == '_') ? 'u' : '_';
+ break;
+
+ default:
+ res [i] = *base;
+ break;
+ }
+ res [i] = '\0';
+
+ return res;
+}
+
+static const char *ada_reserved[] = {
+ "abort", "abs", "abstract", "accept", "access", "aliased", "all", "and",
+ "array", "at", "begin", "body", "case", "constant", "declare", "delay",
+ "delta", "digits", "do", "else", "elsif", "end", "entry", "exception",
+ "exit", "for", "function", "generic", "goto", "if", "in", "interface", "is",
+ "limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or",
+ "overriding", "package", "pragma", "private", "procedure", "protected",
+ "raise", "range", "record", "rem", "renames", "requeue", "return", "reverse",
+ "select", "separate", "subtype", "synchronized", "tagged", "task",
+ "terminate", "then", "type", "until", "use", "when", "while", "with", "xor",
+ NULL};
+
+/* ??? would be nice to specify this list via a config file, so that users
+ can create their own dictionnary of conflicts. */
+static const char *c_duplicates[] = {
+ /* system will cause troubles with System.Address. */
+ "system",
+
+ /* The following values have other definitions with same name/other
+ casing. */
+ "funmap",
+ "rl_vi_fWord",
+ "rl_vi_bWord",
+ "rl_vi_eWord",
+ "rl_readline_version",
+ "_Vx_ushort",
+ "USHORT",
+ "XLookupKeysym",
+ NULL};
+
+/* Return a declaration tree corresponding to TYPE. */
+
+static tree
+get_underlying_decl (tree type)
+{
+ tree decl = NULL_TREE;
+
+ if (type == NULL_TREE)
+ return NULL_TREE;
+
+ /* type is a declaration. */
+ if (DECL_P (type))
+ decl = type;
+
+ /* type is a typedef. */
+ if (TYPE_P (type) && TYPE_NAME (type) && DECL_P (TYPE_NAME (type)))
+ decl = TYPE_NAME (type);
+
+ /* TYPE_STUB_DECL has been set for type. */
+ if (TYPE_P (type) && TYPE_STUB_DECL (type) &&
+ DECL_P (TYPE_STUB_DECL (type)))
+ decl = TYPE_STUB_DECL (type);
+
+ return decl;
+}
+
+/* Return whether TYPE has static fields. */
+
+static int
+has_static_fields (const_tree type)
+{
+ tree tmp;
+
+ for (tmp = TYPE_FIELDS (type); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (DECL_NAME (tmp) && TREE_STATIC (tmp))
+ return true;
+ }
+ return false;
+}
+
+/* Return whether TYPE corresponds to an Ada tagged type (has a dispatch
+ table). */
+
+static int
+is_tagged_type (const_tree type)
+{
+ tree tmp;
+
+ if (!type || !RECORD_OR_UNION_TYPE_P (type))
+ return false;
+
+ for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp))
+ if (DECL_VINDEX (tmp))
+ return true;
+
+ return false;
+}
+
+/* Generate a legal Ada name from a C NAME, returning a malloc'd string.
+ SPACE_FOUND, if not NULL, is used to indicate whether a space was found in
+ NAME. */
+
+static char *
+to_ada_name (const char *name, int *space_found)
+{
+ const char **names;
+ int len = strlen (name);
+ int j, len2 = 0;
+ int found = false;
+ char *s = (char *) xmalloc (len * 2 + 5);
+ char c;
+
+ if (space_found)
+ *space_found = false;
+
+ /* Add trailing "c_" if name is an Ada reserved word. */
+ for (names = ada_reserved; *names; names++)
+ if (!strcasecmp (name, *names))
+ {
+ s [len2++] = 'c';
+ s [len2++] = '_';
+ found = true;
+ break;
+ }
+
+ if (!found)
+ /* Add trailing "c_" if name is an potential case sensitive duplicate. */
+ for (names = c_duplicates; *names; names++)
+ if (!strcmp (name, *names))
+ {
+ s [len2++] = 'c';
+ s [len2++] = '_';
+ found = true;
+ break;
+ }
+
+ for (j = 0; name [j] == '_'; j++)
+ s [len2++] = 'u';
+
+ if (j > 0)
+ s [len2++] = '_';
+ else if (*name == '.' || *name == '$')
+ {
+ s [0] = 'a';
+ s [1] = 'n';
+ s [2] = 'o';
+ s [3] = 'n';
+ len2 = 4;
+ j++;
+ }
+
+ /* Replace unsuitable characters for Ada identifiers. */
+
+ for (; j < len; j++)
+ switch (name [j])
+ {
+ case ' ':
+ if (space_found)
+ *space_found = true;
+ s [len2++] = '_';
+ break;
+
+ /* ??? missing some C++ operators. */
+ case '=':
+ s [len2++] = '_';
+
+ if (name [j + 1] == '=')
+ {
+ j++;
+ s [len2++] = 'e';
+ s [len2++] = 'q';
+ }
+ else
+ {
+ s [len2++] = 'a';
+ s [len2++] = 's';
+ }
+ break;
+
+ case '!':
+ s [len2++] = '_';
+ if (name [j + 1] == '=')
+ {
+ j++;
+ s [len2++] = 'n';
+ s [len2++] = 'e';
+ }
+ break;
+
+ case '~':
+ s [len2++] = '_';
+ s [len2++] = 't';
+ s [len2++] = 'i';
+ break;
+
+ case '&':
+ case '|':
+ case '^':
+ s [len2++] = '_';
+ s [len2++] = name [j] == '&' ? 'a' : name [j] == '|' ? 'o' : 'x';
+
+ if (name [j + 1] == '=')
+ {
+ j++;
+ s [len2++] = 'e';
+ }
+ break;
+
+ case '+':
+ case '-':
+ case '*':
+ case '/':
+ case '(':
+ case '[':
+ if (s [len2 - 1] != '_')
+ s [len2++] = '_';
+
+ switch (name [j + 1]) {
+ case '\0':
+ j++;
+ switch (name [j - 1]) {
+ case '+': s [len2++] = 'p'; break; /* + */
+ case '-': s [len2++] = 'm'; break; /* - */
+ case '*': s [len2++] = 't'; break; /* * */
+ case '/': s [len2++] = 'd'; break; /* / */
+ }
+ break;
+
+ case '=':
+ j++;
+ switch (name [j - 1]) {
+ case '+': s [len2++] = 'p'; break; /* += */
+ case '-': s [len2++] = 'm'; break; /* -= */
+ case '*': s [len2++] = 't'; break; /* *= */
+ case '/': s [len2++] = 'd'; break; /* /= */
+ }
+ s [len2++] = 'a';
+ break;
+
+ case '-': /* -- */
+ j++;
+ s [len2++] = 'm';
+ s [len2++] = 'm';
+ break;
+
+ case '+': /* ++ */
+ j++;
+ s [len2++] = 'p';
+ s [len2++] = 'p';
+ break;
+
+ case ')': /* () */
+ j++;
+ s [len2++] = 'o';
+ s [len2++] = 'p';
+ break;
+
+ case ']': /* [] */
+ j++;
+ s [len2++] = 'o';
+ s [len2++] = 'b';
+ break;
+ }
+
+ break;
+
+ case '<':
+ case '>':
+ c = name [j] == '<' ? 'l' : 'g';
+ s [len2++] = '_';
+
+ switch (name [j + 1]) {
+ case '\0':
+ s [len2++] = c;
+ s [len2++] = 't';
+ break;
+ case '=':
+ j++;
+ s [len2++] = c;
+ s [len2++] = 'e';
+ break;
+ case '>':
+ j++;
+ s [len2++] = 's';
+ s [len2++] = 'r';
+ break;
+ case '<':
+ j++;
+ s [len2++] = 's';
+ s [len2++] = 'l';
+ break;
+ default:
+ break;
+ }
+ break;
+
+ case '_':
+ if (len2 && s [len2 - 1] == '_')
+ s [len2++] = 'u';
+ /* fall through */
+
+ default:
+ s [len2++] = name [j];
+ }
+
+ if (s [len2 - 1] == '_')
+ s [len2++] = 'u';
+
+ s [len2] = '\0';
+
+ return s;
+}
+
+static bool package_prefix = true;
+
+/* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada
+ syntax. LIMITED_ACCESS indicates whether NODE can be accessed via a limited
+ 'with' clause rather than a regular 'with' clause. */
+
+static void
+pp_ada_tree_identifier (pretty_printer *buffer, tree node, tree type,
+ int limited_access)
+{
+ const char *name = IDENTIFIER_POINTER (node);
+ int space_found = false;
+ char *s = to_ada_name (name, &space_found);
+ tree decl;
+
+ /* If the entity is a type and comes from another file, generate "package"
+ prefix. */
+
+ decl = get_underlying_decl (type);
+
+ if (decl)
+ {
+ expanded_location xloc = expand_location (decl_sloc (decl, false));
+
+ if (xloc.file && xloc.line)
+ {
+ if (xloc.file != source_file_base)
+ {
+ switch (TREE_CODE (type))
+ {
+ case ENUMERAL_TYPE:
+ case INTEGER_TYPE:
+ case REAL_TYPE:
+ case FIXED_POINT_TYPE:
+ case BOOLEAN_TYPE:
+ case REFERENCE_TYPE:
+ case POINTER_TYPE:
+ case ARRAY_TYPE:
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ case TYPE_DECL:
+ {
+ char *s1 = get_ada_package (xloc.file);
+
+ if (package_prefix)
+ {
+ append_withs (s1, limited_access);
+ pp_string (buffer, s1);
+ pp_character (buffer, '.');
+ }
+ free (s1);
+ }
+ break;
+ default:
+ break;
+ }
+ }
+ }
+ }
+
+ if (space_found)
+ if (!strcmp (s, "short_int"))
+ pp_string (buffer, "short");
+ else if (!strcmp (s, "short_unsigned_int"))
+ pp_string (buffer, "unsigned_short");
+ else if (!strcmp (s, "unsigned_int"))
+ pp_string (buffer, "unsigned");
+ else if (!strcmp (s, "long_int"))
+ pp_string (buffer, "long");
+ else if (!strcmp (s, "long_unsigned_int"))
+ pp_string (buffer, "unsigned_long");
+ else if (!strcmp (s, "long_long_int"))
+ pp_string (buffer, "Long_Long_Integer");
+ else if (!strcmp (s, "long_long_unsigned_int"))
+ {
+ if (package_prefix)
+ {
+ append_withs ("Interfaces.C.Extensions", false);
+ pp_string (buffer, "Extensions.unsigned_long_long");
+ }
+ else
+ pp_string (buffer, "unsigned_long_long");
+ }
+ else
+ pp_string(buffer, s);
+ else
+ if (!strcmp (s, "bool"))
+ {
+ if (package_prefix)
+ {
+ append_withs ("Interfaces.C.Extensions", false);
+ pp_string (buffer, "Extensions.bool");
+ }
+ else
+ pp_string (buffer, "bool");
+ }
+ else
+ pp_string(buffer, s);
+
+ free (s);
+}
+
+/* Dump in BUFFER the assembly name of T. */
+
+static void
+pp_asm_name (pretty_printer *buffer, tree t)
+{
+ tree name = DECL_ASSEMBLER_NAME (t);
+ char *ada_name = XALLOCAVEC (char, IDENTIFIER_LENGTH (name) + 1), *s;
+ const char *ident = IDENTIFIER_POINTER (name);
+
+ for (s = ada_name; *ident; ident++)
+ {
+ if (*ident == ' ')
+ break;
+ else if (*ident != '*')
+ *s++ = *ident;
+ }
+
+ *s = '\0';
+ pp_string (buffer, ada_name);
+}
+
+/* Dump in BUFFER the name of a DECL node if set, following Ada syntax.
+ LIMITED_ACCESS indicates whether NODE can be accessed via a limited
+ 'with' clause rather than a regular 'with' clause. */
+
+static void
+dump_ada_decl_name (pretty_printer *buffer, tree decl, int limited_access)
+{
+ if (DECL_NAME (decl))
+ pp_ada_tree_identifier (buffer, DECL_NAME (decl), decl, limited_access);
+ else
+ {
+ tree type_name = TYPE_NAME (TREE_TYPE (decl));
+
+ if (!type_name)
+ {
+ pp_string (buffer, "anon");
+ if (TREE_CODE (decl) == FIELD_DECL)
+ pp_scalar (buffer, "%d", DECL_UID (decl));
+ else
+ pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (decl)));
+ }
+ else if (TREE_CODE (type_name) == IDENTIFIER_NODE)
+ pp_ada_tree_identifier (buffer, type_name, decl, limited_access);
+ }
+}
+
+/* Dump in BUFFER a name based on both T1 and T2, followed by S. */
+
+static void
+dump_ada_double_name (pretty_printer *buffer, tree t1, tree t2, const char *s)
+{
+ if (DECL_NAME (t1))
+ pp_ada_tree_identifier (buffer, DECL_NAME (t1), t1, false);
+ else
+ {
+ pp_string (buffer, "anon");
+ pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t1)));
+ }
+
+ pp_character (buffer, '_');
+
+ if (DECL_NAME (t1))
+ pp_ada_tree_identifier (buffer, DECL_NAME (t2), t2, false);
+ else
+ {
+ pp_string (buffer, "anon");
+ pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t2)));
+ }
+
+ pp_string (buffer, s);
+}
+
+/* Dump in BUFFER pragma Import C/CPP on a given node T. */
+
+static void
+dump_ada_import (pretty_printer *buffer, tree t)
+{
+ const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t));
+ int is_stdcall = TREE_CODE (t) == FUNCTION_DECL &&
+ lookup_attribute ("stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t)));
+
+ if (is_stdcall)
+ pp_string (buffer, "pragma Import (Stdcall, ");
+ else if (name [0] == '_' && name [1] == 'Z')
+ pp_string (buffer, "pragma Import (CPP, ");
+ else
+ pp_string (buffer, "pragma Import (C, ");
+
+ dump_ada_decl_name (buffer, t, false);
+ pp_string (buffer, ", \"");
+
+ if (is_stdcall)
+ pp_string (buffer, IDENTIFIER_POINTER (DECL_NAME (t)));
+ else
+ pp_asm_name (buffer, t);
+
+ pp_string (buffer, "\");");
+}
+
+/* Check whether T and its type have different names, and append "the_"
+ otherwise in BUFFER. */
+
+static void
+check_name (pretty_printer *buffer, tree t)
+{
+ const char *s;
+ tree tmp = TREE_TYPE (t);
+
+ while (TREE_CODE (tmp) == POINTER_TYPE && !TYPE_NAME (tmp))
+ tmp = TREE_TYPE (tmp);
+
+ if (TREE_CODE (tmp) != FUNCTION_TYPE)
+ {
+ if (TREE_CODE (tmp) == IDENTIFIER_NODE)
+ s = IDENTIFIER_POINTER (tmp);
+ else if (!TYPE_NAME (tmp))
+ s = "";
+ else if (TREE_CODE (TYPE_NAME (tmp)) == IDENTIFIER_NODE)
+ s = IDENTIFIER_POINTER (TYPE_NAME (tmp));
+ else
+ s = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp)));
+
+ if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t)), s))
+ pp_string (buffer, "the_");
+ }
+}
+
+/* Dump in BUFFER a function declaration FUNC with Ada syntax.
+ IS_METHOD indicates whether FUNC is a C++ method.
+ IS_CONSTRUCTOR whether FUNC is a C++ constructor.
+ IS_DESTRUCTOR whether FUNC is a C++ destructor.
+ SPC is the current indentation level. */
+
+static int
+dump_ada_function_declaration (pretty_printer *buffer, tree func,
+ int is_method, int is_constructor,
+ int is_destructor, int spc)
+{
+ tree arg;
+ const tree node = TREE_TYPE (func);
+ char buf [16];
+ int num = 0, num_args = 0, have_args = true, have_ellipsis = false;
+
+ /* Compute number of arguments. */
+ arg = TYPE_ARG_TYPES (node);
+
+ if (arg)
+ {
+ while (TREE_CHAIN (arg) && arg != error_mark_node)
+ {
+ num_args++;
+ arg = TREE_CHAIN (arg);
+ }
+
+ if (TREE_CODE (TREE_VALUE (arg)) != VOID_TYPE)
+ {
+ num_args++;
+ have_ellipsis = true;
+ }
+ }
+
+ if (is_constructor)
+ num_args--;
+
+ if (is_destructor)
+ num_args = 1;
+
+ if (num_args > 2)
+ newline_and_indent (buffer, spc + 1);
+
+ if (num_args > 0)
+ {
+ pp_space (buffer);
+ pp_character (buffer, '(');
+ }
+
+ if (TREE_CODE (func) == FUNCTION_DECL)
+ arg = DECL_ARGUMENTS (func);
+ else
+ arg = NULL_TREE;
+
+ if (arg == NULL_TREE)
+ {
+ have_args = false;
+ arg = TYPE_ARG_TYPES (node);
+
+ if (arg && TREE_CODE (TREE_VALUE (arg)) == VOID_TYPE)
+ arg = NULL_TREE;
+ }
+
+ if (is_constructor)
+ arg = TREE_CHAIN (arg);
+
+ /* Print the argument names (if available) & types. */
+
+ for (num = 1; num <= num_args; num++)
+ {
+ if (have_args)
+ {
+ if (DECL_NAME (arg))
+ {
+ check_name (buffer, arg);
+ pp_ada_tree_identifier (buffer, DECL_NAME (arg), 0, false);
+ pp_string (buffer, " : ");
+ }
+ else
+ {
+ sprintf (buf, "arg%d : ", num);
+ pp_string (buffer, buf);
+ }
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (arg), node, NULL, spc, 0, true);
+ }
+ else
+ {
+ sprintf (buf, "arg%d : ", num);
+ pp_string (buffer, buf);
+ dump_generic_ada_node
+ (buffer, TREE_VALUE (arg), node, NULL, spc, 0, true);
+ }
+
+ if (TREE_TYPE (arg) && TREE_TYPE (TREE_TYPE (arg))
+ && is_tagged_type (TREE_TYPE (TREE_TYPE (arg))))
+ {
+ if (!is_method
+ || (num != 1 || (!DECL_VINDEX (func) && !is_constructor)))
+ pp_string (buffer, "'Class");
+ }
+
+ arg = TREE_CHAIN (arg);
+
+ if (num < num_args)
+ {
+ pp_character (buffer, ';');
+
+ if (num_args > 2)
+ newline_and_indent (buffer, spc + INDENT_INCR);
+ else
+ pp_space (buffer);
+ }
+ }
+
+ if (have_ellipsis)
+ {
+ pp_string (buffer, " -- , ...");
+ newline_and_indent (buffer, spc + INDENT_INCR);
+ }
+
+ if (num_args > 0)
+ pp_character (buffer, ')');
+ return num_args;
+}
+
+/* Dump in BUFFER all the domains associated with an array NODE,
+ using Ada syntax. SPC is the current indentation level. */
+
+static void
+dump_ada_array_domains (pretty_printer *buffer, tree node, int spc)
+{
+ int first = 1;
+ pp_character (buffer, '(');
+
+ for (; TREE_CODE (node) == ARRAY_TYPE; node = TREE_TYPE (node))
+ {
+ tree domain = TYPE_DOMAIN (node);
+
+ if (domain)
+ {
+ tree min = TYPE_MIN_VALUE (domain);
+ tree max = TYPE_MAX_VALUE (domain);
+
+ if (!first)
+ pp_string (buffer, ", ");
+ first = 0;
+
+ if (min)
+ dump_generic_ada_node (buffer, min, NULL_TREE, NULL, spc, 0, true);
+ pp_string (buffer, " .. ");
+
+ /* If the upper bound is zero, gcc may generate a NULL_TREE
+ for TYPE_MAX_VALUE rather than an integer_cst. */
+ if (max)
+ dump_generic_ada_node (buffer, max, NULL_TREE, NULL, spc, 0, true);
+ else
+ pp_string (buffer, "0");
+ }
+ else
+ pp_string (buffer, "size_t");
+ }
+ pp_character (buffer, ')');
+}
+
+/* Dump in BUFFER file:line:col information related to NODE. */
+
+static void
+dump_sloc (pretty_printer *buffer, tree node)
+{
+ expanded_location xloc;
+
+ xloc.file = NULL;
+
+ if (TREE_CODE_CLASS (TREE_CODE (node)) == tcc_declaration)
+ xloc = expand_location (DECL_SOURCE_LOCATION (node));
+ else if (EXPR_HAS_LOCATION (node))
+ xloc = expand_location (EXPR_LOCATION (node));
+
+ if (xloc.file)
+ {
+ pp_string (buffer, xloc.file);
+ pp_string (buffer, ":");
+ pp_decimal_int (buffer, xloc.line);
+ pp_string (buffer, ":");
+ pp_decimal_int (buffer, xloc.column);
+ }
+}
+
+/* Return true if T designates a one dimension array of "char". */
+
+static bool
+is_char_array (tree t)
+{
+ tree tmp;
+ int num_dim = 0;
+
+ /* Retrieve array's type. */
+ tmp = t;
+ while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ {
+ num_dim++;
+ tmp = TREE_TYPE (tmp);
+ }
+
+ tmp = TREE_TYPE (tmp);
+ return num_dim == 1 && TREE_CODE (tmp) == INTEGER_TYPE
+ && !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp))), "char");
+}
+
+/* Dump in BUFFER an array type T in Ada syntax. Assume that the "type"
+ keyword and name have already been printed. SPC is the indentation
+ level. */
+
+static void
+dump_ada_array_type (pretty_printer *buffer, tree t, int spc)
+{
+ tree tmp;
+ bool char_array = is_char_array (t);
+
+ /* Special case char arrays. */
+ if (char_array)
+ {
+ pp_string (buffer, "Interfaces.C.char_array ");
+ }
+ else
+ pp_string (buffer, "array ");
+
+ /* Print the dimensions. */
+ dump_ada_array_domains (buffer, TREE_TYPE (t), spc);
+
+ /* Retrieve array's type. */
+ tmp = TREE_TYPE (t);
+ while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ tmp = TREE_TYPE (tmp);
+
+ /* Print array's type. */
+ if (!char_array)
+ {
+ pp_string (buffer, " of ");
+
+ if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE)
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (tmp), TREE_TYPE (t), NULL, spc, false, true);
+ }
+}
+
+/* Dump in BUFFER type names associated with a template, each prepended with
+ '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS.
+ CPP_CHECK is used to perform C++ queries on nodes.
+ SPC is the indentation level. */
+
+static void
+dump_template_types (pretty_printer *buffer, tree types,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ size_t i;
+ size_t len = TREE_VEC_LENGTH (types);
+
+ for (i = 0; i < len; i++)
+ {
+ tree elem = TREE_VEC_ELT (types, i);
+ pp_character (buffer, '_');
+ if (!dump_generic_ada_node (buffer, elem, 0, cpp_check, spc, false, true))
+ {
+ pp_string (buffer, "unknown");
+ pp_scalar (buffer, "%lu", (unsigned long) TREE_HASH (elem));
+ }
+ }
+}
+
+/* Dump in BUFFER the contents of all instantiations associated with a given
+ template T. CPP_CHECK is used to perform C++ queries on nodes.
+ SPC is the indentation level. */
+
+static int
+dump_ada_template (pretty_printer *buffer, tree t,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ tree inst = DECL_VINDEX (t);
+ /* DECL_VINDEX is DECL_TEMPLATE_INSTANTIATIONS in this context. */
+ int num_inst = 0;
+
+ while (inst && inst != error_mark_node)
+ {
+ tree types = TREE_PURPOSE (inst);
+ tree instance = TREE_VALUE (inst);
+
+ if (TREE_VEC_LENGTH (types) == 0)
+ break;
+
+ if (!TYPE_METHODS (instance))
+ break;
+
+ num_inst++;
+ INDENT (spc);
+ pp_string (buffer, "package ");
+ package_prefix = false;
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true);
+ dump_template_types (buffer, types, cpp_check, spc);
+ pp_string (buffer, " is");
+ spc += INDENT_INCR;
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "type ");
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true);
+ package_prefix = true;
+
+ if (is_tagged_type (instance))
+ pp_string (buffer, " is tagged limited ");
+ else
+ pp_string (buffer, " is limited ");
+
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, false);
+ pp_newline (buffer);
+ spc -= INDENT_INCR;
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "end;");
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "use ");
+ package_prefix = false;
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true);
+ dump_template_types (buffer, types, cpp_check, spc);
+ package_prefix = true;
+ pp_semicolon (buffer);
+ pp_newline (buffer);
+ pp_newline (buffer);
+
+ inst = TREE_CHAIN (inst);
+ }
+
+ return num_inst > 0;
+}
+
+static bool in_function = true;
+static bool bitfield_used = false;
+
+/* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
+ TYPE. CPP_CHECK is used to perform C++ queries on nodes. SPC is the
+ indentation level. LIMITED_ACCESS indicates whether NODE can be referenced
+ via a "limited with" clause. NAME_ONLY indicates whether we should only
+ dump the name of NODE, instead of its full declaration. */
+
+static int
+dump_generic_ada_node (pretty_printer *buffer, tree node, tree type,
+ int (*cpp_check)(tree, cpp_operation), int spc,
+ int limited_access, bool name_only)
+{
+ if (node == NULL_TREE)
+ return 0;
+
+ switch (TREE_CODE (node))
+ {
+ case ERROR_MARK:
+ pp_string (buffer, "<<< error >>>");
+ return 0;
+
+ case IDENTIFIER_NODE:
+ pp_ada_tree_identifier (buffer, node, type, limited_access);
+ break;
+
+ case TREE_LIST:
+ pp_string (buffer, "--- unexpected node: TREE_LIST");
+ return 0;
+
+ case TREE_BINFO:
+ dump_generic_ada_node
+ (buffer, BINFO_TYPE (node), type, cpp_check,
+ spc, limited_access, name_only);
+
+ case TREE_VEC:
+ pp_string (buffer, "--- unexpected node: TREE_VEC");
+ return 0;
+
+ case VOID_TYPE:
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ break;
+
+ case VECTOR_TYPE:
+ pp_string (buffer, "<vector>");
+ break;
+
+ case COMPLEX_TYPE:
+ pp_string (buffer, "<complex>");
+ break;
+
+ case ENUMERAL_TYPE:
+ if (name_only)
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check, spc, 0, true);
+ else
+ {
+ tree value;
+
+ pp_string (buffer, "unsigned");
+
+ for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
+ {
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+
+ pp_ada_tree_identifier
+ (buffer, TREE_PURPOSE (value), node, false);
+ pp_string (buffer, " : constant ");
+
+ dump_generic_ada_node
+ (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
+ cpp_check, spc, 0, true);
+
+ pp_string (buffer, " := ");
+ dump_generic_ada_node
+ (buffer,
+ TREE_CODE (TREE_VALUE (value)) == INTEGER_CST ?
+ TREE_VALUE (value) : DECL_INITIAL (TREE_VALUE (value)),
+ node,
+ cpp_check, spc, false, true);
+ }
+ }
+ break;
+
+ case INTEGER_TYPE:
+ case REAL_TYPE:
+ case FIXED_POINT_TYPE:
+ case BOOLEAN_TYPE:
+ {
+ enum tree_code_class tclass;
+
+ tclass = TREE_CODE_CLASS (TREE_CODE (node));
+
+ if (tclass == tcc_declaration)
+ {
+ if (DECL_NAME (node))
+ pp_ada_tree_identifier
+ (buffer, DECL_NAME (node), 0, limited_access);
+ else
+ pp_string (buffer, "<unnamed type decl>");
+ }
+ else if (tclass == tcc_type)
+ {
+ if (TYPE_NAME (node))
+ {
+ if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE)
+ pp_ada_tree_identifier (buffer, TYPE_NAME (node),
+ node, limited_access);
+ else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (node)))
+ dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access);
+ else
+ pp_string (buffer, "<unnamed type>");
+ }
+ else if (TREE_CODE (node) == INTEGER_TYPE)
+ {
+ append_withs ("Interfaces.C.Extensions", false);
+ bitfield_used = true;
+
+ if (TYPE_PRECISION (node) == 1)
+ pp_string (buffer, "Extensions.Unsigned_1");
+ else
+ {
+ pp_string (buffer, (TYPE_UNSIGNED (node)
+ ? "Extensions.Unsigned_"
+ : "Extensions.Signed_"));
+ pp_decimal_int (buffer, TYPE_PRECISION (node));
+ }
+ }
+ else
+ pp_string (buffer, "<unnamed type>");
+ }
+ break;
+ }
+
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE)
+ {
+ tree fnode = TREE_TYPE (node);
+ bool is_function;
+ bool prev_in_function = in_function;
+
+ if (VOID_TYPE_P (TREE_TYPE (fnode)))
+ {
+ is_function = false;
+ pp_string (buffer, "access procedure");
+ }
+ else
+ {
+ is_function = true;
+ pp_string (buffer, "access function");
+ }
+
+ in_function = is_function;
+ dump_ada_function_declaration
+ (buffer, node, false, false, false, spc + INDENT_INCR);
+ in_function = prev_in_function;
+
+ if (is_function)
+ {
+ pp_string (buffer, " return ");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (fnode), type, cpp_check, spc, 0, true);
+ }
+ }
+ else
+ {
+ int is_access = false;
+ unsigned int quals = TYPE_QUALS (TREE_TYPE (node));
+
+ if (name_only && TYPE_NAME (node))
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check,
+ spc, limited_access, true);
+ else if (VOID_TYPE_P (TREE_TYPE (node)))
+ {
+ if (!name_only)
+ pp_string (buffer, "new ");
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ }
+ else
+ {
+ if (TREE_CODE (node) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (node)) == INTEGER_TYPE
+ && !strcmp
+ (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
+ (TREE_TYPE (node)))), "char"))
+ {
+ if (!name_only)
+ pp_string (buffer, "new ");
+
+ if (package_prefix)
+ {
+ pp_string (buffer, "Interfaces.C.Strings.chars_ptr");
+ append_withs ("Interfaces.C.Strings", false);
+ }
+ else
+ pp_string (buffer, "chars_ptr");
+ }
+ else
+ {
+ /* For now, handle all access-to-access or
+ access-to-unknown-structs as opaque system.address. */
+
+ tree typ = TYPE_NAME (TREE_TYPE (node));
+ const_tree typ2 = !type ||
+ DECL_P (type) ? type : TYPE_NAME (type);
+ const_tree underlying_type =
+ get_underlying_decl (TREE_TYPE (node));
+
+ if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE
+ /* Pointer to pointer. */
+
+ || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
+ && (!underlying_type
+ || !TYPE_FIELDS (TREE_TYPE (underlying_type))))
+ /* Pointer to opaque structure. */
+
+ || (typ && typ2
+ && DECL_P (underlying_type)
+ && DECL_P (typ2)
+ && decl_sloc (underlying_type, true)
+ > decl_sloc (typ2, true)
+ && DECL_SOURCE_FILE (underlying_type)
+ == DECL_SOURCE_FILE (typ2)))
+ {
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ if (!name_only)
+ pp_string (buffer, "new ");
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ return spc;
+ }
+
+ if (!package_prefix)
+ pp_string (buffer, "access");
+ else if (AGGREGATE_TYPE_P (TREE_TYPE (node)))
+ {
+ if (!type || TREE_CODE (type) != FUNCTION_DECL)
+ {
+ pp_string (buffer, "access ");
+ is_access = true;
+
+ if (quals & TYPE_QUAL_CONST)
+ pp_string (buffer, "constant ");
+ else if (!name_only)
+ pp_string (buffer, "all ");
+ }
+ else if (quals & TYPE_QUAL_CONST)
+ pp_string (buffer, "in ");
+ else if (in_function)
+ {
+ is_access = true;
+ pp_string (buffer, "access ");
+ }
+ else
+ {
+ is_access = true;
+ pp_string (buffer, "access ");
+ /* ??? should be configurable: access or in out. */
+ }
+ }
+ else
+ {
+ is_access = true;
+ pp_string (buffer, "access ");
+
+ if (!name_only)
+ pp_string (buffer, "all ");
+ }
+
+ if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
+ && TYPE_NAME (TREE_TYPE (node)))
+ {
+ tree name = TYPE_NAME (TREE_TYPE (node));
+ tree tmp;
+
+ if (TREE_CODE (name) == TYPE_DECL
+ && DECL_ORIGINAL_TYPE (name)
+ && TYPE_STUB_DECL (DECL_ORIGINAL_TYPE (name)))
+ {
+ tmp = TYPE_NAME (TREE_TYPE (TYPE_STUB_DECL
+ (DECL_ORIGINAL_TYPE (name))));
+
+ if (tmp == NULL_TREE)
+ tmp = TYPE_NAME (TREE_TYPE (node));
+ }
+ else
+ tmp = TYPE_NAME (TREE_TYPE (node));
+
+ dump_generic_ada_node
+ (buffer, tmp,
+ TREE_TYPE (node), cpp_check, spc, is_access, true);
+ }
+ else
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (node), TREE_TYPE (node),
+ cpp_check, spc, 0, true);
+ }
+ }
+ }
+ break;
+
+ case ARRAY_TYPE:
+ if (name_only)
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check,
+ spc, limited_access, true);
+ else
+ dump_ada_array_type (buffer, node, spc);
+ break;
+
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ if (name_only)
+ {
+ if (TYPE_NAME (node))
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check,
+ spc, limited_access, true);
+ else
+ {
+ pp_string (buffer, "anon_");
+ pp_scalar (buffer, "%d", TYPE_UID (node));
+ }
+ }
+ else
+ print_ada_struct_decl
+ (buffer, node, type, cpp_check, spc, true);
+ break;
+
+ case INTEGER_CST:
+ if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE)
+ {
+ pp_wide_integer (buffer, TREE_INT_CST_LOW (node));
+ pp_string (buffer, "B"); /* pseudo-unit */
+ }
+ else if (! host_integerp (node, 0))
+ {
+ tree val = node;
+ unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (val);
+ HOST_WIDE_INT high = TREE_INT_CST_HIGH (val);
+
+ if (tree_int_cst_sgn (val) < 0)
+ {
+ pp_character (buffer, '-');
+ high = ~high + !low;
+ low = -low;
+ }
+ sprintf (pp_buffer (buffer)->digit_buffer,
+ HOST_WIDE_INT_PRINT_DOUBLE_HEX,
+ (unsigned HOST_WIDE_INT) high, low);
+ pp_string (buffer, pp_buffer (buffer)->digit_buffer);
+ }
+ else
+ pp_wide_integer (buffer, TREE_INT_CST_LOW (node));
+ break;
+
+ case REAL_CST:
+ case FIXED_CST:
+ case COMPLEX_CST:
+ case STRING_CST:
+ case VECTOR_CST:
+ return 0;
+
+ case FUNCTION_DECL:
+ case CONST_DECL:
+ dump_ada_decl_name (buffer, node, limited_access);
+ break;
+
+ case TYPE_DECL:
+ if (DECL_IS_BUILTIN (node))
+ {
+ /* Don't print the declaration of built-in types. */
+
+ if (name_only)
+ {
+ /* If we're in the middle of a declaration, defaults to
+ System.Address. */
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ }
+ break;
+ }
+
+ if (name_only)
+ dump_ada_decl_name (buffer, node, limited_access);
+ else
+ {
+ if (is_tagged_type (TREE_TYPE (node)))
+ {
+ tree tmp = TYPE_FIELDS (TREE_TYPE (node));
+ int first = 1;
+
+ /* Look for ancestors. */
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (!DECL_NAME (tmp) && is_tagged_type (TREE_TYPE (tmp)))
+ {
+ if (first)
+ {
+ pp_string (buffer, "limited new ");
+ first = 0;
+ }
+ else
+ pp_string (buffer, " and ");
+
+ dump_ada_decl_name
+ (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
+ }
+ }
+
+ pp_string (buffer, first ? "tagged limited " : " with ");
+ }
+ else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
+ && TYPE_METHODS (TREE_TYPE (node)))
+ pp_string (buffer, "limited ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (node), type, cpp_check, spc, false, false);
+ }
+ break;
+
+ case VAR_DECL:
+ case PARM_DECL:
+ case FIELD_DECL:
+ case NAMESPACE_DECL:
+ dump_ada_decl_name (buffer, node, false);
+ break;
+
+ default:
+ /* Ignore other nodes (e.g. expressions). */
+ return 0;
+ }
+
+ return 1;
+}
+
+/* Dump in BUFFER NODE's methods. CPP_CHECK is used to perform C++ queries on
+ nodes. SPC is the indentation level. */
+
+static void
+print_ada_methods (pretty_printer *buffer, tree node,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ tree tmp = TYPE_METHODS (node);
+ int res = 1;
+
+ if (tmp)
+ {
+ pp_semicolon (buffer);
+
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (res)
+ {
+ pp_newline (buffer);
+ pp_newline (buffer);
+ }
+ res = print_ada_declaration (buffer, tmp, node, cpp_check, spc);
+ }
+ }
+}
+
+/* Dump in BUFFER anonymous types nested inside T's definition.
+ PARENT is the parent node of T. CPP_CHECK is used to perform C++ queries on
+ nodes. SPC is the indentation level. */
+
+static void
+dump_nested_types (pretty_printer *buffer, tree t, tree parent,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ tree field, outer, decl;
+
+ /* Avoid recursing over the same tree. */
+ if (TREE_VISITED (t))
+ return;
+
+ /* Find possible anonymous arrays/unions/structs recursively. */
+
+ outer = TREE_TYPE (t);
+
+ if (outer == NULL_TREE)
+ return;
+
+ field = TYPE_FIELDS (outer);
+ while (field)
+ {
+ if ((TREE_TYPE (field) != outer
+ || (TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
+ && TREE_TYPE (TREE_TYPE (field)) != outer))
+ && (!TYPE_NAME (TREE_TYPE (field))
+ || (TREE_CODE (field) == TYPE_DECL
+ && DECL_NAME (field) != DECL_NAME (t)
+ && TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (outer))))
+ {
+ switch (TREE_CODE (TREE_TYPE (field)))
+ {
+ case POINTER_TYPE:
+ decl = TREE_TYPE (TREE_TYPE (field));
+
+ if (TREE_CODE (decl) == FUNCTION_TYPE)
+ for (decl = TREE_TYPE (decl);
+ decl && TREE_CODE (decl) == POINTER_TYPE;
+ decl = TREE_TYPE (decl));
+
+ decl = get_underlying_decl (decl);
+
+ if (decl
+ && DECL_P (decl)
+ && decl_sloc (decl, true) > decl_sloc (t, true)
+ && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t)
+ && !TREE_VISITED (decl)
+ && !DECL_IS_BUILTIN (decl)
+ && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))
+ || TYPE_FIELDS (TREE_TYPE (decl))))
+ {
+ /* Generate forward declaration. */
+
+ pp_string (buffer, "type ");
+ dump_generic_ada_node
+ (buffer, decl, 0, cpp_check, spc, false, true);
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+
+ /* Ensure we do not generate duplicate forward
+ declarations for this type. */
+ TREE_VISITED (decl) = 1;
+ }
+ break;
+
+ case ARRAY_TYPE:
+ /* Special case char arrays. */
+ if (is_char_array (field))
+ pp_string (buffer, "sub");
+
+ pp_string (buffer, "type ");
+ dump_ada_double_name (buffer, parent, field, "_array is ");
+ dump_ada_array_type (buffer, field, spc);
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ break;
+
+ case UNION_TYPE:
+ TREE_VISITED (t) = 1;
+ dump_nested_types (buffer, field, t, cpp_check, spc);
+
+ pp_string (buffer, "type ");
+
+ if (TYPE_NAME (TREE_TYPE (field)))
+ {
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (TREE_TYPE (field)), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, " (discr : unsigned := 0) is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, ");");
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "pragma Unchecked_Union (");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, ");");
+ }
+ else
+ {
+ dump_ada_double_name
+ (buffer, parent, field,
+ "_union (discr : unsigned := 0) is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_ada_double_name (buffer, parent, field, "_union);");
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "pragma Unchecked_Union (");
+ dump_ada_double_name (buffer, parent, field, "_union);");
+ }
+
+ newline_and_indent (buffer, spc);
+ break;
+
+ case RECORD_TYPE:
+ if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t))
+ {
+ pp_string (buffer, "type ");
+ dump_generic_ada_node
+ (buffer, t, parent, 0, spc, false, true);
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ }
+
+ TREE_VISITED (t) = 1;
+ dump_nested_types (buffer, field, t, cpp_check, spc);
+ pp_string (buffer, "type ");
+
+ if (TYPE_NAME (TREE_TYPE (field)))
+ {
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, " is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, ");");
+ }
+ else
+ {
+ dump_ada_double_name
+ (buffer, parent, field, "_struct is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_ada_double_name (buffer, parent, field, "_struct);");
+ }
+
+ newline_and_indent (buffer, spc);
+ break;
+
+ default:
+ break;
+ }
+ }
+ field = TREE_CHAIN (field);
+ }
+}
+
+/* Dump in BUFFER destructor spec corresponding to T. */
+
+static void
+print_destructor (pretty_printer *buffer, tree t)
+{
+ const char *s = IDENTIFIER_POINTER (DECL_NAME (t));
+
+ if (*s == '_')
+ for (s += 2; *s != ' '; s++)
+ pp_character (buffer, *s);
+ else
+ {
+ pp_string (buffer, "Delete_");
+ pp_ada_tree_identifier (buffer, DECL_NAME (t), t, false);
+ }
+}
+
+/* Return the name of type T. */
+
+static const char *
+type_name (tree t)
+{
+ tree n = TYPE_NAME (t);
+
+ if (TREE_CODE (n) == IDENTIFIER_NODE)
+ return IDENTIFIER_POINTER (n);
+ else
+ return IDENTIFIER_POINTER (DECL_NAME (n));
+}
+
+/* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
+ CPP_CHECK is used to perform C++ queries on nodes. SPC is the indentation
+ level. Return 1 if a declaration was printed, 0 otherwise. */
+
+static int
+print_ada_declaration (pretty_printer *buffer, tree t, tree type,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ int is_var = 0, need_indent = 0;
+ int is_class = false;
+ tree name = TYPE_NAME (TREE_TYPE (t));
+ tree decl_name = DECL_NAME (t);
+ bool dump_internal = get_dump_file_info (TDI_ada)->flags & TDF_RAW;
+ tree orig = NULL_TREE;
+
+ if (cpp_check && cpp_check (t, IS_TEMPLATE))
+ return dump_ada_template (buffer, t, cpp_check, spc);
+
+ if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
+ /* Skip enumeral values: will be handled as part of the type itself. */
+ return 0;
+
+ if (TREE_CODE (t) == TYPE_DECL)
+ {
+ orig = DECL_ORIGINAL_TYPE (t);
+
+ if (orig && TYPE_STUB_DECL (orig))
+ {
+ tree typ = TREE_TYPE (TYPE_STUB_DECL (orig));
+
+ if (TYPE_NAME (typ))
+ {
+ /* If types have same representation, and same name (ignoring
+ casing), then ignore the second type. */
+ if (type_name (typ) == type_name (TREE_TYPE (t))
+ || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t))))
+ return 0;
+
+ INDENT (spc);
+
+ if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ))
+ {
+ pp_string (buffer, "-- skipped empty struct ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ }
+ else
+ {
+ pp_string (buffer, "subtype ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ pp_string (buffer, " is ");
+ dump_generic_ada_node
+ (buffer, typ, type, 0, spc, false, true);
+ pp_semicolon (buffer);
+ }
+ return 1;
+ }
+ }
+
+ /* Skip unnamed or anonymous structs/unions/enum types. */
+ if (!orig && !decl_name && !name)
+ {
+ tree tmp;
+ location_t sloc;
+
+ if (cpp_check || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
+ return 0;
+
+ if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
+ {
+ /* Search next items until finding a named type decl. */
+ sloc = decl_sloc_common (t, true, true);
+
+ for (tmp = TREE_CHAIN (t); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (TREE_CODE (tmp) == TYPE_DECL
+ && (DECL_NAME (tmp) || TYPE_NAME (TREE_TYPE (tmp))))
+ {
+ /* If same sloc, it means we can ignore the anonymous
+ struct. */
+ if (decl_sloc_common (tmp, true, true) == sloc)
+ return 0;
+ else
+ break;
+ }
+ }
+ if (tmp == NULL)
+ return 0;
+ }
+ }
+
+ if (!orig
+ && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE
+ && decl_name
+ && (*IDENTIFIER_POINTER (decl_name) == '.'
+ || *IDENTIFIER_POINTER (decl_name) == '$'))
+ /* Skip anonymous enum types (duplicates of real types). */
+ return 0;
+
+ INDENT (spc);
+
+ switch (TREE_CODE (TREE_TYPE (t)))
+ {
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ /* Skip empty structs (typically forward references to real
+ structs). */
+ if (!TYPE_FIELDS (TREE_TYPE (t)))
+ {
+ pp_string (buffer, "-- skipped empty struct ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ return 1;
+ }
+
+ if (decl_name
+ && (*IDENTIFIER_POINTER (decl_name) == '.'
+ || *IDENTIFIER_POINTER (decl_name) == '$'))
+ {
+ pp_string (buffer, "-- skipped anonymous struct ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ return 1;
+ }
+
+ if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
+ pp_string (buffer, "subtype ");
+ else
+ {
+ dump_nested_types (buffer, t, t, cpp_check, spc);
+
+ if (TYPE_METHODS (TREE_TYPE (t))
+ || has_static_fields (TREE_TYPE (t)))
+ {
+ is_class = true;
+ pp_string (buffer, "package Class_");
+ dump_generic_ada_node
+ (buffer, t, type, 0, spc, false, true);
+ pp_string (buffer, " is");
+ spc += INDENT_INCR;
+ newline_and_indent (buffer, spc);
+ }
+
+ pp_string (buffer, "type ");
+ }
+ break;
+
+ case ARRAY_TYPE:
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
+ || is_char_array (t))
+ pp_string (buffer, "subtype ");
+ else
+ pp_string (buffer, "type ");
+ break;
+
+ case FUNCTION_TYPE:
+ pp_string (buffer, "-- skipped function type ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ return 1;
+ break;
+
+ default:
+ pp_string (buffer, "subtype ");
+ }
+ }
+ else
+ {
+ if (!dump_internal
+ && TREE_CODE (t) == VAR_DECL
+ && decl_name
+ && *IDENTIFIER_POINTER (decl_name) == '_')
+ return 0;
+
+ need_indent = 1;
+ }
+
+ /* Print the type and name. */
+ if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
+ {
+ if (need_indent)
+ INDENT (spc);
+
+ /* Print variable's name. */
+ dump_generic_ada_node (buffer, t, type, cpp_check, spc, false, true);
+
+ if (TREE_CODE (t) == TYPE_DECL)
+ {
+ pp_string (buffer, " is ");
+
+ if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (orig), type,
+ cpp_check, spc, false, true);
+ else
+ dump_ada_array_type (buffer, t, spc);
+ }
+ else
+ {
+ tree tmp = TYPE_NAME (TREE_TYPE (t));
+
+ if (spc == INDENT_INCR || TREE_STATIC (t))
+ is_var = 1;
+
+ pp_string (buffer, " : ");
+
+ if (tmp)
+ {
+ if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE
+ && TREE_CODE (tmp) != INTEGER_TYPE)
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node (buffer, tmp, type, 0, spc, false, true);
+ }
+ else
+ {
+ pp_string (buffer, "aliased ");
+
+ if (!type)
+ dump_ada_array_type (buffer, t, spc);
+ else
+ dump_ada_double_name (buffer, type, t, "_array");
+ }
+ }
+ }
+ else if (TREE_CODE (t) == FUNCTION_DECL)
+ {
+ bool is_function = true, is_method, is_abstract_class = false;
+ tree decl_name = DECL_NAME (t);
+ int prev_in_function = in_function;
+ bool is_abstract = false;
+ bool is_constructor = false;
+ bool is_destructor = false;
+ bool is_copy_constructor = false;
+
+ if (!decl_name)
+ return 0;
+
+ if (cpp_check)
+ {
+ is_abstract = cpp_check (t, IS_ABSTRACT);
+ is_constructor = cpp_check (t, IS_CONSTRUCTOR);
+ is_destructor = cpp_check (t, IS_DESTRUCTOR);
+ is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR);
+ }
+
+ /* Skip __comp_dtor destructor which is redundant with the '~class()'
+ destructor. */
+ if (is_destructor
+ && !strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6))
+ return 0;
+
+ /* Skip copy constructors: some are internal only, and those that are
+ not cannot be called easily from Ada anyway. */
+ if (is_copy_constructor)
+ return 0;
+
+ /* If this function has an entry in the dispatch table, we cannot
+ omit it. */
+ if (!dump_internal && !DECL_VINDEX (t)
+ && *IDENTIFIER_POINTER (decl_name) == '_')
+ {
+ if (IDENTIFIER_POINTER (decl_name)[1] == '_')
+ return 0;
+
+ INDENT (spc);
+ pp_string (buffer, "-- skipped func ");
+ pp_string (buffer, IDENTIFIER_POINTER (decl_name));
+ return 1;
+ }
+
+ if (need_indent)
+ INDENT (spc);
+
+ if (is_constructor)
+ pp_string (buffer, "function New_");
+ else if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))))
+ {
+ is_function = false;
+ pp_string (buffer, "procedure ");
+ }
+ else
+ pp_string (buffer, "function ");
+
+ in_function = is_function;
+ is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE;
+
+ if (is_destructor)
+ print_destructor (buffer, t);
+ else
+ dump_ada_decl_name (buffer, t, false);
+
+ dump_ada_function_declaration
+ (buffer, t, is_method, is_constructor, is_destructor, spc);
+ in_function = prev_in_function;
+
+ if (is_function)
+ {
+ pp_string (buffer, " return ");
+
+ if (is_constructor)
+ {
+ dump_ada_decl_name (buffer, t, false);
+ }
+ else
+ {
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (TREE_TYPE (t)), type, cpp_check,
+ spc, false, true);
+ }
+ }
+
+ if (is_constructor && cpp_check && type
+ && AGGREGATE_TYPE_P (type)
+ && TYPE_METHODS (type))
+ {
+ tree tmp = TYPE_METHODS (type);
+
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ if (cpp_check (tmp, IS_ABSTRACT))
+ {
+ is_abstract_class = 1;
+ break;
+ }
+ }
+
+ if (is_abstract || is_abstract_class)
+ pp_string (buffer, " is abstract");
+
+ pp_semicolon (buffer);
+ pp_string (buffer, " -- ");
+ dump_sloc (buffer, t);
+
+ if (is_abstract)
+ return 1;
+
+ newline_and_indent (buffer, spc);
+
+ if (is_constructor)
+ {
+ pp_string (buffer, "pragma CPP_Constructor (New_");
+ dump_ada_decl_name (buffer, t, false);
+ pp_string (buffer, ", \"");
+ pp_asm_name (buffer, t);
+ pp_string (buffer, "\");");
+ }
+ else if (is_destructor)
+ {
+ pp_string (buffer, "pragma Import (CPP, ");
+ print_destructor (buffer, t);
+ pp_string (buffer, ", \"");
+ pp_asm_name (buffer, t);
+ pp_string (buffer, "\");");
+ }
+ else
+ {
+ dump_ada_import (buffer, t);
+ }
+
+ return 1;
+ }
+ else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t))
+ {
+ int is_interface = 0;
+ int is_abstract_record = 0;
+
+ if (need_indent)
+ INDENT (spc);
+
+ /* Anonymous structs/unions */
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true);
+
+ if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
+ || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE)
+ {
+ pp_string (buffer, " (discr : unsigned := 0)");
+ }
+
+ pp_string (buffer, " is ");
+
+ /* Check whether we have an Ada interface compatible class. */
+ if (cpp_check && AGGREGATE_TYPE_P (TREE_TYPE (t))
+ && TYPE_METHODS (TREE_TYPE (t)))
+ {
+ int num_fields = 0;
+ tree tmp = TYPE_FIELDS (TREE_TYPE (t));
+
+ /* Check that there are no fields other than the virtual table. */
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (TREE_CODE (tmp) == TYPE_DECL)
+ continue;
+ num_fields++;
+ }
+
+ if (num_fields == 1)
+ is_interface = 1;
+
+ /* Also check that there are only virtual methods. */
+ for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (cpp_check (tmp, IS_ABSTRACT))
+ is_abstract_record = 1;
+ else
+ is_interface = 0;
+ }
+ }
+
+ if (is_interface)
+ {
+ pp_string (buffer, "limited interface; -- ");
+ dump_sloc (buffer, t);
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "pragma Import (CPP, ");
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (TREE_TYPE (t)), type, cpp_check,
+ spc, false, true);
+ pp_character (buffer, ')');
+
+ print_ada_methods (buffer, TREE_TYPE (t), cpp_check, spc);
+ }
+ else
+ {
+ if (is_abstract_record)
+ pp_string (buffer, "abstract ");
+ dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, false);
+ }
+ }
+ else
+ {
+ if (need_indent)
+ INDENT (spc);
+
+ if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t))
+ check_name (buffer, t);
+
+ /* Print variable/type's name. */
+ dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, true);
+
+ if (TREE_CODE (t) == TYPE_DECL)
+ {
+ tree orig = DECL_ORIGINAL_TYPE (t);
+ int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t);
+
+ if (!is_subtype
+ && (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
+ || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE))
+ pp_string (buffer, " (discr : unsigned := 0)");
+
+ pp_string (buffer, " is ");
+
+ dump_generic_ada_node
+ (buffer, orig, t, cpp_check, spc, false, is_subtype);
+ }
+ else
+ {
+ if (spc == INDENT_INCR || TREE_STATIC (t))
+ is_var = 1;
+
+ pp_string (buffer, " : ");
+
+ /* Print type declaration. */
+
+ if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
+ && !TYPE_NAME (TREE_TYPE (t)))
+ {
+ dump_ada_double_name (buffer, type, t, "_union");
+ }
+ else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
+ {
+ if (TREE_CODE (TREE_TYPE (t)) == RECORD_TYPE)
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true);
+ }
+ else
+ {
+ if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE
+ && (TYPE_NAME (TREE_TYPE (t))
+ || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE))
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (t), TREE_TYPE (t), cpp_check,
+ spc, false, true);
+ }
+ }
+ }
+
+ if (is_class)
+ {
+ spc -= 3;
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "end;");
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "use Class_");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ pp_semicolon (buffer);
+ pp_newline (buffer);
+
+ /* All needed indentation/newline performed already, so return 0. */
+ return 0;
+ }
+ else
+ {
+ pp_string (buffer, "; -- ");
+ dump_sloc (buffer, t);
+ }
+
+ if (is_var)
+ {
+ newline_and_indent (buffer, spc);
+ dump_ada_import (buffer, t);
+ }
+
+ return 1;
+}
+
+/* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
+ with Ada syntax. CPP_CHECK is used to perform C++ queries on nodes. SPC
+ is the indentation level. If DISPLAY_CONVENTION is true, also print the
+ pragma Convention for NODE. */
+
+static void
+print_ada_struct_decl (pretty_printer *buffer, tree node, tree type,
+ int (*cpp_check)(tree, cpp_operation), int spc,
+ bool display_convention)
+{
+ tree tmp;
+ int is_union =
+ TREE_CODE (node) == UNION_TYPE || TREE_CODE (node) == QUAL_UNION_TYPE;
+ char buf [16];
+ int field_num = 0;
+ int field_spc = spc + INDENT_INCR;
+ int need_semicolon;
+
+ bitfield_used = false;
+
+ if (!TYPE_FIELDS (node))
+ pp_string (buffer, "null record;");
+ else
+ {
+ pp_string (buffer, "record");
+
+ /* Print the contents of the structure. */
+
+ if (is_union)
+ {
+ newline_and_indent (buffer, spc + INDENT_INCR);
+ pp_string (buffer, "case discr is");
+ field_spc = spc + INDENT_INCR * 3;
+ }
+
+ pp_newline (buffer);
+
+ /* Print the non-static fields of the structure. */
+ for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ /* Add parent field if needed. */
+ if (!DECL_NAME (tmp))
+ {
+ if (!is_tagged_type (TREE_TYPE (tmp)))
+ {
+ if (!TYPE_NAME (TREE_TYPE (tmp)))
+ print_ada_declaration
+ (buffer, tmp, type, cpp_check, field_spc);
+ else
+ {
+ INDENT (field_spc);
+
+ if (field_num == 0)
+ pp_string (buffer, "parent : ");
+ else
+ {
+ sprintf (buf, "field_%d : ", field_num + 1);
+ pp_string (buffer, buf);
+ }
+ dump_ada_decl_name
+ (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
+ pp_semicolon (buffer);
+ }
+ pp_newline (buffer);
+ field_num++;
+ }
+ }
+ /* Avoid printing the structure recursively. */
+ else if ((TREE_TYPE (tmp) != node
+ || (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
+ && TREE_TYPE (TREE_TYPE (tmp)) != node))
+ && TREE_CODE (tmp) != TYPE_DECL
+ && !TREE_STATIC (tmp))
+ {
+ /* Skip internal virtual table field. */
+ if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5))
+ {
+ if (is_union)
+ {
+ if (TREE_CHAIN (tmp)
+ && TREE_TYPE (TREE_CHAIN (tmp)) != node
+ && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL)
+ sprintf (buf, "when %d =>", field_num);
+ else
+ sprintf (buf, "when others =>");
+
+ INDENT (spc + INDENT_INCR * 2);
+ pp_string (buffer, buf);
+ pp_newline (buffer);
+ }
+
+ if (print_ada_declaration (buffer,
+ tmp, type, cpp_check, field_spc))
+ {
+ pp_newline (buffer);
+ field_num++;
+ }
+ }
+ }
+ }
+
+ if (is_union)
+ {
+ INDENT (spc + INDENT_INCR);
+ pp_string (buffer, "end case;");
+ pp_newline (buffer);
+ }
+
+ if (field_num == 0)
+ {
+ INDENT (spc + INDENT_INCR);
+ pp_string (buffer, "null;");
+ pp_newline (buffer);
+ }
+
+ INDENT (spc);
+ pp_string (buffer, "end record;");
+ }
+
+ newline_and_indent (buffer, spc);
+
+ if (!display_convention)
+ return;
+
+ if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type)))
+ {
+ if (TYPE_METHODS (TREE_TYPE (type)))
+ pp_string (buffer, "pragma Import (CPP, ");
+ else
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ }
+ else
+ pp_string (buffer, "pragma Convention (C, ");
+
+ package_prefix = false;
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
+ package_prefix = true;
+ pp_character (buffer, ')');
+
+ if (is_union)
+ {
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "pragma Unchecked_Union (");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
+ pp_character (buffer, ')');
+ }
+
+ if (bitfield_used)
+ {
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "pragma Pack (");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
+ pp_character (buffer, ')');
+ bitfield_used = false;
+ }
+
+ print_ada_methods (buffer, node, cpp_check, spc);
+
+ /* Print the static fields of the structure, if any. */
+ need_semicolon = TYPE_METHODS (node) == NULL_TREE;
+ for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (DECL_NAME (tmp) && TREE_STATIC (tmp))
+ {
+ if (need_semicolon)
+ {
+ need_semicolon = false;
+ pp_semicolon (buffer);
+ }
+ pp_newline (buffer);
+ pp_newline (buffer);
+ print_ada_declaration (buffer, tmp, type, cpp_check, spc);
+ }
+ }
+}
+
+/* Dump all the declarations in SOURCE_FILE to an Ada spec.
+ COLLECT_ALL_REFS is a front-end callback used to collect all relevant
+ nodes for SOURCE_FILE. CPP_CHECK is used to perform C++ queries on
+ nodes. */
+
+static void
+dump_ads (const char *source_file,
+ void (*collect_all_refs)(const char *),
+ int (*cpp_check)(tree, cpp_operation))
+{
+ char *ads_name;
+ char *pkg_name;
+ char *s;
+ FILE *f;
+
+ pkg_name = get_ada_package (source_file);
+
+ /* Construct the the .ads filename and package name. */
+ ads_name = xstrdup (pkg_name);
+
+ for (s = ads_name; *s; s++)
+ *s = TOLOWER (*s);
+
+ ads_name = reconcat (ads_name, ads_name, ".ads", NULL);
+
+ /* Write out the .ads file. */
+ f = fopen (ads_name, "w");
+ if (f)
+ {
+ pretty_printer pp;
+
+ pp_construct (&pp, NULL, 0);
+ pp_needs_newline (&pp) = true;
+ pp.buffer->stream = f;
+
+ /* Dump all relevant macros. */
+ dump_ada_macros (&pp, source_file);
+
+ /* Reset the table of withs for this file. */
+ reset_ada_withs ();
+
+ (*collect_all_refs) (source_file);
+
+ /* Dump all references. */
+ dump_ada_nodes (&pp, source_file, cpp_check);
+
+ /* Dump withs. */
+ dump_ada_withs (f);
+
+ fprintf (f, "\npackage %s is\n\n", pkg_name);
+ pp_write_text_to_stream (&pp);
+ /* ??? need to free pp */
+ fprintf (f, "end %s;\n", pkg_name);
+ fclose (f);
+ }
+
+ free (ads_name);
+ free (pkg_name);
+}
+
+static const char **source_refs = NULL;
+static int source_refs_used = 0;
+static int source_refs_allocd = 0;
+
+/* Add an entry for FILENAME to the table SOURCE_REFS. */
+
+void
+collect_source_ref (const char *filename)
+{
+ int i;
+
+ if (!filename)
+ return;
+
+ if (source_refs_allocd == 0)
+ {
+ source_refs_allocd = 1024;
+ source_refs = (const char **)
+ xmalloc (source_refs_allocd * sizeof (const char *));
+ }
+
+ for (i = 0; i < source_refs_used; i++)
+ if (filename == source_refs [i])
+ return;
+
+ if (source_refs_used == source_refs_allocd)
+ {
+ source_refs_allocd *= 2;
+ source_refs = (const char **)
+ xrealloc (source_refs, source_refs_allocd * sizeof (const char *));
+ }
+
+ source_refs [source_refs_used++] = filename;
+}
+
+/* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
+ using callbacks COLLECT_ALL_REFS and CPP_CHECK.
+ COLLECT_ALL_REFS is a front-end callback used to collect all relevant
+ nodes for a given source file.
+ CPP_CHECK is used to perform C++ queries on nodes, or NULL for the C
+ front-end. */
+
+void
+dump_ada_specs (void (*collect_all_refs)(const char *),
+ int (*cpp_check)(tree, cpp_operation))
+{
+ int i;
+
+ /* Iterate over the list of files to dump specs for */
+ for (i = 0; i < source_refs_used; i++)
+ dump_ads (source_refs [i], collect_all_refs, cpp_check);
+
+ /* Free files table. */
+ free (source_refs);
+}
Index: gcc/testsuite/gnat.dg/c-specs/inner_struct1.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/inner_struct1.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/inner_struct1.h (revision 0)
@@ -0,0 +1,11 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+struct inner;
+
+typedef struct {
+ struct inner *p;
+} outer;
+
+struct inner {
+ int f;
+};
Index: gcc/testsuite/gnat.dg/c-specs/inner_struct2.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/inner_struct2.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/inner_struct2.h (revision 0)
@@ -0,0 +1,7 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+ struct _outer {
+ struct _inner {
+ int x;
+ } inner;
+ } outer;
Index: gcc/testsuite/gnat.dg/c-specs/c-specs.exp
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/c-specs.exp (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/c-specs.exp (revision 0)
@@ -0,0 +1,35 @@
+# Copyright (C) 2010 Free Software Foundation, Inc.
+
+# This program 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 3 of the License, or
+# (at your option) any later version.
+#
+# This program 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 GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# GCC testsuite that uses the `dg.exp' driver.
+
+# Load support procs.
+load_lib gnat-dg.exp
+
+# If a testcase doesn't have special options, use these.
+global DEFAULT_CFLAGS
+if ![info exists DEFAULT_CFLAGS] then {
+ set DEFAULT_CFLAGS ""
+}
+
+# Initialize `dg'.
+dg-init
+
+# Main loop.
+dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.h]] "" $DEFAULT_CFLAGS
+
+# All done.
+dg-finish
Index: gcc/testsuite/gnat.dg/c-specs/inner_struct3.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/inner_struct3.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/inner_struct3.h (revision 0)
@@ -0,0 +1,7 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+struct _outer {
+ struct inner {
+ struct _outer * (*fn)(void);
+ } fld;
+};
Index: gcc/testsuite/gnat.dg/c-specs/inner_struct4.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/inner_struct4.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/inner_struct4.h (revision 0)
@@ -0,0 +1,5 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+ typedef struct tag_foo {
+ struct { int inner_field; } outer_field[6];
+ } foo;
Index: gcc/testsuite/gnat.dg/c-specs/comments1.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/comments1.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/comments1.h (revision 0)
@@ -0,0 +1,17 @@
+/* { dg-options "-fdump-ada-spec -C" } */
+
+/*
+ This is a test of capturing comments in generated specs.
+ foo.
+*/
+
+/* Define an integer called 'a'. */
+int a;
+
+// Define an integer called 'b'.
+int b;
+
+/* Define an integer called 'c'. */
+int c;
+
+/* File ends here! */
Index: gcc/testsuite/gnat.dg/c-specs/typedefs_second.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/typedefs_second.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/typedefs_second.h (revision 0)
@@ -0,0 +1,7 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+ typedef struct
+ {
+ int c;
+ int d;
+ } second;
Index: gcc/testsuite/gnat.dg/c-specs/typedef0.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/typedef0.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/typedef0.h (revision 0)
@@ -0,0 +1,16 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+typedef struct
+{
+ union
+ {
+ int wch;
+ char wchb[4];
+ } value;
+} mbstate_t;
+
+typedef struct
+{
+ mbstate_t m;
+} s1;
+
Index: gcc/testsuite/gnat.dg/c-specs/typedef1.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/typedef1.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/typedef1.h (revision 0)
@@ -0,0 +1,5 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+#include "typedef0.h"
+
+typedef s1 s2;
Index: gcc/testsuite/gnat.dg/c-specs/typedef2.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/typedef2.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/typedef2.h (revision 0)
@@ -0,0 +1,5 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+#include "typedef3.h"
+
+typedef s1 s2;
Index: gcc/testsuite/gnat.dg/c-specs/struct_array.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/struct_array.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/struct_array.h (revision 0)
@@ -0,0 +1,4 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+typedef struct { int f[2]; } s1;
+typedef s1 s2;
Index: gcc/testsuite/gnat.dg/c-specs/macro1.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/macro1.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/macro1.h (revision 0)
@@ -0,0 +1,7 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+#define IN_CLASSA_NET 0xff000000U
+#define NULL 0
+#define ARG_MACRO(a) foo(a)
+
+extern int foo();
Index: gcc/testsuite/gnat.dg/c-specs/unknown_struct0.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/unknown_struct0.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/unknown_struct0.h (revision 0)
@@ -0,0 +1,8 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+struct _IO_FILE;
+
+struct _IO_FILE {
+ int f;
+};
+
Index: gcc/testsuite/gnat.dg/c-specs/typedefs.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/typedefs.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/typedefs.h (revision 0)
@@ -0,0 +1,12 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+ #include "typedefs_second.h"
+
+ typedef struct
+ {
+ int a;
+ int b;
+ } first;
+
+ typedef first first_bis;
+ typedef second second_bis;
Index: gcc/testsuite/gnat.dg/c-specs/typedef3.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/typedef3.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/typedef3.h (revision 0)
@@ -0,0 +1,5 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+typedef struct {
+ int f;
+} s1;
Index: gcc/testsuite/gnat.dg/c-specs/unknown_struct1.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/unknown_struct1.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/unknown_struct1.h (revision 0)
@@ -0,0 +1,6 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+typedef struct _IO_FILE FILE;
+typedef struct _IO_FILE __FILE;
+
+#include "unknown_struct0.h"
Index: gcc/testsuite/gnat.dg/c-specs/animals.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/animals.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/animals.h (revision 0)
@@ -0,0 +1,28 @@
+/* { dg-options "-fdump-ada-spec -x c++" } */
+
+class Carnivore {
+public:
+ virtual int Number_Of_Teeth () = 0;
+};
+
+class Domestic {
+public:
+ virtual void Set_Owner (char* Name) = 0;
+};
+
+class Animal {
+public:
+ int Age_Count;
+ virtual void Set_Age (int New_Age);
+};
+
+class Dog : Animal, Carnivore, Domestic {
+ public:
+ int Tooth_Count;
+ char *Owner;
+
+ virtual int Number_Of_Teeth ();
+ virtual void Set_Owner (char* Name);
+
+ Dog(); // Constructor
+};
Index: gcc/testsuite/gnat.dg/c-specs/enum1.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/enum1.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/enum1.h (revision 0)
@@ -0,0 +1,3 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+enum simple_enum { ZERO, ONE, TWO };
Index: gcc/testsuite/gnat.dg/c-specs/unknown_struct2.h
===================================================================
--- gcc/testsuite/gnat.dg/c-specs/unknown_struct2.h (revision 0)
+++ gcc/testsuite/gnat.dg/c-specs/unknown_struct2.h (revision 0)
@@ -0,0 +1,4 @@
+/* { dg-options "-fdump-ada-spec" } */
+
+struct s;
+struct t {};
More information about the Gcc-patches
mailing list