+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S E M _ M E C H --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- 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. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
projects / msp430-gcc.git / blobdiff