New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45959 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 437 insertions, 0 deletions

diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb
new file mode 100644
index 00000000000..800a5e82dc4
--- /dev/null
+++ b/gcc/ada/sem_mech.adb
@@ -0,0 +1,437 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ M E C H                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--          Copyright (C) 1996-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT 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  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Targparm; use Targparm;
+with Nlists;   use Nlists;
+with Sem;      use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+
+package body Sem_Mech is
+
+   -------------------------
+   -- Set_Mechanism_Value --
+   -------------------------
+
+   procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
+      Class : Node_Id;
+      Param : Node_Id;
+
+      procedure Bad_Class;
+      --  Signal bad descriptor class name
+
+      procedure Bad_Mechanism;
+      --  Signal bad mechanism name
+
+      procedure Bad_Class is
+      begin
+         Error_Msg_N ("unrecognized descriptor class name", Class);
+      end Bad_Class;
+
+      procedure Bad_Mechanism is
+      begin
+         Error_Msg_N ("unrecognized mechanism name", Mech_Name);
+      end Bad_Mechanism;
+
+   --  Start of processing for Set_Mechanism_Value
+
+   begin
+      if Mechanism (Ent) /= Default_Mechanism then
+         Error_Msg_NE
+           ("mechanism for & has already been set", Mech_Name, Ent);
+      end if;
+
+      --  MECHANISM_NAME ::= value | reference | descriptor
+
+      if Nkind (Mech_Name) = N_Identifier then
+         if Chars (Mech_Name) = Name_Value then
+            Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name);
+            return;
+
+         elsif Chars (Mech_Name) = Name_Reference then
+            Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name);
+            return;
+
+         elsif Chars (Mech_Name) = Name_Descriptor then
+            Check_VMS (Mech_Name);
+            Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name);
+            return;
+
+         elsif Chars (Mech_Name) = Name_Copy then
+            Error_Msg_N
+              ("bad mechanism name, Value assumed", Mech_Name);
+            Set_Mechanism (Ent, By_Copy);
+
+         else
+            Bad_Mechanism;
+            return;
+         end if;
+
+      --  MECHANISM_NAME ::= descriptor (CLASS_NAME)
+      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
+
+      --  Note: this form is parsed as an indexed component
+
+      elsif Nkind (Mech_Name) = N_Indexed_Component then
+         Class := First (Expressions (Mech_Name));
+
+         if Nkind (Prefix (Mech_Name)) /= N_Identifier
+           or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
+           or else Present (Next (Class))
+         then
+            Bad_Mechanism;
+            return;
+         end if;
+
+      --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
+
+      --  Note: this form is parsed as a function call
+
+      elsif Nkind (Mech_Name) = N_Function_Call then
+
+         Param := First (Parameter_Associations (Mech_Name));
+
+         if Nkind (Name (Mech_Name)) /= N_Identifier
+           or else Chars (Name (Mech_Name)) /= Name_Descriptor
+           or else Present (Next (Param))
+           or else No (Selector_Name (Param))
+           or else Chars (Selector_Name (Param)) /= Name_Class
+         then
+            Bad_Mechanism;
+            return;
+         else
+            Class := Explicit_Actual_Parameter (Param);
+         end if;
+
+      else
+         Bad_Mechanism;
+         return;
+      end if;
+
+      --  Fall through here with Class set to descriptor class name
+
+      Check_VMS (Mech_Name);
+
+      if Nkind (Class) /= N_Identifier then
+         Bad_Class;
+         return;
+
+      elsif Chars (Class) = Name_UBS then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS,  Mech_Name);
+
+      elsif Chars (Class) = Name_UBSB then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
+
+      elsif Chars (Class) = Name_UBA then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA,  Mech_Name);
+
+      elsif Chars (Class) = Name_S then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_S,    Mech_Name);
+
+      elsif Chars (Class) = Name_SB then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_SB,   Mech_Name);
+
+      elsif Chars (Class) = Name_A then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_A,    Mech_Name);
+
+      elsif Chars (Class) = Name_NCA then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA,  Mech_Name);
+
+      else
+         Bad_Class;
+         return;
+      end if;
+
+   end Set_Mechanism_Value;
+
+   -------------------------------
+   -- Set_Mechanism_With_Checks --
+   -------------------------------
+
+   procedure Set_Mechanism_With_Checks
+     (Ent  : Entity_Id;
+      Mech : Mechanism_Type;
+      Enod : Node_Id)
+   is
+   begin
+      --  Right now we only do some checks for functions returning arguments
+      --  by desctiptor. Probably mode checks need to be added here ???
+
+      if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
+         if Is_Record_Type (Etype (Ent)) then
+            Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
+            return;
+         end if;
+      end if;
+
+      --  If we fall through, all checks have passed
+
+      Set_Mechanism (Ent, Mech);
+   end Set_Mechanism_With_Checks;
+
+   --------------------
+   -- Set_Mechanisms --
+   --------------------
+
+   procedure Set_Mechanisms (E : Entity_Id) is
+      Formal : Entity_Id;
+      Typ    : Entity_Id;
+
+   begin
+      --  Skip this processing if inside a generic template. Not only is
+      --  it uneccessary (since neither extra formals nor mechanisms are
+      --  relevant for the template itself), but at least at the moment,
+      --  procedures get frozen early inside a template so attempting to
+      --  look at the formal types does not work too well if they are
+      --  private types that have not been frozen yet.
+
+      if Inside_A_Generic then
+         return;
+      end if;
+
+      --  Loop through formals
+
+      Formal := First_Formal (E);
+      while Present (Formal) loop
+
+         if Mechanism (Formal) = Default_Mechanism then
+            Typ := Underlying_Type (Etype (Formal));
+
+            --  If there is no underlying type, then skip this processing and
+            --  leave the convention set to Default_Mechanism. It seems odd
+            --  that there should ever be such cases but there are (see
+            --  comments for filed regression tests 1418-001 and 1912-009) ???
+
+            if No (Typ) then
+               goto Skip_Formal;
+            end if;
+
+            case Convention (E) is
+
+               ---------
+               -- Ada --
+               ---------
+
+               --  Note: all RM defined conventions are treated the same
+               --  from the point of view of parameter passing mechanims
+
+               when Convention_Ada       |
+                    Convention_Intrinsic |
+                    Convention_Entry     |
+                    Convention_Protected |
+                    Convention_Stubbed   =>
+
+                  --  By reference types are passed by reference (RM 6.2(4))
+
+                  if Is_By_Reference_Type (Typ) then
+                     Set_Mechanism (Formal, By_Reference);
+
+                  --  By copy types are passed by copy (RM 6.2(3))
+
+                  elsif Is_By_Copy_Type (Typ) then
+                     Set_Mechanism (Formal, By_Copy);
+
+                  --  All other types we leave the Default_Mechanism set, so
+                  --  that the backend can choose the appropriate method.
+
+                  else
+                     null;
+                  end if;
+
+               -------
+               -- C --
+               -------
+
+               --  Note: Assembler, C++, Java, Stdcall also use C conventions
+
+               when Convention_Assembler |
+                    Convention_C         |
+                    Convention_CPP       |
+                    Convention_Java      |
+                    Convention_Stdcall   =>
+
+                  --  The following values are passed by copy
+
+                  --    IN Scalar parameters (RM B.3(66))
+                  --    IN parameters of access types (RM B.3(67))
+                  --    Access parameters (RM B.3(68))
+                  --    Access to subprogram types (RM B.3(71))
+
+                  --  Note: in the case of access parameters, it is the
+                  --  pointer that is passed by value. In GNAT access
+                  --  parameters are treated as IN parameters of an
+                  --  anonymous access type, so this falls out free.
+
+                  --  The bottom line is that all IN elementary types
+                  --  are passed by copy in GNAT.
+
+                  if Is_Elementary_Type (Typ) then
+                     if Ekind (Formal) = E_In_Parameter then
+                        Set_Mechanism (Formal, By_Copy);
+
+                     --  OUT and IN OUT parameters of elementary types are
+                     --  passed by reference (RM B.3(68)). Note that we are
+                     --  not following the advice to pass the address of a
+                     --  copy to preserve by copy semantics.
+
+                     else
+                        Set_Mechanism (Formal, By_Reference);
+                     end if;
+
+                  --  Records are normally passed by reference (RM B.3(69)).
+                  --  However, this can be overridden by the use of the
+                  --  C_Pass_By_Copy pragma or C_Pass_By_Copy convention.
+
+                  elsif Is_Record_Type (Typ) then
+
+                     --  If the record is not convention C, then we always
+                     --  pass by reference, C_Pass_By_Copy does not apply.
+
+                     if Convention (Typ) /= Convention_C then
+                        Set_Mechanism (Formal, By_Reference);
+
+                     --  If convention C_Pass_By_Copy was specified for
+                     --  the record type, then we pass by copy.
+
+                     elsif C_Pass_By_Copy (Typ) then
+                        Set_Mechanism (Formal, By_Copy);
+
+                     --  Otherwise, for a C convention record, we set the
+                     --  convention in accordance with a possible use of
+                     --  the C_Pass_By_Copy pragma. Note that the value of
+                     --  Default_C_Record_Mechanism in the absence of such
+                     --  a pragma is By_Reference.
+
+                     else
+                        Set_Mechanism (Formal, Default_C_Record_Mechanism);
+                     end if;
+
+                  --  Array types are passed by reference (B.3 (71))
+
+                  elsif Is_Array_Type (Typ) then
+                     Set_Mechanism (Formal, By_Reference);
+
+                  --  For all other types, use Default_Mechanism mechanism
+
+                  else
+                     null;
+                  end if;
+
+               -----------
+               -- COBOL --
+               -----------
+
+               when Convention_COBOL =>
+
+                  --  Access parameters (which in GNAT look like IN parameters
+                  --  of an access type) are passed by copy (RM B.4(96)) as
+                  --  are all other IN parameters of scalar type (RM B.4(97)).
+
+                  --  For now we pass these parameters by reference as well.
+                  --  The RM specifies the intent BY_CONTENT, but gigi does
+                  --  not currently transform By_Copy properly. If we pass by
+                  --  reference, it will be imperative to introduce copies ???
+
+                  if Is_Elementary_Type (Typ)
+                    and then Ekind (Formal) = E_In_Parameter
+                  then
+                     Set_Mechanism (Formal, By_Reference);
+
+                  --  All other parameters (i.e. all non-scalar types, and
+                  --  all OUT or IN OUT parameters) are passed by reference.
+                  --  Note that at the moment we are not bothering to make
+                  --  copies of scalar types as recommended in the RM.
+
+                  else
+                     Set_Mechanism (Formal, By_Reference);
+                  end if;
+
+               -------------
+               -- Fortran --
+               -------------
+
+               when Convention_Fortran =>
+
+                  --  In OpenVMS, pass a character of array of character
+                  --  value using Descriptor(S). Should this also test
+                  --  Debug_Flag_M ???
+
+                  if OpenVMS_On_Target
+                    and then (Root_Type (Typ) = Standard_Character
+                               or else
+                                 (Is_Array_Type (Typ)
+                                   and then
+                                     Root_Type (Component_Type (Typ)) =
+                                                     Standard_Character))
+                  then
+                     Set_Mechanism (Formal, By_Descriptor_S);
+
+                  --  Access types are passed by default (presumably this
+                  --  will mean they are passed by copy)
+
+                  elsif Is_Access_Type (Typ) then
+                     null;
+
+                  --  For now, we pass all other parameters by reference.
+                  --  It is not clear that this is right in the long run,
+                  --  but it seems to correspond to what gnu f77 wants.
+
+
+                  else
+                     Set_Mechanism (Formal, By_Reference);
+                  end if;
+
+            end case;
+         end if;
+
+         <<Skip_Formal>> -- remove this when problem above is fixed ???
+
+         Next_Formal (Formal);
+      end loop;
+
+      --  Now deal with return type, we always leave the default mechanism
+      --  set except for the case of returning a By_Reference type for an
+      --  Ada convention, where we force return by reference
+
+      if Ekind (E) = E_Function
+        and then Mechanism (E) = Default_Mechanism
+        and then not Has_Foreign_Convention (E)
+        and then Is_By_Reference_Type (Etype (E))
+      then
+         Set_Mechanism (E, By_Reference);
+      end if;
+
+   end Set_Mechanisms;
+
+end Sem_Mech;