Handle Ada Pragma Import and Pragma Export

Ada can import C APIs and also export Ada constructs to C via Pragma
Import and Pragma Export.  This patch adds support for these to gdb,
by arranging to either defer some aspects of a symbol to the
underlying C symbol (for Import) or by introducing a second symbol
(for Export).  A somewhat tricky approach is needed, both because gdb
doesn't generally handle symbol aliasing, and because Ada treats
symbol names in an unusual way (as compared to the rest of gdb).

gdb/Makefile.in

@@ -1061,6 +1061,7 @@ COMMON_SFILES = \
 	dummy-frame.c \
 	dwarf2/abbrev.c \
 	dwarf2/abbrev-cache.c \
+	dwarf2/ada-imported.c \
 	dwarf2/attribute.c \
 	dwarf2/comp-unit-head.c \
 	dwarf2/cooked-index.c \

gdb/dwarf2/ada-imported.c

@@ -0,0 +1,122 @@
+/* Ada Pragma Import support.
+
+   Copyright (C) 2023 Free Software Foundation, Inc.
+
+   This file is part of GDB.
+
+   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 this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include "defs.h"
+#include "symtab.h"
+#include "value.h"
+#include "dwarf2/loc.h"
+
+/* Helper to get the imported symbol's real name.  */
+static const char *
+get_imported_name (const struct symbol *sym)
+{
+  return (const char *) SYMBOL_LOCATION_BATON (sym);
+}
+
+/* Implement the read_variable method from symbol_computed_ops.  */
+
+static struct value *
+ada_imported_read_variable (struct symbol *symbol, frame_info_ptr frame)
+{
+  const char *name = get_imported_name (symbol);
+  bound_minimal_symbol minsym = lookup_minimal_symbol_linkage (name, false);
+  if (minsym.minsym == nullptr)
+    error (_("could not find imported name %s"), name);
+  return value_at (symbol->type (), minsym.value_address ());
+}
+
+/* Implement the read_variable method from symbol_computed_ops.  */
+
+static enum symbol_needs_kind
+ada_imported_get_symbol_read_needs (struct symbol *symbol)
+{
+  return SYMBOL_NEEDS_NONE;
+}
+
+/* Implement the describe_location method from
+   symbol_computed_ops.  */
+
+static void
+ada_imported_describe_location (struct symbol *symbol, CORE_ADDR addr,
+				struct ui_file *stream)
+{
+  gdb_printf (stream, "an imported name for '%s'",
+	      get_imported_name (symbol));
+}
+
+/* Implement the tracepoint_var_ref method from
+   symbol_computed_ops.  */
+
+static void
+ada_imported_tracepoint_var_ref (struct symbol *symbol, struct agent_expr *ax,
+				 struct axs_value *value)
+{
+  /* Probably could be done, but not needed right now.  */
+  error (_("not implemented: trace of imported Ada symbol"));
+}
+
+/* Implement the generate_c_location method from
+   symbol_computed_ops.  */
+
+static void
+ada_imported_generate_c_location (struct symbol *symbol, string_file *stream,
+				  struct gdbarch *gdbarch,
+				  std::vector<bool> &registers_used,
+				  CORE_ADDR pc, const char *result_name)
+{
+  /* Probably could be done, but not needed right now, and perhaps not
+     ever.  */
+  error (_("not implemented: compile translation of imported Ada symbol"));
+}
+
+const struct symbol_computed_ops ada_imported_funcs =
+{
+  ada_imported_read_variable,
+  nullptr,
+  ada_imported_get_symbol_read_needs,
+  ada_imported_describe_location,
+  0,
+  ada_imported_tracepoint_var_ref,
+  ada_imported_generate_c_location
+};
+
+/* Implement the get_block_value method from symbol_block_ops.  */
+
+static const block *
+ada_alias_get_block_value (const struct symbol *sym)
+{
+  const char *name = get_imported_name (sym);
+  block_symbol real_symbol = lookup_global_symbol (name, nullptr,
+						   VAR_DOMAIN);
+  if (real_symbol.symbol == nullptr)
+    error (_("could not find alias '%s' for function '%s'"),
+	   name, sym->print_name ());
+  if (real_symbol.symbol->aclass () != LOC_BLOCK)
+    error (_("alias '%s' for function '%s' is not a function"),
+	   name, sym->print_name ());
+
+  return real_symbol.symbol->value_block ();
+}
+
+const struct symbol_block_ops ada_function_alias_funcs =
+{
+  nullptr,
+  nullptr,
+  ada_alias_get_block_value
+};

gdb/dwarf2/loc.h

@@ -246,9 +246,11 @@ struct dwarf2_property_baton
 
 extern const struct symbol_computed_ops dwarf2_locexpr_funcs;
 extern const struct symbol_computed_ops dwarf2_loclist_funcs;
+extern const struct symbol_computed_ops ada_imported_funcs;
 
 extern const struct symbol_block_ops dwarf2_block_frame_base_locexpr_funcs;
 extern const struct symbol_block_ops dwarf2_block_frame_base_loclist_funcs;
+extern const struct symbol_block_ops ada_function_alias_funcs;
 
 /* Determined tail calls for constructing virtual tail call frames.  */
 

gdb/dwarf2/read.c

@@ -142,8 +142,10 @@ static const registry<objfile>::key<dwarf2_per_bfd>
 
 static int dwarf2_locexpr_index;
 static int dwarf2_loclist_index;
+static int ada_imported_index;
 static int dwarf2_locexpr_block_index;
 static int dwarf2_loclist_block_index;
+static int ada_block_index;
 
 /* Size of .debug_loclists section header for 32-bit DWARF format.  */
 #define LOCLIST_HEADER_SIZE32 12
@@ -1072,6 +1074,9 @@ static void queue_comp_unit (dwarf2_per_cu_data *per_cu,
 
 static void process_queue (dwarf2_per_objfile *per_objfile);
 
+static bool is_ada_import_or_export (dwarf2_cu *cu, const char *name,
+				     const char *linkagename);
+
 /* Class, the destructor of which frees all allocated queue entries.  This
    will only have work to do if an error was thrown while processing the
    dwarf.  If no error was thrown then the queue entries should have all
@@ -10014,6 +10019,31 @@ dwarf2_func_is_main_p (struct die_info *die, struct dwarf2_cu *cu)
 	  && attr->constant_value (DW_CC_normal) == DW_CC_program);
 }
 
+/* A helper to handle Ada's "Pragma Import" feature when it is applied
+   to a function.  */
+
+static bool
+check_ada_pragma_import (struct die_info *die, struct dwarf2_cu *cu)
+{
+  /* A Pragma Import will have both a name and a linkage name.  */
+  const char *name = dwarf2_name (die, cu);
+  if (name == nullptr)
+    return false;
+
+  const char *linkage_name = dw2_linkage_name (die, cu);
+  /* Disallow the special Ada symbols.  */
+  if (!is_ada_import_or_export (cu, name, linkage_name))
+    return false;
+
+  /* A Pragma Import will be a declaration, while a Pragma Export will
+     not be.  */
+  if (!die_is_declaration (die, cu))
+    return false;
+
+  new_symbol (die, read_type_die (die, cu), cu);
+  return true;
+}
+
 static void
 read_func_scope (struct die_info *die, struct dwarf2_cu *cu)
 {
@@ -10060,6 +10090,14 @@ read_func_scope (struct die_info *die, struct dwarf2_cu *cu)
       return;
     }
 
+  if (check_ada_pragma_import (die, cu))
+    {
+      /* We already made the symbol for the Pragma Import, and because
+	 it is a declaration, we know it won't have any other
+	 important information, so we can simply return.  */
+      return;
+    }
+
   /* Ignore functions with missing or invalid low and high pc attributes.  */
   if (dwarf2_get_pc_bounds (die, &lowpc, &highpc, cu, nullptr, nullptr)
       <= PC_BOUNDS_INVALID)
@@ -18821,6 +18859,51 @@ var_decode_location (struct attribute *attr, struct symbol *sym,
     cu->has_loclist = true;
 }
 
+/* A helper function to add an "export" symbol.  The new symbol starts
+   as a clone of ORIG, but is modified to defer to the symbol named
+   ORIG_NAME.  The original symbol uses the name given in the source
+   code, and the symbol that is created here uses the linkage name as
+   its name.  See ada-imported.c.  */
+
+static void
+add_ada_export_symbol (struct symbol *orig, const char *new_name,
+		       const char *orig_name, struct dwarf2_cu *cu,
+		       struct pending **list_to_add)
+{
+  struct symbol *copy
+    = new (&cu->per_objfile->objfile->objfile_obstack) symbol (*orig);
+  copy->set_linkage_name (new_name);
+  SYMBOL_LOCATION_BATON (copy) = (void *) orig_name;
+  copy->set_aclass_index (copy->aclass () == LOC_BLOCK
+			  ? ada_block_index
+			  : ada_imported_index);
+  add_symbol_to_list (copy, list_to_add);
+}
+
+/* A helper function that decides if a given symbol is an Ada Pragma
+   Import or Pragma Export.  */
+
+static bool
+is_ada_import_or_export (dwarf2_cu *cu, const char *name,
+			 const char *linkagename)
+{
+  return (cu->lang () == language_ada
+	  && linkagename != nullptr
+	  && !streq (name, linkagename)
+	  /* The following exclusions are necessary because symbols
+	     with names or linkage names that match here will meet the
+	     other criteria but are not in fact caused by Pragma
+	     Import or Pragma Export, and applying the import/export
+	     treatment to them will introduce problems.  Some of these
+	     checks only apply to functions, but it is simpler and
+	     harmless to always do them all.  */
+	  && !startswith (name, "__builtin")
+	  && !startswith (linkagename, "___ghost_")
+	  && !startswith (linkagename, "__gnat")
+	  && !startswith (linkagename, "_ada_")
+	  && !streq (linkagename, "adainit"));
+}
+
 /* Given a pointer to a DWARF information entry, figure out if we need
    to make a symbol table entry for it, and if so, create a new entry
    and return a pointer to it.
@@ -18961,6 +19044,28 @@ new_symbol (struct die_info *die, struct type *type, struct dwarf2_cu *cu,
 	    {
 	      list_to_add = cu->list_in_scope;
 	    }
+
+	  if (is_ada_import_or_export (cu, name, linkagename))
+	    {
+	      /* This is either a Pragma Import or Export.  They can
+		 be distinguished by the declaration flag.  */
+	      sym->set_linkage_name (name);
+	      if (die_is_declaration (die, cu))
+		{
+		  /* For Import, create a symbol using the source
+		     name, and have it refer to the linkage name.  */
+		  SYMBOL_LOCATION_BATON (sym) = (void *) linkagename;
+		  sym->set_aclass_index (ada_block_index);
+		}
+	      else
+		{
+		  /* For Export, create a symbol using the source
+		     name, then create a second symbol that refers
+		     back to it.  */
+		  add_ada_export_symbol (sym, linkagename, name, cu,
+					 list_to_add);
+		}
+	    }
 	  break;
 	case DW_TAG_inlined_subroutine:
 	  /* SYMBOL_BLOCK_VALUE (sym) will be filled in later by
@@ -19053,6 +19158,15 @@ new_symbol (struct die_info *die, struct type *type, struct dwarf2_cu *cu,
 		}
 	      else
 		list_to_add = cu->list_in_scope;
+
+	      if (is_ada_import_or_export (cu, name, linkagename))
+		{
+		  /* This is a Pragma Export.  A Pragma Import won't
+		     be seen here, because it will not have a location
+		     and so will be handled below.  */
+		  add_ada_export_symbol (sym, name, linkagename, cu,
+					 list_to_add);
+		}
 	    }
 	  else
 	    {
@@ -19074,6 +19188,16 @@ new_symbol (struct die_info *die, struct type *type, struct dwarf2_cu *cu,
 		  if (!suppress_add)
 		    list_to_add = cu->list_in_scope;
 		}
+	      else if (is_ada_import_or_export (cu, name, linkagename))
+		{
+		  /* This is a Pragma Import.  A Pragma Export won't
+		     be seen here, because it will have a location and
+		     so will be handled above.  */
+		  sym->set_linkage_name (name);
+		  list_to_add = cu->list_in_scope;
+		  SYMBOL_LOCATION_BATON (sym) = (void *) linkagename;
+		  sym->set_aclass_index (ada_imported_index);
+		}
 	      else if (attr2 != nullptr && attr2->as_boolean ()
 		       && dwarf2_attr (die, DW_AT_type, cu) != NULL)
 		{
@@ -21923,11 +22047,15 @@ the demangler."),
 							&dwarf2_locexpr_funcs);
   dwarf2_loclist_index = register_symbol_computed_impl (LOC_COMPUTED,
 							&dwarf2_loclist_funcs);
+  ada_imported_index = register_symbol_computed_impl (LOC_COMPUTED,
+						      &ada_imported_funcs);
 
   dwarf2_locexpr_block_index = register_symbol_block_impl (LOC_BLOCK,
 					&dwarf2_block_frame_base_locexpr_funcs);
   dwarf2_loclist_block_index = register_symbol_block_impl (LOC_BLOCK,
 					&dwarf2_block_frame_base_loclist_funcs);
+  ada_block_index = register_symbol_block_impl (LOC_BLOCK,
+						&ada_function_alias_funcs);
 
 #if GDB_SELF_TEST
   selftests::register_test ("dw2_expand_symtabs_matching",

gdb/testsuite/gdb.ada/complete.exp

@@ -160,6 +160,7 @@ test_gdb_complete "pck" \
                               "p pck.ambiguous_func" \
                               "p pck.external_identical_one" \
                               "p pck.inner.inside_variable" \
+			      "p pck.internal_capitalized" \
                               "p pck.local_identical_one" \
                               "p pck.local_identical_two" \
                               "p pck.my_global_variable" \
@@ -172,6 +173,7 @@ test_gdb_complete "pck." \
                               "p pck.ambiguous_func" \
                               "p pck.external_identical_one" \
                               "p pck.inner.inside_variable" \
+			      "p pck.internal_capitalized" \
                               "p pck.local_identical_one" \
                               "p pck.local_identical_two" \
                               "p pck.my_global_variable" \

gdb/testsuite/gdb.ada/complete/pck.ads

@@ -17,8 +17,8 @@ package Pck is
 
    My_Global_Variable : Integer := 1;
 
-   Exported_Capitalized : Integer := 2;
-   pragma Export (C, Exported_Capitalized, "Exported_Capitalized");
+   Internal_Capitalized : Integer := 2;
+   pragma Export (C, Internal_Capitalized, "Exported_Capitalized");
 
    Local_Identical_One : Integer := 4;
    Local_Identical_Two : Integer := 8;

gdb/testsuite/gdb.ada/import.exp

@@ -0,0 +1,58 @@
+# Copyright 2023 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+load_lib "ada.exp"
+
+require allow_ada_tests
+
+standard_ada_testfile prog
+
+set cfile "inc"
+set csrcfile ${srcdir}/${subdir}/${testdir}/${cfile}.c
+set cobject [standard_output_file ${cfile}.o]
+
+if {[gdb_compile "${csrcfile}" "${cobject}" object debug] != ""} {
+    untested "could not compile C file"
+    return
+}
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable \
+	 [list debug additional_flags=-largs \
+	      additional_flags=${cobject} additional_flags=-margs]] != ""} {
+    return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "BREAK" ${testdir}/prog.adb]
+runto "prog.adb:$bp_location"
+
+gdb_test "print ordinary_var" " = 78"
+
+gdb_test "print imported_var" " = 42"
+gdb_test "print imported_var_ada" " = 42"
+gdb_test "print local_imported_var" " = 42"
+gdb_test "print pkg.imported_var_ada" " = 42"
+
+gdb_test "print pkg.exported_var_ada" " = 99"
+gdb_test "print exported_var_ada" " = 99"
+
+gdb_breakpoint "pkg.imported_func_ada" message
+gdb_breakpoint "imported_func" message
+gdb_breakpoint "imported_func_ada" message
+
+gdb_breakpoint "local_imported_func" message
+gdb_breakpoint "pkg.exported_func_ada" message
+gdb_breakpoint "exported_func_ada" message
+gdb_breakpoint "exported_func" message

gdb/testsuite/gdb.ada/import/inc.c

@@ -0,0 +1,27 @@
+/* Copyright 2023 Free Software Foundation, Inc.
+
+   This file is part of GDB.
+
+   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 this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+extern int exported_var;
+extern int exported_func (void);
+
+int imported_var = 42;
+
+int
+imported_func (void)
+{
+  return exported_var + exported_func ();
+}

gdb/testsuite/gdb.ada/import/pkg.adb

@@ -0,0 +1,28 @@
+--  Copyright 2023 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+package body Pkg is
+
+   function Exported_Func_Ada return Integer is
+   begin
+      return Imported_Var_Ada;
+   end Exported_Func_Ada;
+
+   procedure Do_Nothing (A : System.Address) is
+   begin
+      null;
+   end Do_Nothing;
+
+end Pkg;

gdb/testsuite/gdb.ada/import/pkg.ads

@@ -0,0 +1,33 @@
+--  Copyright 2023 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+with System;
+package Pkg is
+
+   Imported_Var_Ada : Integer;
+   pragma Import (C, Imported_Var_Ada, "imported_var");
+
+   function Imported_Func_Ada return Integer;
+   pragma Import (C, Imported_Func_Ada, "imported_func");
+
+   Exported_Var_Ada : Integer := 99;
+   pragma Export (C, Exported_Var_Ada, "exported_var");
+
+   function Exported_Func_Ada return Integer;
+   pragma Export (C, Exported_Func_Ada, "exported_func");
+
+   procedure Do_Nothing (A : System.Address);
+
+end Pkg;

gdb/testsuite/gdb.ada/import/prog.adb

@@ -0,0 +1,31 @@
+--  Copyright 2023 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+with Pkg;
+
+procedure Prog is
+   Ordinary_Var : Integer := 78;
+
+   Local_Imported_Var : Integer;
+   pragma Import (C, Local_Imported_Var, "imported_var");
+
+   function Local_Imported_Func return Integer;
+   pragma Import (C, Local_Imported_Func, "imported_func");
+begin
+   Local_Imported_Var := Local_Imported_Func;  --  BREAK
+   Pkg.Imported_Var_Ada := Pkg.Imported_Func_Ada;
+   Pkg.Do_Nothing (Pkg.Imported_Func_Ada'Address);
+   Pkg.Do_Nothing (Pkg.Exported_Func_Ada'Address);
+end Prog;

gdb/testsuite/gdb.ada/info_auto_lang.exp

@@ -51,8 +51,14 @@ if {![runto "some_c.c:$bp_location"]} {
 
 set func_in_c(c_syntax)      "${decimal}:	void proc_in_c\\\(void\\\);"
 set func_in_c(ada_syntax)    "${decimal}:	procedure proc_in_c;"
-set func_in_ada(c_syntax)    "${decimal}:	void proc_in_ada\\\(void\\\);"
-set func_in_ada(ada_syntax)  "${decimal}:	procedure proc_in_ada;"
+set func_in_ada(c_syntax) \
+    [string cat \
+	 "${decimal}:	void proc_in_ada\\\(void\\\);\r\n" \
+	 "${decimal}:	void proc_in_ada.something_in_c\\\(void\\\);"]
+set func_in_ada(ada_syntax) \
+    [string cat \
+	 "${decimal}:	procedure proc_in_ada;\r\n" \
+	 "${decimal}:	procedure proc_in_ada.something_in_c;"]
 
 set type_in_c(c_syntax) "${decimal}:	typedef struct {\\.\\.\\.} some_type_in_c;"
 set type_in_c(ada_syntax) [multi_line \