| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
