blob: cf362241fb6340c8c5dd53f783d38429d3dcd705 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ M E C H --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2003 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).
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;
-- Note: there is nothing we need to do for the return type here.
-- We deal with returning by reference in the Ada sense, by use of
-- the flag By_Ref, rather than by messing with mechanisms.
-- A mechanism of Reference for the return means that an extra
-- parameter must be provided for the return value (that is the
-- DEC meaning of the pragma), and is unrelated to the Ada notion
-- of return by reference.
-- Note: there was originally code here to set the mechanism to
-- By_Reference for types that are "by reference" in the Ada sense,
-- but, in accordance with the discussion above, this is wrong, and
-- the code was removed.
end Set_Mechanisms;
end Sem_Mech;