diff options
121 files changed, 111795 insertions, 0 deletions
diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb new file mode 100644 index 00000000000..366d7c59f49 --- /dev/null +++ b/gcc/ada/back_end.adb @@ -0,0 +1,283 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B A C K _ E N D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.23 $ +-- -- +-- Copyright (C) 1992-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 Debug; use Debug; +with Elists; use Elists; +with Lib; use Lib; +with Osint; use Osint; +with Opt; use Opt; +with Osint; use Osint; +with Namet; use Namet; +with Nlists; use Nlists; +with Stand; use Stand; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Switch; use Switch; +with System; use System; +with Types; use Types; + +package body Back_End is + + -- Local subprograms + + ------------------- + -- Call_Back_End -- + ------------------- + + procedure Call_Back_End (Mode : Back_End_Mode_Type) is + + -- The File_Record type has a lot of components that are meaningless + -- to the back end, so a new record is created here to contain the + -- needed information for each file. + + type Needed_File_Info_Type is record + File_Name : File_Name_Type; + First_Sloc : Source_Ptr; + Last_Sloc : Source_Ptr; + Num_Source_Lines : Nat; + end record; + + File_Info_Array : + array (Main_Unit .. Last_Unit) of Needed_File_Info_Type; + + procedure gigi ( + gnat_root : Int; + max_gnat_node : Int; + number_name : Nat; + nodes_ptr : Address; + + next_node_ptr : Address; + prev_node_ptr : Address; + elists_ptr : Address; + elmts_ptr : Address; + + strings_ptr : Address; + string_chars_ptr : Address; + list_headers_ptr : Address; + number_units : Int; + + file_info_ptr : Address; + gigi_standard_integer : Entity_Id; + gigi_standard_long_long_float : Entity_Id; + gigi_standard_exception_type : Entity_Id; + gigi_operating_mode : Back_End_Mode_Type); + + pragma Import (C, gigi); + + S : Source_File_Index; + + begin + -- Skip call if in -gnatdH mode + + if Debug_Flag_HH then + return; + end if; + + for J in Main_Unit .. Last_Unit loop + S := Source_Index (J); + File_Info_Array (J).File_Name := File_Name (S); + File_Info_Array (J).First_Sloc := Source_Text (S)'First; + File_Info_Array (J).Last_Sloc := Source_Text (S)'Last; + File_Info_Array (J).Num_Source_Lines := Num_Source_Lines (S); + end loop; + + gigi ( + gnat_root => Int (Cunit (Main_Unit)), + max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1), + number_name => Name_Entries_Count, + nodes_ptr => Nodes_Address, + + next_node_ptr => Next_Node_Address, + prev_node_ptr => Prev_Node_Address, + elists_ptr => Elists_Address, + elmts_ptr => Elmts_Address, + + strings_ptr => Strings_Address, + string_chars_ptr => String_Chars_Address, + list_headers_ptr => Lists_Address, + number_units => Num_Units, + + file_info_ptr => File_Info_Array'Address, + gigi_standard_integer => Standard_Integer, + gigi_standard_long_long_float => Standard_Long_Long_Float, + gigi_standard_exception_type => Standard_Exception_Type, + gigi_operating_mode => Mode); + end Call_Back_End; + + ----------------------------- + -- Scan_Compiler_Arguments -- + ----------------------------- + + procedure Scan_Compiler_Arguments is + + Next_Arg : Pos := 1; + + subtype Big_String is String (Positive); + type BSP is access Big_String; + + type Arg_Array is array (Nat) of BSP; + type Arg_Array_Ptr is access Arg_Array; + + -- Import flag_stack_check from toplev.c. + + flag_stack_check : Int; + pragma Import (C, flag_stack_check); -- Import from toplev.c + + save_argc : Nat; + pragma Import (C, save_argc); -- Import from toplev.c + + save_argv : Arg_Array_Ptr; + pragma Import (C, save_argv); -- Import from toplev.c + + Output_File_Name_Seen : Boolean := False; + -- Set to True after having scanned the file_name for + -- switch "-gnatO file_name" + + -- Local functions + + function Len_Arg (Arg : Pos) return Nat; + -- Determine length of argument number Arg on the original + -- command line from gnat1 + + procedure Scan_Back_End_Switches (Switch_Chars : String); + -- Procedure to scan out switches stored in Switch_Chars. The first + -- character is known to be a valid switch character, and there are no + -- blanks or other switch terminator characters in the string, so the + -- entire string should consist of valid switch characters, except that + -- an optional terminating NUL character is allowed. + -- + -- Back end switches have already been checked and processed by GCC + -- in toplev.c, so no errors can occur and control will always return. + -- The switches must still be scanned to skip the arguments of the + -- "-o" or the (undocumented) "-dumpbase" switch, by incrementing + -- the Next_Arg variable. The "-dumpbase" switch is used to set the + -- basename for GCC dumpfiles. + + ------------- + -- Len_Arg -- + ------------- + + function Len_Arg (Arg : Pos) return Nat is + begin + for J in 1 .. Nat'Last loop + if save_argv (Arg).all (Natural (J)) = ASCII.NUL then + return J - 1; + end if; + end loop; + + raise Program_Error; + end Len_Arg; + + ---------------------------- + -- Scan_Back_End_Switches -- + ---------------------------- + + procedure Scan_Back_End_Switches (Switch_Chars : String) is + First : constant Positive := Switch_Chars'First + 1; + Last : Natural := Switch_Chars'Last; + + begin + if Last >= First + and then Switch_Chars (Last) = ASCII.NUL + then + Last := Last - 1; + end if; + + if Switch_Chars (First .. Last) = "o" + or else Switch_Chars (First .. Last) = "dumpbase" + + then + Next_Arg := Next_Arg + 1; + + elsif Switch_Chars (First .. Last) = "quiet" then + null; -- do not record this switch + + else + -- Store any other GCC switches + Store_Compilation_Switch (Switch_Chars); + end if; + end Scan_Back_End_Switches; + + -- Start of processing for Scan_Compiler_Arguments + + begin + -- Acquire stack checking mode directly from GCC + + Opt.Stack_Checking_Enabled := (flag_stack_check /= 0); + + -- Loop through command line arguments, storing them for later access + + while Next_Arg < save_argc loop + + Look_At_Arg : declare + Argv_Ptr : constant BSP := save_argv (Next_Arg); + Argv_Len : constant Nat := Len_Arg (Next_Arg); + Argv : String := Argv_Ptr (1 .. Natural (Argv_Len)); + + begin + -- If the previous switch has set the Output_File_Name_Present + -- flag (that is we have seen a -gnatO), then the next argument + -- is the name of the output object file. + + if Output_File_Name_Present + and then not Output_File_Name_Seen + then + if Is_Switch (Argv) then + Fail ("Object file name missing after -gnatO"); + + else + Set_Output_Object_File_Name (Argv); + Output_File_Name_Seen := True; + end if; + + elsif not Is_Switch (Argv) then -- must be a file name + Add_File (Argv); + + elsif Is_Front_End_Switch (Argv) then + Scan_Front_End_Switches (Argv); + + -- ??? Should be done in Scan_Front_End_Switches, after + -- Switch is splitted in compiler/make/bind units + + if Argv (2) /= 'I' then + Store_Compilation_Switch (Argv); + end if; + + -- All non-front-end switches are back-end switches + + else + Scan_Back_End_Switches (Argv); + end if; + end Look_At_Arg; + + Next_Arg := Next_Arg + 1; + end loop; + end Scan_Compiler_Arguments; + +end Back_End; diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads new file mode 100644 index 00000000000..60da9aebdd5 --- /dev/null +++ b/gcc/ada/back_end.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B A C K _ E N D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Call the back end with all the information needed. Also contains other +-- back-end specific interfaces required by the front end. + +package Back_End is + + type Back_End_Mode_Type is ( + Generate_Object, + -- Full back end operation with object file generation + + Declarations_Only, + -- Partial back end operation with no object file generation. In this + -- mode the only useful action performed by gigi is to process all + -- declarations issuing any error messages (in partcicular those to + -- do with rep clauses), and to back annotate representation info. + + Skip); + -- Back end call is skipped (syntax only, or errors found) + + pragma Convention (C, Back_End_Mode_Type); + for Back_End_Mode_Type use (0, 1, 2); + + procedure Call_Back_End (Mode : Back_End_Mode_Type); + -- Call back end, i.e. make call to driver traversing the tree and + -- outputting code. This call is made with all tables locked. + -- The back end is responsible for unlocking any tables it may need + -- to change, and locking them again before returning. + + procedure Scan_Compiler_Arguments; + -- Acquires command-line parameters passed to the compiler and processes + -- them. Calls Scan_Front_End_Switches for any front-end switches + -- encountered. + -- + -- The processing of arguments is private to the back end, since + -- the way of acquiring the arguments as well as the set of allowable + -- back end switches is different depending on the particular back end + -- being used. + -- + -- Any processed switches that influence the result of a compilation + -- must be added to the Compilation_Arguments table. + +end Back_End; diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb new file mode 100644 index 00000000000..1d38f96153f --- /dev/null +++ b/gcc/ada/bcheck.adb @@ -0,0 +1,694 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B C H E C K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.39 $ +-- -- +-- Copyright (C) 1992-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 ALI; use ALI; +with ALI.Util; use ALI.Util; +with Binderr; use Binderr; +with Butil; use Butil; +with Casing; use Casing; +with Debug; use Debug; +with Fname; use Fname; +with Namet; use Namet; +with Opt; use Opt; +with Osint; +with Output; use Output; +with Rident; use Rident; +with Types; use Types; + +package body Bcheck is + + -- Local subprograms + + -- The following checking subprograms make up the parts + -- of the configuration consistency check. + + procedure Check_Consistent_Dynamic_Elaboration_Checking; + procedure Check_Consistent_Floating_Point_Format; + procedure Check_Consistent_Locking_Policy; + procedure Check_Consistent_Normalize_Scalars; + procedure Check_Consistent_Queuing_Policy; + procedure Check_Consistent_Zero_Cost_Exception_Handling; + procedure Check_Partition_Restrictions; + + procedure Consistency_Error_Msg (Msg : String); + -- Produce an error or a warning message, depending on whether + -- an inconsistent configuration is permitted or not. + + ------------------------------------ + -- Check_Consistent_Configuration -- + ------------------------------------ + + procedure Check_Configuration_Consistency is + begin + if Float_Format_Specified /= ' ' then + Check_Consistent_Floating_Point_Format; + end if; + + if Queuing_Policy_Specified /= ' ' then + Check_Consistent_Queuing_Policy; + end if; + + if Locking_Policy_Specified /= ' ' then + Check_Consistent_Locking_Policy; + end if; + + if Zero_Cost_Exceptions_Specified then + Check_Consistent_Zero_Cost_Exception_Handling; + end if; + + Check_Consistent_Normalize_Scalars; + Check_Consistent_Dynamic_Elaboration_Checking; + + Check_Partition_Restrictions; + end Check_Configuration_Consistency; + + --------------------------------------------------- + -- Check_Consistent_Dynamic_Elaboration_Checking -- + --------------------------------------------------- + + -- The rule here is that if a unit has dynamic elaboration checks, + -- then any unit it withs must meeting one of the following criteria: + + -- 1. There is a pragma Elaborate_All for the with'ed unit + -- 2. The with'ed unit was compiled with dynamic elaboration checks + -- 3. The with'ed unit has pragma Preelaborate or Pure + -- 4. It is an internal GNAT unit (including children of GNAT) + + procedure Check_Consistent_Dynamic_Elaboration_Checking is + begin + if Dynamic_Elaboration_Checks_Specified then + for U in First_Unit_Entry .. Units.Last loop + declare + UR : Unit_Record renames Units.Table (U); + + begin + if UR.Dynamic_Elab then + for W in UR.First_With .. UR.Last_With loop + declare + WR : With_Record renames Withs.Table (W); + + begin + if Get_Name_Table_Info (WR.Uname) /= 0 then + declare + WU : Unit_Record renames + Units.Table + (Unit_Id + (Get_Name_Table_Info (WR.Uname))); + + begin + -- Case 1. Elaborate_All for with'ed unit + + if WR.Elaborate_All then + null; + + -- Case 2. With'ed unit has dynamic elab checks + + elsif WU.Dynamic_Elab then + null; + + -- Case 3. With'ed unit is Preelaborate or Pure + + elsif WU.Preelab or WU.Pure then + null; + + -- Case 4. With'ed unit is internal file + + elsif Is_Internal_File_Name (WU.Sfile) then + null; + + -- Issue warning, not one of the safe cases + + else + Error_Msg_Name_1 := UR.Sfile; + Error_Msg + ("?% has dynamic elaboration checks " & + "and with's"); + + Error_Msg_Name_1 := WU.Sfile; + Error_Msg + ("? % which has static elaboration " & + "checks"); + + Warnings_Detected := Warnings_Detected - 1; + end if; + end; + end if; + end; + end loop; + end if; + end; + end loop; + end if; + end Check_Consistent_Dynamic_Elaboration_Checking; + + -------------------------------------------- + -- Check_Consistent_Floating_Point_Format -- + -------------------------------------------- + + -- The rule is that all files must be compiled with the same setting + -- for the floating-point format. + + procedure Check_Consistent_Floating_Point_Format is + begin + -- First search for a unit specifying a floating-point format and then + -- check all remaining units against it. + + Find_Format : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Float_Format /= ' ' then + Check_Format : declare + Format : constant Character := ALIs.Table (A1).Float_Format; + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Float_Format /= Format then + Error_Msg_Name_1 := ALIs.Table (A1).Sfile; + Error_Msg_Name_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("% and % compiled with different " & + "floating-point representations"); + exit Find_Format; + end if; + end loop; + end Check_Format; + + exit Find_Format; + end if; + end loop Find_Format; + end Check_Consistent_Floating_Point_Format; + + ------------------------------------- + -- Check_Consistent_Locking_Policy -- + ------------------------------------- + + -- The rule is that all files for which the locking policy is + -- significant must be compiled with the same setting. + + procedure Check_Consistent_Locking_Policy is + begin + -- First search for a unit specifying a policy and then + -- check all remaining units against it. + + Find_Policy : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Locking_Policy /= ' ' then + Check_Policy : declare + Policy : constant Character := ALIs.Table (A1).Locking_Policy; + + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Locking_Policy /= ' ' and + ALIs.Table (A2).Locking_Policy /= Policy + then + Error_Msg_Name_1 := ALIs.Table (A1).Sfile; + Error_Msg_Name_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("% and % compiled with different locking policies"); + exit Find_Policy; + end if; + end loop; + end Check_Policy; + + exit Find_Policy; + end if; + end loop Find_Policy; + end Check_Consistent_Locking_Policy; + + ---------------------------------------- + -- Check_Consistent_Normalize_Scalars -- + ---------------------------------------- + + -- The rule is that if any unit is compiled with Normalized_Scalars, + -- then all other units in the partition must also be compiled with + -- Normalized_Scalars in effect. + + -- There is some issue as to whether this consistency check is + -- desirable, it is certainly required at the moment by the RM. + -- We should keep a watch on the ARG and HRG deliberations here. + -- GNAT no longer depends on this consistency (it used to do so, + -- but that has been corrected in the latest version, since the + -- Initialize_Scalars pragma does not require consistency. + + procedure Check_Consistent_Normalize_Scalars is + begin + if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then + Consistency_Error_Msg + ("some but not all files compiled with Normalize_Scalars"); + + Write_Eol; + Write_Str ("files compiled with Normalize_Scalars"); + Write_Eol; + + for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Normalize_Scalars then + Write_Str (" "); + Write_Name (ALIs.Table (A1).Sfile); + Write_Eol; + end if; + end loop; + + Write_Eol; + Write_Str ("files compiled without Normalize_Scalars"); + Write_Eol; + + for A1 in ALIs.First .. ALIs.Last loop + if not ALIs.Table (A1).Normalize_Scalars then + Write_Str (" "); + Write_Name (ALIs.Table (A1).Sfile); + Write_Eol; + end if; + end loop; + end if; + end Check_Consistent_Normalize_Scalars; + + ------------------------------------- + -- Check_Consistent_Queuing_Policy -- + ------------------------------------- + + -- The rule is that all files for which the queuing policy is + -- significant must be compiled with the same setting. + + procedure Check_Consistent_Queuing_Policy is + begin + -- First search for a unit specifying a policy and then + -- check all remaining units against it. + + Find_Policy : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Queuing_Policy /= ' ' then + Check_Policy : declare + Policy : constant Character := ALIs.Table (A1).Queuing_Policy; + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Queuing_Policy /= ' ' + and then + ALIs.Table (A2).Queuing_Policy /= Policy + then + Error_Msg_Name_1 := ALIs.Table (A1).Sfile; + Error_Msg_Name_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("% and % compiled with different queuing policies"); + exit Find_Policy; + end if; + end loop; + end Check_Policy; + + exit Find_Policy; + end if; + end loop Find_Policy; + end Check_Consistent_Queuing_Policy; + + --------------------------------------------------- + -- Check_Consistent_Zero_Cost_Exception_Handling -- + --------------------------------------------------- + + -- Check consistent zero cost exception handling. The rule is that + -- all units must have the same exception handling mechanism. + + procedure Check_Consistent_Zero_Cost_Exception_Handling is + begin + Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop + if ALIs.Table (A1).Zero_Cost_Exceptions /= + ALIs.Table (ALIs.First).Zero_Cost_Exceptions + + then + Error_Msg_Name_1 := ALIs.Table (A1).Sfile; + Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile; + + Consistency_Error_Msg ("% and % compiled with different " + & "exception handling mechanisms"); + end if; + end loop Check_Mechanism; + end Check_Consistent_Zero_Cost_Exception_Handling; + + ---------------------------------- + -- Check_Partition_Restrictions -- + ---------------------------------- + + -- The rule is that if a restriction is specified in any unit, + -- then all units must obey the restriction. The check applies + -- only to restrictions which require partition wide consistency, + -- and not to internal units. + + -- The check is done in two steps. First for every restriction + -- a unit specifying that restriction is found, if any. + -- Second, all units are verified against the specified restrictions. + + procedure Check_Partition_Restrictions is + + R : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id); + -- Record the first unit specifying each partition restriction + + V : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id); + -- Record the last unit violating each partition restriction + + procedure List_Applicable_Restrictions; + -- Output a list of restrictions that may be applied to the partition, + -- without causing bind errors. + + ---------------------------------- + -- List_Applicable_Restrictions -- + ---------------------------------- + + procedure List_Applicable_Restrictions is + Additional_Restrictions_Listed : Boolean := False; + + begin + -- List any restrictions which were not violated and not specified + + for J in Partition_Restrictions loop + if V (J) = No_ALI_Id and R (J) = No_ALI_Id then + if not Additional_Restrictions_Listed then + Write_Str ("The following additional restrictions may be" & + " applied to this partition:"); + Write_Eol; + Additional_Restrictions_Listed := True; + end if; + + Write_Str ("pragma Restrictions ("); + + declare + S : constant String := Restriction_Id'Image (J); + + begin + Name_Len := S'Length; + Name_Buffer (1 .. Name_Len) := S; + end; + + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str (");"); + Write_Eol; + end if; + end loop; + end List_Applicable_Restrictions; + + -- Start of processing for Check_Partition_Restrictions + + begin + Find_Restrictions : + for A in ALIs.First .. ALIs.Last loop + for J in Partition_Restrictions loop + if R (J) = No_ALI_Id and ALIs.Table (A).Restrictions (J) = 'r' then + R (J) := A; + end if; + end loop; + end loop Find_Restrictions; + + Find_Violations : + for A in ALIs.First .. ALIs.Last loop + for J in Partition_Restrictions loop + if ALIs.Table (A).Restrictions (J) = 'v' + and then not Is_Internal_File_Name (ALIs.Table (A).Sfile) + then + -- A violation of a restriction was found, so check whether + -- that restriction was actually in effect. If so, give an + -- error message. + + -- Note that all such violations found are reported. + + V (J) := A; + + if R (J) /= No_ALI_Id then + Report_Violated_Restriction : declare + M1 : constant String := "% has Restriction ("; + S : constant String := Restriction_Id'Image (J); + M2 : String (1 .. M1'Length + S'Length + 1); + + begin + Name_Buffer (1 .. S'Length) := S; + Name_Len := S'Length; + Set_Casing + (Units.Table (ALIs.Table (R (J)).First_Unit).Icasing); + + M2 (M1'Range) := M1; + M2 (M1'Length + 1 .. M2'Last - 1) := + Name_Buffer (1 .. S'Length); + M2 (M2'Last) := ')'; + + Error_Msg_Name_1 := ALIs.Table (R (J)).Sfile; + Consistency_Error_Msg (M2); + Error_Msg_Name_1 := ALIs.Table (A).Sfile; + Consistency_Error_Msg + ("but file % violates this restriction"); + end Report_Violated_Restriction; + end if; + end if; + end loop; + end loop Find_Violations; + + if Debug_Flag_R then + List_Applicable_Restrictions; + end if; + end Check_Partition_Restrictions; + + ----------------------- + -- Check_Consistency -- + ----------------------- + + procedure Check_Consistency is + Src : Source_Id; + -- Source file Id for this Sdep entry + + begin + -- First, we go through the source table to see if there are any cases + -- in which we should go after source files and compute checksums of + -- the source files. We need to do this for any file for which we have + -- mismatching time stamps and (so far) matching checksums. + + for S in Source.First .. Source.Last loop + + -- If all time stamps for a file match, then there is nothing to + -- do, since we will not be checking checksums in that case anyway + + if Source.Table (S).All_Timestamps_Match then + null; + + -- If we did not find the source file, then we can't compute its + -- checksum anyway. Note that when we have a time stamp mismatch, + -- we try to find the source file unconditionally (i.e. if + -- Check_Source_Files is False). + + elsif not Source.Table (S).Source_Found then + null; + + -- If we already have non-matching or missing checksums, then no + -- need to try going after source file, since we won't trust the + -- checksums in any case. + + elsif not Source.Table (S).All_Checksums_Match then + null; + + -- Now we have the case where we have time stamp mismatches, and + -- the source file is around, but so far all checksums match. This + -- is the case where we need to compute the checksum from the source + -- file, since otherwise we would ignore the time stamp mismatches, + -- and that is wrong if the checksum of the source does not agree + -- with the checksums in the ALI files. + + elsif Check_Source_Files then + if Source.Table (S).Checksum /= + Get_File_Checksum (Source.Table (S).Sfile) + then + Source.Table (S).All_Checksums_Match := False; + end if; + end if; + end loop; + + -- Loop through ALI files + + ALIs_Loop : for A in ALIs.First .. ALIs.Last loop + + -- Loop through Sdep entries in one ALI file + + Sdep_Loop : for D in + ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep + loop + Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile)); + + -- If the time stamps match, or all checksums match, then we + -- are OK, otherwise we have a definite error. + + if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp + and then not Source.Table (Src).All_Checksums_Match + then + Error_Msg_Name_1 := ALIs.Table (A).Sfile; + Error_Msg_Name_2 := Sdep.Table (D).Sfile; + + -- Two styles of message, depending on whether or not + -- the updated file is the one that must be recompiled + + if Error_Msg_Name_1 = Error_Msg_Name_2 then + if Tolerate_Consistency_Errors then + Error_Msg + ("?% has been modified and should be recompiled"); + else + Error_Msg + ("% has been modified and must be recompiled"); + end if; + + else + if Tolerate_Consistency_Errors then + Error_Msg + ("?% should be recompiled (% has been modified)"); + + else + Error_Msg ("% must be recompiled (% has been modified)"); + end if; + end if; + + if (not Tolerate_Consistency_Errors) and Verbose_Mode then + declare + Msg : constant String := "file % has time stamp "; + Buf : String (1 .. Msg'Length + Time_Stamp_Length); + + begin + Buf (1 .. Msg'Length) := Msg; + Buf (Msg'Length + 1 .. Buf'Length) := + String (Source.Table (Src).Stamp); + Error_Msg_Name_1 := ALIs.Table (A).Sfile; + Error_Msg (Buf); + + Buf (Msg'Length + 1 .. Buf'Length) := + String (Sdep.Table (D).Stamp); + Error_Msg_Name_1 := Sdep.Table (D).Sfile; + Error_Msg (Buf); + end; + end if; + + -- Exit from the loop through Sdep entries once we find one + -- that does not match. + + exit Sdep_Loop; + end if; + + end loop Sdep_Loop; + end loop ALIs_Loop; + end Check_Consistency; + + ------------------------------- + -- Check_Duplicated_Subunits -- + ------------------------------- + + procedure Check_Duplicated_Subunits is + begin + for J in Sdep.First .. Sdep.Last loop + if Sdep.Table (J).Subunit_Name /= No_Name then + Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name); + Name_Len := Name_Len + 2; + Name_Buffer (Name_Len - 1) := '%'; + + -- See if there is a body or spec with the same name + + for K in Boolean loop + if K then + Name_Buffer (Name_Len) := 'b'; + + else + Name_Buffer (Name_Len) := 's'; + end if; + + declare + Info : constant Int := Get_Name_Table_Info (Name_Find); + + begin + if Info /= 0 then + Set_Standard_Error; + Write_Str ("error: subunit """); + Write_Name_Decoded (Sdep.Table (J).Subunit_Name); + Write_Str (""" in file """); + Write_Name_Decoded (Sdep.Table (J).Sfile); + Write_Char ('"'); + Write_Eol; + Write_Str (" has same name as unit """); + Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); + Write_Str (""" found in file """); + Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); + Write_Char ('"'); + Write_Eol; + Write_Str (" this is not allowed within a single " + & "partition (RM 10.2(19))"); + Write_Eol; + Osint.Exit_Program (Osint.E_Fatal); + end if; + end; + end loop; + end if; + end loop; + end Check_Duplicated_Subunits; + + -------------------- + -- Check_Versions -- + -------------------- + + procedure Check_Versions is + VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len; + + begin + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Ver_Len /= VL + or else ALIs.Table (A).Ver (1 .. VL) /= + ALIs.Table (ALIs.First).Ver (1 .. VL) + then + Error_Msg_Name_1 := ALIs.Table (A).Sfile; + Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile; + + Consistency_Error_Msg + ("% and % compiled with different GNAT versions"); + end if; + end loop; + end Check_Versions; + + --------------------------- + -- Consistency_Error_Msg -- + --------------------------- + + procedure Consistency_Error_Msg (Msg : String) is + begin + if Tolerate_Consistency_Errors then + + -- If consistency errors are tolerated, + -- output the message as a warning. + + declare + Warning_Msg : String (1 .. Msg'Length + 1); + + begin + Warning_Msg (1) := '?'; + Warning_Msg (2 .. Warning_Msg'Last) := Msg; + + Error_Msg (Warning_Msg); + end; + + -- Otherwise the consistency error is a true error + + else + Error_Msg (Msg); + end if; + end Consistency_Error_Msg; + +end Bcheck; diff --git a/gcc/ada/bcheck.ads b/gcc/ada/bcheck.ads new file mode 100644 index 00000000000..488580ce66d --- /dev/null +++ b/gcc/ada/bcheck.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B C H E C K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1992-1999 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). -- +-- -- +------------------------------------------------------------------------------ + +package Bcheck is + +-- This package contains the routines to perform binder consistency checks + + procedure Check_Duplicated_Subunits; + -- Check that no subunit names duplicate names of other packages in + -- the partition (check required by RM 10.2(19)). + + procedure Check_Versions; + -- Check correct library and standard versions used + + procedure Check_Consistency; + -- This procedure performs checks that the ALI files are consistent + -- with the corresponding source files and with one another. At the + -- time this is called, the Source table has been completely built and + -- contains either the time stamp from the actual source file if the + -- Check_Source_Files mode is set, or the latest stamp found in any of + -- the ALI files in the program. + + procedure Check_Configuration_Consistency; + -- This procedure performs a similar check that configuration pragma + -- set items that are required to be consistent are in fact consistent + +end Bcheck; diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb new file mode 100644 index 00000000000..bce3507a893 --- /dev/null +++ b/gcc/ada/binde.adb @@ -0,0 +1,1296 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.41 $ +-- -- +-- Copyright (C) 1992-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 Binderr; use Binderr; +with Butil; use Butil; +with Debug; use Debug; +with Fname; use Fname; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; + +package body Binde is + + -- The following data structures are used to represent the graph that is + -- used to determine the elaboration order (using a topological sort). + + -- The following structures are used to record successors. If A is a + -- successor of B in this table, it means that A must be elaborated + -- before B is elaborated. + + type Successor_Id is new Nat; + -- Identification of single successor entry + + No_Successor : constant Successor_Id := 0; + -- Used to indicate end of list of successors + + type Elab_All_Id is new Nat; + -- Identification of Elab_All entry link + + No_Elab_All_Link : constant Elab_All_Id := 0; + -- Used to indicate end of list + + -- Succ_Reason indicates the reason for a particular elaboration link + + type Succ_Reason is + (Withed, + -- After directly with's Before, so the spec of Before must be + -- elaborated before After is elaborated. + + Elab, + -- After directly mentions Before in a pragma Elaborate, so the + -- body of Before must be elaborate before After is elaborated. + + Elab_All, + -- After either mentions Before directly in a pragma Elaborate_All, + -- or mentions a third unit, X, which itself requires that Before be + -- elaborated before unit X is elaborated. The Elab_All_Link list + -- traces the dependencies in the latter case. + + Elab_Desirable, + -- This is just like Elab_All, except that the elaborate all was not + -- explicitly present in the source, but rather was created by the + -- front end, which decided that it was "desirable". + + Spec_First); + -- After is a body, and Before is the corresponding spec + + -- Successor_Link contains the information for one link + + type Successor_Link is record + Before : Unit_Id; + -- Predecessor unit + + After : Unit_Id; + -- Successor unit + + Next : Successor_Id; + -- Next successor on this list + + Reason : Succ_Reason; + -- Reason for this link + + Elab_Body : Boolean; + -- Set True if this link is needed for the special Elaborate_Body + -- processing described below. + + Reason_Unit : Unit_Id; + -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit + -- containing the pragma leading to the link. + + Elab_All_Link : Elab_All_Id; + -- If Reason = Elab_All or Elab_Desirable, then this points to the + -- first elment in a list of Elab_All entries that record the with + -- chain leading resulting in this particular dependency. + + end record; + + -- Note on handling of Elaborate_Body. Basically, if we have a pragma + -- Elaborate_Body in a unit, it means that the spec and body have to + -- be handled as a single entity from the point of view of determining + -- an elaboration order. What we do is to essentially remove the body + -- from consideration completely, and transfer all its links (other + -- than the spec link) to the spec. Then when then the spec gets chosen, + -- we choose the body right afterwards. We mark the links that get moved + -- from the body to the spec by setting their Elab_Body flag True, so + -- that we can understand what is going on! + + Succ_First : constant := 1; + + package Succ is new Table.Table ( + Table_Component_Type => Successor_Link, + Table_Index_Type => Successor_Id, + Table_Low_Bound => Succ_First, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "Succ"); + + -- For the case of Elaborate_All, the following table is used to record + -- chains of with relationships that lead to the Elab_All link. These + -- are used solely for diagnostic purposes + + type Elab_All_Entry is record + Needed_By : Unit_Name_Type; + -- Name of unit from which referencing unit was with'ed or otherwise + -- needed as a result of Elaborate_All or Elaborate_Desirable. + + Next_Elab : Elab_All_Id; + -- Link to next entry on chain (No_Elab_All_Link marks end of list) + end record; + + package Elab_All_Entries is new Table.Table ( + Table_Component_Type => Elab_All_Entry, + Table_Index_Type => Elab_All_Id, + Table_Low_Bound => 1, + Table_Initial => 2000, + Table_Increment => 200, + Table_Name => "Elab_All_Entries"); + + -- A Unit_Node record is built for each active unit + + type Unit_Node_Record is record + + Successors : Successor_Id; + -- Pointer to list of links for successor nodes + + Num_Pred : Int; + -- Number of predecessors for this unit. Normally non-negative, but + -- can go negative in the case of units chosen by the diagnose error + -- procedure (when cycles are being removed from the graph). + + Nextnp : Unit_Id; + -- Forward pointer for list of units with no predecessors + + Elab_Order : Nat; + -- Position in elaboration order (zero = not placed yet) + + Visited : Boolean; + -- Used in computing transitive closure for elaborate all and + -- also in locating cycles and paths in the diagnose routines. + + Elab_Position : Natural; + -- Initialized to zero. Set non-zero when a unit is chosen and + -- placed in the elaboration order. The value represents the + -- ordinal position in the elaboration order. + + end record; + + package UNR is new Table.Table ( + Table_Component_Type => Unit_Node_Record, + Table_Index_Type => Unit_Id, + Table_Low_Bound => First_Unit_Entry, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "UNR"); + + No_Pred : Unit_Id; + -- Head of list of items with no predecessors + + Num_Left : Int; + -- Number of entries not yet dealt with + + Cur_Unit : Unit_Id; + -- Current unit, set by Gather_Dependencies, and picked up in Build_Link + -- to set the Reason_Unit field of the created dependency link. + + Num_Chosen : Natural := 0; + -- Number of units chosen in the elaboration order so far + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Better_Choice (U1, U2 : Unit_Id) return Boolean; + -- U1 and U2 are both permitted candidates for selection as the next unit + -- to be elaborated. This function determines whether U1 is a better choice + -- than U2, i.e. should be elaborated in preference to U2, based on a set + -- of heuristics that establish a friendly and predictable order (see body + -- for details). The result is True if U1 is a better choice than U2, and + -- False if it is a worse choice, or there is no preference between them. + + procedure Build_Link + (Before : Unit_Id; + After : Unit_Id; + R : Succ_Reason; + Ea_Id : Elab_All_Id := No_Elab_All_Link); + -- Establish a successor link, Before must be elaborated before After, + -- and the reason for the link is R. Ea_Id is the contents to be placed + -- in the Elab_All_Link of the entry. + + procedure Choose (Chosen : Unit_Id); + -- Chosen is the next entry chosen in the elaboration order. This + -- procedure updates all data structures appropriately. + + function Corresponding_Body (U : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Body); + -- Given a unit which is a spec for which there is a separate body, + -- return the unit id of the body. It is an error to call this routine + -- with a unit that is not a spec, or which does not have a separate body. + + function Corresponding_Spec (U : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Spec); + -- Given a unit which is a body for which there is a separate spec, + -- return the unit id of the spec. It is an error to call this routine + -- with a unit that is not a body, or which does not have a separate spec. + + procedure Diagnose_Elaboration_Problem; + -- Called when no elaboration order can be found. Outputs an appropriate + -- diagnosis of the problem, and then abandons the bind. + + procedure Elab_All_Links + (Before : Unit_Id; + After : Unit_Id; + Reason : Succ_Reason; + Link : Elab_All_Id); + -- Used to compute the transitive closure of elaboration links for an + -- Elaborate_All pragma (Reason = Elab_All) or for an indication of + -- Elaborate_All_Desirable (Reason = Elab_Desirable). Unit After has + -- a pragma Elaborate_All or the front end has determined that a reference + -- probably requires Elaborate_All is required, and unit Before must be + -- previously elaborated. First a link is built making sure that unit + -- Before is elaborated before After, then a recursive call ensures that + -- we also build links for any units needed by Before (i.e. these units + -- must/should also be elaborated before After). Link is used to build + -- a chain of Elab_All_Entries to explain the reason for a link. The + -- value passed is the chain so far. + + procedure Elab_Error_Msg (S : Successor_Id); + -- Given a successor link, outputs an error message of the form + -- "& must be elaborated before & ..." where ... is the reason. + + procedure Gather_Dependencies; + -- Compute dependencies, building the Succ and UNR tables + + function Make_Elab_Entry + (Unam : Unit_Name_Type; + Link : Elab_All_Id) + return Elab_All_Id; + -- Make an Elab_All_Entries table entry with the given Unam and Link. + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; + -- This function uses the Info field set in the names table to obtain + -- the unit Id of a unit, given its name id value. + + function Worse_Choice (U1, U2 : Unit_Id) return Boolean; + -- This is like Better_Choice, and has the same interface, but returns + -- true if U1 is a worse choice than U2 in the sense of the -h (horrible + -- elaboration order) switch. We still have to obey Ada rules, so it is + -- not quite the direct inverse of Better_Choice. + + procedure Write_Dependencies; + -- Write out dependencies (called only if appropriate option is set) + + procedure Write_Elab_All_Chain (S : Successor_Id); + -- If the reason for the link S is Elaborate_All or Elaborate_Desirable, + -- then this routine will output the "needed by" explanation chain. + + ------------------- + -- Better_Choice -- + ------------------- + + function Better_Choice (U1, U2 : Unit_Id) return Boolean is + + function Body_Unit (U : Unit_Id) return Boolean; + -- Determines if given unit is a body + + function Waiting_Body (U : Unit_Id) return Boolean; + -- Determines if U is a waiting body, defined as a body which has + -- not been elaborated, but whose spec has been elaborated. + + function Body_Unit (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body + or else Units.Table (U).Utype = Is_Body_Only; + end Body_Unit; + + function Waiting_Body (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body + and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; + end Waiting_Body; + + -- Start of processing for Better_Choice + + -- Note: the checks here are applied in sequence, and the ordering is + -- significant (i.e. the more important criteria are applied first). + + begin + -- Prefer a waiting body to any other case + + if Waiting_Body (U1) and not Waiting_Body (U2) then + return True; + + elsif Waiting_Body (U2) and not Waiting_Body (U1) then + return False; + + -- Prefer a predefined unit to a non-predefined unit + + elsif Units.Table (U1).Predefined + and not Units.Table (U2).Predefined + then + return True; + + elsif Units.Table (U2).Predefined + and not Units.Table (U1).Predefined + then + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif Units.Table (U1).Internal + and not Units.Table (U2).Internal + then + return True; + + elsif Units.Table (U2).Internal + and not Units.Table (U1).Internal + then + return False; + + -- Prefer a body to a spec + + elsif Body_Unit (U1) and not Body_Unit (U2) then + return True; + + elsif Body_Unit (U2) and not Body_Unit (U1) then + return False; + + -- If both are waiting bodies, then prefer the one whose spec is + -- more recently elaborated. Consider the following: + + -- spec of A + -- spec of B + -- body of A or B? + + -- The normal waiting body preference would have placed the body of + -- A before the spec of B if it could. Since it could not, there it + -- must be the case that A depends on B. It is therefore a good idea + -- to put the body of B first. + + elsif Waiting_Body (U1) and then Waiting_Body (U2) then + return + UNR.Table (Corresponding_Spec (U1)).Elab_Position > + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + + -- Otherwise decide on the basis of alphabetical order + + else + return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); + end if; + end Better_Choice; + + ---------------- + -- Build_Link -- + ---------------- + + procedure Build_Link + (Before : Unit_Id; + After : Unit_Id; + R : Succ_Reason; + Ea_Id : Elab_All_Id := No_Elab_All_Link) + is + Cspec : Unit_Id; + + begin + Succ.Increment_Last; + Succ.Table (Succ.Last).Before := Before; + Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors; + UNR.Table (Before).Successors := Succ.Last; + Succ.Table (Succ.Last).Reason := R; + Succ.Table (Succ.Last).Reason_Unit := Cur_Unit; + Succ.Table (Succ.Last).Elab_All_Link := Ea_Id; + + -- Deal with special Elab_Body case. If the After of this link is + -- a body whose spec has Elaborate_All set, and this is not the link + -- directly from the body to the spec, then we make the After of the + -- link reference its spec instead, marking the link appropriately. + + if Units.Table (After).Utype = Is_Body then + Cspec := Corresponding_Spec (After); + + if Units.Table (Cspec).Elaborate_Body + and then Cspec /= Before + then + Succ.Table (Succ.Last).After := Cspec; + Succ.Table (Succ.Last).Elab_Body := True; + UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1; + return; + end if; + end if; + + -- Fall through on normal case + + Succ.Table (Succ.Last).After := After; + Succ.Table (Succ.Last).Elab_Body := False; + UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; + end Build_Link; + + ------------ + -- Choose -- + ------------ + + procedure Choose (Chosen : Unit_Id) is + S : Successor_Id; + U : Unit_Id; + + begin + if Debug_Flag_C then + Write_Str ("Choosing Unit "); + Write_Unit_Name (Units.Table (Chosen).Uname); + Write_Eol; + end if; + + -- Add to elaboration order. Note that units having no elaboration + -- code are not treated specially yet. The special casing of this + -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile + -- we need them here, because the object file list is also driven + -- by the contents of the Elab_Order table. + + Elab_Order.Increment_Last; + Elab_Order.Table (Elab_Order.Last) := Chosen; + + -- Remove from No_Pred list. This is a little inefficient and may + -- be we should doubly link the list, but it will do for now! + + if No_Pred = Chosen then + No_Pred := UNR.Table (Chosen).Nextnp; + + else + -- Note that we just ignore the situation where it does not + -- appear in the No_Pred list, this happens in calls from the + -- Diagnose_Elaboration_Problem routine, where cycles are being + -- removed arbitrarily from the graph. + + U := No_Pred; + while U /= No_Unit_Id loop + if UNR.Table (U).Nextnp = Chosen then + UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; + exit; + end if; + + U := UNR.Table (U).Nextnp; + end loop; + end if; + + -- For all successors, decrement the number of predecessors, and + -- if it becomes zero, then add to no predecessor list. + + S := UNR.Table (Chosen).Successors; + + while S /= No_Successor loop + U := Succ.Table (S).After; + UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; + + if Debug_Flag_N then + Write_Str (" decrementing Num_Pred for unit "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Str (" new value = "); + Write_Int (Int (UNR.Table (U).Num_Pred)); + Write_Eol; + end if; + + if UNR.Table (U).Num_Pred = 0 then + UNR.Table (U).Nextnp := No_Pred; + No_Pred := U; + end if; + + S := Succ.Table (S).Next; + end loop; + + -- All done, adjust number of units left count and set elaboration pos + + Num_Left := Num_Left - 1; + Num_Chosen := Num_Chosen + 1; + UNR.Table (Chosen).Elab_Position := Num_Chosen; + Units.Table (Chosen).Elab_Position := Num_Chosen; + + -- If we just chose a spec with Elaborate_Body set, then we + -- must immediately elaborate the body, before any other units. + + if Units.Table (Chosen).Elaborate_Body then + + -- If the unit is a spec only, then there is no body. This is a bit + -- odd given that Elaborate_Body is here, but it is valid in an + -- RCI unit, where we only have the interface in the stub bind. + + if Units.Table (Chosen).Utype = Is_Spec_Only + and then Units.Table (Chosen).RCI + then + null; + else + Choose (Corresponding_Body (Chosen)); + end if; + end if; + end Choose; + + ------------------------ + -- Corresponding_Body -- + ------------------------ + + -- Currently if the body and spec are separate, then they appear as + -- two separate units in the same ALI file, with the body appearing + -- first and the spec appearing second. + + function Corresponding_Body (U : Unit_Id) return Unit_Id is + begin + pragma Assert (Units.Table (U).Utype = Is_Spec); + return U - 1; + end Corresponding_Body; + + ------------------------ + -- Corresponding_Spec -- + ------------------------ + + -- Currently if the body and spec are separate, then they appear as + -- two separate units in the same ALI file, with the body appearing + -- first and the spec appearing second. + + function Corresponding_Spec (U : Unit_Id) return Unit_Id is + begin + pragma Assert (Units.Table (U).Utype = Is_Body); + return U + 1; + end Corresponding_Spec; + + ---------------------------------- + -- Diagnose_Elaboration_Problem -- + ---------------------------------- + + procedure Diagnose_Elaboration_Problem is + + function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean; + -- Recursive routine used to find a path from node Ufrom to node Uto. + -- If a path exists, returns True and outputs an appropriate set of + -- error messages giving the path. Also calls Choose for each of the + -- nodes so that they get removed from the remaining set. There are + -- two cases of calls, either Ufrom = Uto for an attempt to find a + -- cycle, or Ufrom is a spec and Uto the corresponding body for the + -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum + -- acceptable length for a path. + + --------------- + -- Find_Path -- + --------------- + + function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is + + function Find_Link (U : Unit_Id; PL : Nat) return Boolean; + -- This is the inner recursive routine, it determines if a path + -- exists from U to Uto, and if so returns True and outputs the + -- appropriate set of error messages. PL is the path length + + --------------- + -- Find_Link -- + --------------- + + function Find_Link (U : Unit_Id; PL : Nat) return Boolean is + S : Successor_Id; + + begin + -- Recursion ends if we are at terminating node and the path + -- is sufficiently long, generate error message and return True. + + if U = Uto and then PL >= ML then + Choose (U); + return True; + + -- All done if already visited, otherwise mark as visited + + elsif UNR.Table (U).Visited then + return False; + + -- Otherwise mark as visited and look at all successors + + else + UNR.Table (U).Visited := True; + + S := UNR.Table (U).Successors; + while S /= No_Successor loop + if Find_Link (Succ.Table (S).After, PL + 1) then + Elab_Error_Msg (S); + Choose (U); + return True; + end if; + + S := Succ.Table (S).Next; + end loop; + + -- Falling through means this does not lead to a path + + return False; + end if; + end Find_Link; + + -- Start of processing for Find_Path + + begin + -- Initialize all non-chosen nodes to not visisted yet + + for U in Units.First .. Units.Last loop + UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; + end loop; + + -- Now try to find the path + + return Find_Link (Ufrom, 0); + end Find_Path; + + -- Start of processing for Diagnose_Elaboration_Error + + begin + Set_Standard_Error; + + -- Output state of things if debug flag N set + + if Debug_Flag_N then + declare + NP : Int; + + begin + Write_Eol; + Write_Eol; + Write_Str ("Diagnose_Elaboration_Problem called"); + Write_Eol; + Write_Str ("List of remaining unchosen units and predecessors"); + Write_Eol; + + for U in Units.First .. Units.Last loop + if UNR.Table (U).Elab_Position = 0 then + NP := UNR.Table (U).Num_Pred; + Write_Eol; + Write_Str (" Unchosen unit: #"); + Write_Int (Int (U)); + Write_Str (" "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Str (" (Num_Pred = "); + Write_Int (NP); + Write_Char (')'); + Write_Eol; + + if NP = 0 then + if Units.Table (U).Elaborate_Body then + Write_Str + (" (not chosen because of Elaborate_Body)"); + Write_Eol; + else + Write_Str (" ****************** why not chosen?"); + Write_Eol; + end if; + end if; + + -- Search links list to find unchosen predecessors + + for S in Succ.First .. Succ.Last loop + declare + SL : Successor_Link renames Succ.Table (S); + + begin + if SL.After = U + and then UNR.Table (SL.Before).Elab_Position = 0 + then + Write_Str (" unchosen predecessor: #"); + Write_Int (Int (SL.Before)); + Write_Str (" "); + Write_Unit_Name (Units.Table (SL.Before).Uname); + Write_Eol; + NP := NP - 1; + end if; + end; + end loop; + + if NP /= 0 then + Write_Str (" **************** Num_Pred value wrong!"); + Write_Eol; + end if; + end if; + end loop; + end; + end if; + + -- Output the header for the error, and manually increment the + -- error count. We are using Error_Msg_Output rather than Error_Msg + -- here for two reasons: + + -- This is really only one error, not one for each line + -- We want this output on standard output since it is voluminous + + -- But we do need to deal with the error count manually in this case + + Errors_Detected := Errors_Detected + 1; + Error_Msg_Output ("elaboration circularity detected", Info => False); + + -- Try to find cycles starting with any of the remaining nodes that have + -- not yet been chosen. There must be at least one (there is some reason + -- we are being called!) + + for U in Units.First .. Units.Last loop + if UNR.Table (U).Elab_Position = 0 then + if Find_Path (U, U, 1) then + raise Unrecoverable_Error; + end if; + end if; + end loop; + + -- We should never get here, since we were called for some reason, + -- and we should have found and eliminated at least one bad path. + + raise Program_Error; + + end Diagnose_Elaboration_Problem; + + -------------------- + -- Elab_All_Links -- + -------------------- + + procedure Elab_All_Links + (Before : Unit_Id; + After : Unit_Id; + Reason : Succ_Reason; + Link : Elab_All_Id) + is + begin + if UNR.Table (Before).Visited then + return; + end if; + + -- Build the direct link for Before + + UNR.Table (Before).Visited := True; + Build_Link (Before, After, Reason, Link); + + -- Process all units with'ed by Before recursively + + for W in + Units.Table (Before).First_With .. Units.Table (Before).Last_With + loop + -- Skip if no ALI file for this with, happens with certain + -- specialized generic files that do not get compiled. + + if Withs.Table (W).Afile /= No_File then + + Elab_All_Links + (Unit_Id_Of (Withs.Table (W).Uname), + After, + Reason, + Make_Elab_Entry (Withs.Table (W).Uname, Link)); + end if; + end loop; + + -- Process corresponding body, if there is one + + if Units.Table (Before).Utype = Is_Spec then + Elab_All_Links + (Corresponding_Body (Before), + After, Reason, + Make_Elab_Entry + (Units.Table (Corresponding_Body (Before)).Uname, Link)); + end if; + end Elab_All_Links; + + -------------------- + -- Elab_Error_Msg -- + -------------------- + + procedure Elab_Error_Msg (S : Successor_Id) is + SL : Successor_Link renames Succ.Table (S); + + begin + -- Nothing to do if internal unit involved and no -de flag + + if not Debug_Flag_E + and then + (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) + or else + Is_Internal_File_Name (Units.Table (SL.After).Sfile)) + then + return; + end if; + + -- Here we want to generate output + + Error_Msg_Name_1 := Units.Table (SL.Before).Uname; + + if SL.Elab_Body then + Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname; + else + Error_Msg_Name_2 := Units.Table (SL.After).Uname; + end if; + + Error_Msg_Output (" & must be elaborated before &", Info => True); + + Error_Msg_Name_1 := Units.Table (SL.Reason_Unit).Uname; + + case SL.Reason is + when Withed => + Error_Msg_Output + (" reason: with clause", + Info => True); + + when Elab => + Error_Msg_Output + (" reason: pragma Elaborate in unit &", + Info => True); + + when Elab_All => + Error_Msg_Output + (" reason: pragma Elaborate_All in unit &", + Info => True); + + when Elab_Desirable => + Error_Msg_Output + (" reason: Elaborate_All probably needed in unit &", + Info => True); + + Error_Msg_Output + (" recompile & with -gnatwl for full details", + Info => True); + + when Spec_First => + Error_Msg_Output + (" reason: spec always elaborated before body", + Info => True); + end case; + + Write_Elab_All_Chain (S); + + if SL.Elab_Body then + Error_Msg_Name_1 := Units.Table (SL.Before).Uname; + Error_Msg_Name_2 := Units.Table (SL.After).Uname; + Error_Msg_Output + (" & must therefore be elaborated before &", + True); + + Error_Msg_Name_1 := Units.Table (SL.After).Uname; + Error_Msg_Output + (" (because & has a pragma Elaborate_Body)", + True); + end if; + + Write_Eol; + end Elab_Error_Msg; + + --------------------- + -- Find_Elab_Order -- + --------------------- + + procedure Find_Elab_Order is + U : Unit_Id; + Best_So_Far : Unit_Id; + + begin + Succ.Init; + Num_Left := Int (Units.Last - Units.First + 1); + + -- Initialize unit table for elaboration control + + for U in Units.First .. Units.Last loop + UNR.Increment_Last; + UNR.Table (UNR.Last).Successors := No_Successor; + UNR.Table (UNR.Last).Num_Pred := 0; + UNR.Table (UNR.Last).Nextnp := No_Unit_Id; + UNR.Table (UNR.Last).Elab_Order := 0; + UNR.Table (UNR.Last).Elab_Position := 0; + end loop; + + -- Gather dependencies and output them if option set + + Gather_Dependencies; + + -- Output elaboration dependencies if option is set + + if Elab_Dependency_Output or Debug_Flag_E then + Write_Dependencies; + end if; + + -- Initialize the no predecessor list + + No_Pred := No_Unit_Id; + + for U in UNR.First .. UNR.Last loop + if UNR.Table (U).Num_Pred = 0 then + UNR.Table (U).Nextnp := No_Pred; + No_Pred := U; + end if; + end loop; + + -- OK, now we determine the elaboration order proper. All we do is to + -- select the best choice from the no predecessor list until all the + -- nodes have been chosen. + + Outer : loop + -- If there are no nodes with predecessors, then either we are + -- done, as indicated by Num_Left being set to zero, or we have + -- a circularity. In the latter case, diagnose the circularity, + -- removing it from the graph and continue + + Get_No_Pred : while No_Pred = No_Unit_Id loop + exit Outer when Num_Left < 1; + Diagnose_Elaboration_Problem; + end loop Get_No_Pred; + + U := No_Pred; + Best_So_Far := No_Unit_Id; + + -- Loop to choose best entry in No_Pred list + + No_Pred_Search : loop + if Debug_Flag_N then + Write_Str (" considering choice of "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Eol; + + if Units.Table (U).Elaborate_Body then + Write_Str + (" Elaborate_Body = True, Num_Pred for body = "); + Write_Int + (Int (UNR.Table (Corresponding_Body (U)).Num_Pred)); + else + Write_Str + (" Elaborate_Body = False"); + end if; + + Write_Eol; + end if; + + -- This is a candididate to be considered for choice + + if Best_So_Far = No_Unit_Id + or else ((not Pessimistic_Elab_Order) + and then Better_Choice (U, Best_So_Far)) + or else (Pessimistic_Elab_Order + and then Worse_Choice (U, Best_So_Far)) + then + if Debug_Flag_N then + Write_Str (" tentatively chosen (best so far)"); + Write_Eol; + end if; + + Best_So_Far := U; + end if; + + U := UNR.Table (U).Nextnp; + exit No_Pred_Search when U = No_Unit_Id; + end loop No_Pred_Search; + + -- If no candididate chosen, it means that no unit has No_Pred = 0, + -- but there are units left, hence we have a circular dependency, + -- which we will get Diagnose_Elaboration_Problem to diagnose it. + + if Best_So_Far = No_Unit_Id then + Diagnose_Elaboration_Problem; + + -- Otherwise choose the best candidate found + + else + Choose (Best_So_Far); + end if; + end loop Outer; + + end Find_Elab_Order; + + ------------------------- + -- Gather_Dependencies -- + ------------------------- + + procedure Gather_Dependencies is + Withed_Unit : Unit_Id; + + begin + -- Loop through all units + + for U in Units.First .. Units.Last loop + Cur_Unit := U; + + -- If there is a body and a spec, then spec must be elaborated first + -- Note that the corresponding spec immediately follows the body + + if Units.Table (U).Utype = Is_Body then + Build_Link (Corresponding_Spec (U), U, Spec_First); + end if; + + -- Process WITH references for this unit ignoring generic units + + for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop + if Withs.Table (W).Sfile /= No_File then + + -- Check for special case of withing a unit that does not + -- exist any more. If the unit was completely missing we would + -- already have detected this, but a nasty case arises when we + -- have a subprogram body with no spec, and some obsolete unit + -- with's a previous (now disappeared) spec. + + if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then + Error_Msg_Name_1 := Units.Table (U).Sfile; + Error_Msg_Name_2 := Withs.Table (W).Uname; + Error_Msg ("% depends on & which no longer exists"); + goto Next_With; + end if; + + Withed_Unit := + Unit_Id (Unit_Id_Of (Withs.Table (W).Uname)); + + -- Pragma Elaborate_All case, for this we use the recursive + -- Elab_All_Links procedure to establish the links. + + if Withs.Table (W).Elaborate_All then + + -- Reset flags used to stop multiple visits to a given node + + for Uref in UNR.First .. UNR.Last loop + UNR.Table (Uref).Visited := False; + end loop; + + -- Now establish all the links we need + + Elab_All_Links + (Withed_Unit, U, Elab_All, + Make_Elab_Entry + (Withs.Table (W).Uname, No_Elab_All_Link)); + + -- Elaborate_All_Desirable case, for this we establish the + -- same links as above, but with a different reason. + + elsif Withs.Table (W).Elab_All_Desirable then + + -- Reset flags used to stop multiple visits to a given node + + for Uref in UNR.First .. UNR.Last loop + UNR.Table (Uref).Visited := False; + end loop; + + -- Now establish all the links we need + + Elab_All_Links + (Withed_Unit, U, Elab_Desirable, + Make_Elab_Entry + (Withs.Table (W).Uname, No_Elab_All_Link)); + + -- Pragma Elaborate case. We must build a link for the withed + -- unit itself, and also the corresponding body if there is one + + -- However, skip this processing if there is no ALI file for + -- the WITH entry, because this means it is a generic (even + -- when we fix the generics so that an ALI file is present, + -- we probably still will have no ALI file for unchecked + -- and other special cases). + + elsif Withs.Table (W).Elaborate + and then Withs.Table (W).Afile /= No_File + then + Build_Link (Withed_Unit, U, Withed); + + if Units.Table (Withed_Unit).Utype = Is_Spec then + Build_Link + (Corresponding_Body (Withed_Unit), U, Elab); + end if; + + -- Case of normal WITH with no elaboration pragmas, just + -- build the single link to the directly referenced unit + + else + Build_Link (Withed_Unit, U, Withed); + end if; + end if; + + <<Next_With>> + null; + end loop; + end loop; + end Gather_Dependencies; + + --------------------- + -- Make_Elab_Entry -- + --------------------- + + function Make_Elab_Entry + (Unam : Unit_Name_Type; + Link : Elab_All_Id) + return Elab_All_Id + is + begin + Elab_All_Entries.Increment_Last; + Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam; + Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link; + return Elab_All_Entries.Last; + end Make_Elab_Entry; + + ---------------- + -- Unit_Id_Of -- + ---------------- + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is + Info : constant Int := Get_Name_Table_Info (Uname); + + begin + pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); + return Unit_Id (Info); + end Unit_Id_Of; + + ------------------ + -- Worse_Choice -- + ------------------ + + function Worse_Choice (U1, U2 : Unit_Id) return Boolean is + + function Body_Unit (U : Unit_Id) return Boolean; + -- Determines if given unit is a body + + function Waiting_Body (U : Unit_Id) return Boolean; + -- Determines if U is a waiting body, defined as a body which has + -- not been elaborated, but whose spec has been elaborated. + + function Body_Unit (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body + or else Units.Table (U).Utype = Is_Body_Only; + end Body_Unit; + + function Waiting_Body (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body and then + UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; + end Waiting_Body; + + -- Start of processing for Worse_Choice + + -- Note: the checks here are applied in sequence, and the ordering is + -- significant (i.e. the more important criteria are applied first). + + begin + -- If either unit is internal, then use Better_Choice, since the + -- language requires that predefined units not mess up in the choice + -- of elaboration order, and for internal units, any problems are + -- ours and not the programmers. + + if Units.Table (U1).Internal or else Units.Table (U2).Internal then + return Better_Choice (U1, U2); + + -- Prefer anything else to a waiting body (!) + + elsif Waiting_Body (U1) and not Waiting_Body (U2) then + return False; + + elsif Waiting_Body (U2) and not Waiting_Body (U1) then + return True; + + -- Prefer a spec to a body (!) + + elsif Body_Unit (U1) and not Body_Unit (U2) then + return False; + + elsif Body_Unit (U2) and not Body_Unit (U1) then + return True; + + -- If both are waiting bodies, then prefer the one whose spec is + -- less recently elaborated. Consider the following: + + -- spec of A + -- spec of B + -- body of A or B? + + -- The normal waiting body preference would have placed the body of + -- A before the spec of B if it could. Since it could not, there it + -- must be the case that A depends on B. It is therefore a good idea + -- to put the body of B last so that if there is an elaboration order + -- problem, we will find it (that's what horrible order is about) + + elsif Waiting_Body (U1) and then Waiting_Body (U2) then + return + UNR.Table (Corresponding_Spec (U1)).Elab_Position < + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + + -- Otherwise decide on the basis of alphabetical order. We do not try + -- to reverse the usual choice here, since it can cause cancelling + -- errors with the other inversions. + + else + return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); + end if; + end Worse_Choice; + + ------------------------ + -- Write_Dependencies -- + ------------------------ + + procedure Write_Dependencies is + begin + Write_Eol; + Write_Str + (" ELABORATION ORDER DEPENDENCIES"); + Write_Eol; + Write_Eol; + + Info_Prefix_Suppress := True; + + for S in Succ_First .. Succ.Last loop + Elab_Error_Msg (S); + end loop; + + Info_Prefix_Suppress := False; + Write_Eol; + end Write_Dependencies; + + -------------------------- + -- Write_Elab_All_Chain -- + -------------------------- + + procedure Write_Elab_All_Chain (S : Successor_Id) is + ST : constant Successor_Link := Succ.Table (S); + After : constant Unit_Name_Type := Units.Table (ST.After).Uname; + + L : Elab_All_Id; + Nam : Unit_Name_Type; + + First_Name : Boolean := True; + + begin + if ST.Reason in Elab_All .. Elab_Desirable then + L := ST.Elab_All_Link; + while L /= No_Elab_All_Link loop + Nam := Elab_All_Entries.Table (L).Needed_By; + Error_Msg_Name_1 := Nam; + Error_Msg_Output (" &", Info => True); + + Get_Name_String (Nam); + + if Name_Buffer (Name_Len) = 'b' then + if First_Name then + Error_Msg_Output + (" must be elaborated along with its spec:", + Info => True); + + else + Error_Msg_Output + (" which must be elaborated " & + "along with its spec:", + Info => True); + end if; + + else + if First_Name then + Error_Msg_Output + (" is withed by:", + Info => True); + + else + Error_Msg_Output + (" which is withed by:", + Info => True); + end if; + end if; + + First_Name := False; + + L := Elab_All_Entries.Table (L).Next_Elab; + end loop; + + Error_Msg_Name_1 := After; + Error_Msg_Output (" &", Info => True); + end if; + end Write_Elab_All_Chain; + +end Binde; diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads new file mode 100644 index 00000000000..9d0351b3329 --- /dev/null +++ b/gcc/ada/binde.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- Copyright (C) 1992-1997 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines to determine elaboration order + +with ALI; use ALI; +with Table; +with Types; use Types; + +package Binde is + + -- The following table records the chosen elaboration order. It is used + -- by Gen_Elab_Call to generate the sequence of elaboration calls. Note + -- that units are included in this table even if they have no elaboration + -- routine, since the table is also used to drive the generation of object + -- files in the binder output. Gen_Elab_Call skips any units that have no + -- elaboration routine. + + package Elab_Order is new Table.Table ( + Table_Component_Type => Unit_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "Elab_Order"); + + procedure Find_Elab_Order; + -- Determine elaboration order + +end Binde; diff --git a/gcc/ada/binderr.adb b/gcc/ada/binderr.adb new file mode 100644 index 00000000000..b9ea3982c65 --- /dev/null +++ b/gcc/ada/binderr.adb @@ -0,0 +1,198 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E R R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.22 $ +-- -- +-- Copyright (C) 1992-2000 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 Butil; use Butil; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; + +package body Binderr is + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Msg : String) is + begin + if Msg (Msg'First) = '?' then + if Warning_Mode = Suppress then + return; + end if; + + if Warning_Mode = Treat_As_Error then + Errors_Detected := Errors_Detected + 1; + else + Warnings_Detected := Warnings_Detected + 1; + end if; + + else + Errors_Detected := Errors_Detected + 1; + end if; + + if Brief_Output or else (not Verbose_Mode) then + Set_Standard_Error; + Error_Msg_Output (Msg, Info => False); + Set_Standard_Output; + end if; + + if Verbose_Mode then + if Errors_Detected + Warnings_Detected = 0 then + Write_Eol; + end if; + + Error_Msg_Output (Msg, Info => False); + end if; + + if Warnings_Detected + Errors_Detected > Maximum_Errors then + raise Unrecoverable_Error; + end if; + + end Error_Msg; + + -------------------- + -- Error_Msg_Info -- + -------------------- + + procedure Error_Msg_Info (Msg : String) is + begin + if Brief_Output or else (not Verbose_Mode) then + Set_Standard_Error; + Error_Msg_Output (Msg, Info => True); + Set_Standard_Output; + end if; + + if Verbose_Mode then + Error_Msg_Output (Msg, Info => True); + end if; + + end Error_Msg_Info; + + ---------------------- + -- Error_Msg_Output -- + ---------------------- + + procedure Error_Msg_Output (Msg : String; Info : Boolean) is + Use_Second_Name : Boolean := False; + + begin + if Warnings_Detected + Errors_Detected > Maximum_Errors then + Write_Str ("error: maximum errors exceeded"); + Write_Eol; + return; + end if; + + if Msg (Msg'First) = '?' then + Write_Str ("warning: "); + elsif Info then + if not Info_Prefix_Suppress then + Write_Str ("info: "); + end if; + else + Write_Str ("error: "); + end if; + + for I in Msg'Range loop + if Msg (I) = '%' then + + if Use_Second_Name then + Get_Name_String (Error_Msg_Name_2); + else + Use_Second_Name := True; + Get_Name_String (Error_Msg_Name_1); + end if; + + Write_Char ('"'); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Char ('"'); + + elsif Msg (I) = '&' then + Write_Char ('"'); + + if Use_Second_Name then + Write_Unit_Name (Error_Msg_Name_2); + else + Use_Second_Name := True; + Write_Unit_Name (Error_Msg_Name_1); + end if; + + Write_Char ('"'); + + elsif Msg (I) /= '?' then + Write_Char (Msg (I)); + end if; + end loop; + + Write_Eol; + end Error_Msg_Output; + + ---------------------- + -- Finalize_Binderr -- + ---------------------- + + procedure Finalize_Binderr is + begin + -- Message giving number of errors detected (verbose mode only) + + if Verbose_Mode then + Write_Eol; + + if Errors_Detected = 0 then + Write_Str ("No errors"); + + elsif Errors_Detected = 1 then + Write_Str ("1 error"); + + else + Write_Int (Errors_Detected); + Write_Str (" errors"); + end if; + + if Warnings_Detected = 1 then + Write_Str (", 1 warning"); + + elsif Warnings_Detected > 1 then + Write_Str (", "); + Write_Int (Warnings_Detected); + Write_Str (" warnings"); + end if; + + Write_Eol; + end if; + end Finalize_Binderr; + + ------------------------ + -- Initialize_Binderr -- + ------------------------ + + procedure Initialize_Binderr is + begin + Errors_Detected := 0; + Warnings_Detected := 0; + end Initialize_Binderr; + +end Binderr; diff --git a/gcc/ada/binderr.ads b/gcc/ada/binderr.ads new file mode 100644 index 00000000000..37a346f095f --- /dev/null +++ b/gcc/ada/binderr.ads @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E R R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines to output error messages for the binder +-- and also the routines for handling fatal error conditions in the binder. + +with Types; use Types; + +package Binderr is + + Errors_Detected : Int; + -- Number of errors detected so far + + Warnings_Detected : Int; + -- Number of warnings detected + + Info_Prefix_Suppress : Boolean := False; + -- If set to True, the normal "info: " header before messages generated + -- by Error_Msg_Info will be omitted. + + --------------------------------------------------------- + -- Error Message Text and Message Insertion Characters -- + --------------------------------------------------------- + + -- Error message text strings are composed of letters, digits and the + -- special characters space, comma, period, colon and semicolon, + -- apostrophe and parentheses. Special insertion characters can also + -- appear which cause the error message circuit to modify the given + -- string as follows: + + -- Insertion character % (Percent: insert file name from Names table) + -- The character % is replaced by the text for the file name specified + -- by the Name_Id value stored in Error_Msg_Name_1. The name is always + -- enclosed in quotes. A second % may appear in a single message in + -- which case it is similarly replaced by the name which is specified + -- by the Name_Id value stored in Error_Msg_Name_2. + + -- Insertion character & (Ampersand: insert unit name from Names table) + -- The character & is replaced by the text for the unit name specified + -- by the Name_Id value stored in Error_Msg_Name_1. The name is always + -- enclosed in quotes. A second & may appear in a single message in + -- which case it is similarly replaced by the name which is specified + -- by the Name_Id value stored in Error_Msg_Name_2. + + -- Insertion character ? (Question mark: warning message) + -- The character ?, which must be the first character in the message + -- string, signals a warning message instead of an error message. + + ----------------------------------------------------- + -- Global Values Used for Error Message Insertions -- + ----------------------------------------------------- + + -- The following global variables are essentially additional parameters + -- passed to the error message routine for insertion sequences described + -- above. The reason these are passed globally is that the insertion + -- mechanism is essentially an untyped one in which the appropriate + -- variables are set dependingon the specific insertion characters used. + + Error_Msg_Name_1 : Name_Id; + Error_Msg_Name_2 : Name_Id; + -- Name_Id values for % insertion characters in message + + ------------------------------ + -- Error Output Subprograms -- + ------------------------------ + + procedure Error_Msg (Msg : String); + -- Output specified error message to standard error or standard output + -- as governed by the brief and verbose switches, and update error + -- counts appropriately + + procedure Error_Msg_Info (Msg : String); + -- Output information line. Indentical in effect to Error_Msg, except + -- that the prefix is info: instead of error: and the error count is + -- not incremented. The prefix may be suppressed by setting the global + -- variable Info_Prefix_Suppress to True. + + procedure Error_Msg_Output (Msg : String; Info : Boolean); + -- Output given message, with insertions, to current message output file. + -- The second argument is True for an info message, false for a normal + -- warning or error message. Normally this is not called directly, but + -- rather only by Error_Msg or Error_Msg_Info. It is called directly + -- when the caller must control whether the output goes to stderr or + -- stdout (Error_Msg_Output always goes to the current output file). + + procedure Finalize_Binderr; + -- Finalize error output for one file + + procedure Initialize_Binderr; + -- Initialize error output for one file + +end Binderr; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb new file mode 100644 index 00000000000..677e495cd79 --- /dev/null +++ b/gcc/ada/bindgen.adb @@ -0,0 +1,2903 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D G E N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.201 $ +-- -- +-- Copyright (C) 1992-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 ALI; use ALI; +with Binde; use Binde; +with Butil; use Butil; +with Casing; use Casing; +with Fname; use Fname; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Types; use Types; +with Sdefault; use Sdefault; +with System; use System; + +with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; + +package body Bindgen is + + Statement_Buffer : String (1 .. 1000); + -- Buffer used for constructing output statements + + Last : Natural := 0; + -- Last location in Statement_Buffer currently set + + With_DECGNAT : Boolean := False; + -- Flag which indicates whether the program uses the DECGNAT library + -- (presence of the unit System.Aux_DEC.DECLIB) + + With_GNARL : Boolean := False; + -- Flag which indicates whether the program uses the GNARL library + -- (presence of the unit System.OS_Interface) + + Num_Elab_Calls : Nat := 0; + -- Number of generated calls to elaboration routines + + subtype chars_ptr is Address; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure WBI (Info : String) renames Osint.Write_Binder_Info; + -- Convenient shorthand used throughout + + function ABE_Boolean_Required (U : Unit_Id) return Boolean; + -- Given a unit id value U, determines if the corresponding unit requires + -- an access-before-elaboration check variable, i.e. it is a non-predefined + -- body for which no pragma Elaborate, Elaborate_All or Elaborate_Body is + -- present, and thus could require ABE checks. + + procedure Resolve_Binder_Options; + -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS + -- since it tests for a package named "dec" which might cause a conflict + -- on non-VMS systems. + + procedure Gen_Adainit_Ada; + -- Generates the Adainit procedure (Ada code case) + + procedure Gen_Adainit_C; + -- Generates the Adainit procedure (C code case) + + procedure Gen_Adafinal_Ada; + -- Generate the Adafinal procedure (Ada code case) + + procedure Gen_Adafinal_C; + -- Generate the Adafinal procedure (C code case) + + procedure Gen_Elab_Calls_Ada; + -- Generate sequence of elaboration calls (Ada code case) + + procedure Gen_Elab_Calls_C; + -- Generate sequence of elaboration calls (C code case) + + procedure Gen_Elab_Order_Ada; + -- Generate comments showing elaboration order chosen (Ada case) + + procedure Gen_Elab_Order_C; + -- Generate comments showing elaboration order chosen (C case) + + procedure Gen_Elab_Defs_C; + -- Generate sequence of definitions for elaboration routines (C code case) + + procedure Gen_Exception_Table_Ada; + -- Generate binder exception table (Ada code case). This consists of + -- declarations followed by a begin followed by a call. If zero cost + -- exceptions are not active, then only the begin is generated. + + procedure Gen_Exception_Table_C; + -- Generate binder exception table (C code case). This has no effect + -- if zero cost exceptions are not active, otherwise it generates a + -- set of declarations followed by a call. + + procedure Gen_Main_Ada; + -- Generate procedure main (Ada code case) + + procedure Gen_Main_C; + -- Generate main() procedure (C code case) + + procedure Gen_Object_Files_Options; + -- Output comments containing a list of the full names of the object + -- files to be linked and the list of linker options supplied by + -- Linker_Options pragmas in the source. (C and Ada code case) + + procedure Gen_Output_File_Ada (Filename : String); + -- Generate output file (Ada code case) + + procedure Gen_Output_File_C (Filename : String); + -- Generate output file (C code case) + + procedure Gen_Scalar_Values; + -- Generates scalar initialization values for -Snn. A single procedure + -- handles both the Ada and C cases, since there is much common code. + + procedure Gen_Versions_Ada; + -- Output series of definitions for unit versions (Ada code case) + + procedure Gen_Versions_C; + -- Output series of definitions for unit versions (C code case) + + function Get_Ada_Main_Name return String; + -- This function is used in the Ada main output case to compute a usable + -- name for the generated main program. The normal main program name is + -- Ada_Main, but this won't work if the user has a unit with this name. + -- This function tries Ada_Main first, and if there is such a clash, then + -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence. + + function Get_Main_Name return String; + -- This function is used in the Ada main output case to compute the + -- correct external main program. It is "main" by default, except on + -- VxWorks where it is the name of the Ada main name without the "_ada". + -- the -Mname binder option overrides the default with name. + + function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; + -- Compare linker options, when sorting, first according to + -- Is_Internal_File (internal files come later) and then by elaboration + -- order position (latest to earliest) except its not possible to + -- distinguish between a linker option in the spec and one in the body. + + procedure Move_Linker_Option (From : Natural; To : Natural); + -- Move routine for sorting linker options + + procedure Public_Version_Warning; + -- Emit a warning concerning the use of the Public version under + -- certain circumstances. See details in body. + + procedure Set_Char (C : Character); + -- Set given character in Statement_Buffer at the Last + 1 position + -- and increment Last by one to reflect the stored character. + + procedure Set_Int (N : Int); + -- Set given value in decimal in Statement_Buffer with no spaces + -- starting at the Last + 1 position, and updating Last past the value. + -- A minus sign is output for a negative value. + + procedure Set_Main_Program_Name; + -- Given the main program name in Name_Buffer (length in Name_Len) + -- generate the name of the routine to be used in the call. The name + -- is generated starting at Last + 1, and Last is updated past it. + + procedure Set_Name_Buffer; + -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer. + + procedure Set_String (S : String); + -- Sets characters of given string in Statement_Buffer, starting at the + -- Last + 1 position, and updating last past the string value. + + procedure Set_Unit_Name; + -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer, + -- starting at the Last + 1 position, and updating last past the value. + -- changing periods to double underscores, and updating Last appropriately. + + procedure Set_Unit_Number (U : Unit_Id); + -- Sets unit number (first unit is 1, leading zeroes output to line + -- up all output unit numbers nicely as required by the value, and + -- by the total number of units. + + procedure Tab_To (N : Natural); + -- If Last is greater than or equal to N, no effect, otherwise store + -- blanks in Statement_Buffer bumping Last, until Last = N. + + function Value (chars : chars_ptr) return String; + -- Return C NUL-terminated string at chars as an Ada string + + procedure Write_Info_Ada_C (Ada : String; C : String; Common : String); + -- For C code case, write C & Common, for Ada case write Ada & Common + -- to current binder output file using Write_Binder_Info. + + procedure Write_Statement_Buffer; + -- Write out contents of statement buffer up to Last, and reset Last to 0 + + procedure Write_Statement_Buffer (S : String); + -- First writes its argument (using Set_String (S)), then writes out the + -- contents of statement buffer up to Last, and reset Last to 0 + + -------------------------- + -- ABE_Boolean_Required -- + -------------------------- + + function ABE_Boolean_Required (U : Unit_Id) return Boolean is + Typ : constant Unit_Type := Units.Table (U).Utype; + Unit : Unit_Id; + + begin + if Typ /= Is_Body then + return False; + + else + Unit := U + 1; + + return (not Units.Table (Unit).Pure) + and then + (not Units.Table (Unit).Preelab) + and then + (not Units.Table (Unit).Elaborate_Body) + and then + (not Units.Table (Unit).Predefined); + end if; + end ABE_Boolean_Required; + + ---------------------- + -- Gen_Adafinal_Ada -- + ---------------------- + + procedure Gen_Adafinal_Ada is + begin + WBI (""); + WBI (" procedure " & Ada_Final_Name.all & " is"); + WBI (" begin"); + + -- If compiling for the JVM, we directly call Adafinal because + -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). + + if Hostparm.Java_VM then + WBI (" System.Standard_Library.Adafinal;"); + else + WBI (" Do_Finalize;"); + end if; + + WBI (" end " & Ada_Final_Name.all & ";"); + end Gen_Adafinal_Ada; + + -------------------- + -- Gen_Adafinal_C -- + -------------------- + + procedure Gen_Adafinal_C is + begin + WBI ("void " & Ada_Final_Name.all & " () {"); + WBI (" system__standard_library__adafinal ();"); + WBI ("}"); + WBI (""); + end Gen_Adafinal_C; + + --------------------- + -- Gen_Adainit_Ada -- + --------------------- + + procedure Gen_Adainit_Ada is + begin + WBI (" procedure " & Ada_Init_Name.all & " is"); + + -- Generate externals for elaboration entities + + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + begin + if U.Set_Elab_Entity then + Set_String (" "); + Set_String ("E"); + Set_Unit_Number (Unum); + Set_String (" : Boolean; pragma Import (Ada, "); + Set_String ("E"); + Set_Unit_Number (Unum); + Set_String (", """); + Get_Name_String (U.Uname); + + -- In the case of JGNAT we need to emit an Import name + -- that includes the class name (using '$' separators + -- in the case of a child unit name). + + if Hostparm.Java_VM then + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) /= '.' then + Set_Char (Name_Buffer (J)); + else + Set_String ("$"); + end if; + end loop; + + Set_String ("."); + + -- If the unit name is very long, then split the + -- Import link name across lines using "&" (occurs + -- in some C2 tests). + + if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then + Set_String (""" &"); + Write_Statement_Buffer; + Set_String (" """); + end if; + end if; + + Set_Unit_Name; + Set_String ("_E"");"); + Write_Statement_Buffer; + end if; + end; + end loop; + + Write_Statement_Buffer; + + -- Normal case (no pragma No_Run_Time). The global values are + -- assigned using the runtime routine Set_Globals (we have to use + -- the routine call, rather than define the globals in the binder + -- file to deal with cross-library calls in some systems. + + if not No_Run_Time_Specified then + WBI (""); + WBI (" procedure Set_Globals"); + WBI (" (Main_Priority : Integer;"); + WBI (" Time_Slice_Value : Integer;"); + WBI (" WC_Encoding : Character;"); + WBI (" Locking_Policy : Character;"); + WBI (" Queuing_Policy : Character;"); + WBI (" Task_Dispatching_Policy : Character;"); + WBI (" Adafinal : System.Address;"); + WBI (" Unreserve_All_Interrupts : Integer;"); + WBI (" Exception_Tracebacks : Integer);"); + WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");"); + WBI (""); + + -- Import entry point for elaboration time signal handler + -- installation, and indication of whether it's been called + -- previously + WBI (""); + WBI (" procedure Install_Handler;"); + WBI (" pragma Import (C, Install_Handler, " & + """__gnat_install_handler"");"); + WBI (""); + WBI (" Handler_Installed : Integer;"); + WBI (" pragma Import (C, Handler_Installed, " & + """__gnat_handler_installed"");"); + + -- Generate exception table + + Gen_Exception_Table_Ada; + + -- Generate the call to Set_Globals + + WBI (" Set_Globals"); + + Set_String (" (Main_Priority => "); + Set_Int (ALIs.Table (ALIs.First).Main_Priority); + Set_Char (','); + Write_Statement_Buffer; + + Set_String (" Time_Slice_Value => "); + + if Task_Dispatching_Policy_Specified = 'F' + and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 + then + Set_Int (0); + else + Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); + end if; + + Set_Char (','); + Write_Statement_Buffer; + + Set_String (" WC_Encoding => '"); + Set_Char (ALIs.Table (ALIs.First).WC_Encoding); + Set_String ("',"); + Write_Statement_Buffer; + + Set_String (" Locking_Policy => '"); + Set_Char (Locking_Policy_Specified); + Set_String ("',"); + Write_Statement_Buffer; + + Set_String (" Queuing_Policy => '"); + Set_Char (Queuing_Policy_Specified); + Set_String ("',"); + Write_Statement_Buffer; + + Set_String (" Task_Dispatching_Policy => '"); + Set_Char (Task_Dispatching_Policy_Specified); + Set_String ("',"); + Write_Statement_Buffer; + + WBI (" Adafinal => System.Null_Address,"); + + Set_String (" Unreserve_All_Interrupts => "); + + if Unreserve_All_Interrupts_Specified then + Set_String ("1"); + else + Set_String ("0"); + end if; + + Set_String (","); + Write_Statement_Buffer; + + Set_String (" Exception_Tracebacks => "); + + if Exception_Tracebacks then + Set_String ("1"); + else + Set_String ("0"); + end if; + + Set_String (");"); + Write_Statement_Buffer; + + -- Generate call to Install_Handler + WBI (""); + WBI (" if Handler_Installed = 0 then"); + WBI (" Install_Handler;"); + WBI (" end if;"); + + -- Case of pragma No_Run_Time present. Globals are not needed since + -- there are no runtime routines to make use of them, and no routine + -- to store them in any case! Also no exception tables are needed. + + else + WBI (" begin"); + WBI (" null;"); + end if; + + Gen_Elab_Calls_Ada; + + WBI (" end " & Ada_Init_Name.all & ";"); + end Gen_Adainit_Ada; + + ------------------- + -- Gen_Adainit_C -- + -------------------- + + procedure Gen_Adainit_C is + begin + WBI ("void " & Ada_Init_Name.all & " ()"); + WBI ("{"); + + -- Generate externals for elaboration entities + + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + begin + if U.Set_Elab_Entity then + Set_String (" extern char "); + Get_Name_String (U.Uname); + Set_Unit_Name; + Set_String ("_E;"); + Write_Statement_Buffer; + end if; + end; + end loop; + + Write_Statement_Buffer; + + -- Code for normal case (no pragma No_Run_Time in use) + + if not No_Run_Time_Specified then + + Gen_Exception_Table_C; + + -- Generate call to set the runtime global variables defined in + -- a-init.c. We define the varables in a-init.c, rather than in + -- the binder generated file itself to avoid undefined externals + -- when the runtime is linked as a shareable image library. + + -- We call the routine from inside adainit() because this works for + -- both programs with and without binder generated "main" functions. + + WBI (" __gnat_set_globals ("); + + Set_String (" "); + Set_Int (ALIs.Table (ALIs.First).Main_Priority); + Set_Char (','); + Tab_To (15); + Set_String ("/* Main_Priority */"); + Write_Statement_Buffer; + + Set_String (" "); + + if Task_Dispatching_Policy = 'F' + and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 + then + Set_Int (0); + else + Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); + end if; + + Set_Char (','); + Tab_To (15); + Set_String ("/* Time_Slice_Value */"); + Write_Statement_Buffer; + + Set_String (" '"); + Set_Char (ALIs.Table (ALIs.First).WC_Encoding); + Set_String ("',"); + Tab_To (15); + Set_String ("/* WC_Encoding */"); + Write_Statement_Buffer; + + Set_String (" '"); + Set_Char (Locking_Policy_Specified); + Set_String ("',"); + Tab_To (15); + Set_String ("/* Locking_Policy */"); + Write_Statement_Buffer; + + Set_String (" '"); + Set_Char (Queuing_Policy_Specified); + Set_String ("',"); + Tab_To (15); + Set_String ("/* Queuing_Policy */"); + Write_Statement_Buffer; + + Set_String (" '"); + Set_Char (Task_Dispatching_Policy_Specified); + Set_String ("',"); + Tab_To (15); + Set_String ("/* Tasking_Dispatching_Policy */"); + Write_Statement_Buffer; + + Set_String (" "); + Set_String ("0,"); + Tab_To (15); + Set_String ("/* Finalization routine address, not used anymore */"); + Write_Statement_Buffer; + + Set_String (" "); + Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); + Set_String (","); + Tab_To (15); + Set_String ("/* Unreserve_All_Interrupts */"); + Write_Statement_Buffer; + + Set_String (" "); + Set_Int (Boolean'Pos (Exception_Tracebacks)); + Set_String (");"); + Tab_To (15); + Set_String ("/* Exception_Tracebacks */"); + Write_Statement_Buffer; + + -- Install elaboration time signal handler + WBI (" if (__gnat_handler_installed == 0)"); + WBI (" {"); + WBI (" __gnat_install_handler ();"); + WBI (" }"); + + -- Case where No_Run_Time pragma is present (no globals required) + -- Nothing more needs to be done in this case. + + else + null; + end if; + + WBI (""); + Gen_Elab_Calls_C; + WBI ("}"); + end Gen_Adainit_C; + + ------------------------ + -- Gen_Elab_Calls_Ada -- + ------------------------ + + procedure Gen_Elab_Calls_Ada is + begin + + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + Unum_Spec : Unit_Id; + -- This is the unit number of the spec that corresponds to + -- this entry. It is the same as Unum except when the body + -- and spec are different and we are currently processing + -- the body, in which case it is the spec (Unum + 1). + + procedure Set_Elab_Entity; + -- Set name of elaboration entity flag + + procedure Set_Elab_Entity is + begin + Get_Decoded_Name_String_With_Brackets (U.Uname); + Name_Len := Name_Len - 2; + Set_Casing (U.Icasing); + Set_Name_Buffer; + end Set_Elab_Entity; + + begin + if U.Utype = Is_Body then + Unum_Spec := Unum + 1; + else + Unum_Spec := Unum; + end if; + + -- Case of no elaboration code + + if U.No_Elab then + + -- The only case in which we have to do something is if + -- this is a body, with a separate spec, where the separate + -- spec has an elaboration entity defined. + + -- In that case, this is where we set the elaboration entity + -- to True, we do not need to test if this has already been + -- done, since it is quicker to set the flag than to test it. + + if U.Utype = Is_Body + and then Units.Table (Unum_Spec).Set_Elab_Entity + then + Set_String (" E"); + Set_Unit_Number (Unum_Spec); + Set_String (" := True;"); + Write_Statement_Buffer; + end if; + + -- Here if elaboration code is present. We generate: + + -- if not uname_E then + -- uname'elab_[spec|body]; + -- uname_E := True; + -- end if; + + -- The uname_E assignment is skipped if this is a separate spec, + -- since the assignment will be done when we process the body. + + else + Set_String (" if not E"); + Set_Unit_Number (Unum_Spec); + Set_String (" then"); + Write_Statement_Buffer; + + Set_String (" "); + Get_Decoded_Name_String_With_Brackets (U.Uname); + + if Name_Buffer (Name_Len) = 's' then + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_spec"; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_body"; + end if; + + Name_Len := Name_Len + 8; + Set_Casing (U.Icasing); + Set_Name_Buffer; + Set_Char (';'); + Write_Statement_Buffer; + + if U.Utype /= Is_Spec then + Set_String (" E"); + Set_Unit_Number (Unum_Spec); + Set_String (" := True;"); + Write_Statement_Buffer; + end if; + + WBI (" end if;"); + end if; + end; + end loop; + + end Gen_Elab_Calls_Ada; + + ---------------------- + -- Gen_Elab_Calls_C -- + ---------------------- + + procedure Gen_Elab_Calls_C is + begin + + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + Unum_Spec : Unit_Id; + -- This is the unit number of the spec that corresponds to + -- this entry. It is the same as Unum except when the body + -- and spec are different and we are currently processing + -- the body, in which case it is the spec (Unum + 1). + + begin + if U.Utype = Is_Body then + Unum_Spec := Unum + 1; + else + Unum_Spec := Unum; + end if; + + -- Case of no elaboration code + + if U.No_Elab then + + -- The only case in which we have to do something is if + -- this is a body, with a separate spec, where the separate + -- spec has an elaboration entity defined. + + -- In that case, this is where we set the elaboration entity + -- to True, we do not need to test if this has already been + -- done, since it is quicker to set the flag than to test it. + + if U.Utype = Is_Body + and then Units.Table (Unum_Spec).Set_Elab_Entity + then + Set_String (" "); + Get_Name_String (U.Uname); + Set_Unit_Name; + Set_String ("_E = 1;"); + Write_Statement_Buffer; + end if; + + -- Here if elaboration code is present. We generate: + + -- if (uname_E == 0) { + -- uname__elab[s|b] (); + -- uname_E++; + -- } + + -- The uname_E assignment is skipped if this is a separate spec, + -- since the assignment will be done when we process the body. + + else + Set_String (" if ("); + Get_Name_String (U.Uname); + Set_Unit_Name; + Set_String ("_E == 0) {"); + Write_Statement_Buffer; + + Set_String (" "); + Set_Unit_Name; + Set_String ("___elab"); + Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body + Set_String (" ();"); + Write_Statement_Buffer; + + if U.Utype /= Is_Spec then + Set_String (" "); + Set_Unit_Name; + Set_String ("_E++;"); + Write_Statement_Buffer; + end if; + + WBI (" }"); + end if; + end; + end loop; + + end Gen_Elab_Calls_C; + + ---------------------- + -- Gen_Elab_Defs_C -- + ---------------------- + + procedure Gen_Elab_Defs_C is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + + -- Generate declaration of elaboration procedure if elaboration + -- needed. Note that passive units are always excluded. + + if not Units.Table (Elab_Order.Table (E)).No_Elab then + Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); + Set_String ("extern void "); + Set_Unit_Name; + Set_String ("___elab"); + Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body + Set_String (" PARAMS ((void));"); + Write_Statement_Buffer; + end if; + + end loop; + + WBI (""); + end Gen_Elab_Defs_C; + + ------------------------ + -- Gen_Elab_Order_Ada -- + ------------------------ + + procedure Gen_Elab_Order_Ada is + begin + WBI (""); + WBI (" -- BEGIN ELABORATION ORDER"); + + for J in Elab_Order.First .. Elab_Order.Last loop + Set_String (" -- "); + Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname); + Set_Name_Buffer; + Write_Statement_Buffer; + end loop; + + WBI (" -- END ELABORATION ORDER"); + end Gen_Elab_Order_Ada; + + ---------------------- + -- Gen_Elab_Order_C -- + ---------------------- + + procedure Gen_Elab_Order_C is + begin + WBI (""); + WBI ("/* BEGIN ELABORATION ORDER"); + + for J in Elab_Order.First .. Elab_Order.Last loop + Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname); + Set_Name_Buffer; + Write_Statement_Buffer; + end loop; + + WBI (" END ELABORATION ORDER */"); + end Gen_Elab_Order_C; + + ----------------------------- + -- Gen_Exception_Table_Ada -- + ----------------------------- + + procedure Gen_Exception_Table_Ada is + Num : Nat; + Last : ALI_Id := No_ALI_Id; + + begin + if not Zero_Cost_Exceptions_Specified then + WBI (" begin"); + return; + end if; + + -- The code we generate looks like + + -- procedure SDP_Table_Build + -- (SDP_Addresses : System.Address; + -- SDP_Count : Natural; + -- Elab_Addresses : System.Address; + -- Elab_Addr_Count : Natural); + -- pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build"); + -- + -- ST : aliased constant array (1 .. nnn) of System.Address := ( + -- unit_name_1'UET_Address, + -- unit_name_2'UET_Address, + -- ... + -- unit_name_3'UET_Address, + -- + -- EA : aliased constant array (1 .. eee) of System.Address := ( + -- adainit'Code_Address, + -- adafinal'Code_Address, + -- unit_name'elab[spec|body]'Code_Address, + -- unit_name'elab[spec|body]'Code_Address, + -- unit_name'elab[spec|body]'Code_Address, + -- unit_name'elab[spec|body]'Code_Address); + -- + -- begin + -- SDP_Table_Build (ST'Address, nnn, EA'Address, eee); + + Num := 0; + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Unit_Exception_Table then + Num := Num + 1; + Last := A; + end if; + end loop; + + WBI (" procedure SDP_Table_Build"); + WBI (" (SDP_Addresses : System.Address;"); + WBI (" SDP_Count : Natural;"); + WBI (" Elab_Addresses : System.Address;"); + WBI (" Elab_Addr_Count : Natural);"); + WBI (" " & + "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");"); + + WBI (" "); + Set_String (" ST : aliased constant array (1 .. "); + Set_Int (Num); + Set_String (") of System.Address := ("); + + if Num = 1 then + Set_String ("1 => A1);"); + Write_Statement_Buffer; + + else + Write_Statement_Buffer; + + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Unit_Exception_Table then + Get_Decoded_Name_String_With_Brackets + (Units.Table (ALIs.Table (A).First_Unit).Uname); + Set_Casing (Mixed_Case); + Set_String (" "); + Set_String (Name_Buffer (1 .. Name_Len - 2)); + Set_String ("'UET_Address"); + + if A = Last then + Set_String (");"); + else + Set_Char (','); + end if; + + Write_Statement_Buffer; + end if; + end loop; + end if; + + WBI (" "); + Set_String (" EA : aliased constant array (1 .. "); + Set_Int (Num_Elab_Calls + 2); + Set_String (") of System.Address := ("); + Write_Statement_Buffer; + WBI (" " & Ada_Init_Name.all & "'Code_Address,"); + + -- If compiling for the JVM, we directly reference Adafinal because + -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). + + if Hostparm.Java_VM then + Set_String (" System.Standard_Library.Adafinal'Code_Address"); + else + Set_String (" Do_Finalize'Code_Address"); + end if; + + for E in Elab_Order.First .. Elab_Order.Last loop + Get_Decoded_Name_String_With_Brackets + (Units.Table (Elab_Order.Table (E)).Uname); + + if Units.Table (Elab_Order.Table (E)).No_Elab then + null; + + else + Set_Char (','); + Write_Statement_Buffer; + Set_String (" "); + + if Name_Buffer (Name_Len) = 's' then + Name_Buffer (Name_Len - 1 .. Name_Len + 21) := + "'elab_spec'code_address"; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 21) := + "'elab_body'code_address"; + end if; + + Name_Len := Name_Len + 21; + Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing); + Set_Name_Buffer; + end if; + end loop; + + Set_String (");"); + Write_Statement_Buffer; + + WBI (" "); + WBI (" begin"); + + Set_String (" SDP_Table_Build (ST'Address, "); + Set_Int (Num); + Set_String (", EA'Address, "); + Set_Int (Num_Elab_Calls + 2); + Set_String (");"); + Write_Statement_Buffer; + end Gen_Exception_Table_Ada; + + --------------------------- + -- Gen_Exception_Table_C -- + --------------------------- + + procedure Gen_Exception_Table_C is + Num : Nat; + Num2 : Nat; + + begin + if not Zero_Cost_Exceptions_Specified then + return; + end if; + + -- The code we generate looks like + + -- extern void *__gnat_unitname1__SDP; + -- extern void *__gnat_unitname2__SDP; + -- ... + -- + -- void **st[nnn] = { + -- &__gnat_unitname1__SDP, + -- &__gnat_unitname2__SDP, + -- ... + -- &__gnat_unitnamen__SDP}; + -- + -- extern void unitname1__elabb (); + -- extern void unitname2__elabb (); + -- ... + -- + -- void (*ea[eee]) () = { + -- adainit, + -- adafinal, + -- unitname1___elab[b,s], + -- unitname2___elab[b,s], + -- ... + -- unitnamen___elab[b,s]}; + -- + -- __gnat_SDP_Table_Build (&st, nnn, &ea, eee); + + Num := 0; + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Unit_Exception_Table then + Num := Num + 1; + + Set_String (" extern void *__gnat_"); + Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname); + Set_Unit_Name; + Set_String ("__SDP"); + Set_Char (';'); + Write_Statement_Buffer; + end if; + end loop; + + WBI (" "); + + Set_String (" void **st["); + Set_Int (Num); + Set_String ("] = {"); + Write_Statement_Buffer; + + Num2 := 0; + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Unit_Exception_Table then + Num2 := Num2 + 1; + + Set_String (" &__gnat_"); + Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname); + Set_Unit_Name; + Set_String ("__SDP"); + + if Num = Num2 then + Set_String ("};"); + else + Set_Char (','); + end if; + + Write_Statement_Buffer; + end if; + end loop; + + WBI (""); + for E in Elab_Order.First .. Elab_Order.Last loop + Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); + + if Units.Table (Elab_Order.Table (E)).No_Elab then + null; + + else + Set_String (" extern void "); + Set_Unit_Name; + Set_String ("___elab"); + Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body + Set_String (" ();"); + Write_Statement_Buffer; + end if; + end loop; + + WBI (""); + Set_String (" void (*ea["); + Set_Int (Num_Elab_Calls + 2); + Set_String ("]) () = {"); + Write_Statement_Buffer; + + WBI (" " & Ada_Init_Name.all & ","); + Set_String (" system__standard_library__adafinal"); + + for E in Elab_Order.First .. Elab_Order.Last loop + Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); + + if Units.Table (Elab_Order.Table (E)).No_Elab then + null; + + else + Set_Char (','); + Write_Statement_Buffer; + Set_String (" "); + Set_Unit_Name; + Set_String ("___elab"); + Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body + end if; + end loop; + + Set_String ("};"); + Write_Statement_Buffer; + + WBI (" "); + + Set_String (" __gnat_SDP_Table_Build (&st, "); + Set_Int (Num); + Set_String (", ea, "); + Set_Int (Num_Elab_Calls + 2); + Set_String (");"); + Write_Statement_Buffer; + end Gen_Exception_Table_C; + + ------------------ + -- Gen_Main_Ada -- + ------------------ + + procedure Gen_Main_Ada is + Target : constant String_Ptr := Target_Name; + VxWorks_Target : constant Boolean := + Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + + begin + WBI (""); + Set_String (" function "); + Set_String (Get_Main_Name); + + if VxWorks_Target then + Set_String (" return Integer is"); + Write_Statement_Buffer; + + else + Write_Statement_Buffer; + WBI (" (argc : Integer;"); + WBI (" argv : System.Address;"); + WBI (" envp : System.Address)"); + WBI (" return Integer"); + WBI (" is"); + end if; + + -- Initialize and Finalize are not used in No_Run_Time mode + + if not No_Run_Time_Specified then + WBI (" procedure initialize;"); + WBI (" pragma Import (C, initialize, ""__gnat_initialize"");"); + WBI (""); + WBI (" procedure finalize;"); + WBI (" pragma Import (C, finalize, ""__gnat_finalize"");"); + WBI (""); + end if; + + -- Deal with declarations for main program case + + if not No_Main_Subprogram then + + -- To call the main program, we declare it using a pragma Import + -- Ada with the right link name. + + -- It might seem more obvious to "with" the main program, and call + -- it in the normal Ada manner. We do not do this for three reasons: + + -- 1. It is more efficient not to recompile the main program + -- 2. We are not entitled to assume the source is accessible + -- 3. We don't know what options to use to compile it + + -- It is really reason 3 that is most critical (indeed we used + -- to generate the "with", but several regression tests failed). + + WBI (""); + + if ALIs.Table (ALIs.First).Main_Program = Func then + WBI (" Result : Integer;"); + WBI (""); + WBI (" function Ada_Main_Program return Integer;"); + + else + WBI (" procedure Ada_Main_Program;"); + end if; + + Set_String (" pragma Import (Ada, Ada_Main_Program, """); + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + Set_Main_Program_Name; + Set_String (""");"); + + Write_Statement_Buffer; + WBI (""); + end if; + + WBI (" begin"); + + -- On VxWorks, there are no command line arguments + + if VxWorks_Target then + WBI (" gnat_argc := 0;"); + WBI (" gnat_argv := System.Null_Address;"); + WBI (" gnat_envp := System.Null_Address;"); + + -- Normal case of command line arguments present + + else + WBI (" gnat_argc := argc;"); + WBI (" gnat_argv := argv;"); + WBI (" gnat_envp := envp;"); + WBI (""); + end if; + + if not No_Run_Time_Specified then + WBI (" Initialize;"); + end if; + + WBI (" " & Ada_Init_Name.all & ";"); + + if not No_Main_Subprogram then + WBI (" Break_Start;"); + + if ALIs.Table (ALIs.First).Main_Program = Proc then + WBI (" Ada_Main_Program;"); + else + WBI (" Result := Ada_Main_Program;"); + end if; + end if; + + -- Adafinal is only called if we have a run time + + if not No_Run_Time_Specified then + + -- If compiling for the JVM, we directly call Adafinal because + -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). + + if Hostparm.Java_VM then + WBI (" System.Standard_Library.Adafinal;"); + else + WBI (" Do_Finalize;"); + end if; + end if; + + -- Finalize is only called if we have a run time + + if not No_Run_Time_Specified then + WBI (" Finalize;"); + end if; + + -- Return result + + if No_Main_Subprogram + or else ALIs.Table (ALIs.First).Main_Program = Proc + then + WBI (" return (gnat_exit_status);"); + else + WBI (" return (Result);"); + end if; + + WBI (" end;"); + end Gen_Main_Ada; + + ---------------- + -- Gen_Main_C -- + ---------------- + + procedure Gen_Main_C is + Target : constant String_Ptr := Target_Name; + VxWorks_Target : constant Boolean := + Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + + begin + Set_String ("int "); + Set_String (Get_Main_Name); + + -- On VxWorks, there are no command line arguments + + if VxWorks_Target then + Set_String (" ()"); + + -- Normal case with command line arguments present + + else + Set_String (" (argc, argv, envp)"); + end if; + + Write_Statement_Buffer; + + -- VxWorks doesn't have the notion of argc/argv + + if VxWorks_Target then + WBI ("{"); + WBI (" int result;"); + WBI (" gnat_argc = 0;"); + WBI (" gnat_argv = 0;"); + WBI (" gnat_envp = 0;"); + + -- Normal case of arguments present + + else + WBI (" int argc;"); + WBI (" char **argv;"); + WBI (" char **envp;"); + WBI ("{"); + + if ALIs.Table (ALIs.First).Main_Program = Func then + WBI (" int result;"); + end if; + + WBI (" gnat_argc = argc;"); + WBI (" gnat_argv = argv;"); + WBI (" gnat_envp = envp;"); + WBI (" "); + end if; + + -- The __gnat_initialize routine is used only if we have a run-time + + if not No_Run_Time_Specified then + WBI + (" __gnat_initialize ();"); + end if; + + WBI (" " & Ada_Init_Name.all & " ();"); + + if not No_Main_Subprogram then + + WBI (" __gnat_break_start ();"); + WBI (" "); + + -- Output main program name + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + + -- Main program is procedure case + + if ALIs.Table (ALIs.First).Main_Program = Proc then + Set_String (" "); + Set_Main_Program_Name; + Set_String (" ();"); + Write_Statement_Buffer; + + -- Main program is function case + + else -- ALIs.Table (ALIs_First).Main_Program = Func + Set_String (" result = "); + Set_Main_Program_Name; + Set_String (" ();"); + Write_Statement_Buffer; + end if; + + end if; + + -- Adafinal is called only when we have a run-time + + if not No_Run_Time_Specified then + WBI (" "); + WBI (" system__standard_library__adafinal ();"); + end if; + + -- The finalize routine is used only if we have a run-time + + if not No_Run_Time_Specified then + WBI (" __gnat_finalize ();"); + end if; + + if ALIs.Table (ALIs.First).Main_Program = Func then + + if Hostparm.OpenVMS then + + -- VMS must use the Posix exit routine in order to get an + -- Unix compatible exit status. + + WBI (" __posix_exit (result);"); + + else + WBI (" exit (result);"); + end if; + + else + + if Hostparm.OpenVMS then + -- VMS must use the Posix exit routine in order to get an + -- Unix compatible exit status. + WBI (" __posix_exit (gnat_exit_status);"); + else + WBI (" exit (gnat_exit_status);"); + end if; + end if; + + WBI ("}"); + end Gen_Main_C; + + ------------------------------ + -- Gen_Object_Files_Options -- + ------------------------------ + + procedure Gen_Object_Files_Options is + Lgnat : Integer; + + procedure Write_Linker_Option; + -- Write binder info linker option. + + ------------------------- + -- Write_Linker_Option -- + ------------------------- + + procedure Write_Linker_Option is + Start : Natural; + Stop : Natural; + + begin + -- Loop through string, breaking at null's + + Start := 1; + while Start < Name_Len loop + + -- Find null ending this section + + Stop := Start + 1; + while Name_Buffer (Stop) /= ASCII.NUL + and then Stop <= Name_Len loop + Stop := Stop + 1; + end loop; + + -- Process section if non-null + + if Stop > Start then + if Output_Linker_Option_List then + Write_Str (Name_Buffer (Start .. Stop - 1)); + Write_Eol; + end if; + Write_Info_Ada_C + (" -- ", "", Name_Buffer (Start .. Stop - 1)); + end if; + + Start := Stop + 1; + end loop; + end Write_Linker_Option; + + -- Start of processing for Gen_Object_Files_Options + + begin + WBI (""); + Write_Info_Ada_C ("--", "/*", " BEGIN Object file/option list"); + + for E in Elab_Order.First .. Elab_Order.Last loop + + -- If not spec that has an associated body, then generate a + -- comment giving the name of the corresponding object file. + + if Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec then + Get_Name_String + (ALIs.Table + (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name); + + -- If the presence of an object file is necessary or if it + -- exists, then use it. + + if not Hostparm.Exclude_Missing_Objects + or else + GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len)) + then + Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); + if Output_Object_List then + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end if; + + -- Don't link with the shared library on VMS if an internal + -- filename object is seen. Multiply defined symbols will + -- result. + + if Hostparm.OpenVMS + and then Is_Internal_File_Name + (ALIs.Table + (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile) + then + Opt.Shared_Libgnat := False; + end if; + + end if; + end if; + end loop; + + -- Add a "-Ldir" for each directory in the object path. We skip this + -- in No_Run_Time mode, where we want more precise control of exactly + -- what goes into the resulting object file + + if not No_Run_Time_Specified then + for J in 1 .. Nb_Dir_In_Obj_Search_Path loop + declare + Dir : String_Ptr := Dir_In_Obj_Search_Path (J); + + begin + Name_Len := 0; + Add_Str_To_Name_Buffer ("-L"); + Add_Str_To_Name_Buffer (Dir.all); + Write_Linker_Option; + end; + end loop; + end if; + + -- Sort linker options + + Sort (Linker_Options.Last, Move_Linker_Option'Access, + Lt_Linker_Option'Access); + + -- Write user linker options + + Lgnat := Linker_Options.Last + 1; + + for J in 1 .. Linker_Options.Last loop + if not Linker_Options.Table (J).Internal_File then + Get_Name_String (Linker_Options.Table (J).Name); + Write_Linker_Option; + else + Lgnat := J; + exit; + end if; + end loop; + + if not (No_Run_Time_Specified or else Opt.No_Stdlib) then + + Name_Len := 0; + + if Opt.Shared_Libgnat then + Add_Str_To_Name_Buffer ("-shared"); + else + Add_Str_To_Name_Buffer ("-static"); + end if; + + -- Write directly to avoid -K output. + + Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); + + if With_DECGNAT then + Name_Len := 0; + Add_Str_To_Name_Buffer ("-ldecgnat"); + Write_Linker_Option; + end if; + + if With_GNARL then + Name_Len := 0; + Add_Str_To_Name_Buffer ("-lgnarl"); + Write_Linker_Option; + end if; + + Name_Len := 0; + Add_Str_To_Name_Buffer ("-lgnat"); + Write_Linker_Option; + + end if; + + -- Write internal linker options + + for J in Lgnat .. Linker_Options.Last loop + Get_Name_String (Linker_Options.Table (J).Name); + Write_Linker_Option; + end loop; + + if Ada_Bind_File then + WBI ("-- END Object file/option list "); + else + WBI (" END Object file/option list */"); + end if; + + end Gen_Object_Files_Options; + + --------------------- + -- Gen_Output_File -- + --------------------- + + procedure Gen_Output_File (Filename : String) is + + function Public_Version return Boolean; + -- Return true if the version number contains a 'p' + + function Public_Version return Boolean is + begin + for J in Gnat_Version_String'Range loop + if Gnat_Version_String (J) = 'p' then + return True; + end if; + end loop; + + return False; + end Public_Version; + + -- Start of processing for Gen_Output_File + + begin + -- Override Ada_Bind_File and Bind_Main_Program for Java since + -- JGNAT only supports Ada code, and the main program is already + -- generated by the compiler. + + if Hostparm.Java_VM then + Ada_Bind_File := True; + Bind_Main_Program := False; + end if; + + -- Override time slice value if -T switch is set + + if Time_Slice_Set then + ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value; + end if; + + -- Count number of elaboration calls + + for E in Elab_Order.First .. Elab_Order.Last loop + if Units.Table (Elab_Order.Table (E)).No_Elab then + null; + else + Num_Elab_Calls := Num_Elab_Calls + 1; + end if; + end loop; + + -- Get the time stamp of the former bind for public version warning + + if Public_Version then + Record_Time_From_Last_Bind; + end if; + + -- Generate output file in appropriate language + + if Ada_Bind_File then + Gen_Output_File_Ada (Filename); + else + Gen_Output_File_C (Filename); + end if; + + -- Periodically issue a warning when the public version is used on + -- big projects + + if Public_Version then + Public_Version_Warning; + end if; + end Gen_Output_File; + + ------------------------- + -- Gen_Output_File_Ada -- + ------------------------- + + procedure Gen_Output_File_Ada (Filename : String) is + + Bfiles : Name_Id; + -- Name of generated bind file (spec) + + Bfileb : Name_Id; + -- Name of generated bind file (body) + + Ada_Main : constant String := Get_Ada_Main_Name; + -- Name to be used for generated Ada main program. See the body of + -- function Get_Ada_Main_Name for details on the form of the name. + + Target : constant String_Ptr := Target_Name; + VxWorks_Target : constant Boolean := + Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + + begin + -- Create spec first + + Create_Binder_Output (Filename, 's', Bfiles); + + if No_Run_Time_Specified then + WBI ("pragma No_Run_Time;"); + end if; + + -- Generate with of System so we can reference System.Address, note + -- that such a reference is safe even in No_Run_Time mode, since we + -- do not need any run-time code for such a reference, and we output + -- a pragma No_Run_Time for this compilation above. + + WBI ("with System;"); + + -- Generate with of System.Initialize_Scalars if active + + if Initialize_Scalars_Used then + WBI ("with System.Scalar_Values;"); + end if; + + Resolve_Binder_Options; + + if not No_Run_Time_Specified then + + -- Usually, adafinal is called using a pragma Import C. Since + -- Import C doesn't have the same semantics for JGNAT, we use + -- standard Ada. + + if Hostparm.Java_VM then + WBI ("with System.Standard_Library;"); + end if; + end if; + + WBI ("package " & Ada_Main & " is"); + + -- Main program case + + if Bind_Main_Program then + + -- Generate argc/argv stuff + + WBI (""); + WBI (" gnat_argc : Integer;"); + WBI (" gnat_argv : System.Address;"); + WBI (" gnat_envp : System.Address;"); + + -- If we have a run time present, these variables are in the + -- runtime data area for easy access from the runtime + + if not No_Run_Time_Specified then + WBI (""); + WBI (" pragma Import (C, gnat_argc);"); + WBI (" pragma Import (C, gnat_argv);"); + WBI (" pragma Import (C, gnat_envp);"); + end if; + + -- Define exit status. Again in normal mode, this is in the + -- run-time library, and is initialized there, but in the no + -- run time case, the variable is here and initialized here. + + WBI (""); + + if No_Run_Time_Specified then + WBI (" gnat_exit_status : Integer := 0;"); + else + WBI (" gnat_exit_status : Integer;"); + WBI (" pragma Import (C, gnat_exit_status);"); + end if; + end if; + + -- Generate the GNAT_Version info only for the main program. Otherwise, + -- it can lead under some circumstances to a symbol duplication during + -- the link (for instance when a C program uses 2 Ada libraries) + + if Bind_Main_Program then + WBI (""); + WBI (" GNAT_Version : constant String :="); + WBI (" ""GNAT Version: " & + Gnat_Version_String & """;"); + WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); + end if; + + -- No need to generate a finalization routine if there is no + -- runtime, since there is nothing to do in this case. + + if not No_Run_Time_Specified then + WBI (""); + WBI (" procedure " & Ada_Final_Name.all & ";"); + WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & + Ada_Final_Name.all & """);"); + end if; + + WBI (""); + WBI (" procedure " & Ada_Init_Name.all & ";"); + WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ & + Ada_Init_Name.all & """);"); + + if Bind_Main_Program then + + -- If we have a run time, then Break_Start is defined there, but + -- if there is no run-time, Break_Start is defined in this file. + + WBI (""); + WBI (" procedure Break_Start;"); + + if No_Run_Time_Specified then + WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");"); + else + WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");"); + end if; + + WBI (""); + WBI (" function " & Get_Main_Name); + + -- Generate argument list (except on VxWorks, where none is present) + + if not VxWorks_Target then + WBI (" (argc : Integer;"); + WBI (" argv : System.Address;"); + WBI (" envp : System.Address)"); + end if; + + WBI (" return Integer;"); + WBI (" pragma Export (C, " & Get_Main_Name & ", """ & + Get_Main_Name & """);"); + end if; + + if Initialize_Scalars_Used then + Gen_Scalar_Values; + end if; + + Gen_Versions_Ada; + Gen_Elab_Order_Ada; + + -- Spec is complete + + WBI (""); + WBI ("end " & Ada_Main & ";"); + Close_Binder_Output; + + -- Prepare to write body + + Create_Binder_Output (Filename, 'b', Bfileb); + + -- Output Source_File_Name pragmas which look like + + -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss"); + -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb"); + + -- where sss/bbb are the spec/body file names respectively + + Get_Name_String (Bfiles); + Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);"; + + WBI ("pragma Source_File_Name (" & + Ada_Main & + ", Spec_File_Name => """ & + Name_Buffer (1 .. Name_Len + 3)); + + Get_Name_String (Bfileb); + Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);"; + + WBI ("pragma Source_File_Name (" & + Ada_Main & + ", Body_File_Name => """ & + Name_Buffer (1 .. Name_Len + 3)); + + WBI (""); + WBI ("package body " & Ada_Main & " is"); + + -- Import the finalization procedure only if there is a runtime. + + if not No_Run_Time_Specified then + + -- In the Java case, pragma Import C cannot be used, so the + -- standard Ada constructs will be used instead. + + if not Hostparm.Java_VM then + WBI (""); + WBI (" procedure Do_Finalize;"); + WBI + (" pragma Import (C, Do_Finalize, " & + """system__standard_library__adafinal"");"); + WBI (""); + end if; + end if; + + Gen_Adainit_Ada; + + -- No need to generate a finalization routine if there is no + -- runtime, since there is nothing to do in this case. + + if not No_Run_Time_Specified then + Gen_Adafinal_Ada; + end if; + + if Bind_Main_Program then + + -- In No_Run_Time mode, generate dummy body for Break_Start + + if No_Run_Time_Specified then + WBI (""); + WBI (" procedure Break_Start is"); + WBI (" begin"); + WBI (" null;"); + WBI (" end;"); + end if; + + Gen_Main_Ada; + end if; + + -- Output object file list and the Ada body is complete + + Gen_Object_Files_Options; + + WBI (""); + WBI ("end " & Ada_Main & ";"); + + Close_Binder_Output; + end Gen_Output_File_Ada; + + ----------------------- + -- Gen_Output_File_C -- + ----------------------- + + procedure Gen_Output_File_C (Filename : String) is + + Bfile : Name_Id; + -- Name of generated bind file + + begin + Create_Binder_Output (Filename, 'c', Bfile); + + Resolve_Binder_Options; + + WBI ("#ifdef __STDC__"); + WBI ("#define PARAMS(paramlist) paramlist"); + WBI ("#else"); + WBI ("#define PARAMS(paramlist) ()"); + WBI ("#endif"); + WBI (""); + + WBI ("extern void __gnat_set_globals "); + WBI (" PARAMS ((int, int, int, int, int, int, "); + WBI (" void (*) PARAMS ((void)), int, int));"); + WBI ("extern void " & Ada_Final_Name.all & " PARAMS ((void));"); + WBI ("extern void " & Ada_Init_Name.all & " PARAMS ((void));"); + + WBI ("extern void system__standard_library__adafinal PARAMS ((void));"); + + if not No_Main_Subprogram then + WBI ("extern int main PARAMS ((int, char **, char **));"); + if Hostparm.OpenVMS then + WBI ("extern void __posix_exit PARAMS ((int));"); + else + WBI ("extern void exit PARAMS ((int));"); + end if; + + WBI ("extern void __gnat_break_start PARAMS ((void));"); + Set_String ("extern "); + + if ALIs.Table (ALIs.First).Main_Program = Proc then + Set_String ("void "); + else + Set_String ("int "); + end if; + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + Set_Main_Program_Name; + Set_String (" PARAMS ((void));"); + Write_Statement_Buffer; + end if; + + if not No_Run_Time_Specified then + WBI ("extern void __gnat_initialize PARAMS ((void));"); + WBI ("extern void __gnat_finalize PARAMS ((void));"); + WBI ("extern void __gnat_install_handler PARAMS ((void));"); + end if; + + WBI (""); + + Gen_Elab_Defs_C; + + -- Imported variable used to track elaboration/finalization phase. + -- Used only when we have a runtime. + + if not No_Run_Time_Specified then + WBI ("extern int __gnat_handler_installed;"); + WBI (""); + end if; + + -- Write argv/argc stuff if main program case + + if Bind_Main_Program then + + -- In the normal case, these are in the runtime library + + if not No_Run_Time_Specified then + WBI ("extern int gnat_argc;"); + WBI ("extern char **gnat_argv;"); + WBI ("extern char **gnat_envp;"); + WBI ("extern int gnat_exit_status;"); + + -- In the No_Run_Time case, they are right in the binder file + -- and we initialize gnat_exit_status in the declaration. + + else + WBI ("int gnat_argc;"); + WBI ("char **gnat_argv;"); + WBI ("char **gnat_envp;"); + WBI ("int gnat_exit_status = 0;"); + end if; + + WBI (""); + end if; + + -- In no run-time mode, the __gnat_break_start routine (for the + -- debugger to get initial control) is defined in this file. + + if No_Run_Time_Specified then + WBI (""); + WBI ("void __gnat_break_start () {}"); + end if; + + -- Generate the __gnat_version info only for the main program. + -- Otherwise, it can lead under some circumstances to a symbol + -- duplication during the link (for instance when a C program + -- uses 2 Ada libraries) + + if Bind_Main_Program then + WBI (""); + WBI ("char __gnat_version[] = ""GNAT Version: " & + Gnat_Version_String & """;"); + end if; + + -- Generate the adafinal routine. In no runtime mode, this is + -- not needed, since there is no finalization to do. + + if not No_Run_Time_Specified then + Gen_Adafinal_C; + end if; + + Gen_Adainit_C; + + -- Main is only present for Ada main case + + if Bind_Main_Program then + Gen_Main_C; + end if; + + -- Scalar values, versions and object files needed in both cases + + if Initialize_Scalars_Used then + Gen_Scalar_Values; + end if; + + Gen_Versions_C; + Gen_Elab_Order_C; + Gen_Object_Files_Options; + + -- C binder output is complete + + Close_Binder_Output; + end Gen_Output_File_C; + + ----------------------- + -- Gen_Scalar_Values -- + ----------------------- + + procedure Gen_Scalar_Values is + + -- Strings to hold hex values of initialization constants. Note that + -- we store these strings in big endian order, but they are actually + -- used to initialize integer values, so the actual generated data + -- will automaticaly have the right endianess. + + IS_Is1 : String (1 .. 2); + IS_Is2 : String (1 .. 4); + IS_Is4 : String (1 .. 8); + IS_Is8 : String (1 .. 16); + IS_Iu1 : String (1 .. 2); + IS_Iu2 : String (1 .. 4); + IS_Iu4 : String (1 .. 8); + IS_Iu8 : String (1 .. 16); + IS_Isf : String (1 .. 8); + IS_Ifl : String (1 .. 8); + IS_Ilf : String (1 .. 16); + + -- The string for Long_Long_Float is special. This is used only on the + -- ia32 with 80-bit extended float (stored in 96 bits by gcc). The + -- value here is represented little-endian, since that's the only way + -- it is ever generated (this is not used on big-endian machines. + + IS_Ill : String (1 .. 24); + + begin + -- -Sin (invalid values) + + if Opt.Initialize_Scalars_Mode = 'I' then + IS_Is1 := "80"; + IS_Is2 := "8000"; + IS_Is4 := "80000000"; + IS_Is8 := "8000000000000000"; + IS_Iu1 := "FF"; + IS_Iu2 := "FFFF"; + IS_Iu4 := "FFFFFFFF"; + IS_Iu8 := "FFFFFFFFFFFFFFFF"; + IS_Isf := IS_Iu4; + IS_Ifl := IS_Iu4; + IS_Ilf := IS_Iu8; + IS_Ill := "00000000000000C0FFFF0000"; + + -- -Slo (low values) + + elsif Opt.Initialize_Scalars_Mode = 'L' then + IS_Is1 := "80"; + IS_Is2 := "8000"; + IS_Is4 := "80000000"; + IS_Is8 := "8000000000000000"; + IS_Iu1 := "00"; + IS_Iu2 := "0000"; + IS_Iu4 := "00000000"; + IS_Iu8 := "0000000000000000"; + IS_Isf := "FF800000"; + IS_Ifl := IS_Isf; + IS_Ilf := "FFF0000000000000"; + IS_Ill := "0000000000000080FFFF0000"; + + -- -Shi (high values) + + elsif Opt.Initialize_Scalars_Mode = 'H' then + IS_Is1 := "7F"; + IS_Is2 := "7FFF"; + IS_Is4 := "7FFFFFFF"; + IS_Is8 := "7FFFFFFFFFFFFFFF"; + IS_Iu1 := "FF"; + IS_Iu2 := "FFFF"; + IS_Iu4 := "FFFFFFFF"; + IS_Iu8 := "FFFFFFFFFFFFFFFF"; + IS_Isf := "7F800000"; + IS_Ifl := IS_Isf; + IS_Ilf := "7FF0000000000000"; + IS_Ill := "0000000000000080FF7F0000"; + + -- -Shh (hex byte) + + else pragma Assert (Opt.Initialize_Scalars_Mode = 'X'); + IS_Is1 (1 .. 2) := Opt.Initialize_Scalars_Val; + IS_Is2 (1 .. 2) := Opt.Initialize_Scalars_Val; + IS_Is2 (3 .. 4) := Opt.Initialize_Scalars_Val; + + for J in 1 .. 4 loop + IS_Is4 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val; + end loop; + + for J in 1 .. 8 loop + IS_Is8 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val; + end loop; + + IS_Iu1 := IS_Is1; + IS_Iu2 := IS_Is2; + IS_Iu4 := IS_Is4; + IS_Iu8 := IS_Is8; + + IS_Isf := IS_Is4; + IS_Ifl := IS_Is4; + IS_Ilf := IS_Is8; + + for J in 1 .. 12 loop + IS_Ill (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val; + end loop; + end if; + + -- Generate output, Ada case + + if Ada_Bind_File then + WBI (""); + + Set_String (" IS_Is1 : constant System.Scalar_Values.Byte1 := 16#"); + Set_String (IS_Is1); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Is2 : constant System.Scalar_Values.Byte2 := 16#"); + Set_String (IS_Is2); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Is4 : constant System.Scalar_Values.Byte4 := 16#"); + Set_String (IS_Is4); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Is8 : constant System.Scalar_Values.Byte8 := 16#"); + Set_String (IS_Is8); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Iu1 : constant System.Scalar_Values.Byte1 := 16#"); + Set_String (IS_Iu1); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Iu2 : constant System.Scalar_Values.Byte2 := 16#"); + Set_String (IS_Iu2); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Iu4 : constant System.Scalar_Values.Byte4 := 16#"); + Set_String (IS_Iu4); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Iu8 : constant System.Scalar_Values.Byte8 := 16#"); + Set_String (IS_Iu8); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Isf : constant System.Scalar_Values.Byte4 := 16#"); + Set_String (IS_Isf); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Ifl : constant System.Scalar_Values.Byte4 := 16#"); + Set_String (IS_Ifl); + Write_Statement_Buffer ("#;"); + + Set_String (" IS_Ilf : constant System.Scalar_Values.Byte8 := 16#"); + Set_String (IS_Ilf); + Write_Statement_Buffer ("#;"); + + -- Special case of Long_Long_Float. This is a 10-byte value used + -- only on the x86. We could omit it for other architectures, but + -- we don't easily have that kind of target specialization in the + -- binder, and it's only 10 bytes, and only if -Sxx is used. Note + -- that for architectures where Long_Long_Float is the same as + -- Long_Float, the expander uses the Long_Float constant for the + -- initializations of Long_Long_Float values. + + WBI (" IS_Ill : constant array (1 .. 12) of"); + WBI (" System.Scalar_Values.Byte1 := ("); + Set_String (" "); + + for J in 1 .. 6 loop + Set_String (" 16#"); + Set_Char (IS_Ill (2 * J - 1)); + Set_Char (IS_Ill (2 * J)); + Set_String ("#,"); + end loop; + + Write_Statement_Buffer; + Set_String (" "); + + for J in 7 .. 12 loop + Set_String (" 16#"); + Set_Char (IS_Ill (2 * J - 1)); + Set_Char (IS_Ill (2 * J)); + + if J = 12 then + Set_String ("#);"); + else + Set_String ("#,"); + end if; + end loop; + + Write_Statement_Buffer; + + -- Output export statements to export to System.Scalar_Values + + WBI (""); + + WBI (" pragma Export (Ada, IS_Is1, ""__gnat_Is1"");"); + WBI (" pragma Export (Ada, IS_Is2, ""__gnat_Is2"");"); + WBI (" pragma Export (Ada, IS_Is4, ""__gnat_Is4"");"); + WBI (" pragma Export (Ada, IS_Is8, ""__gnat_Is8"");"); + WBI (" pragma Export (Ada, IS_Iu1, ""__gnat_Iu1"");"); + WBI (" pragma Export (Ada, IS_Iu2, ""__gnat_Iu2"");"); + WBI (" pragma Export (Ada, IS_Iu4, ""__gnat_Iu4"");"); + WBI (" pragma Export (Ada, IS_Iu8, ""__gnat_Iu8"");"); + WBI (" pragma Export (Ada, IS_Isf, ""__gnat_Isf"");"); + WBI (" pragma Export (Ada, IS_Ifl, ""__gnat_Ifl"");"); + WBI (" pragma Export (Ada, IS_Ilf, ""__gnat_Ilf"");"); + WBI (" pragma Export (Ada, IS_Ill, ""__gnat_Ill"");"); + + -- Generate output C case + + else + -- The lines we generate in this case are of the form + -- typ __gnat_I?? = 0x??; + -- where typ is appropriate to the length + + WBI (""); + + Set_String ("unsigned char __gnat_Is1 = 0x"); + Set_String (IS_Is1); + Write_Statement_Buffer (";"); + + Set_String ("unsigned short __gnat_Is2 = 0x"); + Set_String (IS_Is2); + Write_Statement_Buffer (";"); + + Set_String ("unsigned __gnat_Is4 = 0x"); + Set_String (IS_Is4); + Write_Statement_Buffer (";"); + + Set_String ("long long unsigned __gnat_Is8 = 0x"); + Set_String (IS_Is8); + Write_Statement_Buffer ("LL;"); + + Set_String ("unsigned char __gnat_Iu1 = 0x"); + Set_String (IS_Is1); + Write_Statement_Buffer (";"); + + Set_String ("unsigned short __gnat_Iu2 = 0x"); + Set_String (IS_Is2); + Write_Statement_Buffer (";"); + + Set_String ("unsigned __gnat_Iu4 = 0x"); + Set_String (IS_Is4); + Write_Statement_Buffer (";"); + + Set_String ("long long unsigned __gnat_Iu8 = 0x"); + Set_String (IS_Is8); + Write_Statement_Buffer ("LL;"); + + Set_String ("unsigned __gnat_Isf = 0x"); + Set_String (IS_Isf); + Write_Statement_Buffer (";"); + + Set_String ("unsigned __gnat_Ifl = 0x"); + Set_String (IS_Ifl); + Write_Statement_Buffer (";"); + + Set_String ("long long unsigned __gnat_Ilf = 0x"); + Set_String (IS_Ilf); + Write_Statement_Buffer ("LL;"); + + -- For Long_Long_Float, we generate + -- char __gnat_Ill[12] = {0x??, 0x??, 0x??, 0x??, 0x??, 0x??, + -- 0x??, 0x??, 0x??, 0x??, 0x??, 0x??); + + Set_String ("unsigned char __gnat_Ill[12] = {"); + + for J in 1 .. 6 loop + Set_String ("0x"); + Set_Char (IS_Ill (2 * J - 1)); + Set_Char (IS_Ill (2 * J)); + Set_String (", "); + end loop; + + Write_Statement_Buffer; + Set_String (" "); + + for J in 7 .. 12 loop + Set_String ("0x"); + Set_Char (IS_Ill (2 * J - 1)); + Set_Char (IS_Ill (2 * J)); + + if J = 12 then + Set_String ("};"); + else + Set_String (", "); + end if; + end loop; + + Write_Statement_Buffer; + end if; + end Gen_Scalar_Values; + + ---------------------- + -- Gen_Versions_Ada -- + ---------------------- + + -- This routine generates two sets of lines. The first set has the form: + + -- unnnnn : constant Integer := 16#hhhhhhhh#; + + -- The second set has the form + + -- pragma Export (C, unnnnn, unam); + + -- for each unit, where unam is the unit name suffixed by either B or + -- S for body or spec, with dots replaced by double underscores, and + -- hhhhhhhh is the version number, and nnnnn is a 5-digits serial number. + + procedure Gen_Versions_Ada is + Ubuf : String (1 .. 6) := "u00000"; + + procedure Increment_Ubuf; + -- Little procedure to increment the serial number + + procedure Increment_Ubuf is + begin + for J in reverse Ubuf'Range loop + Ubuf (J) := Character'Succ (Ubuf (J)); + exit when Ubuf (J) <= '9'; + Ubuf (J) := '0'; + end loop; + end Increment_Ubuf; + + -- Start of processing for Gen_Versions_Ada + + begin + if Bind_For_Library then + + -- When building libraries, the version number of each unit can + -- not be computed, since the binder does not know the full list + -- of units. Therefore, the 'Version and 'Body_Version + -- attributes can not supported in this case. + + return; + end if; + + WBI (""); + + WBI (" type Version_32 is mod 2 ** 32;"); + for U in Units.First .. Units.Last loop + Increment_Ubuf; + WBI (" " & Ubuf & " : constant Version_32 := 16#" & + Units.Table (U).Version & "#;"); + end loop; + + WBI (""); + Ubuf := "u00000"; + + for U in Units.First .. Units.Last loop + Increment_Ubuf; + Set_String (" pragma Export (C, "); + Set_String (Ubuf); + Set_String (", """); + + Get_Name_String (Units.Table (U).Uname); + + for K in 1 .. Name_Len loop + if Name_Buffer (K) = '.' then + Set_Char ('_'); + Set_Char ('_'); + + elsif Name_Buffer (K) = '%' then + exit; + + else + Set_Char (Name_Buffer (K)); + end if; + end loop; + + if Name_Buffer (Name_Len) = 's' then + Set_Char ('S'); + else + Set_Char ('B'); + end if; + + Set_String (""");"); + Write_Statement_Buffer; + end loop; + + end Gen_Versions_Ada; + + -------------------- + -- Gen_Versions_C -- + -------------------- + + -- This routine generates a line of the form: + + -- unsigned unam = 0xhhhhhhhh; + + -- for each unit, where unam is the unit name suffixed by either B or + -- S for body or spec, with dots replaced by double underscores. + + procedure Gen_Versions_C is + begin + if Bind_For_Library then + + -- When building libraries, the version number of each unit can + -- not be computed, since the binder does not know the full list + -- of units. Therefore, the 'Version and 'Body_Version + -- attributes can not supported. + + return; + end if; + + for U in Units.First .. Units.Last loop + Set_String ("unsigned "); + + Get_Name_String (Units.Table (U).Uname); + + for K in 1 .. Name_Len loop + if Name_Buffer (K) = '.' then + Set_String ("__"); + + elsif Name_Buffer (K) = '%' then + exit; + + else + Set_Char (Name_Buffer (K)); + end if; + end loop; + + if Name_Buffer (Name_Len) = 's' then + Set_Char ('S'); + else + Set_Char ('B'); + end if; + + Set_String (" = 0x"); + Set_String (Units.Table (U).Version); + Set_Char (';'); + Write_Statement_Buffer; + end loop; + + end Gen_Versions_C; + + ----------------------- + -- Get_Ada_Main_Name -- + ----------------------- + + function Get_Ada_Main_Name return String is + Suffix : constant String := "_00"; + Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) := + Opt.Ada_Main_Name.all & Suffix; + Nlen : Natural; + + begin + -- The main program generated by JGNAT expects a package called + -- ada_<main procedure>. + + if Hostparm.Java_VM then + -- Get main program name + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + + -- Remove the %b + + return "ada_" & Name_Buffer (1 .. Name_Len - 2); + end if; + + -- This loop tries the following possibilities in order + -- <Ada_Main> + -- <Ada_Main>_01 + -- <Ada_Main>_02 + -- .. + -- <Ada_Main>_99 + -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default, + -- it is set to 'ada_main'. + + for J in 0 .. 99 loop + if J = 0 then + Nlen := Name'Length - Suffix'Length; + else + Nlen := Name'Length; + Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0')); + Name (Name'Last - 1) := + Character'Val (J / 10 + Character'Pos ('0')); + end if; + + for K in ALIs.First .. ALIs.Last loop + for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop + + -- Get unit name, removing %b or %e at end + + Get_Name_String (Units.Table (L).Uname); + Name_Len := Name_Len - 2; + + if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then + goto Continue; + end if; + end loop; + end loop; + + return Name (1 .. Nlen); + + <<Continue>> + null; + end loop; + + -- If we fall through, just use a peculiar unlikely name + + return ("Qwertyuiop"); + end Get_Ada_Main_Name; + + ------------------- + -- Get_Main_Name -- + ------------------- + + function Get_Main_Name return String is + Target : constant String_Ptr := Target_Name; + VxWorks_Target : constant Boolean := + Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + + begin + -- Explicit name given with -M switch + + if Bind_Alternate_Main_Name then + return Alternate_Main_Name.all; + + -- Case of main program name to be used directly + + elsif VxWorks_Target then + + -- Get main program name + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + + -- If this is a child name, return only the name of the child, + -- since we can't have dots in a nested program name. Note that + -- we do not include the %b at the end of the unit name. + + for J in reverse 1 .. Name_Len - 3 loop + if J = 1 or else Name_Buffer (J - 1) = '.' then + return Name_Buffer (J .. Name_Len - 2); + end if; + end loop; + + raise Program_Error; -- impossible exit + + -- Case where "main" is to be used as default + + else + return "main"; + end if; + end Get_Main_Name; + + ---------------------- + -- Lt_Linker_Option -- + ---------------------- + + function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is + begin + if Linker_Options.Table (Op1).Internal_File + /= + Linker_Options.Table (Op2).Internal_File + then + return Linker_Options.Table (Op1).Internal_File + < + Linker_Options.Table (Op2).Internal_File; + else + if Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position + /= + Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position + then + return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position + > + Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; + + else + return Linker_Options.Table (Op1).Original_Pos + < + Linker_Options.Table (Op2).Original_Pos; + end if; + end if; + end Lt_Linker_Option; + + ------------------------ + -- Move_Linker_Option -- + ------------------------ + + procedure Move_Linker_Option (From : Natural; To : Natural) is + begin + Linker_Options.Table (To) := Linker_Options.Table (From); + end Move_Linker_Option; + + ---------------------------- + -- Public_Version_Warning -- + ---------------------------- + + procedure Public_Version_Warning is + + Time : Int := Time_From_Last_Bind; + + -- Constants to help defining periods + + Hour : constant := 60; + Day : constant := 24 * Hour; + + Never : constant := Integer'Last; + -- Special value indicating no warnings should be given + + -- Constants defining when the warning is issued. Programs with more + -- than Large Units will issue a warning every Period_Large amount of + -- time. Smaller programs will generate a warning every Period_Small + -- amount of time. + + Large : constant := 20; + -- Threshold for considering a program small or large + + Period_Large : constant := Day; + -- Periodic warning time for large programs + + Period_Small : constant := Never; + -- Periodic warning time for small programs + + Nb_Unit : Int; + + begin + -- Compute the number of units that are not GNAT internal files + + Nb_Unit := 0; + for A in ALIs.First .. ALIs.Last loop + if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then + Nb_Unit := Nb_Unit + 1; + end if; + end loop; + + -- Do not emit the message if the last message was emitted in the + -- specified period taking into account the number of units. + + if Nb_Unit < Large and then Time <= Period_Small then + return; + + elsif Time <= Period_Large then + return; + end if; + + Write_Eol; + Write_Str ("IMPORTANT NOTICE:"); + Write_Eol; + Write_Str (" This version of GNAT is unsupported" + & " and comes with absolutely no warranty."); + Write_Eol; + Write_Str (" If you intend to evaluate or use GNAT for building " + & "commercial applications,"); + Write_Eol; + Write_Str (" please consult http://www.gnat.com/ for information"); + Write_Eol; + Write_Str (" on the GNAT Professional product line."); + Write_Eol; + Write_Eol; + end Public_Version_Warning; + + ---------------------------- + -- Resolve_Binder_Options -- + ---------------------------- + + procedure Resolve_Binder_Options is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); + + -- The procedure of looking for specific packages and setting + -- flags is very wrong, but there isn't a good alternative at + -- this time. + + if Name_Buffer (1 .. 19) = "system.os_interface" then + With_GNARL := True; + end if; + + if Hostparm.OpenVMS and then Name_Buffer (1 .. 3) = "dec" then + With_DECGNAT := True; + end if; + end loop; + end Resolve_Binder_Options; + + -------------- + -- Set_Char -- + -------------- + + procedure Set_Char (C : Character) is + begin + Last := Last + 1; + Statement_Buffer (Last) := C; + end Set_Char; + + ------------- + -- Set_Int -- + ------------- + + procedure Set_Int (N : Int) is + begin + if N < 0 then + Set_String ("-"); + Set_Int (-N); + + else + if N > 9 then + Set_Int (N / 10); + end if; + + Last := Last + 1; + Statement_Buffer (Last) := + Character'Val (N mod 10 + Character'Pos ('0')); + end if; + end Set_Int; + + --------------------------- + -- Set_Main_Program_Name -- + --------------------------- + + procedure Set_Main_Program_Name is + begin + -- Note that name has %b on the end which we ignore + + -- First we output the initial _ada_ since we know that the main + -- program is a library level subprogram. + + Set_String ("_ada_"); + + -- Copy name, changing dots to double underscores + + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) = '.' then + Set_String ("__"); + else + Set_Char (Name_Buffer (J)); + end if; + end loop; + end Set_Main_Program_Name; + + --------------------- + -- Set_Name_Buffer -- + --------------------- + + procedure Set_Name_Buffer is + begin + for J in 1 .. Name_Len loop + Set_Char (Name_Buffer (J)); + end loop; + end Set_Name_Buffer; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String (S : String) is + begin + Statement_Buffer (Last + 1 .. Last + S'Length) := S; + Last := Last + S'Length; + end Set_String; + + ------------------- + -- Set_Unit_Name -- + ------------------- + + procedure Set_Unit_Name is + begin + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) /= '.' then + Set_Char (Name_Buffer (J)); + else + Set_String ("__"); + end if; + end loop; + end Set_Unit_Name; + + --------------------- + -- Set_Unit_Number -- + --------------------- + + procedure Set_Unit_Number (U : Unit_Id) is + Num_Units : constant Nat := Nat (Units.Table'Last) - Nat (Unit_Id'First); + Unum : constant Nat := Nat (U) - Nat (Unit_Id'First); + + begin + if Num_Units >= 10 and then Unum < 10 then + Set_Char ('0'); + end if; + + if Num_Units >= 100 and then Unum < 100 then + Set_Char ('0'); + end if; + + Set_Int (Unum); + end Set_Unit_Number; + + ------------ + -- Tab_To -- + ------------ + + procedure Tab_To (N : Natural) is + begin + while Last < N loop + Set_Char (' '); + end loop; + end Tab_To; + + ----------- + -- Value -- + ----------- + + function Value (chars : chars_ptr) return String is + function Strlen (chars : chars_ptr) return Natural; + pragma Import (C, Strlen); + + begin + if chars = Null_Address then + return ""; + + else + declare + subtype Result_Type is String (1 .. Strlen (chars)); + + Result : Result_Type; + for Result'Address use chars; + + begin + return Result; + end; + end if; + end Value; + + ---------------------- + -- Write_Info_Ada_C -- + ---------------------- + + procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is + begin + if Ada_Bind_File then + declare + S : String (1 .. Ada'Length + Common'Length); + + begin + S (1 .. Ada'Length) := Ada; + S (Ada'Length + 1 .. S'Length) := Common; + WBI (S); + end; + + else + declare + S : String (1 .. C'Length + Common'Length); + + begin + S (1 .. C'Length) := C; + S (C'Length + 1 .. S'Length) := Common; + WBI (S); + end; + end if; + end Write_Info_Ada_C; + + ---------------------------- + -- Write_Statement_Buffer -- + ---------------------------- + + procedure Write_Statement_Buffer is + begin + WBI (Statement_Buffer (1 .. Last)); + Last := 0; + end Write_Statement_Buffer; + + procedure Write_Statement_Buffer (S : String) is + begin + Set_String (S); + Write_Statement_Buffer; + end Write_Statement_Buffer; + +end Bindgen; diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads new file mode 100644 index 00000000000..11cabd37812 --- /dev/null +++ b/gcc/ada/bindgen.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D G E N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995,1996 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines to output the binder file. This is +-- a C program which contains the following: + +-- initialization for main program case +-- sequence of calls to elaboration routines in appropriate order +-- call to main program for main program case + +-- See the body for exact details of the file that is generated + +package Bindgen is + + ------------------ + -- Subprograms -- + ------------------ + + procedure Gen_Output_File (Filename : String); + -- Filename is the full path name of the binder output file + +end Bindgen; diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb new file mode 100644 index 00000000000..764e9c426c9 --- /dev/null +++ b/gcc/ada/bindusg.adb @@ -0,0 +1,273 @@ +------------------------------------------------------------------------------ +-- -- +-- GBIND BINDER COMPONENTS -- +-- -- +-- B I N D U S G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.52 $ +-- -- +-- Copyright (C) 1992-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 Osint; use Osint; +with Output; use Output; + +procedure Bindusg is + + procedure Write_Switch_Char; + -- Write two spaces followed by appropriate switch character + + procedure Write_Switch_Char is + begin + Write_Str (" "); + Write_Char (Switch_Character); + end Write_Switch_Char; + +-- Start of processing for Bindusg + +begin + -- Usage line + + Write_Str ("Usage: "); + Write_Program_Name; + Write_Char (' '); + Write_Str ("switches lfile"); + Write_Eol; + Write_Eol; + + -- Line for -aO switch + + Write_Switch_Char; + Write_Str ("aOdir Specify library files search path"); + Write_Eol; + + -- Line for -aI switch + + Write_Switch_Char; + Write_Str ("aIdir Specify source files search path"); + Write_Eol; + + -- Line for A switch + + Write_Switch_Char; + Write_Str ("A Generate binder program in Ada (default)"); + Write_Eol; + + -- Line for -b switch + + Write_Switch_Char; + Write_Str ("b Generate brief messages to std"); + Write_Str ("err even if verbose mode set"); + Write_Eol; + + -- Line for -c switch + + Write_Switch_Char; + Write_Str ("c Check only, no generation of b"); + Write_Str ("inder output file"); + Write_Eol; + + -- Line for C switch + + Write_Switch_Char; + Write_Str ("C Generate binder program in C"); + Write_Eol; + + -- Line for -e switch + + Write_Switch_Char; + Write_Str ("e Output complete list of elabor"); + Write_Str ("ation order dependencies"); + Write_Eol; + + -- Line for -E switch + + Write_Switch_Char; + Write_Str ("E Store tracebacks in Exception occurrences"); + Write_Eol; + + -- Line for -f switch + + Write_Switch_Char; + Write_Str ("f Force RM elaboration ordering rules"); + Write_Eol; + + -- Line for -h switch + + Write_Switch_Char; + Write_Str ("h Output this usage (help) infor"); + Write_Str ("mation"); + Write_Eol; + + -- Line for -I switch + + Write_Switch_Char; + Write_Str ("Idir Specify library and source files search path"); + Write_Eol; + + -- Line for -I- switch + + Write_Switch_Char; + Write_Str ("I- Don't look for sources & library files"); + Write_Str (" in default directory"); + Write_Eol; + + -- Line for -K switch + + Write_Switch_Char; + Write_Str ("K Give list of linker options specified for link"); + Write_Eol; + + -- Line for -l switch + + Write_Switch_Char; + Write_Str ("l Output chosen elaboration order"); + Write_Eol; + + -- Line of -L switch + + Write_Switch_Char; + Write_Str ("Lxyz Library build: adainit/final "); + Write_Str ("renamed to xyzinit/final, implies -n"); + Write_Eol; + + -- Line for -M switch + + Write_Switch_Char; + Write_Str ("Mxyz Rename generated main program from main to xyz"); + Write_Eol; + + -- Line for -m switch + + Write_Switch_Char; + Write_Str ("mnnn Limit number of detected error"); + Write_Str ("s to nnn (1-999)"); + Write_Eol; + + -- Line for -n switch + + Write_Switch_Char; + Write_Str ("n No Ada main program (foreign main routine)"); + Write_Eol; + + -- Line for -nostdinc + + Write_Switch_Char; + Write_Str ("nostdinc Don't look for source files"); + Write_Str (" in the system default directory"); + Write_Eol; + + -- Line for -nostdlib + + Write_Switch_Char; + Write_Str ("nostdlib Don't look for library files"); + Write_Str (" in the system default directory"); + Write_Eol; + + -- Line for -o switch + + Write_Switch_Char; + Write_Str ("o file Give the output file name (default is b~xxx.adb) "); + Write_Eol; + + -- Line for -O switch + + Write_Switch_Char; + Write_Str ("O Give list of objects required for link"); + Write_Eol; + + -- Line for -p switch + + Write_Switch_Char; + Write_Str ("p Pessimistic (worst-case) elaborat"); + Write_Str ("ion order"); + Write_Eol; + + -- Line for -s switch + + Write_Switch_Char; + Write_Str ("s Require all source files to be"); + Write_Str (" present"); + Write_Eol; + + -- Line for -Sxx switch + + Write_Switch_Char; + Write_Str ("S?? Sin/lo/hi/xx for Initialize_Scalars"); + Write_Str (" invalid/low/high/hex"); + Write_Eol; + + -- Line for -static + + Write_Switch_Char; + Write_Str ("static Link against a static GNAT run time"); + Write_Eol; + + -- Line for -shared + + Write_Switch_Char; + Write_Str ("shared Link against a shared GNAT run time"); + Write_Eol; + + -- Line for -t switch + + Write_Switch_Char; + Write_Str ("t Tolerate time stamp and other consistency errors"); + Write_Eol; + + -- Line for -T switch + + Write_Switch_Char; + Write_Str ("Tn Set time slice value to n microseconds (n >= 0)"); + Write_Eol; + + -- Line for -v switch + + Write_Switch_Char; + Write_Str ("v Verbose mode. Error messages, "); + Write_Str ("header, summary output to stdout"); + Write_Eol; + + -- Lines for -w switch + + Write_Switch_Char; + Write_Str ("wx Warning mode. (x=s/e for supp"); + Write_Str ("ress/treat as error)"); + Write_Eol; + + -- Line for -x switch + + Write_Switch_Char; + Write_Str ("x Exclude source files (check ob"); + Write_Str ("ject consistency only)"); + Write_Eol; + + -- Line for -z switch + + Write_Switch_Char; + Write_Str ("z No main subprogram (zero main)"); + Write_Eol; + + -- Line for sfile + + Write_Str (" lfile Library file names"); + Write_Eol; + +end Bindusg; diff --git a/gcc/ada/bindusg.ads b/gcc/ada/bindusg.ads new file mode 100644 index 00000000000..1bb5169edab --- /dev/null +++ b/gcc/ada/bindusg.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D U S G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Procedure to generate screen of usage information if no file name present + +procedure Bindusg; diff --git a/gcc/ada/butil.adb b/gcc/ada/butil.adb new file mode 100644 index 00000000000..ef5d1820d4e --- /dev/null +++ b/gcc/ada/butil.adb @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B U T I L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1992-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 Hostparm; use Hostparm; +with Namet; use Namet; +with Output; use Output; + +package body Butil is + + -------------------------- + -- Get_Unit_Name_String -- + -------------------------- + + procedure Get_Unit_Name_String (U : Unit_Name_Type) is + begin + Get_Name_String (U); + + if Name_Buffer (Name_Len) = 's' then + Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)"; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)"; + end if; + + Name_Len := Name_Len + 5; + end Get_Unit_Name_String; + + ---------------------- + -- Is_Internal_Unit -- + ---------------------- + + -- Note: the reason we do not use the Fname package for this function + -- is that it would drag too much junk into the binder. + + function Is_Internal_Unit return Boolean is + begin + return Is_Predefined_Unit + or else (Name_Len > 4 + and then (Name_Buffer (1 .. 5) = "gnat%" + or else + Name_Buffer (1 .. 5) = "gnat.")) + or else + (OpenVMS + and then Name_Len > 3 + and then (Name_Buffer (1 .. 4) = "dec%" + or else + Name_Buffer (1 .. 4) = "dec.")); + + end Is_Internal_Unit; + + ------------------------ + -- Is_Predefined_Unit -- + ------------------------ + + -- Note: the reason we do not use the Fname package for this function + -- is that it would drag too much junk into the binder. + + function Is_Predefined_Unit return Boolean is + begin + return (Name_Len > 3 + and then Name_Buffer (1 .. 4) = "ada.") + + or else (Name_Len > 6 + and then Name_Buffer (1 .. 7) = "system.") + + or else (Name_Len > 10 + and then Name_Buffer (1 .. 11) = "interfaces.") + + or else (Name_Len > 3 + and then Name_Buffer (1 .. 4) = "ada%") + + or else (Name_Len > 8 + and then Name_Buffer (1 .. 9) = "calendar%") + + or else (Name_Len > 9 + and then Name_Buffer (1 .. 10) = "direct_io%") + + or else (Name_Len > 10 + and then Name_Buffer (1 .. 11) = "interfaces%") + + or else (Name_Len > 13 + and then Name_Buffer (1 .. 14) = "io_exceptions%") + + or else (Name_Len > 12 + and then Name_Buffer (1 .. 13) = "machine_code%") + + or else (Name_Len > 13 + and then Name_Buffer (1 .. 14) = "sequential_io%") + + or else (Name_Len > 6 + and then Name_Buffer (1 .. 7) = "system%") + + or else (Name_Len > 7 + and then Name_Buffer (1 .. 8) = "text_io%") + + or else (Name_Len > 20 + and then Name_Buffer (1 .. 21) = "unchecked_conversion%") + + or else (Name_Len > 22 + and then Name_Buffer (1 .. 23) = "unchecked_deallocation%") + + or else (Name_Len > 4 + and then Name_Buffer (1 .. 5) = "gnat%") + + or else (Name_Len > 4 + and then Name_Buffer (1 .. 5) = "gnat."); + end Is_Predefined_Unit; + + ---------------- + -- Uname_Less -- + ---------------- + + function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is + begin + Get_Name_String (U1); + + declare + U1_Name : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + Min_Length : Natural; + + begin + Get_Name_String (U2); + + if Name_Len < U1_Name'Last then + Min_Length := Name_Len; + else + Min_Length := U1_Name'Last; + end if; + + for I in 1 .. Min_Length loop + if U1_Name (I) > Name_Buffer (I) then + return False; + elsif U1_Name (I) < Name_Buffer (I) then + return True; + end if; + end loop; + + return U1_Name'Last < Name_Len; + end; + end Uname_Less; + + --------------------- + -- Write_Unit_Name -- + --------------------- + + procedure Write_Unit_Name (U : Unit_Name_Type) is + begin + Get_Name_String (U); + Write_Str (Name_Buffer (1 .. Name_Len - 2)); + + if Name_Buffer (Name_Len) = 's' then + Write_Str (" (spec)"); + else + Write_Str (" (body)"); + end if; + + Name_Len := Name_Len + 5; + end Write_Unit_Name; + +end Butil; diff --git a/gcc/ada/butil.ads b/gcc/ada/butil.ads new file mode 100644 index 00000000000..0dd08f81fe3 --- /dev/null +++ b/gcc/ada/butil.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B U T I L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 1992-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 Types; use Types; + +package Butil is + +-- This package contains utility routines for the binder + + function Is_Predefined_Unit return Boolean; + -- Given a unit name stored in Name_Buffer with length in Name_Len, + -- returns True if this is the name of a predefined unit or a child of + -- a predefined unit (including the obsolescent renamings). This is used + -- in the preference selection (see Better_Choice in body of Binde). + + function Is_Internal_Unit return Boolean; + -- Given a unit name stored in Name_Buffer with length in Name_Len, + -- returns True if this is the name of an internal unit or a child of + -- an internal. Similar in usage to Is_Predefined_Unit. + + -- Note: the following functions duplicate functionality in Uname, but + -- we want to avoid bringing Uname into the binder since it generates + -- to many unnecessary dependencies, and makes the binder too large. + + function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean; + -- Determines if the unit name U1 is alphabetically before U2 + + procedure Get_Unit_Name_String (U : Unit_Name_Type); + -- Compute unit name with (body) or (spec) after as required. On return + -- the result is stored in Name_Buffer and Name_Len is the length. + + procedure Write_Unit_Name (U : Unit_Name_Type); + -- Output unit name with (body) or (spec) after as required. On return + -- Name_Len is set to the number of characters which were output. + +end Butil; diff --git a/gcc/ada/cal.c b/gcc/ada/cal.c new file mode 100644 index 00000000000..d0a7f544dff --- /dev/null +++ b/gcc/ada/cal.c @@ -0,0 +1,95 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C A L * + * * + * C Implementation File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +/* This file contains those routines named by Import pragmas in package */ +/* GNAT.Calendar. It is used to to Duration to timeval convertion. */ +/* These are simple wrappers function to abstarct the fact that the C */ +/* struct timeval fields type are not normalized (they are generaly */ +/* defined as int or long values). */ + +#if defined(VMS) + +/* this is temporary code to avoid build failure under VMS */ + +void +__gnat_timeval_to_duration (void *t, long *sec, long *usec) +{ +} + +void +__gnat_duration_to_timeval (long sec, long usec, void *t) +{ +} + +#else + +#if defined (__vxworks) +#include <sys/times.h> +#else +#include <sys/time.h> +#endif + +void +__gnat_timeval_to_duration (struct timeval *t, long *sec, long *usec) +{ + *sec = (long) t->tv_sec; + *usec = (long) t->tv_usec; +} + +void +__gnat_duration_to_timeval (long sec, long usec, struct timeval *t) +{ + /* here we are doing implicit convertion from a long to the struct timeval + fields types. */ + + t->tv_sec = sec; + t->tv_usec = usec; +} +#endif + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#elif defined (__vxworks) +#include <types/vxTypesOld.h> +#endif + +/* Return the value of the "time" C library function. We always return + a long and do it this way to avoid problems with not knowing + what time_t is on the target. */ + +long +gnat_time () +{ + return time (0); +} diff --git a/gcc/ada/calendar.ads b/gcc/ada/calendar.ads new file mode 100644 index 00000000000..eb8f374f852 --- /dev/null +++ b/gcc/ada/calendar.ads @@ -0,0 +1,20 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +package Calendar renames Ada.Calendar; diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb new file mode 100644 index 00000000000..e9ed296110a --- /dev/null +++ b/gcc/ada/casing.adb @@ -0,0 +1,186 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C A S I N G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.23 $ +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 Csets; use Csets; +with Namet; use Namet; +with Opt; use Opt; +with Types; use Types; +with Widechar; use Widechar; + +package body Casing is + + ---------------------- + -- Determine_Casing -- + ---------------------- + + function Determine_Casing (Ident : Text_Buffer) return Casing_Type is + + All_Lower : Boolean := True; + -- Set False if upper case letter found + + All_Upper : Boolean := True; + -- Set False if lower case letter found + + Mixed : Boolean := True; + -- Set False if exception to mixed case rule found (lower case letter + -- at start or after underline, or upper case letter elsewhere). + + Decisive : Boolean := False; + -- Set True if at least one instance of letter not after underline + + After_Und : Boolean := True; + -- True at start of string, and after an underline character + + begin + for S in Ident'Range loop + if Ident (S) = '_' or else Ident (S) = '.' then + After_Und := True; + + elsif Is_Lower_Case_Letter (Ident (S)) then + All_Upper := False; + + if not After_Und then + Decisive := True; + else + After_Und := False; + Mixed := False; + end if; + + elsif Is_Upper_Case_Letter (Ident (S)) then + All_Lower := False; + + if not After_Und then + Decisive := True; + Mixed := False; + else + After_Und := False; + end if; + end if; + end loop; + + -- Now we can figure out the result from the flags we set in that loop + + if All_Lower then + return All_Lower_Case; + + elsif not Decisive then + return Unknown; + + elsif All_Upper then + return All_Upper_Case; + + elsif Mixed then + return Mixed_Case; + + else + return Unknown; + end if; + end Determine_Casing; + + ------------------------ + -- Set_All_Upper_Case -- + ------------------------ + + procedure Set_All_Upper_Case is + begin + Set_Casing (All_Upper_Case); + end Set_All_Upper_Case; + + ---------------- + -- Set_Casing -- + ---------------- + + procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is + Ptr : Natural; + + Actual_Casing : Casing_Type; + -- Set from C or D as appropriate + + After_Und : Boolean := True; + -- True at start of string, and after an underline character or after + -- any other special character that is not a normal identifier char). + + begin + if C /= Unknown then + Actual_Casing := C; + else + Actual_Casing := D; + end if; + + Ptr := 1; + + while Ptr <= Name_Len loop + if Name_Buffer (Ptr) = ASCII.ESC + or else Name_Buffer (Ptr) = '[' + or else (Upper_Half_Encoding + and then Name_Buffer (Ptr) in Upper_Half_Character) + then + Skip_Wide (Name_Buffer, Ptr); + After_Und := False; + + elsif Name_Buffer (Ptr) = '_' + or else not Identifier_Char (Name_Buffer (Ptr)) + then + After_Und := True; + Ptr := Ptr + 1; + + elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then + if Actual_Casing = All_Upper_Case + or else (After_Und and then Actual_Casing = Mixed_Case) + then + Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr)); + end if; + + After_Und := False; + Ptr := Ptr + 1; + + elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then + if Actual_Casing = All_Lower_Case + or else (not After_Und and then Actual_Casing = Mixed_Case) + then + Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr)); + end if; + + After_Und := False; + Ptr := Ptr + 1; + + else -- all other characters + After_Und := False; + Ptr := Ptr + 1; + end if; + end loop; + end Set_Casing; + +end Casing; diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads new file mode 100644 index 00000000000..a8aa6c82bfc --- /dev/null +++ b/gcc/ada/casing.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C A S I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1992-2000 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 Types; use Types; + +package Casing is + + -- This package contains data and subprograms to support the feature that + -- recognizes the letter case styles used in the source program being + -- compiled, and uses this information for error message formatting, and + -- for recognizing reserved words that are misused as identifiers. + + ------------------------------- + -- Case Control Declarations -- + ------------------------------- + + -- Declaration of type for describing casing convention + + type Casing_Type is ( + + All_Upper_Case, + -- All letters are upper case + + All_Lower_Case, + -- All letters are lower case + + Mixed_Case, + -- The initial letter, and any letters after underlines are upper case. + -- All other letters are lower case + + Unknown + -- Used if an identifier does not distinguish between the above cases, + -- (e.g. X, Y_3, M4, A_B, or if it is inconsistent ABC_def). + ); + + ------------------------------ + -- Case Control Subprograms -- + ------------------------------ + + procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case); + -- Takes the name stored in the first Name_Len positions of Name_Buffer + -- and modifies it to be consistent with the casing given by C, or if + -- C = Unknown, then with the casing given by D. The name is basically + -- treated as an identifier, except that special separator characters + -- other than underline are permitted and treated like underlines (this + -- handles cases like minus and period in unit names, apostrophes in error + -- messages, angle brackets in names like <any_type>, etc). + + procedure Set_All_Upper_Case; + pragma Inline (Set_All_Upper_Case); + -- This procedure is called with an identifier name stored in Name_Buffer. + -- On return, the identifier is converted to all upper case. The call is + -- equivalent to Set_Casing (All_Upper_Case). + + function Determine_Casing (Ident : Text_Buffer) return Casing_Type; + -- Determines the casing of the identifier/keyword string Ident + +end Casing; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb new file mode 100644 index 00000000000..b71b3ff99c1 --- /dev/null +++ b/gcc/ada/checks.adb @@ -0,0 +1,4093 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C H E C K S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.205 $ +-- -- +-- Copyright (C) 1992-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 Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch2; use Exp_Ch2; +with Exp_Util; use Exp_Util; +with Elists; use Elists; +with Freeze; use Freeze; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Urealp; use Urealp; +with Validsw; use Validsw; + +package body Checks is + + -- General note: many of these routines are concerned with generating + -- checking code to make sure that constraint error is raised at runtime. + -- Clearly this code is only needed if the expander is active, since + -- otherwise we will not be generating code or going into the runtime + -- execution anyway. + + -- We therefore disconnect most of these checks if the expander is + -- inactive. This has the additional benefit that we do not need to + -- worry about the tree being messed up by previous errors (since errors + -- turn off expansion anyway). + + -- There are a few exceptions to the above rule. For instance routines + -- such as Apply_Scalar_Range_Check that do not insert any code can be + -- safely called even when the Expander is inactive (but Errors_Detected + -- is 0). The benefit of executing this code when expansion is off, is + -- the ability to emit constraint error warning for static expressions + -- even when we are not generating code. + + ---------------------------- + -- Local Subprogram Specs -- + ---------------------------- + + procedure Apply_Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean); + -- This is the subprogram that does all the work for Apply_Length_Check + -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as + -- described for the above routines. The Do_Static flag indicates that + -- only a static check is to be done. + + procedure Apply_Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean); + -- This is the subprogram that does all the work for Apply_Range_Check. + -- Expr, Target_Typ and Source_Typ are as described for the above + -- routine. The Do_Static flag indicates that only a static check is + -- to be done. + + function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id; + -- If a discriminal is used in constraining a prival, Return reference + -- to the discriminal of the protected body (which renames the parameter + -- of the enclosing protected operation). This clumsy transformation is + -- needed because privals are created too late and their actual subtypes + -- are not available when analysing the bodies of the protected operations. + -- To be cleaned up??? + + function Guard_Access + (Cond : Node_Id; + Loc : Source_Ptr; + Ck_Node : Node_Id) + return Node_Id; + -- In the access type case, guard the test with a test to ensure + -- that the access value is non-null, since the checks do not + -- not apply to null access values. + + procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); + -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the + -- Constraint_Error node. + + function Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) + return Check_Result; + -- Like Apply_Selected_Length_Checks, except it doesn't modify + -- anything, just returns a list of nodes as described in the spec of + -- this package for the Range_Check function. + + function Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) + return Check_Result; + -- Like Apply_Selected_Range_Checks, except it doesn't modify anything, + -- just returns a list of nodes as described in the spec of this package + -- for the Range_Check function. + + ------------------------------ + -- Access_Checks_Suppressed -- + ------------------------------ + + function Access_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Access_Checks + or else (Present (E) and then Suppress_Access_Checks (E)); + end Access_Checks_Suppressed; + + ------------------------------------- + -- Accessibility_Checks_Suppressed -- + ------------------------------------- + + function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Accessibility_Checks + or else (Present (E) and then Suppress_Accessibility_Checks (E)); + end Accessibility_Checks_Suppressed; + + ------------------------- + -- Append_Range_Checks -- + ------------------------- + + procedure Append_Range_Checks + (Checks : Check_Result; + Stmts : List_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr; + Flag_Node : Node_Id) + is + Internal_Flag_Node : Node_Id := Flag_Node; + Internal_Static_Sloc : Source_Ptr := Static_Sloc; + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Suppress_Typ)) + or else + (not Range_Checks_Suppressed (Suppress_Typ)); + + begin + -- For now we just return if Checks_On is false, however this should + -- be enhanced to check for an always True value in the condition + -- and to generate a compilation warning??? + + if not Checks_On then + return; + end if; + + for J in 1 .. 2 loop + exit when No (Checks (J)); + + if Nkind (Checks (J)) = N_Raise_Constraint_Error + and then Present (Condition (Checks (J))) + then + if not Has_Dynamic_Range_Check (Internal_Flag_Node) then + Append_To (Stmts, Checks (J)); + Set_Has_Dynamic_Range_Check (Internal_Flag_Node); + end if; + + else + Append_To + (Stmts, Make_Raise_Constraint_Error (Internal_Static_Sloc)); + end if; + end loop; + end Append_Range_Checks; + + ------------------------ + -- Apply_Access_Check -- + ------------------------ + + procedure Apply_Access_Check (N : Node_Id) is + P : constant Node_Id := Prefix (N); + + begin + if Inside_A_Generic then + return; + end if; + + if Is_Entity_Name (P) then + Check_Unset_Reference (P); + end if; + + if Is_Entity_Name (P) + and then Access_Checks_Suppressed (Entity (P)) + then + return; + + elsif Access_Checks_Suppressed (Etype (P)) then + return; + + else + Set_Do_Access_Check (N, True); + end if; + end Apply_Access_Check; + + ------------------------------- + -- Apply_Accessibility_Check -- + ------------------------------- + + procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Param_Ent : constant Entity_Id := Param_Entity (N); + Param_Level : Node_Id; + Type_Level : Node_Id; + + begin + if Inside_A_Generic then + return; + + -- Only apply the run-time check if the access parameter + -- has an associated extra access level parameter and + -- when the level of the type is less deep than the level + -- of the access parameter. + + elsif Present (Param_Ent) + and then Present (Extra_Accessibility (Param_Ent)) + and then UI_Gt (Object_Access_Level (N), + Type_Access_Level (Typ)) + and then not Accessibility_Checks_Suppressed (Param_Ent) + and then not Accessibility_Checks_Suppressed (Typ) + then + Param_Level := + New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); + + Type_Level := + Make_Integer_Literal (Loc, Type_Access_Level (Typ)); + + -- Raise Program_Error if the accessibility level of the + -- the access parameter is deeper than the level of the + -- target access type. + + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level))); + + Analyze_And_Resolve (N); + end if; + end Apply_Accessibility_Check; + + ------------------------------------- + -- Apply_Arithmetic_Overflow_Check -- + ------------------------------------- + + -- This routine is called only if the type is an integer type, and + -- a software arithmetic overflow check must be performed for op + -- (add, subtract, multiply). The check is performed only if + -- Software_Overflow_Checking is enabled and Do_Overflow_Check + -- is set. In this case we expand the operation into a more complex + -- sequence of tests that ensures that overflow is properly caught. + + procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Rtyp : constant Entity_Id := Root_Type (Typ); + Siz : constant Int := UI_To_Int (Esize (Rtyp)); + Dsiz : constant Int := Siz * 2; + Opnod : Node_Id; + Ctyp : Entity_Id; + Opnd : Node_Id; + Cent : RE_Id; + Lo : Uint; + Hi : Uint; + OK : Boolean; + + begin + if not Software_Overflow_Checking + or else not Do_Overflow_Check (N) + or else not Expander_Active + then + return; + end if; + + -- Nothing to do if the range of the result is known OK + + Determine_Range (N, OK, Lo, Hi); + + -- Note in the test below that we assume that if a bound of the + -- range is equal to that of the type. That's not quite accurate + -- but we do this for the following reasons: + + -- a) The way that Determine_Range works, it will typically report + -- the bounds of the value are the bounds of the type, because + -- it either can't tell anything more precise, or does not think + -- it is worth the effort to be more precise. + + -- b) It is very unusual to have a situation in which this would + -- generate an unnecessary overflow check (an example would be + -- a subtype with a range 0 .. Integer'Last - 1 to which the + -- literal value one is added. + + -- c) The alternative is a lot of special casing in this routine + -- which would partially duplicate the Determine_Range processing. + + if OK + and then Lo > Expr_Value (Type_Low_Bound (Typ)) + and then Hi < Expr_Value (Type_High_Bound (Typ)) + then + return; + end if; + + -- None of the special case optimizations worked, so there is nothing + -- for it but to generate the full general case code: + + -- x op y + + -- is expanded into + + -- Typ (Checktyp (x) op Checktyp (y)); + + -- where Typ is the type of the original expression, and Checktyp is + -- an integer type of sufficient length to hold the largest possible + -- result. + + -- In the case where check type exceeds the size of Long_Long_Integer, + -- we use a different approach, expanding to: + + -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) + + -- where xxx is Add, Multiply or Subtract as appropriate + + -- Find check type if one exists + + if Dsiz <= Standard_Integer_Size then + Ctyp := Standard_Integer; + + elsif Dsiz <= Standard_Long_Long_Integer_Size then + Ctyp := Standard_Long_Long_Integer; + + -- No check type exists, use runtime call + + else + if Nkind (N) = N_Op_Add then + Cent := RE_Add_With_Ovflo_Check; + + elsif Nkind (N) = N_Op_Multiply then + Cent := RE_Multiply_With_Ovflo_Check; + + else + pragma Assert (Nkind (N) = N_Op_Subtract); + Cent := RE_Subtract_With_Ovflo_Check; + end if; + + Rewrite (N, + OK_Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Cent), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), + OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); + + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- If we fall through, we have the case where we do the arithmetic in + -- the next higher type and get the check by conversion. In these cases + -- Ctyp is set to the type to be used as the check type. + + Opnod := Relocate_Node (N); + + Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); + + Analyze (Opnd); + Set_Etype (Opnd, Ctyp); + Set_Analyzed (Opnd, True); + Set_Left_Opnd (Opnod, Opnd); + + Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); + + Analyze (Opnd); + Set_Etype (Opnd, Ctyp); + Set_Analyzed (Opnd, True); + Set_Right_Opnd (Opnod, Opnd); + + -- The type of the operation changes to the base type of the check + -- type, and we reset the overflow check indication, since clearly + -- no overflow is possible now that we are using a double length + -- type. We also set the Analyzed flag to avoid a recursive attempt + -- to expand the node. + + Set_Etype (Opnod, Base_Type (Ctyp)); + Set_Do_Overflow_Check (Opnod, False); + Set_Analyzed (Opnod, True); + + -- Now build the outer conversion + + Opnd := OK_Convert_To (Typ, Opnod); + + Analyze (Opnd); + Set_Etype (Opnd, Typ); + Set_Analyzed (Opnd, True); + Set_Do_Overflow_Check (Opnd, True); + + Rewrite (N, Opnd); + end Apply_Arithmetic_Overflow_Check; + + ---------------------------- + -- Apply_Array_Size_Check -- + ---------------------------- + + -- Note: Really of course this entre check should be in the backend, + -- and perhaps this is not quite the right value, but it is good + -- enough to catch the normal cases (and the relevant ACVC tests!) + + procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + Ent : constant Entity_Id := Defining_Identifier (N); + Decl : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Lob : Uint; + Hib : Uint; + Siz : Uint; + Xtyp : Entity_Id; + Indx : Node_Id; + Sizx : Node_Id; + Code : Node_Id; + + Static : Boolean := True; + -- Set false if any index subtye bound is non-static + + Umark : constant Uintp.Save_Mark := Uintp.Mark; + -- We can throw away all the Uint computations here, since they are + -- done only to generate boolean test results. + + Check_Siz : Uint; + -- Size to check against + + function Is_Address_Or_Import (Decl : Node_Id) return Boolean; + -- Determines if Decl is an address clause or Import/Interface pragma + -- that references the defining identifier of the current declaration. + + -------------------------- + -- Is_Address_Or_Import -- + -------------------------- + + function Is_Address_Or_Import (Decl : Node_Id) return Boolean is + begin + if Nkind (Decl) = N_At_Clause then + return Chars (Identifier (Decl)) = Chars (Ent); + + elsif Nkind (Decl) = N_Attribute_Definition_Clause then + return + Chars (Decl) = Name_Address + and then + Nkind (Name (Decl)) = N_Identifier + and then + Chars (Name (Decl)) = Chars (Ent); + + elsif Nkind (Decl) = N_Pragma then + if (Chars (Decl) = Name_Import + or else + Chars (Decl) = Name_Interface) + and then Present (Pragma_Argument_Associations (Decl)) + then + declare + F : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + + begin + return + Present (F) + and then + Present (Next (F)) + and then + Nkind (Expression (Next (F))) = N_Identifier + and then + Chars (Expression (Next (F))) = Chars (Ent); + end; + + else + return False; + end if; + + else + return False; + end if; + end Is_Address_Or_Import; + + -- Start of processing for Apply_Array_Size_Check + + begin + if not Expander_Active + or else Storage_Checks_Suppressed (Typ) + then + return; + end if; + + -- It is pointless to insert this check inside an _init_proc, because + -- that's too late, we have already built the object to be the right + -- size, and if it's too large, too bad! + + if Inside_Init_Proc then + return; + end if; + + -- Look head for pragma interface/import or address clause applying + -- to this entity. If found, we suppress the check entirely. For now + -- we only look ahead 20 declarations to stop this becoming too slow + -- Note that eventually this whole routine gets moved to gigi. + + Decl := N; + for Ctr in 1 .. 20 loop + Next (Decl); + exit when No (Decl); + + if Is_Address_Or_Import (Decl) then + return; + end if; + end loop; + + -- First step is to calculate the maximum number of elements. For this + -- calculation, we use the actual size of the subtype if it is static, + -- and if a bound of a subtype is non-static, we go to the bound of the + -- base type. + + Siz := Uint_1; + Indx := First_Index (Typ); + while Present (Indx) loop + Xtyp := Etype (Indx); + Lo := Type_Low_Bound (Xtyp); + Hi := Type_High_Bound (Xtyp); + + -- If any bound raises constraint error, we will never get this + -- far, so there is no need to generate any kind of check. + + if Raises_Constraint_Error (Lo) + or else + Raises_Constraint_Error (Hi) + then + Uintp.Release (Umark); + return; + end if; + + -- Otherwise get bounds values + + if Is_Static_Expression (Lo) then + Lob := Expr_Value (Lo); + else + Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp))); + Static := False; + end if; + + if Is_Static_Expression (Hi) then + Hib := Expr_Value (Hi); + else + Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp))); + Static := False; + end if; + + Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0); + Next_Index (Indx); + end loop; + + -- Compute the limit against which we want to check. For subprograms, + -- where the array will go on the stack, we use 8*2**24, which (in + -- bits) is the size of a 16 megabyte array. + + if Is_Subprogram (Scope (Ent)) then + Check_Siz := Uint_2 ** 27; + else + Check_Siz := Uint_2 ** 31; + end if; + + -- If we have all static bounds and Siz is too large, then we know we + -- know we have a storage error right now, so generate message + + if Static and then Siz >= Check_Siz then + Insert_Action (N, + Make_Raise_Storage_Error (Loc)); + Warn_On_Instance := True; + Error_Msg_N ("?Storage_Error will be raised at run-time", N); + Warn_On_Instance := False; + Uintp.Release (Umark); + return; + end if; + + -- Case of component size known at compile time. If the array + -- size is definitely in range, then we do not need a check. + + if Known_Esize (Ctyp) + and then Siz * Esize (Ctyp) < Check_Siz + then + Uintp.Release (Umark); + return; + end if; + + -- Here if a dynamic check is required + + -- What we do is to build an expression for the size of the array, + -- which is computed as the 'Size of the array component, times + -- the size of each dimension. + + Uintp.Release (Umark); + + Sizx := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ctyp, Loc), + Attribute_Name => Name_Size); + + Indx := First_Index (Typ); + + for J in 1 .. Number_Dimensions (Typ) loop + + if Sloc (Etype (Indx)) = Sloc (N) then + Ensure_Defined (Etype (Indx), N); + end if; + + Sizx := + Make_Op_Multiply (Loc, + Left_Opnd => Sizx, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))); + Next_Index (Indx); + end loop; + + Code := + Make_Raise_Storage_Error (Loc, + Condition => + Make_Op_Ge (Loc, + Left_Opnd => Sizx, + Right_Opnd => + Make_Integer_Literal (Loc, Check_Siz))); + + Set_Size_Check_Code (Defining_Identifier (N), Code); + Insert_Action (N, Code); + + end Apply_Array_Size_Check; + + ---------------------------- + -- Apply_Constraint_Check -- + ---------------------------- + + procedure Apply_Constraint_Check + (N : Node_Id; + Typ : Entity_Id; + No_Sliding : Boolean := False) + is + Desig_Typ : Entity_Id; + + begin + if Inside_A_Generic then + return; + + elsif Is_Scalar_Type (Typ) then + Apply_Scalar_Range_Check (N, Typ); + + elsif Is_Array_Type (Typ) then + + if Is_Constrained (Typ) then + Apply_Length_Check (N, Typ); + + if No_Sliding then + Apply_Range_Check (N, Typ); + end if; + else + Apply_Range_Check (N, Typ); + end if; + + elsif (Is_Record_Type (Typ) + or else Is_Private_Type (Typ)) + and then Has_Discriminants (Base_Type (Typ)) + and then Is_Constrained (Typ) + then + Apply_Discriminant_Check (N, Typ); + + elsif Is_Access_Type (Typ) then + + Desig_Typ := Designated_Type (Typ); + + -- No checks necessary if expression statically null + + if Nkind (N) = N_Null then + null; + + -- No sliding possible on access to arrays + + elsif Is_Array_Type (Desig_Typ) then + if Is_Constrained (Desig_Typ) then + Apply_Length_Check (N, Typ); + end if; + + Apply_Range_Check (N, Typ); + + elsif Has_Discriminants (Base_Type (Desig_Typ)) + and then Is_Constrained (Desig_Typ) + then + Apply_Discriminant_Check (N, Typ); + end if; + end if; + end Apply_Constraint_Check; + + ------------------------------ + -- Apply_Discriminant_Check -- + ------------------------------ + + procedure Apply_Discriminant_Check + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (N); + Do_Access : constant Boolean := Is_Access_Type (Typ); + S_Typ : Entity_Id := Etype (N); + Cond : Node_Id; + T_Typ : Entity_Id; + + function Is_Aliased_Unconstrained_Component return Boolean; + -- It is possible for an aliased component to have a nominal + -- unconstrained subtype (through instantiation). If this is a + -- discriminated component assigned in the expansion of an aggregate + -- in an initialization, the check must be suppressed. This unusual + -- situation requires a predicate of its own (see 7503-008). + + ---------------------------------------- + -- Is_Aliased_Unconstrained_Component -- + ---------------------------------------- + + function Is_Aliased_Unconstrained_Component return Boolean is + Comp : Entity_Id; + Pref : Node_Id; + + begin + if Nkind (Lhs) /= N_Selected_Component then + return False; + else + Comp := Entity (Selector_Name (Lhs)); + Pref := Prefix (Lhs); + end if; + + if Ekind (Comp) /= E_Component + or else not Is_Aliased (Comp) + then + return False; + end if; + + return not Comes_From_Source (Pref) + and then In_Instance + and then not Is_Constrained (Etype (Comp)); + end Is_Aliased_Unconstrained_Component; + + -- Start of processing for Apply_Discriminant_Check + + begin + if Do_Access then + T_Typ := Designated_Type (Typ); + else + T_Typ := Typ; + end if; + + -- Nothing to do if discriminant checks are suppressed or else no code + -- is to be generated + + if not Expander_Active + or else Discriminant_Checks_Suppressed (T_Typ) + then + return; + end if; + + -- No discriminant checks necessary for access when expression + -- is statically Null. This is not only an optimization, this is + -- fundamental because otherwise discriminant checks may be generated + -- in init procs for types containing an access to a non-frozen yet + -- record, causing a deadly forward reference. + + -- Also, if the expression is of an access type whose designated + -- type is incomplete, then the access value must be null and + -- we suppress the check. + + if Nkind (N) = N_Null then + return; + + elsif Is_Access_Type (S_Typ) then + S_Typ := Designated_Type (S_Typ); + + if Ekind (S_Typ) = E_Incomplete_Type then + return; + end if; + end if; + + -- If an assignment target is present, then we need to generate + -- the actual subtype if the target is a parameter or aliased + -- object with an unconstrained nominal subtype. + + if Present (Lhs) + and then (Present (Param_Entity (Lhs)) + or else (not Is_Constrained (T_Typ) + and then Is_Aliased_View (Lhs) + and then not Is_Aliased_Unconstrained_Component)) + then + T_Typ := Get_Actual_Subtype (Lhs); + end if; + + -- Nothing to do if the type is unconstrained (this is the case + -- where the actual subtype in the RM sense of N is unconstrained + -- and no check is required). + + if not Is_Constrained (T_Typ) then + return; + end if; + + -- Suppress checks if the subtypes are the same. + -- the check must be preserved in an assignment to a formal, because + -- the constraint is given by the actual. + + if Nkind (Original_Node (N)) /= N_Allocator + and then (No (Lhs) + or else not Is_Entity_Name (Lhs) + or else (Ekind (Entity (Lhs)) /= E_In_Out_Parameter + and then Ekind (Entity (Lhs)) /= E_Out_Parameter)) + then + if (Etype (N) = Typ + or else (Do_Access and then Designated_Type (Typ) = S_Typ)) + and then not Is_Aliased_View (Lhs) + then + return; + end if; + + -- We can also eliminate checks on allocators with a subtype mark + -- that coincides with the context type. The context type may be a + -- subtype without a constraint (common case, a generic actual). + + elsif Nkind (Original_Node (N)) = N_Allocator + and then Is_Entity_Name (Expression (Original_Node (N))) + then + declare + Alloc_Typ : Entity_Id := Entity (Expression (Original_Node (N))); + + begin + if Alloc_Typ = T_Typ + or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration + and then Is_Entity_Name ( + Subtype_Indication (Parent (T_Typ))) + and then Alloc_Typ = Base_Type (T_Typ)) + + then + return; + end if; + end; + end if; + + -- See if we have a case where the types are both constrained, and + -- all the constraints are constants. In this case, we can do the + -- check successfully at compile time. + + -- we skip this check for the case where the node is a rewritten` + -- allocator, because it already carries the context subtype, and + -- extracting the discriminants from the aggregate is messy. + + if Is_Constrained (S_Typ) + and then Nkind (Original_Node (N)) /= N_Allocator + then + declare + DconT : Elmt_Id; + Discr : Entity_Id; + DconS : Elmt_Id; + ItemS : Node_Id; + ItemT : Node_Id; + + begin + -- S_Typ may not have discriminants in the case where it is a + -- private type completed by a default discriminated type. In + -- that case, we need to get the constraints from the + -- underlying_type. If the underlying type is unconstrained (i.e. + -- has no default discriminants) no check is needed. + + if Has_Discriminants (S_Typ) then + Discr := First_Discriminant (S_Typ); + DconS := First_Elmt (Discriminant_Constraint (S_Typ)); + + else + Discr := First_Discriminant (Underlying_Type (S_Typ)); + DconS := + First_Elmt + (Discriminant_Constraint (Underlying_Type (S_Typ))); + + if No (DconS) then + return; + end if; + end if; + + DconT := First_Elmt (Discriminant_Constraint (T_Typ)); + + while Present (Discr) loop + ItemS := Node (DconS); + ItemT := Node (DconT); + + exit when + not Is_OK_Static_Expression (ItemS) + or else + not Is_OK_Static_Expression (ItemT); + + if Expr_Value (ItemS) /= Expr_Value (ItemT) then + if Do_Access then -- needs run-time check. + exit; + else + Apply_Compile_Time_Constraint_Error + (N, "incorrect value for discriminant&?", Ent => Discr); + return; + end if; + end if; + + Next_Elmt (DconS); + Next_Elmt (DconT); + Next_Discriminant (Discr); + end loop; + + if No (Discr) then + return; + end if; + end; + end if; + + -- Here we need a discriminant check. First build the expression + -- for the comparisons of the discriminants: + + -- (n.disc1 /= typ.disc1) or else + -- (n.disc2 /= typ.disc2) or else + -- ... + -- (n.discn /= typ.discn) + + Cond := Build_Discriminant_Checks (N, T_Typ); + + -- If Lhs is set and is a parameter, then the condition is + -- guarded by: lhs'constrained and then (condition built above) + + if Present (Param_Entity (Lhs)) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc), + Attribute_Name => Name_Constrained), + Right_Opnd => Cond); + end if; + + if Do_Access then + Cond := Guard_Access (Cond, Loc, N); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, Condition => Cond)); + + end Apply_Discriminant_Check; + + ------------------------ + -- Apply_Divide_Check -- + ------------------------ + + procedure Apply_Divide_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + LLB : Uint; + Llo : Uint; + Lhi : Uint; + LOK : Boolean; + Rlo : Uint; + Rhi : Uint; + ROK : Boolean; + + begin + if Expander_Active + and then Software_Overflow_Checking + then + Determine_Range (Right, ROK, Rlo, Rhi); + + -- See if division by zero possible, and if so generate test. This + -- part of the test is not controlled by the -gnato switch. + + if Do_Division_Check (N) then + + if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Right), + Right_Opnd => Make_Integer_Literal (Loc, 0)))); + end if; + end if; + + -- Test for extremely annoying case of xxx'First divided by -1 + + if Do_Overflow_Check (N) then + + if Nkind (N) = N_Op_Divide + and then Is_Signed_Integer_Type (Typ) + then + Determine_Range (Left, LOK, Llo, Lhi); + LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); + + if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) + and then + ((not LOK) or else (Llo = LLB)) + then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_And_Then (Loc, + + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Left), + Right_Opnd => Make_Integer_Literal (Loc, LLB)), + + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Right), + Right_Opnd => + Make_Integer_Literal (Loc, -1))))); + end if; + end if; + end if; + end if; + end Apply_Divide_Check; + + ------------------------ + -- Apply_Length_Check -- + ------------------------ + + procedure Apply_Length_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty) + is + begin + Apply_Selected_Length_Checks + (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); + end Apply_Length_Check; + + ----------------------- + -- Apply_Range_Check -- + ----------------------- + + procedure Apply_Range_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty) + is + begin + Apply_Selected_Range_Checks + (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); + end Apply_Range_Check; + + ------------------------------ + -- Apply_Scalar_Range_Check -- + ------------------------------ + + -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check + -- flag off if it is already set on. + + procedure Apply_Scalar_Range_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Fixed_Int : Boolean := False) + is + Parnt : constant Node_Id := Parent (Expr); + S_Typ : Entity_Id; + Arr : Node_Id := Empty; -- initialize to prevent warning + Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning + OK : Boolean; + + Is_Subscr_Ref : Boolean; + -- Set true if Expr is a subscript + + Is_Unconstrained_Subscr_Ref : Boolean; + -- Set true if Expr is a subscript of an unconstrained array. In this + -- case we do not attempt to do an analysis of the value against the + -- range of the subscript, since we don't know the actual subtype. + + Int_Real : Boolean; + -- Set to True if Expr should be regarded as a real value + -- even though the type of Expr might be discrete. + + procedure Bad_Value; + -- Procedure called if value is determined to be out of range + + procedure Bad_Value is + begin + Apply_Compile_Time_Constraint_Error + (Expr, "value not in range of}?", + Ent => Target_Typ, + Typ => Target_Typ); + end Bad_Value; + + begin + if Inside_A_Generic then + return; + + -- Return if check obviously not needed. Note that we do not check + -- for the expander being inactive, since this routine does not + -- insert any code, but it does generate useful warnings sometimes, + -- which we would like even if we are in semantics only mode. + + elsif Target_Typ = Any_Type + or else not Is_Scalar_Type (Target_Typ) + or else Raises_Constraint_Error (Expr) + then + return; + end if; + + -- Now, see if checks are suppressed + + Is_Subscr_Ref := + Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component; + + if Is_Subscr_Ref then + Arr := Prefix (Parnt); + Arr_Typ := Get_Actual_Subtype_If_Available (Arr); + end if; + + if not Do_Range_Check (Expr) then + + -- Subscript reference. Check for Index_Checks suppressed + + if Is_Subscr_Ref then + + -- Check array type and its base type + + if Index_Checks_Suppressed (Arr_Typ) + or else Suppress_Index_Checks (Base_Type (Arr_Typ)) + then + return; + + -- Check array itself if it is an entity name + + elsif Is_Entity_Name (Arr) + and then Suppress_Index_Checks (Entity (Arr)) + then + return; + + -- Check expression itself if it is an entity name + + elsif Is_Entity_Name (Expr) + and then Suppress_Index_Checks (Entity (Expr)) + then + return; + end if; + + -- All other cases, check for Range_Checks suppressed + + else + -- Check target type and its base type + + if Range_Checks_Suppressed (Target_Typ) + or else Suppress_Range_Checks (Base_Type (Target_Typ)) + then + return; + + -- Check expression itself if it is an entity name + + elsif Is_Entity_Name (Expr) + and then Suppress_Range_Checks (Entity (Expr)) + then + return; + + -- If Expr is part of an assignment statement, then check + -- left side of assignment if it is an entity name. + + elsif Nkind (Parnt) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parnt)) + and then Suppress_Range_Checks (Entity (Name (Parnt))) + then + return; + end if; + end if; + end if; + + -- Now see if we need a check + + if No (Source_Typ) then + S_Typ := Etype (Expr); + else + S_Typ := Source_Typ; + end if; + + if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then + return; + end if; + + Is_Unconstrained_Subscr_Ref := + Is_Subscr_Ref and then not Is_Constrained (Arr_Typ); + + -- Always do a range check if the source type includes infinities + -- and the target type does not include infinities. + + if Is_Floating_Point_Type (S_Typ) + and then Has_Infinities (S_Typ) + and then not Has_Infinities (Target_Typ) + then + Enable_Range_Check (Expr); + end if; + + -- Return if we know expression is definitely in the range of + -- the target type as determined by Determine_Range. Right now + -- we only do this for discrete types, and not fixed-point or + -- floating-point types. + + -- The additional less-precise tests below catch these cases. + + -- Note: skip this if we are given a source_typ, since the point + -- of supplying a Source_Typ is to stop us looking at the expression. + -- could sharpen this test to be out parameters only ??? + + if Is_Discrete_Type (Target_Typ) + and then Is_Discrete_Type (Etype (Expr)) + and then not Is_Unconstrained_Subscr_Ref + and then No (Source_Typ) + then + declare + Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); + Thi : constant Node_Id := Type_High_Bound (Target_Typ); + Lo : Uint; + Hi : Uint; + + begin + if Compile_Time_Known_Value (Tlo) + and then Compile_Time_Known_Value (Thi) + then + Determine_Range (Expr, OK, Lo, Hi); + + if OK then + declare + Lov : constant Uint := Expr_Value (Tlo); + Hiv : constant Uint := Expr_Value (Thi); + + begin + if Lo >= Lov and then Hi <= Hiv then + return; + + elsif Lov > Hi or else Hiv < Lo then + Bad_Value; + return; + end if; + end; + end if; + end if; + end; + end if; + + Int_Real := + Is_Floating_Point_Type (S_Typ) + or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int); + + -- Check if we can determine at compile time whether Expr is in the + -- range of the target type. Note that if S_Typ is within the + -- bounds of Target_Typ then this must be the case. This checks is + -- only meaningful if this is not a conversion between integer and + -- real types. + + if not Is_Unconstrained_Subscr_Ref + and then + Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) + and then + (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) + or else + Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real)) + then + return; + + elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then + Bad_Value; + return; + + -- Do not set range checks if they are killed + + elsif Nkind (Expr) = N_Unchecked_Type_Conversion + and then Kill_Range_Check (Expr) + then + return; + + -- ??? We only need a runtime check if the target type is constrained + -- (the predefined type Float is not for instance). + -- so the following should really be + -- + -- elsif Is_Constrained (Target_Typ) then + -- + -- but it isn't because certain types do not have the Is_Constrained + -- flag properly set (see 1503-003). + + else + Enable_Range_Check (Expr); + return; + end if; + + end Apply_Scalar_Range_Check; + + ---------------------------------- + -- Apply_Selected_Length_Checks -- + ---------------------------------- + + procedure Apply_Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean) + is + Cond : Node_Id; + R_Result : Check_Result; + R_Cno : Node_Id; + + Loc : constant Source_Ptr := Sloc (Ck_Node); + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Target_Typ)) + or else + (not Length_Checks_Suppressed (Target_Typ)); + + begin + if not Expander_Active or else not Checks_On then + return; + end if; + + R_Result := + Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); + + for J in 1 .. 2 loop + + R_Cno := R_Result (J); + exit when No (R_Cno); + + -- A length check may mention an Itype which is attached to a + -- subsequent node. At the top level in a package this can cause + -- an order-of-elaboration problem, so we make sure that the itype + -- is referenced now. + + if Ekind (Current_Scope) = E_Package + and then Is_Compilation_Unit (Current_Scope) + then + Ensure_Defined (Target_Typ, Ck_Node); + + if Present (Source_Typ) then + Ensure_Defined (Source_Typ, Ck_Node); + + elsif Is_Itype (Etype (Ck_Node)) then + Ensure_Defined (Etype (Ck_Node), Ck_Node); + end if; + end if; + + -- If the item is a conditional raise of constraint error, + -- then have a look at what check is being performed and + -- ??? + + if Nkind (R_Cno) = N_Raise_Constraint_Error + and then Present (Condition (R_Cno)) + then + Cond := Condition (R_Cno); + + if not Has_Dynamic_Length_Check (Ck_Node) then + Insert_Action (Ck_Node, R_Cno); + + if not Do_Static then + Set_Has_Dynamic_Length_Check (Ck_Node); + end if; + + end if; + + -- Output a warning if the condition is known to be True + + if Is_Entity_Name (Cond) + and then Entity (Cond) = Standard_True + then + Apply_Compile_Time_Constraint_Error + (Ck_Node, "wrong length for array of}?", + Ent => Target_Typ, + Typ => Target_Typ); + + -- If we were only doing a static check, or if checks are not + -- on, then we want to delete the check, since it is not needed. + -- We do this by replacing the if statement by a null statement + + elsif Do_Static or else not Checks_On then + Rewrite (R_Cno, Make_Null_Statement (Loc)); + end if; + + else + Install_Static_Check (R_Cno, Loc); + end if; + + end loop; + + end Apply_Selected_Length_Checks; + + --------------------------------- + -- Apply_Selected_Range_Checks -- + --------------------------------- + + procedure Apply_Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean) + is + Cond : Node_Id; + R_Result : Check_Result; + R_Cno : Node_Id; + + Loc : constant Source_Ptr := Sloc (Ck_Node); + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Target_Typ)) + or else + (not Range_Checks_Suppressed (Target_Typ)); + + begin + if not Expander_Active or else not Checks_On then + return; + end if; + + R_Result := + Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); + + for J in 1 .. 2 loop + + R_Cno := R_Result (J); + exit when No (R_Cno); + + -- If the item is a conditional raise of constraint error, + -- then have a look at what check is being performed and + -- ??? + + if Nkind (R_Cno) = N_Raise_Constraint_Error + and then Present (Condition (R_Cno)) + then + Cond := Condition (R_Cno); + + if not Has_Dynamic_Range_Check (Ck_Node) then + Insert_Action (Ck_Node, R_Cno); + + if not Do_Static then + Set_Has_Dynamic_Range_Check (Ck_Node); + end if; + end if; + + -- Output a warning if the condition is known to be True + + if Is_Entity_Name (Cond) + and then Entity (Cond) = Standard_True + then + -- Since an N_Range is technically not an expression, we + -- have to set one of the bounds to C_E and then just flag + -- the N_Range. The warning message will point to the + -- lower bound and complain about a range, which seems OK. + + if Nkind (Ck_Node) = N_Range then + Apply_Compile_Time_Constraint_Error + (Low_Bound (Ck_Node), "static range out of bounds of}?", + Ent => Target_Typ, + Typ => Target_Typ); + + Set_Raises_Constraint_Error (Ck_Node); + + else + Apply_Compile_Time_Constraint_Error + (Ck_Node, "static value out of range of}?", + Ent => Target_Typ, + Typ => Target_Typ); + end if; + + -- If we were only doing a static check, or if checks are not + -- on, then we want to delete the check, since it is not needed. + -- We do this by replacing the if statement by a null statement + + elsif Do_Static or else not Checks_On then + Rewrite (R_Cno, Make_Null_Statement (Loc)); + end if; + + else + Install_Static_Check (R_Cno, Loc); + end if; + + end loop; + + end Apply_Selected_Range_Checks; + + ------------------------------- + -- Apply_Static_Length_Check -- + ------------------------------- + + procedure Apply_Static_Length_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty) + is + begin + Apply_Selected_Length_Checks + (Expr, Target_Typ, Source_Typ, Do_Static => True); + end Apply_Static_Length_Check; + + ------------------------------------- + -- Apply_Subscript_Validity_Checks -- + ------------------------------------- + + procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is + Sub : Node_Id; + + begin + pragma Assert (Nkind (Expr) = N_Indexed_Component); + + -- Loop through subscripts + + Sub := First (Expressions (Expr)); + while Present (Sub) loop + + -- Check one subscript. Note that we do not worry about + -- enumeration type with holes, since we will convert the + -- value to a Pos value for the subscript, and that convert + -- will do the necessary validity check. + + Ensure_Valid (Sub, Holes_OK => True); + + -- Move to next subscript + + Sub := Next (Sub); + end loop; + end Apply_Subscript_Validity_Checks; + + ---------------------------------- + -- Apply_Type_Conversion_Checks -- + ---------------------------------- + + procedure Apply_Type_Conversion_Checks (N : Node_Id) is + Target_Type : constant Entity_Id := Etype (N); + Target_Base : constant Entity_Id := Base_Type (Target_Type); + + Expr : constant Node_Id := Expression (N); + Expr_Type : constant Entity_Id := Etype (Expr); + + begin + if Inside_A_Generic then + return; + + -- Skip these checks if errors detected, there are some nasty + -- situations of incomplete trees that blow things up. + + elsif Errors_Detected > 0 then + return; + + -- Scalar type conversions of the form Target_Type (Expr) require + -- two checks: + -- + -- - First there is an overflow check to insure that Expr is + -- in the base type of Target_Typ (4.6 (28)), + -- + -- - After we know Expr fits into the base type, we must perform a + -- range check to ensure that Expr meets the constraints of the + -- Target_Type. + + elsif Is_Scalar_Type (Target_Type) then + declare + Conv_OK : constant Boolean := Conversion_OK (N); + -- If the Conversion_OK flag on the type conversion is set + -- and no floating point type is involved in the type conversion + -- then fixed point values must be read as integral values. + + begin + -- Overflow check. + + if not Overflow_Checks_Suppressed (Target_Base) + and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK) + then + Set_Do_Overflow_Check (N); + end if; + + if not Range_Checks_Suppressed (Target_Type) + and then not Range_Checks_Suppressed (Expr_Type) + then + Apply_Scalar_Range_Check + (Expr, Target_Type, Fixed_Int => Conv_OK); + end if; + end; + + elsif Comes_From_Source (N) + and then Is_Record_Type (Target_Type) + and then Is_Derived_Type (Target_Type) + and then not Is_Tagged_Type (Target_Type) + and then not Is_Constrained (Target_Type) + and then Present (Girder_Constraint (Target_Type)) + then + -- A unconstrained derived type may have inherited discriminants. + -- Build an actual discriminant constraint list using the girder + -- constraint, to verify that the expression of the parent type + -- satisfies the constraints imposed by the (unconstrained!) + -- derived type. This applies to value conversions, not to view + -- conversions of tagged types. + + declare + Loc : constant Source_Ptr := Sloc (N); + Cond : Node_Id; + Constraint : Elmt_Id; + Discr_Value : Node_Id; + Discr : Entity_Id; + New_Constraints : Elist_Id := New_Elmt_List; + Old_Constraints : Elist_Id := Discriminant_Constraint (Expr_Type); + + begin + Constraint := First_Elmt (Girder_Constraint (Target_Type)); + + while Present (Constraint) loop + Discr_Value := Node (Constraint); + + if Is_Entity_Name (Discr_Value) + and then Ekind (Entity (Discr_Value)) = E_Discriminant + then + Discr := Corresponding_Discriminant (Entity (Discr_Value)); + + if Present (Discr) + and then Scope (Discr) = Base_Type (Expr_Type) + then + -- Parent is constrained by new discriminant. Obtain + -- Value of original discriminant in expression. If + -- the new discriminant has been used to constrain more + -- than one of the girder ones, this will provide the + -- required consistency check. + + Append_Elmt ( + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr (Expr, Name_Req => True), + Selector_Name => + Make_Identifier (Loc, Chars (Discr))), + New_Constraints); + + else + -- Discriminant of more remote ancestor ??? + + return; + end if; + + -- Derived type definition has an explicit value for + -- this girder discriminant. + + else + Append_Elmt + (Duplicate_Subexpr (Discr_Value), New_Constraints); + end if; + + Next_Elmt (Constraint); + end loop; + + -- Use the unconstrained expression type to retrieve the + -- discriminants of the parent, and apply momentarily the + -- discriminant constraint synthesized above. + + Set_Discriminant_Constraint (Expr_Type, New_Constraints); + Cond := Build_Discriminant_Checks (Expr, Expr_Type); + Set_Discriminant_Constraint (Expr_Type, Old_Constraints); + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, Condition => Cond)); + end; + + -- should there be other checks here for array types ??? + + else + null; + end if; + + end Apply_Type_Conversion_Checks; + + ---------------------------------------------- + -- Apply_Universal_Integer_Attribute_Checks -- + ---------------------------------------------- + + procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + if Inside_A_Generic then + return; + + -- Nothing to do if checks are suppressed + + elsif Range_Checks_Suppressed (Typ) + and then Overflow_Checks_Suppressed (Typ) + then + return; + + -- Nothing to do if the attribute does not come from source. The + -- internal attributes we generate of this type do not need checks, + -- and furthermore the attempt to check them causes some circular + -- elaboration orders when dealing with packed types. + + elsif not Comes_From_Source (N) then + return; + + -- Otherwise, replace the attribute node with a type conversion + -- node whose expression is the attribute, retyped to universal + -- integer, and whose subtype mark is the target type. The call + -- to analyze this conversion will set range and overflow checks + -- as required for proper detection of an out of range value. + + else + Set_Etype (N, Universal_Integer); + Set_Analyzed (N, True); + + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (N))); + + Analyze_And_Resolve (N, Typ); + return; + end if; + + end Apply_Universal_Integer_Attribute_Checks; + + ------------------------------- + -- Build_Discriminant_Checks -- + ------------------------------- + + function Build_Discriminant_Checks + (N : Node_Id; + T_Typ : Entity_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Cond : Node_Id; + Disc : Elmt_Id; + Disc_Ent : Entity_Id; + Dval : Node_Id; + + begin + Cond := Empty; + Disc := First_Elmt (Discriminant_Constraint (T_Typ)); + + -- For a fully private type, use the discriminants of the parent + -- type. + + if Is_Private_Type (T_Typ) + and then No (Full_View (T_Typ)) + then + Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ))); + else + Disc_Ent := First_Discriminant (T_Typ); + end if; + + while Present (Disc) loop + + Dval := Node (Disc); + + if Nkind (Dval) = N_Identifier + and then Ekind (Entity (Dval)) = E_Discriminant + then + Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc); + else + Dval := Duplicate_Subexpr (Dval); + end if; + + Evolve_Or_Else (Cond, + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr (N, Name_Req => True), + Selector_Name => + Make_Identifier (Loc, Chars (Disc_Ent))), + Right_Opnd => Dval)); + + Next_Elmt (Disc); + Next_Discriminant (Disc_Ent); + end loop; + + return Cond; + end Build_Discriminant_Checks; + + ----------------------------------- + -- Check_Valid_Lvalue_Subscripts -- + ----------------------------------- + + procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is + begin + -- Skip this if range checks are suppressed + + if Range_Checks_Suppressed (Etype (Expr)) then + return; + + -- Only do this check for expressions that come from source. We + -- assume that expander generated assignments explicitly include + -- any necessary checks. Note that this is not just an optimization, + -- it avoids infinite recursions! + + elsif not Comes_From_Source (Expr) then + return; + + -- For a selected component, check the prefix + + elsif Nkind (Expr) = N_Selected_Component then + Check_Valid_Lvalue_Subscripts (Prefix (Expr)); + return; + + -- Case of indexed component + + elsif Nkind (Expr) = N_Indexed_Component then + Apply_Subscript_Validity_Checks (Expr); + + -- Prefix may itself be or contain an indexed component, and + -- these subscripts need checking as well + + Check_Valid_Lvalue_Subscripts (Prefix (Expr)); + end if; + end Check_Valid_Lvalue_Subscripts; + + --------------------- + -- Determine_Range -- + --------------------- + + Cache_Size : constant := 2 ** 6; + type Cache_Index is range 0 .. Cache_Size - 1; + -- Determine size of below cache (power of 2 is more efficient!) + + Determine_Range_Cache_N : array (Cache_Index) of Node_Id; + Determine_Range_Cache_Lo : array (Cache_Index) of Uint; + Determine_Range_Cache_Hi : array (Cache_Index) of Uint; + -- The above arrays are used to implement a small direct cache + -- for Determine_Range calls. Because of the way Determine_Range + -- recursively traces subexpressions, and because overflow checking + -- calls the routine on the way up the tree, a quadratic behavior + -- can otherwise be encountered in large expressions. The cache + -- entry for node N is stored in the (N mod Cache_Size) entry, and + -- can be validated by checking the actual node value stored there. + + procedure Determine_Range + (N : Node_Id; + OK : out Boolean; + Lo : out Uint; + Hi : out Uint) + is + Typ : constant Entity_Id := Etype (N); + + Lo_Left : Uint; + Lo_Right : Uint; + Hi_Left : Uint; + Hi_Right : Uint; + Bound : Node_Id; + Hbound : Uint; + Lor : Uint; + Hir : Uint; + OK1 : Boolean; + Cindex : Cache_Index; + + function OK_Operands return Boolean; + -- Used for binary operators. Determines the ranges of the left and + -- right operands, and if they are both OK, returns True, and puts + -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left + + ----------------- + -- OK_Operands -- + ----------------- + + function OK_Operands return Boolean is + begin + Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left); + + if not OK1 then + return False; + end if; + + Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right); + return OK1; + end OK_Operands; + + -- Start of processing for Determine_Range + + begin + -- Prevent junk warnings by initializing range variables + + Lo := No_Uint; + Hi := No_Uint; + Lor := No_Uint; + Hir := No_Uint; + + -- If the type is not discrete, or is undefined, then we can't + -- do anything about determining the range. + + if No (Typ) or else not Is_Discrete_Type (Typ) + or else Error_Posted (N) + then + OK := False; + return; + end if; + + -- For all other cases, we can determine the range + + OK := True; + + -- If value is compile time known, then the possible range is the + -- one value that we know this expression definitely has! + + if Compile_Time_Known_Value (N) then + Lo := Expr_Value (N); + Hi := Lo; + return; + end if; + + -- Return if already in the cache + + Cindex := Cache_Index (N mod Cache_Size); + + if Determine_Range_Cache_N (Cindex) = N then + Lo := Determine_Range_Cache_Lo (Cindex); + Hi := Determine_Range_Cache_Hi (Cindex); + return; + end if; + + -- Otherwise, start by finding the bounds of the type of the + -- expression, the value cannot be outside this range (if it + -- is, then we have an overflow situation, which is a separate + -- check, we are talking here only about the expression value). + + -- We use the actual bound unless it is dynamic, in which case + -- use the corresponding base type bound if possible. If we can't + -- get a bound then + + Bound := Type_Low_Bound (Typ); + + if Compile_Time_Known_Value (Bound) then + Lo := Expr_Value (Bound); + + elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then + Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ))); + + else + OK := False; + return; + end if; + + Bound := Type_High_Bound (Typ); + + if Compile_Time_Known_Value (Bound) then + Hi := Expr_Value (Bound); + + elsif Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then + Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ))); + Hi := Hbound; + + else + OK := False; + return; + end if; + + -- We may be able to refine this value in certain situations. If + -- refinement is possible, then Lor and Hir are set to possibly + -- tighter bounds, and OK1 is set to True. + + case Nkind (N) is + + -- For unary plus, result is limited by range of operand + + when N_Op_Plus => + Determine_Range (Right_Opnd (N), OK1, Lor, Hir); + + -- For unary minus, determine range of operand, and negate it + + when N_Op_Minus => + Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right); + + if OK1 then + Lor := -Hi_Right; + Hir := -Lo_Right; + end if; + + -- For binary addition, get range of each operand and do the + -- addition to get the result range. + + when N_Op_Add => + if OK_Operands then + Lor := Lo_Left + Lo_Right; + Hir := Hi_Left + Hi_Right; + end if; + + -- Division is tricky. The only case we consider is where the + -- right operand is a positive constant, and in this case we + -- simply divide the bounds of the left operand + + when N_Op_Divide => + if OK_Operands then + if Lo_Right = Hi_Right + and then Lo_Right > 0 + then + Lor := Lo_Left / Lo_Right; + Hir := Hi_Left / Lo_Right; + + else + OK1 := False; + end if; + end if; + + -- For binary subtraction, get range of each operand and do + -- the worst case subtraction to get the result range. + + when N_Op_Subtract => + if OK_Operands then + Lor := Lo_Left - Hi_Right; + Hir := Hi_Left - Lo_Right; + end if; + + -- For MOD, if right operand is a positive constant, then + -- result must be in the allowable range of mod results. + + when N_Op_Mod => + if OK_Operands then + if Lo_Right = Hi_Right then + if Lo_Right > 0 then + Lor := Uint_0; + Hir := Lo_Right - 1; + + elsif Lo_Right < 0 then + Lor := Lo_Right + 1; + Hir := Uint_0; + end if; + + else + OK1 := False; + end if; + end if; + + -- For REM, if right operand is a positive constant, then + -- result must be in the allowable range of mod results. + + when N_Op_Rem => + if OK_Operands then + if Lo_Right = Hi_Right then + declare + Dval : constant Uint := (abs Lo_Right) - 1; + + begin + -- The sign of the result depends on the sign of the + -- dividend (but not on the sign of the divisor, hence + -- the abs operation above). + + if Lo_Left < 0 then + Lor := -Dval; + else + Lor := Uint_0; + end if; + + if Hi_Left < 0 then + Hir := Uint_0; + else + Hir := Dval; + end if; + end; + + else + OK1 := False; + end if; + end if; + + -- Attribute reference cases + + when N_Attribute_Reference => + case Attribute_Name (N) is + + -- For Pos/Val attributes, we can refine the range using the + -- possible range of values of the attribute expression + + when Name_Pos | Name_Val => + Determine_Range (First (Expressions (N)), OK1, Lor, Hir); + + -- For Length attribute, use the bounds of the corresponding + -- index type to refine the range. + + when Name_Length => + declare + Atyp : Entity_Id := Etype (Prefix (N)); + Inum : Nat; + Indx : Node_Id; + + LL, LU : Uint; + UL, UU : Uint; + + begin + if Is_Access_Type (Atyp) then + Atyp := Designated_Type (Atyp); + end if; + + -- For string literal, we know exact value + + if Ekind (Atyp) = E_String_Literal_Subtype then + OK := True; + Lo := String_Literal_Length (Atyp); + Hi := String_Literal_Length (Atyp); + return; + end if; + + -- Otherwise check for expression given + + if No (Expressions (N)) then + Inum := 1; + else + Inum := + UI_To_Int (Expr_Value (First (Expressions (N)))); + end if; + + Indx := First_Index (Atyp); + for J in 2 .. Inum loop + Indx := Next_Index (Indx); + end loop; + + Determine_Range + (Type_Low_Bound (Etype (Indx)), OK1, LL, LU); + + if OK1 then + Determine_Range + (Type_High_Bound (Etype (Indx)), OK1, UL, UU); + + if OK1 then + + -- The maximum value for Length is the biggest + -- possible gap between the values of the bounds. + -- But of course, this value cannot be negative. + + Hir := UI_Max (Uint_0, UU - LL); + + -- For constrained arrays, the minimum value for + -- Length is taken from the actual value of the + -- bounds, since the index will be exactly of + -- this subtype. + + if Is_Constrained (Atyp) then + Lor := UI_Max (Uint_0, UL - LU); + + -- For an unconstrained array, the minimum value + -- for length is always zero. + + else + Lor := Uint_0; + end if; + end if; + end if; + end; + + -- No special handling for other attributes + -- Probably more opportunities exist here ??? + + when others => + OK1 := False; + + end case; + + -- For type conversion from one discrete type to another, we + -- can refine the range using the converted value. + + when N_Type_Conversion => + Determine_Range (Expression (N), OK1, Lor, Hir); + + -- Nothing special to do for all other expression kinds + + when others => + OK1 := False; + Lor := No_Uint; + Hir := No_Uint; + end case; + + -- At this stage, if OK1 is true, then we know that the actual + -- result of the computed expression is in the range Lor .. Hir. + -- We can use this to restrict the possible range of results. + + if OK1 then + + -- If the refined value of the low bound is greater than the + -- type high bound, then reset it to the more restrictive + -- value. However, we do NOT do this for the case of a modular + -- type where the possible upper bound on the value is above the + -- base type high bound, because that means the result could wrap. + + if Lor > Lo + and then not (Is_Modular_Integer_Type (Typ) + and then Hir > Hbound) + then + Lo := Lor; + end if; + + -- Similarly, if the refined value of the high bound is less + -- than the value so far, then reset it to the more restrictive + -- value. Again, we do not do this if the refined low bound is + -- negative for a modular type, since this would wrap. + + if Hir < Hi + and then not (Is_Modular_Integer_Type (Typ) + and then Lor < Uint_0) + then + Hi := Hir; + end if; + end if; + + -- Set cache entry for future call and we are all done + + Determine_Range_Cache_N (Cindex) := N; + Determine_Range_Cache_Lo (Cindex) := Lo; + Determine_Range_Cache_Hi (Cindex) := Hi; + return; + + -- If any exception occurs, it means that we have some bug in the compiler + -- possibly triggered by a previous error, or by some unforseen peculiar + -- occurrence. However, this is only an optimization attempt, so there is + -- really no point in crashing the compiler. Instead we just decide, too + -- bad, we can't figure out a range in this case after all. + + exception + when others => + + -- Debug flag K disables this behavior (useful for debugging) + + if Debug_Flag_K then + raise; + else + OK := False; + Lo := No_Uint; + Hi := No_Uint; + return; + end if; + + end Determine_Range; + + ------------------------------------ + -- Discriminant_Checks_Suppressed -- + ------------------------------------ + + function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Discriminant_Checks + or else (Present (E) and then Suppress_Discriminant_Checks (E)); + end Discriminant_Checks_Suppressed; + + -------------------------------- + -- Division_Checks_Suppressed -- + -------------------------------- + + function Division_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Division_Checks + or else (Present (E) and then Suppress_Division_Checks (E)); + end Division_Checks_Suppressed; + + ----------------------------------- + -- Elaboration_Checks_Suppressed -- + ----------------------------------- + + function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Elaboration_Checks + or else (Present (E) and then Suppress_Elaboration_Checks (E)); + end Elaboration_Checks_Suppressed; + + ------------------------ + -- Enable_Range_Check -- + ------------------------ + + procedure Enable_Range_Check (N : Node_Id) is + begin + if Nkind (N) = N_Unchecked_Type_Conversion + and then Kill_Range_Check (N) + then + return; + else + Set_Do_Range_Check (N, True); + end if; + end Enable_Range_Check; + + ------------------ + -- Ensure_Valid -- + ------------------ + + procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is + Typ : constant Entity_Id := Etype (Expr); + + begin + -- Ignore call if we are not doing any validity checking + + if not Validity_Checks_On then + return; + + -- No check required if expression is from the expander, we assume + -- the expander will generate whatever checks are needed. Note that + -- this is not just an optimization, it avoids infinite recursions! + + -- Unchecked conversions must be checked, unless they are initialized + -- scalar values, as in a component assignment in an init_proc. + + elsif not Comes_From_Source (Expr) + and then (Nkind (Expr) /= N_Unchecked_Type_Conversion + or else Kill_Range_Check (Expr)) + then + return; + + -- No check required if expression is known to have valid value + + elsif Expr_Known_Valid (Expr) then + return; + + -- No check required if checks off + + elsif Range_Checks_Suppressed (Typ) then + return; + + -- Ignore case of enumeration with holes where the flag is set not + -- to worry about holes, since no special validity check is needed + + elsif Is_Enumeration_Type (Typ) + and then Has_Non_Standard_Rep (Typ) + and then Holes_OK + then + return; + + -- No check required on the left-hand side of an assignment. + + elsif Nkind (Parent (Expr)) = N_Assignment_Statement + and then Expr = Name (Parent (Expr)) + then + return; + + -- An annoying special case. If this is an out parameter of a scalar + -- type, then the value is not going to be accessed, therefore it is + -- inappropriate to do any validity check at the call site. + + else + -- Only need to worry about scalar types + + if Is_Scalar_Type (Typ) then + declare + P : Node_Id; + N : Node_Id; + E : Entity_Id; + F : Entity_Id; + A : Node_Id; + L : List_Id; + + begin + -- Find actual argument (which may be a parameter association) + -- and the parent of the actual argument (the call statement) + + N := Expr; + P := Parent (Expr); + + if Nkind (P) = N_Parameter_Association then + N := P; + P := Parent (N); + end if; + + -- Only need to worry if we are argument of a procedure + -- call since functions don't have out parameters. + + if Nkind (P) = N_Procedure_Call_Statement then + L := Parameter_Associations (P); + E := Entity (Name (P)); + + -- Only need to worry if there are indeed actuals, and + -- if this could be a procedure call, otherwise we cannot + -- get a match (either we are not an argument, or the + -- mode of the formal is not OUT). This test also filters + -- out the generic case. + + if Is_Non_Empty_List (L) + and then Is_Subprogram (E) + then + -- This is the loop through parameters, looking to + -- see if there is an OUT parameter for which we are + -- the argument. + + F := First_Formal (E); + A := First (L); + + while Present (F) loop + if Ekind (F) = E_Out_Parameter and then A = N then + return; + end if; + + Next_Formal (F); + Next (A); + end loop; + end if; + end if; + end; + end if; + end if; + + -- If we fall through, a validity check is required. Note that it would + -- not be good to set Do_Range_Check, even in contexts where this is + -- permissible, since this flag causes checking against the target type, + -- not the source type in contexts such as assignments + + Insert_Valid_Check (Expr); + end Ensure_Valid; + + ---------------------- + -- Expr_Known_Valid -- + ---------------------- + + function Expr_Known_Valid (Expr : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Expr); + + begin + -- Non-scalar types are always consdered valid, since they never + -- give rise to the issues of erroneous or bounded error behavior + -- that are the concern. In formal reference manual terms the + -- notion of validity only applies to scalar types. + + if not Is_Scalar_Type (Typ) then + return True; + + -- If no validity checking, then everything is considered valid + + elsif not Validity_Checks_On then + return True; + + -- Floating-point types are considered valid unless floating-point + -- validity checks have been specifically turned on. + + elsif Is_Floating_Point_Type (Typ) + and then not Validity_Check_Floating_Point + then + return True; + + -- If the expression is the value of an object that is known to + -- be valid, then clearly the expression value itself is valid. + + elsif Is_Entity_Name (Expr) + and then Is_Known_Valid (Entity (Expr)) + then + return True; + + -- If the type is one for which all values are known valid, then + -- we are sure that the value is valid except in the slightly odd + -- case where the expression is a reference to a variable whose size + -- has been explicitly set to a value greater than the object size. + + elsif Is_Known_Valid (Typ) then + if Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Variable + and then Esize (Entity (Expr)) > Esize (Typ) + then + return False; + else + return True; + end if; + + -- Integer and character literals always have valid values, where + -- appropriate these will be range checked in any case. + + elsif Nkind (Expr) = N_Integer_Literal + or else + Nkind (Expr) = N_Character_Literal + then + return True; + + -- If we have a type conversion or a qualification of a known valid + -- value, then the result will always be valid. + + elsif Nkind (Expr) = N_Type_Conversion + or else + Nkind (Expr) = N_Qualified_Expression + then + return Expr_Known_Valid (Expression (Expr)); + + -- The result of any function call or operator is always considered + -- valid, since we assume the necessary checks are done by the call. + + elsif Nkind (Expr) in N_Binary_Op + or else + Nkind (Expr) in N_Unary_Op + or else + Nkind (Expr) = N_Function_Call + then + return True; + + -- For all other cases, we do not know the expression is valid + + else + return False; + end if; + end Expr_Known_Valid; + + --------------------- + -- Get_Discriminal -- + --------------------- + + function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (E); + D : Entity_Id; + Sc : Entity_Id; + + begin + -- The entity E is the type of a private component of the protected + -- type, or the type of a renaming of that component within a protected + -- operation of that type. + + Sc := Scope (E); + + if Ekind (Sc) /= E_Protected_Type then + Sc := Scope (Sc); + + if Ekind (Sc) /= E_Protected_Type then + return Bound; + end if; + end if; + + D := First_Discriminant (Sc); + + while Present (D) + and then Chars (D) /= Chars (Bound) + loop + Next_Discriminant (D); + end loop; + + return New_Occurrence_Of (Discriminal (D), Loc); + end Get_Discriminal; + + ------------------ + -- Guard_Access -- + ------------------ + + function Guard_Access + (Cond : Node_Id; + Loc : Source_Ptr; + Ck_Node : Node_Id) + return Node_Id + is + begin + if Nkind (Cond) = N_Or_Else then + Set_Paren_Count (Cond, 1); + end if; + + if Nkind (Ck_Node) = N_Allocator then + return Cond; + else + return + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Ck_Node), + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Cond); + end if; + end Guard_Access; + + ----------------------------- + -- Index_Checks_Suppressed -- + ----------------------------- + + function Index_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Index_Checks + or else (Present (E) and then Suppress_Index_Checks (E)); + end Index_Checks_Suppressed; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + for J in Determine_Range_Cache_N'Range loop + Determine_Range_Cache_N (J) := Empty; + end loop; + end Initialize; + + ------------------------- + -- Insert_Range_Checks -- + ------------------------- + + procedure Insert_Range_Checks + (Checks : Check_Result; + Node : Node_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr := No_Location; + Flag_Node : Node_Id := Empty; + Do_Before : Boolean := False) + is + Internal_Flag_Node : Node_Id := Flag_Node; + Internal_Static_Sloc : Source_Ptr := Static_Sloc; + + Check_Node : Node_Id; + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Suppress_Typ)) + or else + (not Range_Checks_Suppressed (Suppress_Typ)); + + begin + -- For now we just return if Checks_On is false, however this should + -- be enhanced to check for an always True value in the condition + -- and to generate a compilation warning??? + + if not Expander_Active or else not Checks_On then + return; + end if; + + if Static_Sloc = No_Location then + Internal_Static_Sloc := Sloc (Node); + end if; + + if No (Flag_Node) then + Internal_Flag_Node := Node; + end if; + + for J in 1 .. 2 loop + exit when No (Checks (J)); + + if Nkind (Checks (J)) = N_Raise_Constraint_Error + and then Present (Condition (Checks (J))) + then + if not Has_Dynamic_Range_Check (Internal_Flag_Node) then + Check_Node := Checks (J); + Mark_Rewrite_Insertion (Check_Node); + + if Do_Before then + Insert_Before_And_Analyze (Node, Check_Node); + else + Insert_After_And_Analyze (Node, Check_Node); + end if; + + Set_Has_Dynamic_Range_Check (Internal_Flag_Node); + end if; + + else + Check_Node := + Make_Raise_Constraint_Error (Internal_Static_Sloc); + Mark_Rewrite_Insertion (Check_Node); + + if Do_Before then + Insert_Before_And_Analyze (Node, Check_Node); + else + Insert_After_And_Analyze (Node, Check_Node); + end if; + end if; + end loop; + end Insert_Range_Checks; + + ------------------------ + -- Insert_Valid_Check -- + ------------------------ + + procedure Insert_Valid_Check (Expr : Node_Id) is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + -- Do not insert if checks off, or if not checking validity + + if Range_Checks_Suppressed (Etype (Expr)) + or else (not Validity_Checks_On) + then + null; + + -- Otherwise insert the validity check. Note that we do this with + -- validity checks turned off, to avoid recursion, we do not want + -- validity checks on the validity checking code itself! + + else + Validity_Checks_On := False; + Insert_Action + (Expr, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Expr, Name_Req => True), + Attribute_Name => Name_Valid))), + Suppress => All_Checks); + Validity_Checks_On := True; + end if; + end Insert_Valid_Check; + + -------------------------- + -- Install_Static_Check -- + -------------------------- + + procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is + Stat : constant Boolean := Is_Static_Expression (R_Cno); + Typ : constant Entity_Id := Etype (R_Cno); + + begin + Rewrite (R_Cno, Make_Raise_Constraint_Error (Loc)); + Set_Analyzed (R_Cno); + Set_Etype (R_Cno, Typ); + Set_Raises_Constraint_Error (R_Cno); + Set_Is_Static_Expression (R_Cno, Stat); + end Install_Static_Check; + + ------------------------------ + -- Length_Checks_Suppressed -- + ------------------------------ + + function Length_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Length_Checks + or else (Present (E) and then Suppress_Length_Checks (E)); + end Length_Checks_Suppressed; + + -------------------------------- + -- Overflow_Checks_Suppressed -- + -------------------------------- + + function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Overflow_Checks + or else (Present (E) and then Suppress_Overflow_Checks (E)); + end Overflow_Checks_Suppressed; + + ----------------- + -- Range_Check -- + ----------------- + + function Range_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Warn_Node : Node_Id := Empty) + return Check_Result + is + begin + return Selected_Range_Checks + (Ck_Node, Target_Typ, Source_Typ, Warn_Node); + end Range_Check; + + ----------------------------- + -- Range_Checks_Suppressed -- + ----------------------------- + + function Range_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + -- Note: for now we always suppress range checks on Vax float types, + -- since Gigi does not know how to generate these checks. + + return Scope_Suppress.Range_Checks + or else (Present (E) and then Suppress_Range_Checks (E)) + or else Vax_Float (E); + end Range_Checks_Suppressed; + + ---------------------------- + -- Selected_Length_Checks -- + ---------------------------- + + function Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) + return Check_Result + is + Loc : constant Source_Ptr := Sloc (Ck_Node); + S_Typ : Entity_Id; + T_Typ : Entity_Id; + Expr_Actual : Node_Id; + Exptyp : Entity_Id; + Cond : Node_Id := Empty; + Do_Access : Boolean := False; + Wnode : Node_Id := Warn_Node; + Ret_Result : Check_Result := (Empty, Empty); + Num_Checks : Natural := 0; + + procedure Add_Check (N : Node_Id); + -- Adds the action given to Ret_Result if N is non-Empty + + function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id; + function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id; + + function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean; + -- True for equal literals and for nodes that denote the same constant + -- entity, even if its value is not a static constant. This removes + -- some obviously superfluous checks. + + function Length_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id; + -- Returns expression to compute: + -- Typ'Length /= Exptyp'Length + + function Length_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id; + -- Returns expression to compute: + -- Typ'Length /= Expr'Length + + --------------- + -- Add_Check -- + --------------- + + procedure Add_Check (N : Node_Id) is + begin + if Present (N) then + + -- For now, ignore attempt to place more than 2 checks ??? + + if Num_Checks = 2 then + return; + end if; + + pragma Assert (Num_Checks <= 1); + Num_Checks := Num_Checks + 1; + Ret_Result (Num_Checks) := N; + end if; + end Add_Check; + + ------------------ + -- Get_E_Length -- + ------------------ + + function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is + N : Node_Id; + E1 : Entity_Id := E; + Pt : Entity_Id := Scope (Scope (E)); + + begin + if Ekind (Scope (E)) = E_Record_Type + and then Has_Discriminants (Scope (E)) + then + N := Build_Discriminal_Subtype_Of_Component (E); + + if Present (N) then + Insert_Action (Ck_Node, N); + E1 := Defining_Identifier (N); + end if; + end if; + + if Ekind (E1) = E_String_Literal_Subtype then + return + Make_Integer_Literal (Loc, + Intval => String_Literal_Length (E1)); + + elsif Ekind (Pt) = E_Protected_Type + and then Has_Discriminants (Pt) + and then Has_Completion (Pt) + and then not Inside_Init_Proc + then + + -- If the type whose length is needed is a private component + -- constrained by a discriminant, we must expand the 'Length + -- attribute into an explicit computation, using the discriminal + -- of the current protected operation. This is because the actual + -- type of the prival is constructed after the protected opera- + -- tion has been fully expanded. + + declare + Indx_Type : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Do_Expand : Boolean := False; + + begin + Indx_Type := First_Index (E); + + for J in 1 .. Indx - 1 loop + Next_Index (Indx_Type); + end loop; + + Get_Index_Bounds (Indx_Type, Lo, Hi); + + if Nkind (Lo) = N_Identifier + and then Ekind (Entity (Lo)) = E_In_Parameter + then + Lo := Get_Discriminal (E, Lo); + Do_Expand := True; + end if; + + if Nkind (Hi) = N_Identifier + and then Ekind (Entity (Hi)) = E_In_Parameter + then + Hi := Get_Discriminal (E, Hi); + Do_Expand := True; + end if; + + if Do_Expand then + if not Is_Entity_Name (Lo) then + Lo := Duplicate_Subexpr (Lo); + end if; + + if not Is_Entity_Name (Hi) then + Lo := Duplicate_Subexpr (Hi); + end if; + + N := + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Hi, + Right_Opnd => Lo), + + Right_Opnd => Make_Integer_Literal (Loc, 1)); + return N; + + else + N := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (E1, Loc)); + + if Indx > 1 then + Set_Expressions (N, New_List ( + Make_Integer_Literal (Loc, Indx))); + end if; + + return N; + end if; + end; + + else + N := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (E1, Loc)); + + if Indx > 1 then + Set_Expressions (N, New_List ( + Make_Integer_Literal (Loc, Indx))); + end if; + + return N; + + end if; + end Get_E_Length; + + ------------------ + -- Get_N_Length -- + ------------------ + + function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + Duplicate_Subexpr (N, Name_Req => True), + Expressions => New_List ( + Make_Integer_Literal (Loc, Indx))); + + end Get_N_Length; + + ------------------- + -- Length_E_Cond -- + ------------------- + + function Length_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id + is + begin + return + Make_Op_Ne (Loc, + Left_Opnd => Get_E_Length (Typ, Indx), + Right_Opnd => Get_E_Length (Exptyp, Indx)); + + end Length_E_Cond; + + ------------------- + -- Length_N_Cond -- + ------------------- + + function Length_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id + is + begin + return + Make_Op_Ne (Loc, + Left_Opnd => Get_E_Length (Typ, Indx), + Right_Opnd => Get_N_Length (Expr, Indx)); + + end Length_N_Cond; + + function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is + begin + return + (Nkind (L) = N_Integer_Literal + and then Nkind (R) = N_Integer_Literal + and then Intval (L) = Intval (R)) + + or else + (Is_Entity_Name (L) + and then Ekind (Entity (L)) = E_Constant + and then ((Is_Entity_Name (R) + and then Entity (L) = Entity (R)) + or else + (Nkind (R) = N_Type_Conversion + and then Is_Entity_Name (Expression (R)) + and then Entity (L) = Entity (Expression (R))))) + + or else + (Is_Entity_Name (R) + and then Ekind (Entity (R)) = E_Constant + and then Nkind (L) = N_Type_Conversion + and then Is_Entity_Name (Expression (L)) + and then Entity (R) = Entity (Expression (L))); + end Same_Bounds; + + -- Start of processing for Selected_Length_Checks + + begin + if not Expander_Active then + return Ret_Result; + end if; + + if Target_Typ = Any_Type + or else Target_Typ = Any_Composite + or else Raises_Constraint_Error (Ck_Node) + then + return Ret_Result; + end if; + + if No (Wnode) then + Wnode := Ck_Node; + end if; + + T_Typ := Target_Typ; + + if No (Source_Typ) then + S_Typ := Etype (Ck_Node); + else + S_Typ := Source_Typ; + end if; + + if S_Typ = Any_Type or else S_Typ = Any_Composite then + return Ret_Result; + end if; + + if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then + S_Typ := Designated_Type (S_Typ); + T_Typ := Designated_Type (T_Typ); + Do_Access := True; + + -- A simple optimization + + if Nkind (Ck_Node) = N_Null then + return Ret_Result; + end if; + end if; + + if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then + if Is_Constrained (T_Typ) then + + -- The checking code to be generated will freeze the + -- corresponding array type. However, we must freeze the + -- type now, so that the freeze node does not appear within + -- the generated condional expression, but ahead of it. + + Freeze_Before (Ck_Node, T_Typ); + + Expr_Actual := Get_Referenced_Object (Ck_Node); + Exptyp := Get_Actual_Subtype (Expr_Actual); + + if Is_Access_Type (Exptyp) then + Exptyp := Designated_Type (Exptyp); + end if; + + -- String_Literal case. This needs to be handled specially be- + -- cause no index types are available for string literals. The + -- condition is simply: + + -- T_Typ'Length = string-literal-length + + if Nkind (Expr_Actual) = N_String_Literal then + Cond := + Make_Op_Ne (Loc, + Left_Opnd => Get_E_Length (T_Typ, 1), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => + String_Literal_Length (Etype (Expr_Actual)))); + + -- General array case. Here we have a usable actual subtype for + -- the expression, and the condition is built from the two types + -- (Do_Length): + + -- T_Typ'Length /= Exptyp'Length or else + -- T_Typ'Length (2) /= Exptyp'Length (2) or else + -- T_Typ'Length (3) /= Exptyp'Length (3) or else + -- ... + + elsif Is_Constrained (Exptyp) then + declare + L_Index : Node_Id; + R_Index : Node_Id; + Ndims : Nat := Number_Dimensions (T_Typ); + + L_Low : Node_Id; + L_High : Node_Id; + R_Low : Node_Id; + R_High : Node_Id; + + L_Length : Uint; + R_Length : Uint; + + begin + L_Index := First_Index (T_Typ); + R_Index := First_Index (Exptyp); + + for Indx in 1 .. Ndims loop + if not (Nkind (L_Index) = N_Raise_Constraint_Error + or else Nkind (R_Index) = N_Raise_Constraint_Error) + then + Get_Index_Bounds (L_Index, L_Low, L_High); + Get_Index_Bounds (R_Index, R_Low, R_High); + + -- Deal with compile time length check. Note that we + -- skip this in the access case, because the access + -- value may be null, so we cannot know statically. + + if not Do_Access + and then Compile_Time_Known_Value (L_Low) + and then Compile_Time_Known_Value (L_High) + and then Compile_Time_Known_Value (R_Low) + and then Compile_Time_Known_Value (R_High) + then + if Expr_Value (L_High) >= Expr_Value (L_Low) then + L_Length := Expr_Value (L_High) - + Expr_Value (L_Low) + 1; + else + L_Length := UI_From_Int (0); + end if; + + if Expr_Value (R_High) >= Expr_Value (R_Low) then + R_Length := Expr_Value (R_High) - + Expr_Value (R_Low) + 1; + else + R_Length := UI_From_Int (0); + end if; + + if L_Length > R_Length then + Add_Check + (Compile_Time_Constraint_Error + (Wnode, "too few elements for}?", T_Typ)); + + elsif L_Length < R_Length then + Add_Check + (Compile_Time_Constraint_Error + (Wnode, "too many elements for}?", T_Typ)); + end if; + + -- The comparison for an individual index subtype + -- is omitted if the corresponding index subtypes + -- statically match, since the result is known to + -- be true. Note that this test is worth while even + -- though we do static evaluation, because non-static + -- subtypes can statically match. + + elsif not + Subtypes_Statically_Match + (Etype (L_Index), Etype (R_Index)) + + and then not + (Same_Bounds (L_Low, R_Low) + and then Same_Bounds (L_High, R_High)) + then + Evolve_Or_Else + (Cond, Length_E_Cond (Exptyp, T_Typ, Indx)); + end if; + + Next (L_Index); + Next (R_Index); + end if; + end loop; + end; + + -- Handle cases where we do not get a usable actual subtype that + -- is constrained. This happens for example in the function call + -- and explicit dereference cases. In these cases, we have to get + -- the length or range from the expression itself, making sure we + -- do not evaluate it more than once. + + -- Here Ck_Node is the original expression, or more properly the + -- result of applying Duplicate_Expr to the original tree, + -- forcing the result to be a name. + + else + declare + Ndims : Nat := Number_Dimensions (T_Typ); + + begin + -- Build the condition for the explicit dereference case + + for Indx in 1 .. Ndims loop + Evolve_Or_Else + (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx)); + end loop; + end; + end if; + end if; + end if; + + -- Construct the test and insert into the tree + + if Present (Cond) then + if Do_Access then + Cond := Guard_Access (Cond, Loc, Ck_Node); + end if; + + Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond)); + end if; + + return Ret_Result; + + end Selected_Length_Checks; + + --------------------------- + -- Selected_Range_Checks -- + --------------------------- + + function Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) + return Check_Result + is + Loc : constant Source_Ptr := Sloc (Ck_Node); + S_Typ : Entity_Id; + T_Typ : Entity_Id; + Expr_Actual : Node_Id; + Exptyp : Entity_Id; + Cond : Node_Id := Empty; + Do_Access : Boolean := False; + Wnode : Node_Id := Warn_Node; + Ret_Result : Check_Result := (Empty, Empty); + Num_Checks : Integer := 0; + + procedure Add_Check (N : Node_Id); + -- Adds the action given to Ret_Result if N is non-Empty + + function Discrete_Range_Cond + (Expr : Node_Id; + Typ : Entity_Id) + return Node_Id; + -- Returns expression to compute: + -- Low_Bound (Expr) < Typ'First + -- or else + -- High_Bound (Expr) > Typ'Last + + function Discrete_Expr_Cond + (Expr : Node_Id; + Typ : Entity_Id) + return Node_Id; + -- Returns expression to compute: + -- Expr < Typ'First + -- or else + -- Expr > Typ'Last + + function Get_E_First_Or_Last + (E : Entity_Id; + Indx : Nat; + Nam : Name_Id) + return Node_Id; + -- Returns expression to compute: + -- E'First or E'Last + + function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; + function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; + -- Returns expression to compute: + -- N'First or N'Last using Duplicate_Subexpr + + function Range_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id; + -- Returns expression to compute: + -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last + + function Range_Equal_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id; + -- Returns expression to compute: + -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last + + function Range_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id; + -- Return expression to compute: + -- Expr'First < Typ'First or else Expr'Last > Typ'Last + + --------------- + -- Add_Check -- + --------------- + + procedure Add_Check (N : Node_Id) is + begin + if Present (N) then + + -- For now, ignore attempt to place more than 2 checks ??? + + if Num_Checks = 2 then + return; + end if; + + pragma Assert (Num_Checks <= 1); + Num_Checks := Num_Checks + 1; + Ret_Result (Num_Checks) := N; + end if; + end Add_Check; + + ------------------------- + -- Discrete_Expr_Cond -- + ------------------------- + + function Discrete_Expr_Cond + (Expr : Node_Id; + Typ : Entity_Id) + return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => + Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)), + Right_Opnd => + Convert_To (Base_Type (Typ), + Get_E_First_Or_Last (Typ, 0, Name_First))), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => + Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)), + Right_Opnd => + Convert_To + (Base_Type (Typ), + Get_E_First_Or_Last (Typ, 0, Name_Last)))); + end Discrete_Expr_Cond; + + ------------------------- + -- Discrete_Range_Cond -- + ------------------------- + + function Discrete_Range_Cond + (Expr : Node_Id; + Typ : Entity_Id) + return Node_Id + is + LB : Node_Id := Low_Bound (Expr); + HB : Node_Id := High_Bound (Expr); + + Left_Opnd : Node_Id; + Right_Opnd : Node_Id; + + begin + if Nkind (LB) = N_Identifier + and then Ekind (Entity (LB)) = E_Discriminant then + LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); + end if; + + if Nkind (HB) = N_Identifier + and then Ekind (Entity (HB)) = E_Discriminant then + HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); + end if; + + Left_Opnd := + Make_Op_Lt (Loc, + Left_Opnd => + Convert_To + (Base_Type (Typ), Duplicate_Subexpr (LB)), + + Right_Opnd => + Convert_To + (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First))); + + if Base_Type (Typ) = Typ then + return Left_Opnd; + + elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ))) + and then + Compile_Time_Known_Value (High_Bound (Scalar_Range + (Base_Type (Typ)))) + then + if Is_Floating_Point_Type (Typ) then + if Expr_Value_R (High_Bound (Scalar_Range (Typ))) = + Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ)))) + then + return Left_Opnd; + end if; + + else + if Expr_Value (High_Bound (Scalar_Range (Typ))) = + Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ)))) + then + return Left_Opnd; + end if; + end if; + end if; + + Right_Opnd := + Make_Op_Gt (Loc, + Left_Opnd => + Convert_To + (Base_Type (Typ), Duplicate_Subexpr (HB)), + + Right_Opnd => + Convert_To + (Base_Type (Typ), + Get_E_First_Or_Last (Typ, 0, Name_Last))); + + return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); + end Discrete_Range_Cond; + + ------------------------- + -- Get_E_First_Or_Last -- + ------------------------- + + function Get_E_First_Or_Last + (E : Entity_Id; + Indx : Nat; + Nam : Name_Id) + return Node_Id + is + N : Node_Id; + LB : Node_Id; + HB : Node_Id; + Bound : Node_Id; + + begin + if Is_Array_Type (E) then + N := First_Index (E); + + for J in 2 .. Indx loop + Next_Index (N); + end loop; + + else + N := Scalar_Range (E); + end if; + + if Nkind (N) = N_Subtype_Indication then + LB := Low_Bound (Range_Expression (Constraint (N))); + HB := High_Bound (Range_Expression (Constraint (N))); + + elsif Is_Entity_Name (N) then + LB := Type_Low_Bound (Etype (N)); + HB := Type_High_Bound (Etype (N)); + + else + LB := Low_Bound (N); + HB := High_Bound (N); + end if; + + if Nam = Name_First then + Bound := LB; + else + Bound := HB; + end if; + + if Nkind (Bound) = N_Identifier + and then Ekind (Entity (Bound)) = E_Discriminant + then + return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); + + elsif Nkind (Bound) = N_Identifier + and then Ekind (Entity (Bound)) = E_In_Parameter + and then not Inside_Init_Proc + then + return Get_Discriminal (E, Bound); + + elsif Nkind (Bound) = N_Integer_Literal then + return Make_Integer_Literal (Loc, Intval (Bound)); + + else + return Duplicate_Subexpr (Bound); + end if; + end Get_E_First_Or_Last; + + ----------------- + -- Get_N_First -- + ----------------- + + function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => + Duplicate_Subexpr (N, Name_Req => True), + Expressions => New_List ( + Make_Integer_Literal (Loc, Indx))); + + end Get_N_First; + + ---------------- + -- Get_N_Last -- + ---------------- + + function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => + Duplicate_Subexpr (N, Name_Req => True), + Expressions => New_List ( + Make_Integer_Literal (Loc, Indx))); + + end Get_N_Last; + + ------------------ + -- Range_E_Cond -- + ------------------ + + function Range_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), + Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), + Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + + end Range_E_Cond; + + ------------------------ + -- Range_Equal_E_Cond -- + ------------------------ + + function Range_Equal_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), + Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + Right_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), + Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + end Range_Equal_E_Cond; + + ------------------ + -- Range_N_Cond -- + ------------------ + + function Range_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Get_N_First (Expr, Indx), + Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Get_N_Last (Expr, Indx), + Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + end Range_N_Cond; + + -- Start of processing for Selected_Range_Checks + + begin + if not Expander_Active then + return Ret_Result; + end if; + + if Target_Typ = Any_Type + or else Target_Typ = Any_Composite + or else Raises_Constraint_Error (Ck_Node) + then + return Ret_Result; + end if; + + if No (Wnode) then + Wnode := Ck_Node; + end if; + + T_Typ := Target_Typ; + + if No (Source_Typ) then + S_Typ := Etype (Ck_Node); + else + S_Typ := Source_Typ; + end if; + + if S_Typ = Any_Type or else S_Typ = Any_Composite then + return Ret_Result; + end if; + + -- The order of evaluating T_Typ before S_Typ seems to be critical + -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed + -- in, and since Node can be an N_Range node, it might be invalid. + -- Should there be an assert check somewhere for taking the Etype of + -- an N_Range node ??? + + if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then + S_Typ := Designated_Type (S_Typ); + T_Typ := Designated_Type (T_Typ); + Do_Access := True; + + -- A simple optimization + + if Nkind (Ck_Node) = N_Null then + return Ret_Result; + end if; + end if; + + -- For an N_Range Node, check for a null range and then if not + -- null generate a range check action. + + if Nkind (Ck_Node) = N_Range then + + -- There's no point in checking a range against itself + + if Ck_Node = Scalar_Range (T_Typ) then + return Ret_Result; + end if; + + declare + T_LB : constant Node_Id := Type_Low_Bound (T_Typ); + T_HB : constant Node_Id := Type_High_Bound (T_Typ); + LB : constant Node_Id := Low_Bound (Ck_Node); + HB : constant Node_Id := High_Bound (Ck_Node); + Null_Range : Boolean; + + Out_Of_Range_L : Boolean; + Out_Of_Range_H : Boolean; + + begin + -- Check for case where everything is static and we can + -- do the check at compile time. This is skipped if we + -- have an access type, since the access value may be null. + + -- ??? This code can be improved since you only need to know + -- that the two respective bounds (LB & T_LB or HB & T_HB) + -- are known at compile time to emit pertinent messages. + + if Compile_Time_Known_Value (LB) + and then Compile_Time_Known_Value (HB) + and then Compile_Time_Known_Value (T_LB) + and then Compile_Time_Known_Value (T_HB) + and then not Do_Access + then + -- Floating-point case + + if Is_Floating_Point_Type (S_Typ) then + Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); + Out_Of_Range_L := + (Expr_Value_R (LB) < Expr_Value_R (T_LB)) + or else + (Expr_Value_R (LB) > Expr_Value_R (T_HB)); + + Out_Of_Range_H := + (Expr_Value_R (HB) > Expr_Value_R (T_HB)) + or else + (Expr_Value_R (HB) < Expr_Value_R (T_LB)); + + -- Fixed or discrete type case + + else + Null_Range := Expr_Value (HB) < Expr_Value (LB); + Out_Of_Range_L := + (Expr_Value (LB) < Expr_Value (T_LB)) + or else + (Expr_Value (LB) > Expr_Value (T_HB)); + + Out_Of_Range_H := + (Expr_Value (HB) > Expr_Value (T_HB)) + or else + (Expr_Value (HB) < Expr_Value (T_LB)); + end if; + + if not Null_Range then + if Out_Of_Range_L then + if No (Warn_Node) then + Add_Check + (Compile_Time_Constraint_Error + (Low_Bound (Ck_Node), + "static value out of range of}?", T_Typ)); + + else + Add_Check + (Compile_Time_Constraint_Error + (Wnode, + "static range out of bounds of}?", T_Typ)); + end if; + end if; + + if Out_Of_Range_H then + if No (Warn_Node) then + Add_Check + (Compile_Time_Constraint_Error + (High_Bound (Ck_Node), + "static value out of range of}?", T_Typ)); + + else + Add_Check + (Compile_Time_Constraint_Error + (Wnode, + "static range out of bounds of}?", T_Typ)); + end if; + end if; + + end if; + + else + declare + LB : Node_Id := Low_Bound (Ck_Node); + HB : Node_Id := High_Bound (Ck_Node); + + begin + + -- If either bound is a discriminant and we are within + -- the record declaration, it is a use of the discriminant + -- in a constraint of a component, and nothing can be + -- checked here. The check will be emitted within the + -- init_proc. Before then, the discriminal has no real + -- meaning. + + if Nkind (LB) = N_Identifier + and then Ekind (Entity (LB)) = E_Discriminant + then + if Current_Scope = Scope (Entity (LB)) then + return Ret_Result; + else + LB := + New_Occurrence_Of (Discriminal (Entity (LB)), Loc); + end if; + end if; + + if Nkind (HB) = N_Identifier + and then Ekind (Entity (HB)) = E_Discriminant + then + if Current_Scope = Scope (Entity (HB)) then + return Ret_Result; + else + HB := + New_Occurrence_Of (Discriminal (Entity (HB)), Loc); + end if; + end if; + + Cond := Discrete_Range_Cond (Ck_Node, T_Typ); + Set_Paren_Count (Cond, 1); + + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ge (Loc, + Left_Opnd => Duplicate_Subexpr (HB), + Right_Opnd => Duplicate_Subexpr (LB)), + Right_Opnd => Cond); + end; + + end if; + end; + + elsif Is_Scalar_Type (S_Typ) then + + -- This somewhat duplicates what Apply_Scalar_Range_Check does, + -- except the above simply sets a flag in the node and lets + -- gigi generate the check base on the Etype of the expression. + -- Sometimes, however we want to do a dynamic check against an + -- arbitrary target type, so we do that here. + + if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then + Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + + -- For literals, we can tell if the constraint error will be + -- raised at compile time, so we never need a dynamic check, but + -- if the exception will be raised, then post the usual warning, + -- and replace the literal with a raise constraint error + -- expression. As usual, skip this for access types + + elsif Compile_Time_Known_Value (Ck_Node) + and then not Do_Access + then + declare + LB : constant Node_Id := Type_Low_Bound (T_Typ); + UB : constant Node_Id := Type_High_Bound (T_Typ); + + Out_Of_Range : Boolean; + Static_Bounds : constant Boolean := + Compile_Time_Known_Value (LB) + and Compile_Time_Known_Value (UB); + + begin + -- Following range tests should use Sem_Eval routine ??? + + if Static_Bounds then + if Is_Floating_Point_Type (S_Typ) then + Out_Of_Range := + (Expr_Value_R (Ck_Node) < Expr_Value_R (LB)) + or else + (Expr_Value_R (Ck_Node) > Expr_Value_R (UB)); + + else -- fixed or discrete type + Out_Of_Range := + Expr_Value (Ck_Node) < Expr_Value (LB) + or else + Expr_Value (Ck_Node) > Expr_Value (UB); + end if; + + -- Bounds of the type are static and the literal is + -- out of range so make a warning message. + + if Out_Of_Range then + if No (Warn_Node) then + Add_Check + (Compile_Time_Constraint_Error + (Ck_Node, + "static value out of range of}?", T_Typ)); + + else + Add_Check + (Compile_Time_Constraint_Error + (Wnode, + "static value out of range of}?", T_Typ)); + end if; + end if; + + else + Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + end if; + end; + + -- Here for the case of a non-static expression, we need a runtime + -- check unless the source type range is guaranteed to be in the + -- range of the target type. + + else + if not In_Subrange_Of (S_Typ, T_Typ) then + Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + end if; + end if; + end if; + + if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then + if Is_Constrained (T_Typ) then + + Expr_Actual := Get_Referenced_Object (Ck_Node); + Exptyp := Get_Actual_Subtype (Expr_Actual); + + if Is_Access_Type (Exptyp) then + Exptyp := Designated_Type (Exptyp); + end if; + + -- String_Literal case. This needs to be handled specially be- + -- cause no index types are available for string literals. The + -- condition is simply: + + -- T_Typ'Length = string-literal-length + + if Nkind (Expr_Actual) = N_String_Literal then + null; + + -- General array case. Here we have a usable actual subtype for + -- the expression, and the condition is built from the two types + + -- T_Typ'First < Exptyp'First or else + -- T_Typ'Last > Exptyp'Last or else + -- T_Typ'First(1) < Exptyp'First(1) or else + -- T_Typ'Last(1) > Exptyp'Last(1) or else + -- ... + + elsif Is_Constrained (Exptyp) then + declare + L_Index : Node_Id; + R_Index : Node_Id; + Ndims : Nat := Number_Dimensions (T_Typ); + + L_Low : Node_Id; + L_High : Node_Id; + R_Low : Node_Id; + R_High : Node_Id; + + begin + L_Index := First_Index (T_Typ); + R_Index := First_Index (Exptyp); + + for Indx in 1 .. Ndims loop + if not (Nkind (L_Index) = N_Raise_Constraint_Error + or else Nkind (R_Index) = N_Raise_Constraint_Error) + then + Get_Index_Bounds (L_Index, L_Low, L_High); + Get_Index_Bounds (R_Index, R_Low, R_High); + + -- Deal with compile time length check. Note that we + -- skip this in the access case, because the access + -- value may be null, so we cannot know statically. + + if not + Subtypes_Statically_Match + (Etype (L_Index), Etype (R_Index)) + then + -- If the target type is constrained then we + -- have to check for exact equality of bounds + -- (required for qualified expressions). + + if Is_Constrained (T_Typ) then + Evolve_Or_Else + (Cond, + Range_Equal_E_Cond (Exptyp, T_Typ, Indx)); + + else + Evolve_Or_Else + (Cond, Range_E_Cond (Exptyp, T_Typ, Indx)); + end if; + end if; + + Next (L_Index); + Next (R_Index); + + end if; + end loop; + end; + + -- Handle cases where we do not get a usable actual subtype that + -- is constrained. This happens for example in the function call + -- and explicit dereference cases. In these cases, we have to get + -- the length or range from the expression itself, making sure we + -- do not evaluate it more than once. + + -- Here Ck_Node is the original expression, or more properly the + -- result of applying Duplicate_Expr to the original tree, + -- forcing the result to be a name. + + else + declare + Ndims : Nat := Number_Dimensions (T_Typ); + + begin + -- Build the condition for the explicit dereference case + + for Indx in 1 .. Ndims loop + Evolve_Or_Else + (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx)); + end loop; + end; + + end if; + + else + -- Generate an Action to check that the bounds of the + -- source value are within the constraints imposed by the + -- target type for a conversion to an unconstrained type. + -- Rule is 4.6(38). + + if Nkind (Parent (Ck_Node)) = N_Type_Conversion then + declare + Opnd_Index : Node_Id; + Targ_Index : Node_Id; + + begin + Opnd_Index + := First_Index (Get_Actual_Subtype (Ck_Node)); + Targ_Index := First_Index (T_Typ); + + while Opnd_Index /= Empty loop + if Nkind (Opnd_Index) = N_Range then + if Is_In_Range + (Low_Bound (Opnd_Index), Etype (Targ_Index)) + and then + Is_In_Range + (High_Bound (Opnd_Index), Etype (Targ_Index)) + then + null; + + elsif Is_Out_Of_Range + (Low_Bound (Opnd_Index), Etype (Targ_Index)) + or else + Is_Out_Of_Range + (High_Bound (Opnd_Index), Etype (Targ_Index)) + then + Add_Check + (Compile_Time_Constraint_Error + (Wnode, "value out of range of}?", T_Typ)); + + else + Evolve_Or_Else + (Cond, + Discrete_Range_Cond + (Opnd_Index, Etype (Targ_Index))); + end if; + end if; + + Next_Index (Opnd_Index); + Next_Index (Targ_Index); + end loop; + end; + end if; + end if; + end if; + + -- Construct the test and insert into the tree + + if Present (Cond) then + if Do_Access then + Cond := Guard_Access (Cond, Loc, Ck_Node); + end if; + + Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond)); + end if; + + return Ret_Result; + + end Selected_Range_Checks; + + ------------------------------- + -- Storage_Checks_Suppressed -- + ------------------------------- + + function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Storage_Checks + or else (Present (E) and then Suppress_Storage_Checks (E)); + end Storage_Checks_Suppressed; + + --------------------------- + -- Tag_Checks_Suppressed -- + --------------------------- + + function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + return Scope_Suppress.Tag_Checks + or else (Present (E) and then Suppress_Tag_Checks (E)); + end Tag_Checks_Suppressed; + +end Checks; diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads new file mode 100644 index 00000000000..d265ae8da8f --- /dev/null +++ b/gcc/ada/checks.ads @@ -0,0 +1,526 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C H E C K S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.55 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing routines used to deal with runtime checks. These +-- routines are used both by the semantics and by the expander. In some +-- cases, checks are enabled simply by setting flags for gigi, and in +-- other cases the code for the check is expanded. + +-- The approach used for range and length checks, in regards to suppressed +-- checks, is to attempt to detect at compilation time that a constraint +-- error will occur. If this is detected a warning or error is issued and the +-- offending expression or statement replaced with a constraint error node. +-- This always occurs whether checks are suppressed or not. Dynamic range +-- checks are, of course, not inserted if checks are suppressed. + +with Types; use Types; +with Uintp; use Uintp; + +package Checks is + + procedure Initialize; + -- Called for each new main source program, to initialize internal + -- variables used in the package body of the Checks unit. + + function Access_Checks_Suppressed (E : Entity_Id) return Boolean; + function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean; + function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean; + function Division_Checks_Suppressed (E : Entity_Id) return Boolean; + function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean; + function Index_Checks_Suppressed (E : Entity_Id) return Boolean; + function Length_Checks_Suppressed (E : Entity_Id) return Boolean; + function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean; + function Range_Checks_Suppressed (E : Entity_Id) return Boolean; + function Storage_Checks_Suppressed (E : Entity_Id) return Boolean; + function Tag_Checks_Suppressed (E : Entity_Id) return Boolean; + -- These functions check to see if the named check is suppressed, + -- either by an active scope suppress setting, or because the check + -- has been specifically suppressed for the given entity. If no entity + -- is relevant for the current check, then Empty is used as an argument. + -- Note: the reason we insist on specifying Empty is to force the + -- caller to think about whether there is any relevant entity that + -- should be checked. + + -- General note on following checks. These checks are always active if + -- Expander_Active and not Inside_A_Generic. They are inactive and have + -- no effect Inside_A_Generic. In the case where not Expander_Active + -- and not Inside_A_Generic, most of them are inactive, but some of them + -- operate anyway since they may generate useful compile time warnings. + + procedure Apply_Access_Check (N : Node_Id); + -- Determines whether an expression node should be flagged as needing + -- a runtime access check. If the node requires such a check, the + -- Do_Access_Check flag is turned on. + + procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id); + -- Given a name N denoting an access parameter, emits a run-time + -- accessibility check (if necessary), checking that the level of + -- the object denoted by the access parameter is not deeper than the + -- level of the type Typ. Program_Error is raised if the check fails. + + procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id); + -- N is the node for an object declaration that declares an object of + -- array type Typ. This routine generates, if necessary, a check that + -- the size of the array is not too large, raising Storage_Error if so. + + procedure Apply_Arithmetic_Overflow_Check (N : Node_Id); + -- Given a binary arithmetic operator (+ - *) expand a software integer + -- overflow check using range checks on a larger checking type or a call + -- to an appropriate runtime routine. This is used for all three operators + -- for the signed integer case, and for +/- in the fixed-point case. The + -- check is expanded only if Software_Overflow_Checking is enabled and + -- Do_Overflow_Check is set on node N. Note that divide is handled + -- separately using Apply_Arithmetic_Divide_Overflow_Check. + + procedure Apply_Constraint_Check + (N : Node_Id; + Typ : Entity_Id; + No_Sliding : Boolean := False); + -- Top-level procedure, calls all the others depending on the class of Typ. + -- Checks that expression N verifies the constraint of type Typ. No_Sliding + -- is only relevant for constrained array types, id set to true, it + -- checks that indexes are in range. + + procedure Apply_Discriminant_Check + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id := Empty); + -- Given an expression N of a discriminated type, or of an access type + -- whose designated type is a discriminanted type, generates a check to + -- ensure that the expression can be converted to the subtype given as + -- the second parameter. Lhs is empty except in the case of assignments, + -- where the target object may be needed to determine the subtype to + -- check against (such as the cases of unconstrained formal parameters + -- and unconstrained aliased objects). For the case of unconstrained + -- formals, the check is peformed only if the corresponding actual is + -- constrained, i.e., whether Lhs'Constrained is True. + + function Build_Discriminant_Checks + (N : Node_Id; + T_Typ : Entity_Id) + return Node_Id; + -- Subsidiary routine for Apply_Discriminant_Check. Builds the expression + -- that compares discriminants of the expression with discriminants of the + -- type. Also used directly for membership tests (see Exp_Ch4.Expand_N_In). + + procedure Apply_Divide_Check (N : Node_Id); + -- The node kind is N_Op_Divide, N_Op_Mod, or N_Op_Rem. An appropriate + -- check is generated to ensure that the right operand is non-zero. In + -- the divide case, we also check that we do not have the annoying case + -- of the largest negative number divided by minus one. + + procedure Apply_Type_Conversion_Checks (N : Node_Id); + -- N is an N_Type_Conversion node. A type conversion actually involves + -- two sorts of checks. The first check is the checks that ensures that + -- the operand in the type conversion fits onto the base type of the + -- subtype it is being converted to (see RM 4.6 (28)-(50)). The second + -- check is there to ensure that once the operand has been converted to + -- a value of the target type, this converted value meets the + -- constraints imposed by the target subtype (see RM 4.6 (51)). + + procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id); + -- The argument N is an attribute reference node intended for processing + -- by gigi. The attribute is one that returns a universal integer, but + -- the attribute reference node is currently typed with the expected + -- result type. This routine deals with range and overflow checks needed + -- to make sure that the universal result is in range. + + procedure Determine_Range + (N : Node_Id; + OK : out Boolean; + Lo : out Uint; + Hi : out Uint); + -- N is a node for a subexpression. If N is of a discrete type with + -- no error indications, and no other peculiarities (e.g. missing + -- type fields), then OK is True on return, and Lo and Hi are set + -- to a conservative estimate of the possible range of values of N. + -- Thus if OK is True on return, the value of the subexpression N is + -- known to like in the range Lo .. Hi (inclusive). If the expression + -- is not of a discrete type, or some kind of error condition is + -- detected, then OK is False on exit, and Lo/Hi are set to No_Uint. + -- Thus the significance of OK being False on return is that no + -- useful information is available on the range of the expression. + + ----------------------------- + -- Length and Range Checks -- + ----------------------------- + + -- In the following procedures, there are three arguments which have + -- a common meaning as follows: + + -- Expr The expression to be checked. If a check is required, + -- the appropriate flag will be placed on this node. Whether + -- this node is further examined depends on the setting of + -- the parameter Source_Typ, as described below. + + -- Target_Typ The target type on which the check is to be based. For + -- example, if we have a scalar range check, then the check + -- is that we are in range of this type. + + -- Source_Typ Normally Empty, but can be set to a type, in which case + -- this type is used for the check, see below. + + -- The checks operate in one of two modes: + + -- If Source_Typ is Empty, then the node Expr is examined, at the + -- very least to get the source subtype. In addition for some of + -- the checks, the actual form of the node may be examined. For + -- example, a node of type Integer whose actual form is an Integer + -- conversion from a type with range 0 .. 3 can be determined to + -- have a value in the range 0 .. 3. + + -- If Source_Typ is given, then nothing can be assumed about the + -- Expr, and indeed its contents are not examined. In this case the + -- check is based on the assumption that Expr can be an arbitrary + -- value of the given Source_Typ. + + -- Currently, the only case in which a Source_Typ is explicitly supplied + -- is for the case of Out and In_Out parameters, where, for the conversion + -- on return (the Out direction), the types must be reversed. This is + -- handled by the caller. + + procedure Apply_Length_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty); + -- This procedure builds a sequence of declarations to do a length check + -- that checks if the lengths of the two arrays Target_Typ and source type + -- are the same. The resulting actions are inserted at Node using a call + -- to Insert_Actions. + -- + -- For access types, the Directly_Designated_Type is retrieved and + -- processing continues as enumerated above, with a guard against + -- null values. + -- + -- Note: calls to Apply_Length_Check currently never supply an explicit + -- Source_Typ parameter, but Apply_Length_Check takes this parameter and + -- processes it as described above for consistency with the other routines + -- in this section. + + procedure Apply_Range_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty); + -- For an Node of kind N_Range, constructs a range check action that + -- tests first that the range is not null and then that the range + -- is contained in the Target_Typ range. + -- + -- For scalar types, constructs a range check action that first tests that + -- the expression is contained in the Target_Typ range. The difference + -- between this and Apply_Scalar_Range_Check is that the latter generates + -- the actual checking code in gigi against the Etype of the expression. + -- + -- For constrained array types, construct series of range check actions + -- to check that each Expr range is properly contained in the range of + -- Target_Typ. + -- + -- For a type conversion to an unconstrained array type, constructs + -- a range check action to check that the bounds of the source type + -- are within the constraints imposed by the Target_Typ. + -- + -- For access types, the Directly_Designated_Type is retrieved and + -- processing continues as enumerated above, with a guard against + -- null values. + -- + -- The source type is used by type conversions to unconstrained array + -- types to retrieve the corresponding bounds. + + procedure Apply_Static_Length_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty); + -- Tries to determine statically whether the two array types source type + -- and Target_Typ have the same length. If it can be determined at compile + -- time that they do not, then an N_Raise_Constraint_Error node replaces + -- Expr, and a warning message is issued. + + procedure Apply_Scalar_Range_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Fixed_Int : Boolean := False); + -- For scalar types, determines whether an expression node should be + -- flagged as needing a runtime range check. If the node requires such + -- a check, the Do_Range_Check flag is turned on. The Fixed_Int flag + -- if set causes any fixed-point values to be treated as though they + -- were discrete values (i.e. the underlying integer value is used). + + type Check_Result is private; + -- Type used to return result of Range_Check call, for later use in + -- call to Insert_Range_Checks procedure. + + procedure Append_Range_Checks + (Checks : Check_Result; + Stmts : List_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr; + Flag_Node : Node_Id); + -- Called to append range checks as returned by a call to Range_Check. + -- Stmts is a list to which either the dynamic check is appended or + -- the raise Constraint_Error statement is appended (for static checks). + -- Static_Sloc is the Sloc at which the raise CE node points, + -- Flag_Node is used as the node at which to set the Has_Dynamic_Check + -- flag. Checks_On is a boolean value that says if range and index checking + -- is on or not. + + procedure Enable_Range_Check (N : Node_Id); + pragma Inline (Enable_Range_Check); + -- Set Do_Range_Check flag in node N to True unless Kill_Range_Check flag + -- is set in N (the purpose of the latter flag is precisely to prevent + -- Do_Range_Check from being set). + + procedure Insert_Range_Checks + (Checks : Check_Result; + Node : Node_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr := No_Location; + Flag_Node : Node_Id := Empty; + Do_Before : Boolean := False); + -- Called to insert range checks as returned by a call to Range_Check. + -- Node is the node after which either the dynamic check is inserted or + -- the raise Constraint_Error statement is inserted (for static checks). + -- Suppress_Typ is the type to check to determine if checks are suppressed. + -- Static_Sloc, if passed, is the Sloc at which the raise CE node points, + -- otherwise Sloc (Node) is used. The Has_Dynamic_Check flag is normally + -- set at Node. If Flag_Node is present, then this is used instead as the + -- node at which to set the Has_Dynamic_Check flag. Normally the check is + -- inserted after, if Do_Before is True, the check is inserted before + -- Node. + + function Range_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Warn_Node : Node_Id := Empty) + return Check_Result; + -- Like Apply_Range_Check, except it does not modify anything. Instead + -- it returns an encapsulated result of the check operations for later + -- use in a call to Insert_Range_Checks. If Warn_Node is non-empty, its + -- Sloc is used, in the static case, for the generated warning or error. + -- Additionally, it is used rather than Expr (or Low/High_Bound of Expr) + -- in constructing the check. + + ----------------------- + -- Validity Checking -- + ----------------------- + + -- In (RM 13.9.1(9-11)) we have the following rules on invalid values + + -- 9 If the representation of a scalar object does not represent a + -- value of the object's subtype (perhaps because the object was not + -- initialized), the object is said to have an invalid representation. + -- It is a bounded error to evaluate the value of such an object. If + -- the error is detected, either Constraint_Error or Program_Error is + -- raised. Otherwise, execution continues using the invalid + -- representation. The rules of the language outside this subclause + -- assume that all objects have valid representations. The semantics + -- of operations on invalid representations are as follows: + -- + -- 10 If the representation of the object represents a value of the + -- object's type, the value of the type is used. + -- + -- 11 If the representation of the object does not represent a value + -- of the object's type, the semantics of operations on such + -- representations is implementation-defined, but does not by + -- itself lead to erroneous or unpredictable execution, or to + -- other objects becoming abnormal. + + -- We quote the rules in full here since they are quite delicate. Most + -- of the time, we can just compute away with wrong values, and get a + -- possibly wrong result, which is well within the range of allowed + -- implementation defined behavior. The two tricky cases are subscripted + -- array assignments, where we don't want to do wild stores, and case + -- statements where we don't want to do wild jumps. + + -- In GNAT, we control validity checking with a switch -gnatV that + -- can take three parameters, n/d/f for None/Default/Full. These + -- modes have the following meanings: + + -- None (no validity checking) + + -- In this mode, there is no specific checking for invalid values + -- and the code generator assumes that all stored values are always + -- within the bounds of the object subtype. The consequences are as + -- follows: + + -- For case statements, an out of range invalid value will cause + -- Constraint_Error to be raised, or an arbitrary one of the case + -- alternatives will be executed. Wild jumps cannot result even + -- in this mode, since we always do a range check + + -- For subscripted array assignments, wild stores will result in + -- the expected manner when addresses are calculated using values + -- of subscripts that are out of range. + + -- It could perhaps be argued that this mode is still conformant with + -- the letter of the RM, since implementation defined is a rather + -- broad category, but certainly it is not in the spirit of the + -- RM requirement, since wild stores certainly seem to be a case of + -- erroneous behavior. + + -- Default (default standard RM-compatible validity checking) + + -- In this mode, which is the default, minimal validity checking is + -- performed to ensure no erroneous behavior as follows: + + -- For case statements, an out of range invalid value will cause + -- Constraint_Error to be raised. + + -- For subscripted array assignments, invalid out of range + -- subscript values will cause Constraint_Error to be raised. + + -- Full (Full validity checking) + + -- In this mode, the protections guaranteed by the standard mode are + -- in place, and the following additional checks are made: + + -- For every assignment, the right side is checked for validity + + -- For every call, IN and IN OUT parameters are checked for validity + + -- For every subscripted array reference, both for stores and loads, + -- all subscripts are checked for validity. + + -- These checks are not required by the RM, but will in practice + -- improve the detection of uninitialized variables, particularly + -- if used in conjunction with pragma Normalize_Scalars. + + -- In the above description, we talk about performing validity checks, + -- but we don't actually generate a check in a case where the compiler + -- can be sure that the value is valid. Note that this assurance must + -- be achieved without assuming that any uninitialized value lies within + -- the range of its type. The following are cases in which values are + -- known to be valid. The flag Is_Known_Valid is used to keep track of + -- some of these cases. + + -- If all possible stored values are valid, then any uninitialized + -- value must be valid. + + -- Literals, including enumeration literals, are clearly always valid. + + -- Constants are always assumed valid, with a validity check being + -- performed on the initializing value where necessary to ensure that + -- this is the case. + + -- For variables, the status is set to known valid if there is an + -- initializing expression. Again a check is made on the initializing + -- value if necessary to ensure that this assumption is valid. The + -- status can change as a result of local assignments to a variable. + -- If a known valid value is unconditionally assigned, then we mark + -- the left side as known valid. If a value is assigned that is not + -- known to be valid, then we mark the left side as invalid. This + -- kind of processing does NOT apply to non-local variables since we + -- are not following the flow graph (more properly the flow of actual + -- processing only corresponds to the flow graph for local assignments). + -- For non-local variables, we preserve the current setting, i.e. a + -- validity check is performed when assigning to a knonwn valid global. + + -- Note: no validity checking is required if range checks are suppressed + -- regardless of the setting of the validity checking mode. + + -- The following procedures are used in handling validity checking + + procedure Apply_Subscript_Validity_Checks (Expr : Node_Id); + -- Expr is the node for an indexed component. If validity checking and + -- range checking are enabled, all subscripts for this indexed component + -- are checked for validity. + + procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id); + -- Expr is a lvalue, i.e. an expression representing the target of + -- an assignment. This procedure checks for this expression involving + -- an assignment to an array value. We have to be sure that all the + -- subscripts in such a case are valid, since according to the rules + -- in (RM 13.9.1(9-11)) such assignments are not permitted to result + -- in erroneous behavior in the case of invalid subscript values. + + procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False); + -- Ensure that Expr represents a valid value of its type. If this type + -- is not a scalar type, then the call has no effect, since validity + -- is only an issue for scalar types. The effect of this call is to + -- check if the value is known valid, if so, nothing needs to be done. + -- If this is not known, then either Expr is set to be range checked, + -- or specific checking code is inserted so that an exception is raised + -- if the value is not valid. + -- + -- The optional argument Holes_OK indicates whether it is necessary to + -- worry about enumeration types with non-standard representations leading + -- to "holes" in the range of possible representations. If Holes_OK is + -- True, then such values are assumed valid (this is used when the caller + -- will make a separate check for this case anyway). If Holes_OK is False, + -- then this case is checked, and code is inserted to ensure that Expr is + -- valid, raising Constraint_Error if the value is not valid. + + function Expr_Known_Valid (Expr : Node_Id) return Boolean; + -- This function tests it the value of Expr is known to be valid in + -- the sense of RM 13.9.1(9-11). In the case of GNAT, it is only + -- discrete types which are a concern, since for non-discrete types + -- we simply continue computation with invalid values, which does + -- not lead to erroneous behavior. Thus Expr_Known_Valid always + -- returns True if the type of Expr is non-discrete. For discrete + -- types the value returned is True only if it can be determined + -- that the value is Valid. Otherwise False is returned. + + procedure Insert_Valid_Check (Expr : Node_Id); + -- Inserts code that will check for the value of Expr being valid, in + -- the sense of the 'Valid attribute returning True. Constraint_Error + -- will be raised if the value is not valid. + +private + + type Check_Result is array (Positive range 1 .. 2) of Node_Id; + -- There are two cases for the result returned by Range_Check: + -- + -- For the static case the result is one or two nodes that should cause + -- a Constraint_Error. Typically these will include Expr itself or the + -- direct descendents of Expr, such as Low/High_Bound (Expr)). It is the + -- responsibility of the caller to rewrite and substitute the nodes with + -- N_Raise_Constraint_Error nodes. + -- + -- For the non-static case a single N_Raise_Constraint_Error node + -- with a non-empty Condition field is returned. + -- + -- Unused entries in Check_Result, if any, are simply set to Empty + -- For external clients, the required processing on this result is + -- achieved using the Insert_Range_Checks routine. + + pragma Inline (Access_Checks_Suppressed); + pragma Inline (Accessibility_Checks_Suppressed); + pragma Inline (Discriminant_Checks_Suppressed); + pragma Inline (Division_Checks_Suppressed); + pragma Inline (Elaboration_Checks_Suppressed); + pragma Inline (Index_Checks_Suppressed); + pragma Inline (Length_Checks_Suppressed); + pragma Inline (Overflow_Checks_Suppressed); + pragma Inline (Range_Checks_Suppressed); + pragma Inline (Storage_Checks_Suppressed); + pragma Inline (Tag_Checks_Suppressed); + + pragma Inline (Apply_Length_Check); + pragma Inline (Apply_Range_Check); + pragma Inline (Apply_Static_Length_Check); +end Checks; diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c new file mode 100644 index 00000000000..bcd83c3fb99 --- /dev/null +++ b/gcc/ada/cio.c @@ -0,0 +1,145 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C I O * + * * + * C Implementation File * + * * + * $Revision: 1.2 $ + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include <sys/stat.h> +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +#ifdef __RT__ + +/* Linux kernel modules don't have inputs, so don't define get_int. + Simple output can be done via printk. */ + +void +put_char (c) + int c; +{ + printk ("%c", c); +} + +void +put_char_stderr (c) + int c; +{ + put_char (c); +} + +void +put_int (x) + int x; +{ + printk ("%d", x); +} + +void +put_int_stderr (int x) +{ + put_int (x); +} + +#else + +/* Don't use macros on linux since they cause incompatible changes between + glibc 2.0 and 2.1 */ +#ifdef linux +#undef putchar +#undef getchar +#undef fputc +#undef stderr +#endif + +int +get_char () +{ +#ifdef VMS + return decc$getchar(); +#else + return getchar (); +#endif +} + +int +get_int () +{ + int x; + + scanf (" %d", &x); + return x; +} + +void +put_int (x) + int x; +{ + printf ("%d", x); +} + +void +put_int_stderr (x) + int x; +{ + fprintf (stderr, "%d", x); +} + +void +put_char (c) + int c; +{ + putchar (c); +} + +void +put_char_stderr (c) + int c; +{ + fputc (c, stderr); +} +#endif + +#ifdef __vxworks + +char * +mktemp (template) + char *template; +{ + return tmpnam (NULL); +} +#endif diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb new file mode 100644 index 00000000000..e92e0c4a97e --- /dev/null +++ b/gcc/ada/comperr.adb @@ -0,0 +1,357 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C O M P E R R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.57 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines called when a fatal internal compiler +-- error is detected. Calls to these routines cause termination of the +-- current compilation with appropriate error output. + +with Atree; use Atree; +with Debug; use Debug; +with Errout; use Errout; +with Fname; use Fname; +with Gnatvsn; use Gnatvsn; +with Lib; use Lib; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Sinput; use Sinput; +with Sprint; use Sprint; +with Sdefault; use Sdefault; +with Treepr; use Treepr; +with Types; use Types; + +with Ada.Exceptions; use Ada.Exceptions; + +with System.Soft_Links; use System.Soft_Links; + +package body Comperr is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Repeat_Char (Char : Character; Col : Nat; After : Character); + -- Output Char until current column is at or past Col, and then output + -- the character given by After (if column is already past Col on entry, + -- then the effect is simply to output the After character). + + -------------------- + -- Compiler_Abort -- + -------------------- + + procedure Compiler_Abort + (X : String; + Code : Integer := 0) + is + procedure End_Line; + -- Add blanks up to column 76, and then a final vertical bar + + procedure End_Line is + begin + Repeat_Char (' ', 76, '|'); + Write_Eol; + end End_Line; + + Public_Version : constant Boolean := (Gnat_Version_String (5) = 'p'); + + -- Start of processing for Compiler_Abort + + begin + -- If errors have already occured, then we guess that the abort may + -- well be caused by previous errors, and we don't make too much fuss + -- about it, since we want to let the programmer fix the errors first. + + -- Debug flag K disables this behavior (useful for debugging) + + if Errors_Detected /= 0 and then not Debug_Flag_K then + Errout.Finalize; + + Set_Standard_Error; + Write_Str ("compilation abandoned due to previous error"); + Write_Eol; + + Set_Standard_Output; + Source_Dump; + Tree_Dump; + Exit_Program (E_Errors); + + -- Otherwise give message with details of the abort + + else + Set_Standard_Error; + + -- Generate header for bug box + + Write_Char ('+'); + Repeat_Char ('=', 29, 'G'); + Write_Str ("NAT BUG DETECTED"); + Repeat_Char ('=', 76, '+'); + Write_Eol; + + -- Output GNAT version identification + + Write_Str ("| "); + Write_Str (Gnat_Version_String); + Write_Str (" ("); + + -- Output target name, deleting junk final reverse slash + + if Target_Name.all (Target_Name.all'Last) = '\' + or else Target_Name.all (Target_Name.all'Last) = '/' + then + Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1)); + else + Write_Str (Target_Name.all); + end if; + + -- Output identification of error + + Write_Str (") "); + + if X'Length + Column > 76 then + if Code < 0 then + Write_Str ("GCC error:"); + end if; + + End_Line; + + Write_Str ("| "); + end if; + + if X'Length > 70 then + declare + Last_Blank : Integer := 70; + + begin + for P in 40 .. 69 loop + if X (P) = ' ' then + Last_Blank := P; + end if; + end loop; + + Write_Str (X (1 .. Last_Blank)); + End_Line; + Write_Str ("| "); + Write_Str (X (Last_Blank + 1 .. X'Length)); + end; + else + Write_Str (X); + end if; + + if Code > 0 then + Write_Str (", Code="); + Write_Int (Int (Code)); + + elsif Code = 0 then + + -- For exception case, get exception message from the TSD. Note + -- that it would be neater and cleaner to pass the exception + -- message (obtained from Exception_Message) as a parameter to + -- Compiler_Abort, but we can't do this quite yet since it would + -- cause bootstrap path problems for 3.10 to 3.11. + + Write_Char (' '); + Write_Str (Exception_Message (Get_Current_Excep.all.all)); + end if; + + End_Line; + + -- Output source location information + + if Sloc (Current_Error_Node) <= Standard_Location + or else Sloc (Current_Error_Node) = No_Location + then + Write_Str ("| No source file position information available"); + End_Line; + else + Write_Str ("| Error detected at "); + Write_Location (Sloc (Current_Error_Node)); + End_Line; + end if; + + -- There are two cases now. If the file gnat_bug.box exists, + -- we use the contents of this file at this point. + + declare + Lo : Source_Ptr; + Hi : Source_Ptr; + Src : Source_Buffer_Ptr; + + begin + Namet.Unlock; + Name_Buffer (1 .. 12) := "gnat_bug.box"; + Name_Len := 12; + Read_Source_File (Name_Enter, 0, Hi, Src); + + -- If we get a Src file, we use it + + if Src /= null then + Lo := 0; + + Outer : while Lo < Hi loop + Write_Str ("| "); + + Inner : loop + exit Inner when Src (Lo) = ASCII.CR + or else Src (Lo) = ASCII.LF; + Write_Char (Src (Lo)); + Lo := Lo + 1; + end loop Inner; + + End_Line; + + while Lo <= Hi + and then (Src (Lo) = ASCII.CR + or else Src (Lo) = ASCII.LF) + loop + Lo := Lo + 1; + end loop; + end loop Outer; + + -- Otherwise we use the standard fixed text + + else + Write_Str + ("| Please submit bug report by email to report@gnat.com."); + End_Line; + + if not Public_Version then + Write_Str + ("| Use a subject line meaningful to you" & + " and us to track the bug."); + End_Line; + + Write_Str + ("| (include your customer number #nnn " & + "in the subject line)."); + End_Line; + end if; + + Write_Str + ("| Include the entire contents of this bug " & + "box in the report."); + End_Line; + + Write_Str + ("| Include the exact gcc or gnatmake command " & + "that you entered."); + End_Line; + + Write_Str + ("| Also include sources listed below in gnatchop format"); + End_Line; + + Write_Str + ("| (concatenated together with no headers between files)."); + End_Line; + + if Public_Version then + Write_Str + ("| (use plain ASCII or MIME attachment)."); + End_Line; + + Write_Str + ("| See gnatinfo.txt for full info on procedure " & + "for submitting bugs."); + End_Line; + + else + Write_Str + ("| (use plain ASCII or MIME attachment, or FTP " + & "to your customer directory)."); + End_Line; + + Write_Str + ("| See README.GNATPRO for full info on procedure " & + "for submitting bugs."); + End_Line; + end if; + end if; + end; + + -- Complete output of bug box + + Write_Char ('+'); + Repeat_Char ('=', 76, '+'); + Write_Eol; + + if Debug_Flag_3 then + Write_Eol; + Write_Eol; + Print_Tree_Node (Current_Error_Node); + Write_Eol; + end if; + + Write_Eol; + + Write_Line ("Please include these source files with error report"); + Write_Eol; + + for U in Main_Unit .. Last_Unit loop + begin + if not Is_Internal_File_Name + (File_Name (Source_Index (U))) + then + Write_Name (Full_File_Name (Source_Index (U))); + Write_Eol; + end if; + + -- No point in double bug box if we blow up trying to print + -- the list of file names! Output informative msg and quit. + + exception + when others => + Write_Str ("list may be incomplete"); + exit; + end; + end loop; + + Write_Eol; + Set_Standard_Output; + + Tree_Dump; + Source_Dump; + raise Unrecoverable_Error; + end if; + + end Compiler_Abort; + + ----------------- + -- Repeat_Char -- + ----------------- + + procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is + begin + while Column < Col loop + Write_Char (Char); + end loop; + + Write_Char (After); + end Repeat_Char; + +end Comperr; diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads new file mode 100644 index 00000000000..a55a49fb5c3 --- /dev/null +++ b/gcc/ada/comperr.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C O M P E R R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine called when a fatal internal compiler +-- error is detected. Calls to this routines cause termination of the +-- current compilation with appropriate error output. + +package Comperr is + + procedure Compiler_Abort + (X : String; + Code : Integer := 0); + -- Signals an internal compiler error. Never returns control. Depending + -- on processing may end up raising Unrecoverable_Error, or exiting + -- directly. The message output is a "bug box" containing the + -- string passed as an argument. The node in Current_Error_Node is used + -- to provide the location where the error should be signalled. The + -- message includes the node id, and the code parameter if it is positive. + -- Note that this is only used at the outer level (to handle constraint + -- errors or assert errors etc.) In the normal logic of the compiler we + -- always use pragma Assert to check for errors, and if necessary an + -- explicit abort is achieved by pragma Assert (False). Code is positive + -- for a gigi abort (giving the gigi abort code), zero for a front + -- end exception (with possible message stored in TSD.Current_Excep, + -- and negative (an unused value) for a GCC abort. + + ------------------------------ + -- Use of gnat_bug.box File -- + ------------------------------ + + -- When comperr generates the "bug box". The first two lines contain + -- information on the version number, type of abort, and source location. + + -- Normally the remaining text is one of the following two forms + -- depending on the version number (p identifies public versions): + + -- Please submit bug report by email to report@gnat.com. + -- Use a subject line meaningful to you and us to track the bug. + -- (include your customer number #nnn in the subject line). + -- Include the entire contents of this bug box in the report. + -- Include the exact gcc or gnatmake command that you entered. + -- Also include sources listed below in gnatchop format + -- (concatenated together with no headers between files). + -- (use plain ASCII or MIME attachment, + -- or FTP to your customer directory). + -- See README.GNATPRO for full info on procedure for submitting bugs. + + -- or (public version case) + + -- Please submit bug report by email to report@gnat.com. + -- Use a subject line meaningful to you and us to track the bug. + -- (include your customer number #nnn in the subject line). + -- Include the entire contents of this bug box in the report. + -- Include the exact gcc or gnatmake command that you entered. + -- Also include sources listed below in gnatchop format + -- (concatenated together with no headers between files). + -- See gnatinfo.txt for full info on procedure for submitting bugs. + + -- However, an alternative mechanism exists for easily substituting + -- different text for this message. Compiler_Abort checks for the + -- existence of the file "gnat_bug.box" in the current source path. + -- Most typically this file, if present, will be in the directory + -- containing the run-time sources. + + -- If this file is present, then it is a plain ASCII file, whose + -- contents replace the above quoted paragraphs. The lines in this + -- file should be 72 characters or less to avoid misformatting the + -- right boundary of the box. Note that the file does not contain + -- the vertical bar characters or any leading spaces in lines. + +end Comperr; diff --git a/gcc/ada/config-lang.in b/gcc/ada/config-lang.in new file mode 100644 index 00000000000..5268fe2b81f --- /dev/null +++ b/gcc/ada/config-lang.in @@ -0,0 +1,39 @@ +# Top level configure fragment for GNU Ada (GNAT). +# Copyright (C) 1994 Free Software Foundation, Inc. + +#This file is part of GNU CC. + +#GNU CC 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 2, or (at your option) +#any later version. + +#GNU CC 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 GNU CC; see the file COPYING. If not, write to +#the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +# Configure looks for the existence of this file to auto-config each language. +# We define several parameters used by configure: +# +# language - name of language as it would appear in $(LANGUAGES) +# boot_language - "yes" if we need to build this language in stage1 +# compilers - value to add to $(COMPILERS) +# stagestuff - files to add to $(STAGESTUFF) +# diff_excludes - files to ignore when building diffs between two versions. + +language="ada" +boot_language=yes +boot_language_boot_flags='ADAFLAGS="$(BOOT_ADAFLAGS)"' + +compilers="gnat1\$(exeext)" + +stagestuff="gnatbind\$(exeext) gnat1\$(exeext)" + +diff_excludes="-x ada/a-einfo.h -x ada/a-sinfo.h -x ada/nmake.adb -x ada/nmake.ads -x ada/treeprs.ads -x ada/sysid.ads" + +outputs=ada/Makefile diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb new file mode 100644 index 00000000000..6855f4dc0af --- /dev/null +++ b/gcc/ada/csets.adb @@ -0,0 +1,1037 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S E T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.25 $ +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 Opt; use Opt; + +with System.WCh_Con; use System.WCh_Con; + +package body Csets is + + X_80 : constant Character := Character'Val (16#80#); + X_81 : constant Character := Character'Val (16#81#); + X_82 : constant Character := Character'Val (16#82#); + X_83 : constant Character := Character'Val (16#83#); + X_84 : constant Character := Character'Val (16#84#); + X_85 : constant Character := Character'Val (16#85#); + X_86 : constant Character := Character'Val (16#86#); + X_87 : constant Character := Character'Val (16#87#); + X_88 : constant Character := Character'Val (16#88#); + X_89 : constant Character := Character'Val (16#89#); + X_8A : constant Character := Character'Val (16#8A#); + X_8B : constant Character := Character'Val (16#8B#); + X_8C : constant Character := Character'Val (16#8C#); + X_8D : constant Character := Character'Val (16#8D#); + X_8E : constant Character := Character'Val (16#8E#); + X_8F : constant Character := Character'Val (16#8F#); + X_90 : constant Character := Character'Val (16#90#); + X_91 : constant Character := Character'Val (16#91#); + X_92 : constant Character := Character'Val (16#92#); + X_93 : constant Character := Character'Val (16#93#); + X_94 : constant Character := Character'Val (16#94#); + X_95 : constant Character := Character'Val (16#95#); + X_96 : constant Character := Character'Val (16#96#); + X_97 : constant Character := Character'Val (16#97#); + X_98 : constant Character := Character'Val (16#98#); + X_99 : constant Character := Character'Val (16#99#); + X_9A : constant Character := Character'Val (16#9A#); + X_9B : constant Character := Character'Val (16#9B#); + X_9C : constant Character := Character'Val (16#9C#); + X_9D : constant Character := Character'Val (16#9D#); + X_9E : constant Character := Character'Val (16#9E#); + X_9F : constant Character := Character'Val (16#9F#); + X_A0 : constant Character := Character'Val (16#A0#); + X_A1 : constant Character := Character'Val (16#A1#); + X_A2 : constant Character := Character'Val (16#A2#); + X_A3 : constant Character := Character'Val (16#A3#); + X_A4 : constant Character := Character'Val (16#A4#); + X_A5 : constant Character := Character'Val (16#A5#); + X_A6 : constant Character := Character'Val (16#A6#); + X_A7 : constant Character := Character'Val (16#A7#); + X_A8 : constant Character := Character'Val (16#A8#); + X_A9 : constant Character := Character'Val (16#A9#); + X_AA : constant Character := Character'Val (16#AA#); + X_AB : constant Character := Character'Val (16#AB#); + X_AC : constant Character := Character'Val (16#AC#); + X_AD : constant Character := Character'Val (16#AD#); + X_AE : constant Character := Character'Val (16#AE#); + X_AF : constant Character := Character'Val (16#AF#); + X_B0 : constant Character := Character'Val (16#B0#); + X_B1 : constant Character := Character'Val (16#B1#); + X_B2 : constant Character := Character'Val (16#B2#); + X_B3 : constant Character := Character'Val (16#B3#); + X_B4 : constant Character := Character'Val (16#B4#); + X_B5 : constant Character := Character'Val (16#B5#); + X_B6 : constant Character := Character'Val (16#B6#); + X_B7 : constant Character := Character'Val (16#B7#); + X_B8 : constant Character := Character'Val (16#B8#); + X_B9 : constant Character := Character'Val (16#B9#); + X_BA : constant Character := Character'Val (16#BA#); + X_BB : constant Character := Character'Val (16#BB#); + X_BC : constant Character := Character'Val (16#BC#); + X_BD : constant Character := Character'Val (16#BD#); + X_BE : constant Character := Character'Val (16#BE#); + X_BF : constant Character := Character'Val (16#BF#); + X_C0 : constant Character := Character'Val (16#C0#); + X_C1 : constant Character := Character'Val (16#C1#); + X_C2 : constant Character := Character'Val (16#C2#); + X_C3 : constant Character := Character'Val (16#C3#); + X_C4 : constant Character := Character'Val (16#C4#); + X_C5 : constant Character := Character'Val (16#C5#); + X_C6 : constant Character := Character'Val (16#C6#); + X_C7 : constant Character := Character'Val (16#C7#); + X_C8 : constant Character := Character'Val (16#C8#); + X_C9 : constant Character := Character'Val (16#C9#); + X_CA : constant Character := Character'Val (16#CA#); + X_CB : constant Character := Character'Val (16#CB#); + X_CC : constant Character := Character'Val (16#CC#); + X_CD : constant Character := Character'Val (16#CD#); + X_CE : constant Character := Character'Val (16#CE#); + X_CF : constant Character := Character'Val (16#CF#); + X_D0 : constant Character := Character'Val (16#D0#); + X_D1 : constant Character := Character'Val (16#D1#); + X_D2 : constant Character := Character'Val (16#D2#); + X_D3 : constant Character := Character'Val (16#D3#); + X_D4 : constant Character := Character'Val (16#D4#); + X_D5 : constant Character := Character'Val (16#D5#); + X_D6 : constant Character := Character'Val (16#D6#); + X_D7 : constant Character := Character'Val (16#D7#); + X_D8 : constant Character := Character'Val (16#D8#); + X_D9 : constant Character := Character'Val (16#D9#); + X_DA : constant Character := Character'Val (16#DA#); + X_DB : constant Character := Character'Val (16#DB#); + X_DC : constant Character := Character'Val (16#DC#); + X_DD : constant Character := Character'Val (16#DD#); + X_DE : constant Character := Character'Val (16#DE#); + X_DF : constant Character := Character'Val (16#DF#); + X_E0 : constant Character := Character'Val (16#E0#); + X_E1 : constant Character := Character'Val (16#E1#); + X_E2 : constant Character := Character'Val (16#E2#); + X_E3 : constant Character := Character'Val (16#E3#); + X_E4 : constant Character := Character'Val (16#E4#); + X_E5 : constant Character := Character'Val (16#E5#); + X_E6 : constant Character := Character'Val (16#E6#); + X_E7 : constant Character := Character'Val (16#E7#); + X_E8 : constant Character := Character'Val (16#E8#); + X_E9 : constant Character := Character'Val (16#E9#); + X_EA : constant Character := Character'Val (16#EA#); + X_EB : constant Character := Character'Val (16#EB#); + X_EC : constant Character := Character'Val (16#EC#); + X_ED : constant Character := Character'Val (16#ED#); + X_EE : constant Character := Character'Val (16#EE#); + X_EF : constant Character := Character'Val (16#EF#); + X_F0 : constant Character := Character'Val (16#F0#); + X_F1 : constant Character := Character'Val (16#F1#); + X_F2 : constant Character := Character'Val (16#F2#); + X_F3 : constant Character := Character'Val (16#F3#); + X_F4 : constant Character := Character'Val (16#F4#); + X_F5 : constant Character := Character'Val (16#F5#); + X_F6 : constant Character := Character'Val (16#F6#); + X_F7 : constant Character := Character'Val (16#F7#); + X_F8 : constant Character := Character'Val (16#F8#); + X_F9 : constant Character := Character'Val (16#F9#); + X_FA : constant Character := Character'Val (16#FA#); + X_FB : constant Character := Character'Val (16#FB#); + X_FC : constant Character := Character'Val (16#FC#); + X_FD : constant Character := Character'Val (16#FD#); + X_FE : constant Character := Character'Val (16#FE#); + X_FF : constant Character := Character'Val (16#FF#); + + ----------------------------- + -- Definitions for Latin-1 -- + ----------------------------- + + Fold_Latin_1 : Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, + 'p' => 'P', X_EF => X_CF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, + 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_FF => X_FF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ----------------------------- + -- Definitions for Latin-2 -- + ----------------------------- + + Fold_Latin_2 : Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, X_B3 => X_A3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, X_BE => X_AE, + 'p' => 'P', X_EF => X_CF, X_FF => X_DF, X_BF => X_AF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, X_A3 => X_A3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, X_AE => X_AE, + 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_AF => X_AF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ----------------------------- + -- Definitions for Latin-3 -- + ----------------------------- + + Fold_Latin_3 : Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_F3 => X_D3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, + 'p' => 'P', X_EF => X_CF, X_BF => X_AF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_D3 => X_D3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, + 'P' => 'P', X_CF => X_CF, X_AF => X_AF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ----------------------------- + -- Definitions for Latin-4 -- + ----------------------------- + + Fold_Latin_4 : Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, X_B3 => X_A3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, X_BE => X_AE, + 'p' => 'P', X_EF => X_CF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, X_A3 => X_A3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, X_AE => X_AE, + 'P' => 'P', X_CF => X_CF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + -------------------------------------------- + -- Definitions for IBM PC (Code Page 437) -- + -------------------------------------------- + + -- Note: Code page 437 is the typical default in DOS, Windows and OS/2 + -- for PC's in the US, it corresponds to the original PC character set. + -- See also the definitions for code page 850. + + Fold_IBM_PC_437 : Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + X_80 => X_80, -- C cedilla + X_81 => X_9A, -- u umlaut + X_82 => X_90, -- e acute + X_83 => X_83, -- a circumflex + X_84 => X_8E, -- a umlaut + X_85 => X_85, -- a grave + X_86 => X_8F, -- a ring + X_87 => X_80, -- c cedilla + X_88 => X_88, -- e circumflex + X_89 => X_89, -- e umlaut + X_8A => X_8A, -- e grave + X_8B => X_8B, -- i umlaut + X_8C => X_8C, -- i circumflex + X_8D => X_8D, -- i grave + X_8E => X_8E, -- A umlaut + X_8F => X_8F, -- A ring + + X_90 => X_90, -- E acute + X_91 => X_92, -- ae + X_92 => X_92, -- AE + X_93 => X_93, -- o circumflex + X_94 => X_99, -- o umlaut + X_95 => X_95, -- o grave + X_96 => X_96, -- u circumflex + X_97 => X_97, -- u grave + X_98 => X_98, -- y umlaut + X_99 => X_99, -- O umlaut + X_9A => X_9A, -- U umlaut + + X_A0 => X_A0, -- a acute + X_A1 => X_A1, -- i acute + X_A2 => X_A2, -- o acute + X_A3 => X_A3, -- u acute + X_A4 => X_A5, -- n tilde + X_A5 => X_A5, -- N tilde + X_A6 => X_A6, -- a underline + X_A7 => X_A7, -- o underline + + X_E0 => X_E0, -- lower case alpha + X_E1 => X_E1, -- lower case beta + X_E2 => X_E2, -- upper case gamma + X_E3 => X_E3, -- lower case pi + X_E4 => X_E4, -- upper case sigma (lower/upper sigma not equivalent) + X_E5 => X_E5, -- lower case sigma (lower/upper sigma not equivalent) + X_E6 => X_E6, -- lower case mu + X_E7 => X_E7, -- lower case tau + X_E8 => X_E8, -- upper case phi (lower/upper phi not equivalent) + X_E9 => X_E9, -- lower case theta + X_EA => X_EA, -- upper case omega + X_EB => X_EB, -- lower case delta + X_ED => X_ED, -- lower case phi (lower/upper phi not equivalent) + X_EE => X_EE, -- lower case epsilon + + X_FC => X_FC, -- lower case eta + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + -------------------------------------------- + -- Definitions for IBM PC (Code Page 850) -- + -------------------------------------------- + + -- Note: Code page 850 is the typical default in DOS, Windows and OS/2 + -- for PC's in Europe, it is an extension of the original PC character + -- set to include the additional characters defined in ISO Latin-1. + -- See also the definitions for code page 437. + + Fold_IBM_PC_850 : Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + X_80 => X_80, -- C cedilla + X_81 => X_9A, -- u umlaut + X_82 => X_90, -- e acute + X_83 => X_B6, -- a circumflex + X_84 => X_8E, -- a umlaut + X_85 => X_B7, -- a grave + X_86 => X_8F, -- a ring + X_87 => X_80, -- c cedilla + X_88 => X_D2, -- e circumflex + X_89 => X_D3, -- e umlaut + X_8A => X_D4, -- e grave + X_8B => X_D8, -- i umlaut + X_8C => X_D7, -- i circumflex + X_8D => X_DE, -- i grave + X_8E => X_8E, -- A umlaut + X_8F => X_8F, -- A ring + + X_90 => X_90, -- E acute + X_91 => X_92, -- ae + X_92 => X_92, -- AE + X_93 => X_E2, -- o circumflex + X_94 => X_99, -- o umlaut + X_95 => X_E3, -- o grave + X_96 => X_EA, -- u circumflex + X_97 => X_EB, -- u grave + X_98 => X_98, -- y umlaut + X_99 => X_99, -- O umlaut + X_9A => X_9A, -- U umlaut + + X_A0 => X_B5, -- a acute + X_A1 => X_D6, -- i acute + X_A2 => X_E0, -- o acute + X_A3 => X_E9, -- u acute + X_A4 => X_A5, -- n tilde + X_A5 => X_A5, -- N tilde + X_A6 => X_A6, -- a underline + X_A7 => X_A7, -- o underline + + X_B5 => X_B5, -- A acute + X_B6 => X_B6, -- A circumflex + X_B7 => X_B7, -- A grave + + X_C6 => X_C7, -- a tilde + X_C7 => X_C7, -- A tilde + + X_D0 => X_D1, -- eth + X_D1 => X_D1, -- Eth + X_D2 => X_D2, -- E circumflex + X_D3 => X_D3, -- E umlaut + X_D4 => X_D4, -- E grave + X_D5 => X_D5, -- dotless i, no uppercase + X_D6 => X_D6, -- I acute + X_D7 => X_D7, -- I circumflex + X_D8 => X_D8, -- I umlaut + X_DE => X_DE, -- I grave + + X_E0 => X_E0, -- O acute + X_E1 => X_E1, -- german dbl s, no uppercase + X_E2 => X_E2, -- O circumflex + X_E3 => X_E3, -- O grave + X_E4 => X_E4, -- o tilde + X_E5 => X_E5, -- O tilde + X_E7 => X_E8, -- thorn + X_E8 => X_E8, -- Thorn + X_E9 => X_E9, -- U acute + X_EA => X_EA, -- U circumflex + X_EB => X_EB, -- U grave + X_EC => X_ED, -- y acute + X_ED => X_ED, -- Y acute + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ----------------------------------------- + -- Definitions for Full Upper Half Set -- + ----------------------------------------- + + -- The full upper half set allows all upper half characters as letters, + -- and does not recognize any upper/lower case equivalences in this half. + + Fold_Full_Upper_Half : Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + X_80 => X_80, X_90 => X_90, X_A0 => X_A0, X_B0 => X_B0, + X_81 => X_81, X_91 => X_91, X_A1 => X_A1, X_B1 => X_B1, + X_82 => X_82, X_92 => X_92, X_A2 => X_A2, X_B2 => X_B2, + X_83 => X_83, X_93 => X_93, X_A3 => X_A3, X_B3 => X_B3, + X_84 => X_84, X_94 => X_94, X_A4 => X_A4, X_B4 => X_B4, + X_85 => X_85, X_95 => X_95, X_A5 => X_A5, X_B5 => X_B5, + X_86 => X_86, X_96 => X_96, X_A6 => X_A6, X_B6 => X_B6, + X_87 => X_87, X_97 => X_97, X_A7 => X_A7, X_B7 => X_B7, + X_88 => X_88, X_98 => X_98, X_A8 => X_A8, X_B8 => X_B8, + X_89 => X_89, X_99 => X_99, X_A9 => X_A9, X_B9 => X_B9, + X_8A => X_8A, X_9A => X_9A, X_AA => X_AA, X_BA => X_BA, + X_8B => X_8B, X_9B => X_9B, X_AB => X_AB, X_BB => X_BB, + X_8C => X_8C, X_9C => X_9C, X_AC => X_AC, X_BC => X_BC, + X_8D => X_8D, X_9D => X_9D, X_AD => X_AD, X_BD => X_BD, + X_8E => X_8E, X_9E => X_9E, X_AE => X_AE, X_BE => X_BE, + X_8F => X_8F, X_9F => X_9F, X_AF => X_AF, X_BF => X_BF, + + X_C0 => X_C0, X_D0 => X_D0, X_E0 => X_E0, X_F0 => X_F0, + X_C1 => X_C1, X_D1 => X_D1, X_E1 => X_E1, X_F1 => X_F1, + X_C2 => X_C2, X_D2 => X_D2, X_E2 => X_E2, X_F2 => X_F2, + X_C3 => X_C3, X_D3 => X_D3, X_E3 => X_E3, X_F3 => X_F3, + X_C4 => X_C4, X_D4 => X_D4, X_E4 => X_E4, X_F4 => X_F4, + X_C5 => X_C5, X_D5 => X_D5, X_E5 => X_E5, X_F5 => X_F5, + X_C6 => X_C6, X_D6 => X_D6, X_E6 => X_E6, X_F6 => X_F6, + X_C7 => X_C7, X_D7 => X_D7, X_E7 => X_E7, X_F7 => X_F7, + X_C8 => X_C8, X_D8 => X_D8, X_E8 => X_E8, X_F8 => X_F8, + X_C9 => X_C9, X_D9 => X_D9, X_E9 => X_E9, X_F9 => X_F9, + X_CA => X_CA, X_DA => X_DA, X_EA => X_EA, X_FA => X_FA, + X_CB => X_CB, X_DB => X_DB, X_EB => X_EB, X_FB => X_FB, + X_CC => X_CC, X_DC => X_DC, X_EC => X_EC, X_FC => X_FC, + X_CD => X_CD, X_DD => X_DD, X_ED => X_ED, X_FD => X_FD, + X_CE => X_CE, X_DE => X_DE, X_EE => X_EE, X_FE => X_FE, + X_CF => X_CF, X_DF => X_DF, X_EF => X_EF, X_FF => X_FF, + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + --------------------------------------- + -- Definitions for No Upper Half Set -- + --------------------------------------- + + -- The no upper half set allows no upper half characters as letters, and + -- thus there are no upper/lower case equivalences in this half. This set + -- corresponds to the Ada 83 rules. + + Fold_No_Upper_Half : Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + + -- Set Fold_Upper table from source code indication + + if Identifier_Character_Set = '1' + or else Identifier_Character_Set = 'w' + then + Fold_Upper := Fold_Latin_1; + + elsif Identifier_Character_Set = '2' then + Fold_Upper := Fold_Latin_2; + + elsif Identifier_Character_Set = '3' then + Fold_Upper := Fold_Latin_3; + + elsif Identifier_Character_Set = '4' then + Fold_Upper := Fold_Latin_4; + + elsif Identifier_Character_Set = 'p' then + Fold_Upper := Fold_IBM_PC_437; + + elsif Identifier_Character_Set = '8' then + Fold_Upper := Fold_IBM_PC_850; + + elsif Identifier_Character_Set = 'f' then + Fold_Upper := Fold_Full_Upper_Half; + + else -- Identifier_Character_Set = 'n' + Fold_Upper := Fold_No_Upper_Half; + end if; + + -- Use Fold_Upper table to compute Fold_Lower table + + Fold_Lower := Fold_Upper; + + for J in Character loop + if J /= Fold_Upper (J) then + Fold_Lower (Fold_Upper (J)) := J; + Fold_Lower (J) := J; + end if; + end loop; + + Fold_Lower (' ') := ' '; + + -- Build Identifier_Char table from used entries of Fold_Upper + + for J in Character loop + Identifier_Char (J) := (Fold_Upper (J) /= ' '); + end loop; + + -- Always add [ as an identifier character to deal with the brackets + -- notation for wide characters used in identifiers. Note that if + -- we are not allowing wide characters in identifiers, then any use + -- of this notation will be flagged as an error in Scan_Identifier. + + Identifier_Char ('[') := True; + + -- Add entry for ESC if wide characters in use with a wide character + -- encoding method active that uses the ESC code for encoding. Also + -- add entry for left bracket to capture use of brackets notation. + + if Identifier_Character_Set = 'w' + and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method + then + Identifier_Char (ASCII.ESC) := True; + end if; + end Initialize; + + -------------------------- + -- Is_Lower_Case_Letter -- + -------------------------- + + function Is_Lower_Case_Letter (C : Character) return Boolean is + begin + return C /= Fold_Upper (C); + end Is_Lower_Case_Letter; + + -------------------------- + -- Is_Upper_Case_Letter -- + -------------------------- + + function Is_Upper_Case_Letter (C : Character) return Boolean is + begin + return C /= Fold_Lower (C); + end Is_Upper_Case_Letter; + +end Csets; diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads new file mode 100644 index 00000000000..8ed7fb1dac4 --- /dev/null +++ b/gcc/ada/csets.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S E T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.16 $ -- +-- -- +-- Copyright (C) 1992-1997 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package Csets is +pragma Elaborate_Body (Csets); + + -- This package contains character tables for the various character + -- sets that are supported for source representation. Character and + -- string literals are not affected, only identifiers. For each set, + -- the table in this package gives the mapping of letters to their + -- upper case equivalent. Each table thus provides the information + -- for building the table used to fold lower case to upper case, and + -- also the table of flags showing which characters are allowed in + -- identifiers. + + type Translate_Table is array (Character) of Character; + -- Type used to describe translate tables + + type Char_Array_Flags is array (Character) of Boolean; + -- Type used for character attribute arrays. Note that we deliberately + -- do NOT pack this table, since we don't want the extra overhead of + -- accessing a packed bit string. + + ----------------------------------------------- + -- Character Tables For Current Compilation -- + ----------------------------------------------- + + procedure Initialize; + -- Routine to initialize following character tables, whose content depends + -- on the character code being used to represent the source program. In + -- particular, the use of the upper half of the 8-bit code set varies. + -- The character set in use is specified by the value stored in + -- Opt.Identifier_Character_Set, which has the following settings: + + -- '1' Latin-1 + -- '2' Latin-2 + -- '3' Latin-3 + -- '4' Latin-4 + -- 'p' IBM PC (code page 437) + -- '8' IBM PC (code page 850) + -- 'f' Full upper set (all distinct) + -- 'n' No upper characters (Ada/83 rules) + -- 'w' Latin-1 plus wide characters also allowed + + function Is_Upper_Case_Letter (C : Character) return Boolean; + pragma Inline (Is_Upper_Case_Letter); + -- Determine if character is upper case letter + + function Is_Lower_Case_Letter (C : Character) return Boolean; + pragma Inline (Is_Lower_Case_Letter); + -- Determine if character is lower case letter + + Fold_Upper : Translate_Table; + -- Table to fold lower case identifier letters to upper case + + Fold_Lower : Translate_Table; + -- Table to fold upper case identifier letters to lower case + + Identifier_Char : Char_Array_Flags; + -- This table has True entries for all characters that can legally appear + -- in identifiers, including digits, the underline character, all letters + -- including upper and lower case and extended letters (as controlled by + -- the setting of Opt.Identifier_Character_Set, left bracket for brackets + -- notation wide characters and also ESC if wide characters are permitted + -- in identifiers using escape sequences starting with ESC. + +end Csets; diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb new file mode 100644 index 00000000000..5f167fb3b0c --- /dev/null +++ b/gcc/ada/cstand.adb @@ -0,0 +1,1518 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S T A N D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.213 $ +-- -- +-- Copyright (C) 1992-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 Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Layout; use Layout; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Ttypef; use Ttypef; +with Sem_Mech; use Sem_Mech; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body CStand is + + Stloc : constant Source_Ptr := Standard_Location; + Staloc : constant Source_Ptr := Standard_ASCII_Location; + -- Standard abbreviations used throughout this package + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Build_Float_Type (E : Entity_Id; Siz : Int; Digs : Int); + -- Procedure to build standard predefined float base type. The first + -- parameter is the entity for the type, and the second parameter + -- is the size in bits. The third parameter is the digits value. + + procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int); + -- Procedure to build standard predefined signed integer subtype. The + -- first parameter is the entity for the subtype. The second parameter + -- is the size in bits. The corresponding base type is not built by + -- this routine but instead must be built by the caller where needed. + + procedure Create_Operators; + -- Make entries for each of the predefined operators in Standard + + procedure Create_Unconstrained_Base_Type + (E : Entity_Id; + K : Entity_Kind); + -- The predefined signed integer types are constrained subtypes which + -- must have a corresponding unconstrained base type. This type is almost + -- useless. The only place it has semantics is Subtypes_Statically_Match. + -- Consequently, we arrange for it to be identical apart from the setting + -- of the constrained bit. This routine takes an entity E for the Type, + -- copies it to estabish the base type, then resets the Ekind of the + -- original entity to K (the Ekind for the subtype). The Etype field of + -- E is set by the call (to point to the created base type entity), and + -- also the Is_Constrained flag of E is set. + -- + -- To understand the exact requirement for this, see RM 3.5.4(11) which + -- makes it clear that Integer, for example, is constrained, with the + -- constraint bounds matching the bounds of the (unconstrained) base + -- type. The point is that Integer and Integer'Base have identical + -- bounds, but do not statically match, since a subtype with constraints + -- never matches a subtype with no constraints. + + function Identifier_For (S : Standard_Entity_Type) return Node_Id; + -- Returns an identifier node with the same name as the defining + -- identifier corresponding to the given Standard_Entity_Type value + + procedure Make_Component + (Rec : Entity_Id; + Typ : Entity_Id; + Nam : String); + -- Build a record component with the given type and name, and append to + -- the list of components of Rec. + + function Make_Formal + (Typ : Entity_Id; + Formal_Name : String) + return Entity_Id; + -- Construct entity for subprogram formal with given name and type + + function Make_Integer (V : Uint) return Node_Id; + -- Builds integer literal with given value + + procedure Make_Name (Id : Entity_Id; Nam : String); + -- Make an entry in the names table for Nam, and set as Chars field of Id + + function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id; + -- Build entity for standard operator with given name and type. + + function New_Standard_Entity + (New_Node_Kind : Node_Kind := N_Defining_Identifier) + return Entity_Id; + -- Builds a new entity for Standard + + procedure Set_Integer_Bounds + (Id : Entity_Id; + Typ : Entity_Id; + Lb : Uint; + Hb : Uint); + -- Procedure to set bounds for integer type or subtype. Id is the entity + -- whose bounds and type are to be set. The Typ parameter is the Etype + -- value for the entity (which will be the same as Id for all predefined + -- integer base types. The third and fourth parameters are the bounds. + + ---------------------- + -- Build_Float_Type -- + ---------------------- + + procedure Build_Float_Type (E : Entity_Id; Siz : Int; Digs : Int) is + begin + Set_Type_Definition (Parent (E), + Make_Floating_Point_Definition (Stloc, + Digits_Expression => Make_Integer (UI_From_Int (Digs)))); + Set_Ekind (E, E_Floating_Point_Type); + Set_Etype (E, E); + Init_Size (E, Siz); + Set_Prim_Alignment (E); + Init_Digits_Value (E, Digs); + Set_Float_Bounds (E); + Set_Is_Frozen (E); + Set_Is_Public (E); + Set_Size_Known_At_Compile_Time (E); + end Build_Float_Type; + + ------------------------------- + -- Build_Signed_Integer_Type -- + ------------------------------- + + procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int) is + U2Siz1 : constant Uint := 2 ** (Siz - 1); + Lbound : constant Uint := -U2Siz1; + Ubound : constant Uint := U2Siz1 - 1; + + begin + Set_Type_Definition (Parent (E), + Make_Signed_Integer_Type_Definition (Stloc, + Low_Bound => Make_Integer (Lbound), + High_Bound => Make_Integer (Ubound))); + + Set_Ekind (E, E_Signed_Integer_Type); + Set_Etype (E, E); + Init_Size (E, Siz); + Set_Prim_Alignment (E); + Set_Integer_Bounds (E, E, Lbound, Ubound); + Set_Is_Frozen (E); + Set_Is_Public (E); + Set_Is_Known_Valid (E); + Set_Size_Known_At_Compile_Time (E); + end Build_Signed_Integer_Type; + + ---------------------- + -- Create_Operators -- + ---------------------- + + -- Each operator has an abbreviated signature. The formals have the names + -- LEFT and RIGHT. Their types are not actually used for resolution. + + procedure Create_Operators is + Op_Node : Entity_Id; + + -- Following list has two entries for concatenation, to include + -- explicitly the operation on wide strings. + + Binary_Ops : constant array (S_Binary_Ops) of Name_Id := + (Name_Op_Add, Name_Op_And, Name_Op_Concat, Name_Op_Concat, + Name_Op_Divide, Name_Op_Eq, Name_Op_Expon, Name_Op_Ge, + Name_Op_Gt, Name_Op_Le, Name_Op_Lt, Name_Op_Mod, + Name_Op_Multiply, Name_Op_Ne, Name_Op_Or, Name_Op_Rem, + Name_Op_Subtract, Name_Op_Xor); + + Bin_Op_Types : constant array (S_Binary_Ops) of Entity_Id := + (Universal_Integer, Standard_Boolean, + Standard_String, Standard_Wide_String, + Universal_Integer, Standard_Boolean, + Universal_Integer, Standard_Boolean, + Standard_Boolean, Standard_Boolean, + Standard_Boolean, Universal_Integer, + Universal_Integer, Standard_Boolean, + Standard_Boolean, Universal_Integer, + Universal_Integer, Standard_Boolean); + + Unary_Ops : constant array (S_Unary_Ops) of Name_Id := + (Name_Op_Abs, Name_Op_Subtract, Name_Op_Not, Name_Op_Add); + + Unary_Op_Types : constant array (S_Unary_Ops) of Entity_Id := + (Universal_Integer, Universal_Integer, + Standard_Boolean, Universal_Integer); + + -- Corresponding to Abs, Minus, Not, and Plus. + + begin + for J in S_Binary_Ops loop + Op_Node := New_Operator (Binary_Ops (J), Bin_Op_Types (J)); + SE (J) := Op_Node; + Append_Entity (Make_Formal (Any_Type, "LEFT"), Op_Node); + Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); + end loop; + + for J in S_Unary_Ops loop + Op_Node := New_Operator (Unary_Ops (J), Unary_Op_Types (J)); + SE (J) := Op_Node; + Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); + end loop; + + -- For concatenation, we create a separate operator for each + -- array type. This simplifies the resolution of the component- + -- component concatenation operation. In Standard, we set the types + -- of the formals for string and wide string concatenation. + + Set_Etype (First_Entity (Standard_Op_Concat), Standard_String); + Set_Etype (Last_Entity (Standard_Op_Concat), Standard_String); + + Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String); + Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String); + + end Create_Operators; + + --------------------- + -- Create_Standard -- + --------------------- + + -- The tree for the package Standard is prefixed to all compilations. + -- Several entities required by semantic analysis are denoted by global + -- variables that are initialized to point to the corresponding + -- occurences in STANDARD. The visible entities of STANDARD are + -- created here. The private entities defined in STANDARD are created + -- by Initialize_Standard in the semantics module. + + procedure Create_Standard is + Decl_S : List_Id; + -- List of declarations in Standard + + Decl_A : List_Id; + -- List of declarations in ASCII + + Decl : Node_Id; + Pspec : Node_Id; + Tdef_Node : Node_Id; + Ident_Node : Node_Id; + Ccode : Char_Code; + E_Id : Entity_Id; + R_Node : Node_Id; + B_Node : Node_Id; + + procedure Build_Exception (S : Standard_Entity_Type); + -- Procedure to declare given entity as an exception + + --------------------- + -- Build_Exception -- + --------------------- + + procedure Build_Exception (S : Standard_Entity_Type) is + begin + Set_Ekind (Standard_Entity (S), E_Exception); + Set_Etype (Standard_Entity (S), Standard_Exception_Type); + Set_Exception_Code (Standard_Entity (S), Uint_0); + Set_Is_Public (Standard_Entity (S), True); + + Decl := + Make_Exception_Declaration (Stloc, + Defining_Identifier => Standard_Entity (S)); + Append (Decl, Decl_S); + end Build_Exception; + + -- Start of processing for Create_Standard + + begin + Decl_S := New_List; + + -- First step is to create defining identifiers for each entity + + for S in Standard_Entity_Type loop + declare + S_Name : constant String := Standard_Entity_Type'Image (S); + -- Name of entity (note we skip S_ at the start) + + Ident_Node : Node_Id; + -- Defining identifier node + + begin + Ident_Node := New_Standard_Entity; + Make_Name (Ident_Node, S_Name (3 .. S_Name'Length)); + Standard_Entity (S) := Ident_Node; + end; + end loop; + + -- Create package declaration node for package Standard + + Standard_Package_Node := New_Node (N_Package_Declaration, Stloc); + + Pspec := New_Node (N_Package_Specification, Stloc); + Set_Specification (Standard_Package_Node, Pspec); + + Set_Defining_Unit_Name (Pspec, Standard_Standard); + Set_Visible_Declarations (Pspec, Decl_S); + + Set_Ekind (Standard_Standard, E_Package); + Set_Is_Pure (Standard_Standard); + Set_Is_Compilation_Unit (Standard_Standard); + + -- Create type declaration nodes for standard types + + for S in S_Types loop + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Entity (S)); + Set_Is_Frozen (Standard_Entity (S)); + Set_Is_Public (Standard_Entity (S)); + Append (Decl, Decl_S); + end loop; + + -- Create type definition node for type Boolean. The Size is set to + -- 1 as required by Ada 95 and current ARG interpretations for Ada/83. + + -- Note: Object_Size of Boolean is 8. This means that we do NOT in + -- general know that Boolean variables have valid values, so we do + -- not set the Is_Known_Valid flag. + + Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); + Set_Literals (Tdef_Node, New_List); + Append (Standard_False, Literals (Tdef_Node)); + Append (Standard_True, Literals (Tdef_Node)); + Set_Type_Definition (Parent (Standard_Boolean), Tdef_Node); + + Set_Ekind (Standard_Boolean, E_Enumeration_Type); + Set_First_Literal (Standard_Boolean, Standard_False); + Set_Etype (Standard_Boolean, Standard_Boolean); + Init_Esize (Standard_Boolean, 8); + Init_RM_Size (Standard_Boolean, 1); + Set_Prim_Alignment (Standard_Boolean); + + Set_Is_Unsigned_Type (Standard_Boolean); + Set_Size_Known_At_Compile_Time (Standard_Boolean); + + Set_Ekind (Standard_True, E_Enumeration_Literal); + Set_Etype (Standard_True, Standard_Boolean); + Set_Enumeration_Pos (Standard_True, Uint_1); + Set_Enumeration_Rep (Standard_True, Uint_1); + Set_Is_Known_Valid (Standard_True, True); + + Set_Ekind (Standard_False, E_Enumeration_Literal); + Set_Etype (Standard_False, Standard_Boolean); + Set_Enumeration_Pos (Standard_False, Uint_0); + Set_Enumeration_Rep (Standard_False, Uint_0); + Set_Is_Known_Valid (Standard_False, True); + + -- For the bounds of Boolean, we create a range node corresponding to + + -- range False .. True + + -- where the occurrences of the literals must point to the + -- corresponding definition. + + R_Node := New_Node (N_Range, Stloc); + B_Node := New_Node (N_Identifier, Stloc); + Set_Chars (B_Node, Chars (Standard_False)); + Set_Entity (B_Node, Standard_False); + Set_Etype (B_Node, Standard_Boolean); + Set_Is_Static_Expression (B_Node); + Set_Low_Bound (R_Node, B_Node); + + B_Node := New_Node (N_Identifier, Stloc); + Set_Chars (B_Node, Chars (Standard_True)); + Set_Entity (B_Node, Standard_True); + Set_Etype (B_Node, Standard_Boolean); + Set_Is_Static_Expression (B_Node); + Set_High_Bound (R_Node, B_Node); + + Set_Scalar_Range (Standard_Boolean, R_Node); + Set_Etype (R_Node, Standard_Boolean); + Set_Parent (R_Node, Standard_Boolean); + + -- Create type definition nodes for predefined integer types + + Build_Signed_Integer_Type + (Standard_Short_Short_Integer, Standard_Short_Short_Integer_Size); + + Build_Signed_Integer_Type + (Standard_Short_Integer, Standard_Short_Integer_Size); + + Build_Signed_Integer_Type + (Standard_Integer, Standard_Integer_Size); + + declare + LIS : Nat; + + begin + if Debug_Flag_M then + LIS := 64; + else + LIS := Standard_Long_Integer_Size; + end if; + + Build_Signed_Integer_Type (Standard_Long_Integer, LIS); + end; + + Build_Signed_Integer_Type + (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); + + Create_Unconstrained_Base_Type + (Standard_Short_Short_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Short_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Long_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Long_Long_Integer, E_Signed_Integer_Subtype); + + -- Create type definition nodes for predefined float types + + Build_Float_Type + (Standard_Short_Float, + Standard_Short_Float_Size, + Standard_Short_Float_Digits); + + Build_Float_Type + (Standard_Float, + Standard_Float_Size, + Standard_Float_Digits); + + Build_Float_Type + (Standard_Long_Float, + Standard_Long_Float_Size, + Standard_Long_Float_Digits); + + Build_Float_Type + (Standard_Long_Long_Float, + Standard_Long_Long_Float_Size, + Standard_Long_Long_Float_Digits); + + -- Create type definition node for type Character. Note that we do not + -- set the Literals field, since type Character is handled with special + -- routine that do not need a literal list. + + Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); + Set_Type_Definition (Parent (Standard_Character), Tdef_Node); + + Set_Ekind (Standard_Character, E_Enumeration_Type); + Set_Etype (Standard_Character, Standard_Character); + Init_Size (Standard_Character, Standard_Character_Size); + Set_Prim_Alignment (Standard_Character); + + Set_Is_Unsigned_Type (Standard_Character); + Set_Is_Character_Type (Standard_Character); + Set_Is_Known_Valid (Standard_Character); + Set_Size_Known_At_Compile_Time (Standard_Character); + + -- Create the bounds for type Character. + + R_Node := New_Node (N_Range, Stloc); + + -- Low bound for type Character (Standard.Nul) + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); + Set_Char_Literal_Value (B_Node, 16#00#); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Character); + Set_Low_Bound (R_Node, B_Node); + + -- High bound for type Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); + Set_Char_Literal_Value (B_Node, 16#FF#); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Character); + Set_High_Bound (R_Node, B_Node); + + Set_Scalar_Range (Standard_Character, R_Node); + Set_Etype (R_Node, Standard_Character); + Set_Parent (R_Node, Standard_Character); + + -- Create type definition for type Wide_Character. Note that we do not + -- set the Literals field, since type Wide_Character is handled with + -- special routines that do not need a literal list. + + Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); + Set_Type_Definition (Parent (Standard_Wide_Character), Tdef_Node); + + Set_Ekind (Standard_Wide_Character, E_Enumeration_Type); + Set_Etype (Standard_Wide_Character, Standard_Wide_Character); + Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size); + + Set_Prim_Alignment (Standard_Wide_Character); + Set_Is_Unsigned_Type (Standard_Wide_Character); + Set_Is_Character_Type (Standard_Wide_Character); + Set_Is_Known_Valid (Standard_Wide_Character); + Set_Size_Known_At_Compile_Time (Standard_Wide_Character); + + -- Create the bounds for type Wide_Character. + + R_Node := New_Node (N_Range, Stloc); + + -- Low bound for type Wide_Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); -- ??? + Set_Char_Literal_Value (B_Node, 16#0000#); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Wide_Character); + Set_Low_Bound (R_Node, B_Node); + + -- High bound for type Wide_Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); -- ??? + Set_Char_Literal_Value (B_Node, 16#FFFF#); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Wide_Character); + Set_High_Bound (R_Node, B_Node); + + Set_Scalar_Range (Standard_Wide_Character, R_Node); + Set_Etype (R_Node, Standard_Wide_Character); + Set_Parent (R_Node, Standard_Wide_Character); + + -- Create type definition node for type String + + Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); + Set_Subtype_Indication (Tdef_Node, Identifier_For (S_Character)); + Set_Subtype_Marks (Tdef_Node, New_List); + Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); + Set_Type_Definition (Parent (Standard_String), Tdef_Node); + + Set_Ekind (Standard_String, E_String_Type); + Set_Etype (Standard_String, Standard_String); + Set_Component_Type (Standard_String, Standard_Character); + Set_Component_Size (Standard_String, Uint_8); + Init_Size_Align (Standard_String); + + -- Set index type of String + + E_Id := First + (Subtype_Marks (Type_Definition (Parent (Standard_String)))); + Set_First_Index (Standard_String, E_Id); + Set_Entity (E_Id, Standard_Positive); + Set_Etype (E_Id, Standard_Positive); + + -- Create type definition node for type Wide_String + + Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); + Set_Subtype_Indication (Tdef_Node, Identifier_For (S_Wide_Character)); + Set_Subtype_Marks (Tdef_Node, New_List); + Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); + Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); + + Set_Ekind (Standard_Wide_String, E_String_Type); + Set_Etype (Standard_Wide_String, Standard_Wide_String); + Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); + Set_Component_Size (Standard_Wide_String, Uint_16); + Init_Size_Align (Standard_Wide_String); + + -- Set index type of Wide_String + + E_Id := First + (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String)))); + Set_First_Index (Standard_Wide_String, E_Id); + Set_Entity (E_Id, Standard_Positive); + Set_Etype (E_Id, Standard_Positive); + + -- Create subtype declaration for Natural + + Decl := New_Node (N_Subtype_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Natural); + Set_Subtype_Indication (Decl, + New_Occurrence_Of (Standard_Integer, Stloc)); + Append (Decl, Decl_S); + + Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype); + Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); + Init_Esize (Standard_Natural, Standard_Integer_Size); + Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1); + Set_Prim_Alignment (Standard_Natural); + Set_Size_Known_At_Compile_Time + (Standard_Natural); + Set_Integer_Bounds (Standard_Natural, + Typ => Base_Type (Standard_Integer), + Lb => Uint_0, + Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); + Set_Is_Constrained (Standard_Natural); + Set_Is_Frozen (Standard_Natural); + Set_Is_Public (Standard_Natural); + + -- Create subtype declaration for Positive + + Decl := New_Node (N_Subtype_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Positive); + Set_Subtype_Indication (Decl, + New_Occurrence_Of (Standard_Integer, Stloc)); + Append (Decl, Decl_S); + + Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype); + Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); + Init_Esize (Standard_Positive, Standard_Integer_Size); + Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1); + Set_Prim_Alignment (Standard_Positive); + + Set_Size_Known_At_Compile_Time (Standard_Positive); + + Set_Integer_Bounds (Standard_Positive, + Typ => Base_Type (Standard_Integer), + Lb => Uint_1, + Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); + Set_Is_Constrained (Standard_Positive); + Set_Is_Frozen (Standard_Positive); + Set_Is_Public (Standard_Positive); + + -- Create declaration for package ASCII + + Decl := New_Node (N_Package_Declaration, Stloc); + Append (Decl, Decl_S); + + Pspec := New_Node (N_Package_Specification, Stloc); + Set_Specification (Decl, Pspec); + + Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII)); + Set_Ekind (Standard_Entity (S_ASCII), E_Package); + Decl_A := New_List; -- for ASCII declarations + Set_Visible_Declarations (Pspec, Decl_A); + + -- Create control character definitions in package ASCII. Note that + -- the character literal entries created here correspond to literal + -- values that are impossible in the source, but can be represented + -- internally with no difficulties. + + Ccode := 16#00#; + + for S in S_ASCII_Names loop + Decl := New_Node (N_Object_Declaration, Staloc); + Set_Constant_Present (Decl, True); + + declare + A_Char : Entity_Id := Standard_Entity (S); + Expr_Decl : Node_Id; + + begin + Set_Sloc (A_Char, Staloc); + Set_Ekind (A_Char, E_Constant); + Set_Not_Source_Assigned (A_Char, True); + Set_Is_True_Constant (A_Char, True); + Set_Etype (A_Char, Standard_Character); + Set_Scope (A_Char, Standard_Entity (S_ASCII)); + Set_Is_Immediately_Visible (A_Char, False); + Set_Is_Public (A_Char, True); + Set_Is_Known_Valid (A_Char, True); + + Append_Entity (A_Char, Standard_Entity (S_ASCII)); + Set_Defining_Identifier (Decl, A_Char); + + Set_Object_Definition (Decl, Identifier_For (S_Character)); + Expr_Decl := New_Node (N_Character_Literal, Staloc); + Set_Expression (Decl, Expr_Decl); + + Set_Is_Static_Expression (Expr_Decl); + Set_Chars (Expr_Decl, No_Name); + Set_Etype (Expr_Decl, Standard_Character); + Set_Char_Literal_Value (Expr_Decl, Ccode); + end; + + Append (Decl, Decl_A); + + -- Increment character code, dealing with non-contiguities + + Ccode := Ccode + 1; + + if Ccode = 16#20# then + Ccode := 16#21#; + elsif Ccode = 16#27# then + Ccode := 16#3A#; + elsif Ccode = 16#3C# then + Ccode := 16#3F#; + elsif Ccode = 16#41# then + Ccode := 16#5B#; + end if; + end loop; + + -- Create semantic phase entities + + Standard_Void_Type := New_Standard_Entity; + Set_Ekind (Standard_Void_Type, E_Void); + Set_Etype (Standard_Void_Type, Standard_Void_Type); + Init_Size_Align (Standard_Void_Type); + Set_Scope (Standard_Void_Type, Standard_Standard); + Make_Name (Standard_Void_Type, "_void_type"); + + -- The type field of packages is set to void + + Set_Etype (Standard_Standard, Standard_Void_Type); + Set_Etype (Standard_ASCII, Standard_Void_Type); + + -- Standard_A_String is actually used in generated code, so it has a + -- type name that is reasonable, but does not overlap any Ada name. + + Standard_A_String := New_Standard_Entity; + Set_Ekind (Standard_A_String, E_Access_Type); + Set_Scope (Standard_A_String, Standard_Standard); + Set_Etype (Standard_A_String, Standard_A_String); + + if Debug_Flag_6 then + Init_Size (Standard_A_String, System_Address_Size); + else + Init_Size (Standard_A_String, System_Address_Size * 2); + end if; + + Init_Alignment (Standard_A_String); + + Set_Directly_Designated_Type + (Standard_A_String, Standard_String); + Make_Name (Standard_A_String, "access_string"); + + Standard_A_Char := New_Standard_Entity; + Set_Ekind (Standard_A_Char, E_Access_Type); + Set_Scope (Standard_A_Char, Standard_Standard); + Set_Etype (Standard_A_Char, Standard_A_String); + Init_Size (Standard_A_Char, System_Address_Size); + Set_Prim_Alignment (Standard_A_Char); + + Set_Directly_Designated_Type (Standard_A_Char, Standard_Character); + Make_Name (Standard_A_Char, "access_character"); + + -- Note on type names. The type names for the following special types + -- are constructed so that they will look reasonable should they ever + -- appear in error messages etc, although in practice the use of the + -- special insertion character } for types results in special handling + -- of these type names in any case. The blanks in these names would + -- trouble in Gigi, but that's OK here, since none of these types + -- should ever get through to Gigi! Attributes of these types are + -- filled out to minimize problems with cascaded errors (for example, + -- Any_Integer is given reasonable and consistent type and size values) + + Any_Type := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Any_Type); + Set_Scope (Any_Type, Standard_Standard); + Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size); + Make_Name (Any_Type, "any type"); + + Any_Id := New_Standard_Entity; + Set_Ekind (Any_Id, E_Variable); + Set_Scope (Any_Id, Standard_Standard); + Set_Etype (Any_Id, Any_Type); + Init_Size_Align (Any_Id); + Make_Name (Any_Id, "any id"); + + Any_Access := New_Standard_Entity; + Set_Ekind (Any_Access, E_Access_Type); + Set_Scope (Any_Access, Standard_Standard); + Set_Etype (Any_Access, Any_Access); + Init_Size (Any_Access, System_Address_Size); + Set_Prim_Alignment (Any_Access); + Make_Name (Any_Access, "an access type"); + + Any_Array := New_Standard_Entity; + Set_Ekind (Any_Array, E_String_Type); + Set_Scope (Any_Array, Standard_Standard); + Set_Etype (Any_Array, Any_Array); + Set_Component_Type (Any_Array, Any_Character); + Init_Size_Align (Any_Array); + Make_Name (Any_Array, "an array type"); + + Any_Boolean := New_Standard_Entity; + Set_Ekind (Any_Boolean, E_Enumeration_Type); + Set_Scope (Any_Boolean, Standard_Standard); + Set_Etype (Any_Boolean, Standard_Boolean); + Init_Esize (Any_Boolean, 8); + Init_RM_Size (Any_Boolean, 1); + Set_Prim_Alignment (Any_Boolean); + Set_Is_Unsigned_Type (Any_Boolean); + Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean)); + Make_Name (Any_Boolean, "a boolean type"); + + Any_Character := New_Standard_Entity; + Set_Ekind (Any_Character, E_Enumeration_Type); + Set_Scope (Any_Character, Standard_Standard); + Set_Etype (Any_Character, Any_Character); + Set_Is_Unsigned_Type (Any_Character); + Set_Is_Character_Type (Any_Character); + Init_Size (Any_Character, Standard_Character_Size); + Set_Prim_Alignment (Any_Character); + Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); + Make_Name (Any_Character, "a character type"); + + Any_Composite := New_Standard_Entity; + Set_Ekind (Any_Composite, E_Array_Type); + Set_Scope (Any_Composite, Standard_Standard); + Set_Etype (Any_Composite, Any_Composite); + Set_Component_Size (Any_Composite, Uint_0); + Set_Component_Type (Any_Composite, Standard_Integer); + Init_Size_Align (Any_Composite); + Make_Name (Any_Composite, "a composite type"); + + Any_Discrete := New_Standard_Entity; + Set_Ekind (Any_Discrete, E_Signed_Integer_Type); + Set_Scope (Any_Discrete, Standard_Standard); + Set_Etype (Any_Discrete, Any_Discrete); + Init_Size (Any_Discrete, Standard_Integer_Size); + Set_Prim_Alignment (Any_Discrete); + Make_Name (Any_Discrete, "a discrete type"); + + Any_Fixed := New_Standard_Entity; + Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type); + Set_Scope (Any_Fixed, Standard_Standard); + Set_Etype (Any_Fixed, Any_Fixed); + Init_Size (Any_Fixed, Standard_Integer_Size); + Set_Prim_Alignment (Any_Fixed); + Make_Name (Any_Fixed, "a fixed-point type"); + + Any_Integer := New_Standard_Entity; + Set_Ekind (Any_Integer, E_Signed_Integer_Type); + Set_Scope (Any_Integer, Standard_Standard); + Set_Etype (Any_Integer, Standard_Long_Long_Integer); + Init_Size (Any_Integer, Standard_Long_Long_Integer_Size); + Set_Prim_Alignment (Any_Integer); + + Set_Integer_Bounds + (Any_Integer, + Typ => Base_Type (Standard_Integer), + Lb => Uint_0, + Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); + Make_Name (Any_Integer, "an integer type"); + + Any_Modular := New_Standard_Entity; + Set_Ekind (Any_Modular, E_Modular_Integer_Type); + Set_Scope (Any_Modular, Standard_Standard); + Set_Etype (Any_Modular, Standard_Long_Long_Integer); + Init_Size (Any_Modular, Standard_Long_Long_Integer_Size); + Set_Prim_Alignment (Any_Modular); + Set_Is_Unsigned_Type (Any_Modular); + Make_Name (Any_Modular, "a modular type"); + + Any_Numeric := New_Standard_Entity; + Set_Ekind (Any_Numeric, E_Signed_Integer_Type); + Set_Scope (Any_Numeric, Standard_Standard); + Set_Etype (Any_Numeric, Standard_Long_Long_Integer); + Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size); + Set_Prim_Alignment (Any_Numeric); + Make_Name (Any_Numeric, "a numeric type"); + + Any_Real := New_Standard_Entity; + Set_Ekind (Any_Real, E_Floating_Point_Type); + Set_Scope (Any_Real, Standard_Standard); + Set_Etype (Any_Real, Standard_Long_Long_Float); + Init_Size (Any_Real, Standard_Long_Long_Float_Size); + Set_Prim_Alignment (Any_Real); + Make_Name (Any_Real, "a real type"); + + Any_Scalar := New_Standard_Entity; + Set_Ekind (Any_Scalar, E_Signed_Integer_Type); + Set_Scope (Any_Scalar, Standard_Standard); + Set_Etype (Any_Scalar, Any_Scalar); + Init_Size (Any_Scalar, Standard_Integer_Size); + Set_Prim_Alignment (Any_Scalar); + Make_Name (Any_Scalar, "a scalar type"); + + Any_String := New_Standard_Entity; + Set_Ekind (Any_String, E_String_Type); + Set_Scope (Any_String, Standard_Standard); + Set_Etype (Any_String, Any_String); + Set_Component_Type (Any_String, Any_Character); + Init_Size_Align (Any_String); + Make_Name (Any_String, "a string type"); + + declare + Index : Node_Id; + Indexes : List_Id; + + begin + Index := + Make_Range (Stloc, + Low_Bound => Make_Integer (Uint_0), + High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size)); + Indexes := New_List (Index); + Set_Etype (Index, Standard_Integer); + Set_First_Index (Any_String, Index); + end; + + Standard_Integer_8 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_8); + Make_Name (Standard_Integer_8, "integer_8"); + Set_Scope (Standard_Integer_8, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_8, 8); + + Standard_Integer_16 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_16); + Make_Name (Standard_Integer_16, "integer_16"); + Set_Scope (Standard_Integer_16, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_16, 16); + + Standard_Integer_32 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_32); + Make_Name (Standard_Integer_32, "integer_32"); + Set_Scope (Standard_Integer_32, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_32, 32); + + Standard_Integer_64 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_64); + Make_Name (Standard_Integer_64, "integer_64"); + Set_Scope (Standard_Integer_64, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_64, 64); + + Standard_Unsigned := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Unsigned); + Make_Name (Standard_Unsigned, "unsigned"); + + Set_Ekind (Standard_Unsigned, E_Modular_Integer_Type); + Set_Scope (Standard_Unsigned, Standard_Standard); + Set_Etype (Standard_Unsigned, Standard_Unsigned); + Init_Size (Standard_Unsigned, Standard_Integer_Size); + Set_Prim_Alignment (Standard_Unsigned); + Set_Modulus (Standard_Unsigned, + Uint_2 ** Standard_Integer_Size); + + Set_Is_Unsigned_Type (Standard_Unsigned); + + R_Node := New_Node (N_Range, Stloc); + Set_Low_Bound (R_Node, + Make_Integer_Literal (Stloc, 0)); + Set_High_Bound (R_Node, + Make_Integer_Literal (Stloc, Modulus (Standard_Unsigned))); + Set_Scalar_Range (Standard_Unsigned, R_Node); + + -- Note: universal integer and universal real are constructed as fully + -- formed signed numeric types, with parameters corresponding to the + -- longest runtime types (Long_Long_Integer and Long_Long_Float). This + -- allows Gigi to properly process references to universal types that + -- are not folded at compile time. + + Universal_Integer := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Universal_Integer); + Make_Name (Universal_Integer, "universal_integer"); + Set_Scope (Universal_Integer, Standard_Standard); + Build_Signed_Integer_Type + (Universal_Integer, Standard_Long_Long_Integer_Size); + + Universal_Real := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Universal_Real); + Make_Name (Universal_Real, "universal_real"); + Set_Scope (Universal_Real, Standard_Standard); + Build_Float_Type + (Universal_Real, + Standard_Long_Long_Float_Size, + Standard_Long_Long_Float_Digits); + + -- Note: universal fixed, unlike universal integer and universal real, + -- is never used at runtime, so it does not need to have bounds set. + + Universal_Fixed := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Universal_Fixed); + Make_Name (Universal_Fixed, "universal_fixed"); + Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type); + Set_Etype (Universal_Fixed, Universal_Fixed); + Set_Scope (Universal_Fixed, Standard_Standard); + Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size); + Set_Prim_Alignment (Universal_Fixed); + Set_Size_Known_At_Compile_Time + (Universal_Fixed); + + -- Create type declaration for Duration, using a 64-bit size. + -- Delta is 1 nanosecond. + + Build_Duration : declare + Dlo : constant Uint := Intval (Type_Low_Bound (Standard_Integer_64)); + Dhi : constant Uint := Intval (Type_High_Bound (Standard_Integer_64)); + + Delta_Val : constant Ureal := UR_From_Components (Uint_1, Uint_9, 10); + + begin + Decl := + Make_Full_Type_Declaration (Stloc, + Defining_Identifier => Standard_Duration, + Type_Definition => + Make_Ordinary_Fixed_Point_Definition (Stloc, + Delta_Expression => Make_Real_Literal (Stloc, Delta_Val), + Real_Range_Specification => + Make_Real_Range_Specification (Stloc, + Low_Bound => Make_Real_Literal (Stloc, + Realval => Dlo * Delta_Val), + High_Bound => Make_Real_Literal (Stloc, + Realval => Dhi * Delta_Val)))); + + Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type); + Set_Etype (Standard_Duration, Standard_Duration); + Init_Size (Standard_Duration, 64); + Set_Prim_Alignment (Standard_Duration); + Set_Delta_Value (Standard_Duration, Delta_Val); + Set_Small_Value (Standard_Duration, Delta_Val); + Set_Scalar_Range (Standard_Duration, + Real_Range_Specification + (Type_Definition (Decl))); + + -- Normally it does not matter that nodes in package Standard are + -- not marked as analyzed. The Scalar_Range of the fixed-point + -- type Standard_Duration is an exception, because of the special + -- test made in Freeze.Freeze_Fixed_Point_Type. + + Set_Analyzed (Scalar_Range (Standard_Duration)); + + Set_Etype (Type_High_Bound (Standard_Duration), Standard_Duration); + Set_Etype (Type_Low_Bound (Standard_Duration), Standard_Duration); + + Set_Is_Static_Expression (Type_High_Bound (Standard_Duration)); + Set_Is_Static_Expression (Type_Low_Bound (Standard_Duration)); + + Set_Corresponding_Integer_Value + (Type_High_Bound (Standard_Duration), Dhi); + + Set_Corresponding_Integer_Value + (Type_Low_Bound (Standard_Duration), Dlo); + + Set_Size_Known_At_Compile_Time (Standard_Duration); + end Build_Duration; + + -- Build standard exception type. Note that the type name here is + -- actually used in the generated code, so it must be set correctly + + Standard_Exception_Type := New_Standard_Entity; + Set_Ekind (Standard_Exception_Type, E_Record_Type); + Set_Etype (Standard_Exception_Type, Standard_Exception_Type); + Set_Scope (Standard_Exception_Type, Standard_Standard); + Set_Girder_Constraint + (Standard_Exception_Type, No_Elist); + Init_Size_Align (Standard_Exception_Type); + Set_Size_Known_At_Compile_Time + (Standard_Exception_Type, True); + Make_Name (Standard_Exception_Type, "exception"); + + Make_Component (Standard_Exception_Type, Standard_Boolean, + "Not_Handled_By_Others"); + Make_Component (Standard_Exception_Type, Standard_Character, "Lang"); + Make_Component (Standard_Exception_Type, Standard_Natural, + "Name_Length"); + Make_Component (Standard_Exception_Type, Standard_A_Char, + "Full_Name"); + Make_Component (Standard_Exception_Type, Standard_A_Char, + "HTable_Ptr"); + Make_Component (Standard_Exception_Type, Standard_Integer, + "Import_Code"); + + -- Build tree for record declaration, for use by the back-end. + + declare + Comp_List : List_Id; + Comp : Entity_Id; + + begin + Comp := First_Entity (Standard_Exception_Type); + Comp_List := New_List; + + while Present (Comp) loop + Append ( + Make_Component_Declaration (Stloc, + Defining_Identifier => Comp, + Subtype_Indication => New_Occurrence_Of (Etype (Comp), Stloc)), + Comp_List); + + Next_Entity (Comp); + end loop; + + Decl := Make_Full_Type_Declaration (Stloc, + Defining_Identifier => Standard_Exception_Type, + Type_Definition => + Make_Record_Definition (Stloc, + End_Label => Empty, + Component_List => + Make_Component_List (Stloc, + Component_Items => Comp_List))); + end; + + Append (Decl, Decl_S); + + -- Create declarations of standard exceptions + + Build_Exception (S_Constraint_Error); + Build_Exception (S_Program_Error); + Build_Exception (S_Storage_Error); + Build_Exception (S_Tasking_Error); + + -- Numeric_Error is a normal exception in Ada 83, but in Ada 95 + -- it is a renaming of Constraint_Error + + if Ada_83 then + Build_Exception (S_Numeric_Error); + + else + Decl := New_Node (N_Exception_Renaming_Declaration, Stloc); + E_Id := Standard_Entity (S_Numeric_Error); + + Set_Ekind (E_Id, E_Exception); + Set_Exception_Code (E_Id, Uint_0); + Set_Etype (E_Id, Standard_Exception_Type); + Set_Is_Public (E_Id); + Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error)); + + Set_Defining_Identifier (Decl, E_Id); + Append (Decl, Decl_S); + + Ident_Node := New_Node (N_Identifier, Stloc); + Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); + Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); + Set_Name (Decl, Ident_Node); + end if; + + -- Abort_Signal is an entity that does not get made visible + + Abort_Signal := New_Standard_Entity; + Set_Chars (Abort_Signal, Name_uAbort_Signal); + Set_Ekind (Abort_Signal, E_Exception); + Set_Exception_Code (Abort_Signal, Uint_0); + Set_Etype (Abort_Signal, Standard_Exception_Type); + Set_Scope (Abort_Signal, Standard_Standard); + Set_Is_Public (Abort_Signal, True); + Decl := + Make_Exception_Declaration (Stloc, + Defining_Identifier => Abort_Signal); + + -- Create defining identifiers for shift operator entities. Note + -- that these entities are used only for marking shift operators + -- generated internally, and hence need no structure, just a name + -- and a unique identity. + + Standard_Op_Rotate_Left := New_Standard_Entity; + Set_Chars (Standard_Op_Rotate_Left, Name_Rotate_Left); + Set_Ekind (Standard_Op_Rotate_Left, E_Operator); + + Standard_Op_Rotate_Right := New_Standard_Entity; + Set_Chars (Standard_Op_Rotate_Right, Name_Rotate_Right); + Set_Ekind (Standard_Op_Rotate_Right, E_Operator); + + Standard_Op_Shift_Left := New_Standard_Entity; + Set_Chars (Standard_Op_Shift_Left, Name_Shift_Left); + Set_Ekind (Standard_Op_Shift_Left, E_Operator); + + Standard_Op_Shift_Right := New_Standard_Entity; + Set_Chars (Standard_Op_Shift_Right, Name_Shift_Right); + Set_Ekind (Standard_Op_Shift_Right, E_Operator); + + Standard_Op_Shift_Right_Arithmetic := New_Standard_Entity; + Set_Chars (Standard_Op_Shift_Right_Arithmetic, + Name_Shift_Right_Arithmetic); + Set_Ekind (Standard_Op_Shift_Right_Arithmetic, + E_Operator); + + -- Create standard operator declarations + + Create_Operators; + + -- Initialize visibility table with entities in Standard + + for E in Standard_Entity_Type loop + if Ekind (Standard_Entity (E)) /= E_Operator then + Set_Name_Entity_Id + (Chars (Standard_Entity (E)), Standard_Entity (E)); + Set_Homonym (Standard_Entity (E), Empty); + end if; + + if E not in S_ASCII_Names then + Set_Scope (Standard_Entity (E), Standard_Standard); + Set_Is_Immediately_Visible (Standard_Entity (E)); + end if; + end loop; + + -- The predefined package Standard itself does not have a scope; + -- it is the only entity in the system not to have one, and this + -- is what identifies the package to Gigi. + + Set_Scope (Standard_Standard, Empty); + + -- Set global variables indicating last Id values and version + + Last_Standard_Node_Id := Last_Node_Id; + Last_Standard_List_Id := Last_List_Id; + + end Create_Standard; + + ------------------------------------ + -- Create_Unconstrained_Base_Type -- + ------------------------------------ + + procedure Create_Unconstrained_Base_Type + (E : Entity_Id; + K : Entity_Kind) + is + New_Ent : constant Entity_Id := New_Copy (E); + + begin + Set_Ekind (E, K); + Set_Is_Constrained (E, True); + Set_Etype (E, New_Ent); + + Append_Entity (New_Ent, Standard_Standard); + Set_Is_Constrained (New_Ent, False); + Set_Etype (New_Ent, New_Ent); + Set_Is_Known_Valid (New_Ent, True); + + if K = E_Signed_Integer_Subtype then + Set_Etype (Low_Bound (Scalar_Range (E)), New_Ent); + Set_Etype (High_Bound (Scalar_Range (E)), New_Ent); + end if; + + end Create_Unconstrained_Base_Type; + + -------------------- + -- Identifier_For -- + -------------------- + + function Identifier_For (S : Standard_Entity_Type) return Node_Id is + Ident_Node : Node_Id; + + begin + Ident_Node := New_Node (N_Identifier, Stloc); + Set_Chars (Ident_Node, Chars (Standard_Entity (S))); + return Ident_Node; + end Identifier_For; + + -------------------- + -- Make_Component -- + -------------------- + + procedure Make_Component + (Rec : Entity_Id; + Typ : Entity_Id; + Nam : String) + is + Id : Entity_Id := New_Standard_Entity; + + begin + Set_Ekind (Id, E_Component); + Set_Etype (Id, Typ); + Set_Scope (Id, Rec); + Init_Component_Location (Id); + + Set_Original_Record_Component (Id, Id); + Make_Name (Id, Nam); + Append_Entity (Id, Rec); + end Make_Component; + + ----------------- + -- Make_Formal -- + ----------------- + + function Make_Formal + (Typ : Entity_Id; + Formal_Name : String) + return Entity_Id + is + Formal : Entity_Id; + + begin + Formal := New_Standard_Entity; + + Set_Ekind (Formal, E_In_Parameter); + Set_Mechanism (Formal, Default_Mechanism); + Set_Scope (Formal, Standard_Standard); + Set_Etype (Formal, Typ); + Make_Name (Formal, Formal_Name); + + return Formal; + end Make_Formal; + + ------------------ + -- Make_Integer -- + ------------------ + + function Make_Integer (V : Uint) return Node_Id is + N : constant Node_Id := Make_Integer_Literal (Stloc, V); + + begin + Set_Is_Static_Expression (N); + return N; + end Make_Integer; + + --------------- + -- Make_Name -- + --------------- + + procedure Make_Name (Id : Entity_Id; Nam : String) is + begin + for J in 1 .. Nam'Length loop + Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1))); + end loop; + + Name_Len := Nam'Length; + Set_Chars (Id, Name_Find); + end Make_Name; + + ------------------ + -- New_Operator -- + ------------------ + + function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id is + Ident_Node : Entity_Id; + + begin + Ident_Node := Make_Defining_Identifier (Stloc, Op); + + Set_Is_Pure (Ident_Node, True); + Set_Ekind (Ident_Node, E_Operator); + Set_Etype (Ident_Node, Typ); + Set_Scope (Ident_Node, Standard_Standard); + Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op)); + Set_Convention (Ident_Node, Convention_Intrinsic); + + Set_Is_Immediately_Visible (Ident_Node, True); + Set_Is_Intrinsic_Subprogram (Ident_Node, True); + + Set_Name_Entity_Id (Op, Ident_Node); + Append_Entity (Ident_Node, Standard_Standard); + return Ident_Node; + end New_Operator; + + ------------------------- + -- New_Standard_Entity -- + ------------------------- + + function New_Standard_Entity + (New_Node_Kind : Node_Kind := N_Defining_Identifier) + return Entity_Id + is + E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc); + + begin + -- All standard entities are Pure and Public + + Set_Is_Pure (E); + Set_Is_Public (E); + + -- All standard entity names are analyzed manually, and are thus + -- frozen as soon as they are created. + + Set_Is_Frozen (E); + + -- Set debug information required for all standard types + + Set_Needs_Debug_Info (E); + + -- All standard entities are built with fully qualified names, so + -- set the flag to prevent an abortive attempt at requalification! + + Set_Has_Qualified_Name (E); + + -- Return newly created entity to be completed by caller + + return E; + end New_Standard_Entity; + + ---------------------- + -- Set_Float_Bounds -- + ---------------------- + + procedure Set_Float_Bounds (Id : Entity_Id) is + L : Node_Id; + -- Low bound of literal value + + H : Node_Id; + -- High bound of literal value + + R : Node_Id; + -- Range specification + + Digs : constant Nat := UI_To_Int (Digits_Value (Id)); + -- Digits value, used to select bounds + + begin + -- Note: for the call from Cstand to initially create the types in + -- Standard, Vax_Float will always be False. Circuitry in Sem_Vfpt + -- will adjust these types appropriately in the Vax_Float case if + -- a pragma Float_Representation (VAX_Float) is used. + + if Vax_Float (Id) then + if Digs = VAXFF_Digits then + L := Real_Convert + (VAXFF_First'Universal_Literal_String); + H := Real_Convert + (VAXFF_Last'Universal_Literal_String); + + elsif Digs = VAXDF_Digits then + L := Real_Convert + (VAXDF_First'Universal_Literal_String); + H := Real_Convert + (VAXDF_Last'Universal_Literal_String); + + else + pragma Assert (Digs = VAXGF_Digits); + + L := Real_Convert + (VAXGF_First'Universal_Literal_String); + H := Real_Convert + (VAXGF_Last'Universal_Literal_String); + end if; + + elsif Is_AAMP_Float (Id) then + if Digs = AAMPS_Digits then + L := Real_Convert + (AAMPS_First'Universal_Literal_String); + H := Real_Convert + (AAMPS_Last'Universal_Literal_String); + + else + pragma Assert (Digs = AAMPL_Digits); + L := Real_Convert + (AAMPL_First'Universal_Literal_String); + H := Real_Convert + (AAMPL_Last'Universal_Literal_String); + end if; + + elsif Digs = IEEES_Digits then + L := Real_Convert + (IEEES_First'Universal_Literal_String); + H := Real_Convert + (IEEES_Last'Universal_Literal_String); + + elsif Digs = IEEEL_Digits then + L := Real_Convert + (IEEEL_First'Universal_Literal_String); + H := Real_Convert + (IEEEL_Last'Universal_Literal_String); + + else + pragma Assert (Digs = IEEEX_Digits); + + L := Real_Convert + (IEEEX_First'Universal_Literal_String); + H := Real_Convert + (IEEEX_Last'Universal_Literal_String); + end if; + + Set_Etype (L, Id); + Set_Is_Static_Expression (L); + + Set_Etype (H, Id); + Set_Is_Static_Expression (H); + + R := New_Node (N_Range, Stloc); + Set_Low_Bound (R, L); + Set_High_Bound (R, H); + Set_Includes_Infinities (R, True); + Set_Scalar_Range (Id, R); + Set_Etype (R, Id); + Set_Parent (R, Id); + end Set_Float_Bounds; + + ------------------------ + -- Set_Integer_Bounds -- + ------------------------ + + procedure Set_Integer_Bounds + (Id : Entity_Id; + Typ : Entity_Id; + Lb : Uint; + Hb : Uint) + is + L : Node_Id; -- Low bound of literal value + H : Node_Id; -- High bound of literal value + R : Node_Id; -- Range specification + + begin + L := Make_Integer (Lb); + H := Make_Integer (Hb); + + Set_Etype (L, Typ); + Set_Etype (H, Typ); + + R := New_Node (N_Range, Stloc); + Set_Low_Bound (R, L); + Set_High_Bound (R, H); + Set_Scalar_Range (Id, R); + Set_Etype (R, Typ); + Set_Parent (R, Id); + Set_Is_Unsigned_Type (Id, Lb >= 0); + end Set_Integer_Bounds; + +end CStand; diff --git a/gcc/ada/cstand.ads b/gcc/ada/cstand.ads new file mode 100644 index 00000000000..5a344928f73 --- /dev/null +++ b/gcc/ada/cstand.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S T A N D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the procedure that is used to create the tree for +-- package Standard and initialize the entities in package Stand. + +with Types; use Types; + +package CStand is + + procedure Create_Standard; + -- This procedure creates the tree for package standard, and initializes + -- the Standard_Entities array and Standard_Package_Node. First the + -- syntactic representation is created (as though the parser had parsed + -- a copy of the source of Standard) and then semantic information is + -- added as it would be by the semantic phases of the compiler. The + -- tree is in the standard format defined by Syntax_Info, except that + -- all Sloc values are set to Standard_Location except for nodes that + -- are part of package ASCII, which have Sloc = Standard_ASCII_Location. + -- The semantics info is in the format given by Entity_Info. The global + -- variables Last_Standard_Node_Id and Last_Standard_List_Id are also set. + + procedure Set_Float_Bounds (Id : Entity_Id); + -- Procedure to set bounds for float type or subtype. Id is the entity + -- whose bounds and type are to be set (a floating-point type). + +end CStand; diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c new file mode 100644 index 00000000000..7dd5557513c --- /dev/null +++ b/gcc/ada/cstreams.c @@ -0,0 +1,247 @@ +/**************************************************************************** + * * + * GNAT RUN-TIME COMPONENTS * + * * + * C S T R E A M S * + * * + * Auxiliary C functions for Interfaces.C.Streams * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +/* Routines required for implementing routines in Interfaces.C.Streams */ + +#ifdef __vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include <sys/stat.h> +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +#ifdef __EMX__ +int max_path_len = _MAX_PATH; +#elif defined (VMS) +#include <unixlib.h> +int max_path_len = 255; /* PATH_MAX */ + +#elif defined (__vxworks) || defined (__OPENNT) + +int max_path_len = PATH_MAX; + +#else + +#ifdef linux + +/* Don't use macros on linux since they cause incompatible changes between + glibc 2.0 and 2.1 */ + +#ifdef stderr +# undef stderr +#endif +#ifdef stdin +# undef stdin +#endif +#ifdef stdout +# undef stdout +#endif + +#endif + +#include <sys/param.h> + +int max_path_len = MAXPATHLEN; +#endif + +/* The _IONBF value in CYGNUS or MINGW32 stdio.h is wrong. */ +#if defined (WINNT) || defined (_WINNT) +#undef _IONBF +#define _IONBF 0004 +#endif + + +int +__gnat_feof (stream) + FILE *stream; +{ + return (feof (stream)); +} + +int +__gnat_ferror (stream) + FILE *stream; +{ + return (ferror (stream)); +} + +int +__gnat_fileno (stream) + FILE *stream; +{ + return (fileno (stream)); +} + +int +__gnat_is_regular_file_fd (fd) + int fd; +{ + int ret; + struct stat statbuf; + +#ifdef __EMX__ + /* Programs using screen I/O may need to reset the FPU after + initialization of screen-handling related DLL's, so force + DLL initialization by doing a null-write and then reset the FPU */ + + DosWrite (0, &ret, 0, &ret); + __gnat_init_float(); +#endif + + ret = fstat (fd, &statbuf); + return (!ret && S_ISREG (statbuf.st_mode)); +} + +/* on some systems, the constants for seek are not defined, if so, then + provide the conventional definitions */ + +#ifndef SEEK_SET +#define SEEK_SET 0 /* Set file pointer to offset */ +#define SEEK_CUR 1 /* Set file pointer to its current value plus offset */ +#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */ +#endif + +/* if L_tmpnam is not set, use a large number that should be safe */ +#ifndef L_tmpnam +#define L_tmpnam 256 +#endif + +int __gnat_constant_eof = EOF; +int __gnat_constant_iofbf = _IOFBF; +int __gnat_constant_iolbf = _IOLBF; +int __gnat_constant_ionbf = _IONBF; +int __gnat_constant_l_tmpnam = L_tmpnam; +int __gnat_constant_seek_cur = SEEK_CUR; +int __gnat_constant_seek_end = SEEK_END; +int __gnat_constant_seek_set = SEEK_SET; + +FILE * +__gnat_constant_stderr () +{ + return stderr; +} + +FILE * +__gnat_constant_stdin () +{ + return stdin; +} + +FILE * +__gnat_constant_stdout () +{ + return stdout; +} + +char * +__gnat_full_name (nam, buffer) + char *nam; + char *buffer; +{ + char *p; + +#if defined(__EMX__) || defined (__MINGW32__) + /* If this is a device file return it as is; under Windows NT and + OS/2 a device file end with ":". */ + if (nam [strlen (nam) - 1] == ':') + strcpy (buffer, nam); + else + { + _fullpath (buffer, nam, max_path_len); + + for (p = buffer; *p; p++) + if (*p == '/') + *p = '\\'; + } + +#elif defined (MSDOS) + _fixpath (nam, buffer); + +#elif defined (sgi) + + /* Use realpath function which resolves links and references to .. and .. + on those Unix systems that support it. Note that linux provides it but + cannot handle more than 5 symbolic links in a full name, so we use the + getcwd approach instead. */ + realpath (nam, buffer); + +#elif defined (VMS) + strcpy (buffer, __gnat_to_canonical_file_spec (nam)); + + if (buffer[0] == '/') + strcpy (buffer, __gnat_to_host_file_spec (buffer)); + else + { + char nambuffer [MAXPATHLEN]; + + strcpy (nambuffer, buffer); + strcpy (buffer, getcwd (buffer, max_path_len, 0)); + strcat (buffer, "/"); + strcat (buffer, nambuffer); + strcpy (buffer, __gnat_to_host_file_spec (buffer)); + } + + return buffer; + +#else + if (nam[0] != '/') + { + p = getcwd (buffer, max_path_len); + if (p == 0) + { + buffer[0] = '\0'; + return 0; + } + + /* If the name returned is an absolute path, it is safe to append '/' + to the path and concatenate the name of the file. */ + if (buffer[0] == '/') + strcat (buffer, "/"); + + strcat (buffer, nam); + } + else + strcpy (buffer, nam); + + return buffer; +#endif +} diff --git a/gcc/ada/cuintp.c b/gcc/ada/cuintp.c new file mode 100644 index 00000000000..8b1835b67a2 --- /dev/null +++ b/gcc/ada/cuintp.c @@ -0,0 +1,110 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C U I N T P * + * * + * C Implementation File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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). * + * * + ****************************************************************************/ + +/* This file corresponds to the Ada package body Uintp. It was created + manually from the files uintp.ads and uintp.adb. */ + +#include "config.h" +#include "system.h" +#include "tree.h" +#include "ada.h" +#include "types.h" +#include "uintp.h" +#include "atree.h" +#include "elists.h" +#include "nlists.h" +#include "stringt.h" +#include "fe.h" +#include "gigi.h" + +/* Universal integers are represented by the Uint type which is an index into + the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an + index and length for getting the "digits" of the universal integer from the + Udigits_Ptr table. + + For efficiency, this method is used only for integer values larger than the + constant Uint_Bias. If a Uint is less than this constant, then it contains + the integer value itself. The origin of the Uints_Ptr table is adjusted so + that a Uint value of Uint_Bias indexes the first element. */ + +/* Similarly to UI_To_Int, but return a GCC INTEGER_CST. Overflow is tested + by the constant-folding used to build the node. TYPE is the GCC type of the + resulting node. */ + +tree +UI_To_gnu (Input, type) + Uint Input; + tree type; +{ + tree gnu_ret; + + if (Input <= Uint_Direct_Last) + gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias, + Input < Uint_Direct_Bias ? -1 : 0)); + else + { + Int Idx = Uints_Ptr[Input].Loc; + Pos Length = Uints_Ptr[Input].Length; + Int First = Udigits_Ptr[Idx]; + /* Do computations in integer type or TYPE whichever is wider, then + convert later. This avoid overflow if type is short integer. */ + tree comp_type + = (TYPE_PRECISION (type) >= TYPE_PRECISION (integer_type_node) + ? type : integer_type_node); + tree gnu_base = convert (comp_type, build_int_2 (Base, 0)); + + if (Length <= 0) + gigi_abort (601); + + gnu_ret = convert (comp_type, build_int_2 (First, First < 0 ? -1 : 0)); + if (First < 0) + for (Idx++, Length--; Length; Idx++, Length--) + gnu_ret = fold (build (MINUS_EXPR, comp_type, + fold (build (MULT_EXPR, comp_type, + gnu_ret, gnu_base)), + convert (comp_type, + build_int_2 (Udigits_Ptr[Idx], 0)))); + else + for (Idx++, Length--; Length; Idx++, Length--) + gnu_ret = fold (build (PLUS_EXPR, comp_type, + fold (build (MULT_EXPR, comp_type, + gnu_ret, gnu_base)), + convert (comp_type, + build_int_2 (Udigits_Ptr[Idx], 0)))); + } + + gnu_ret = convert (type, gnu_ret); + + /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RET. */ + while ((TREE_CODE (gnu_ret) == NOP_EXPR + || TREE_CODE (gnu_ret) == NON_LVALUE_EXPR) + && TREE_TYPE (TREE_OPERAND (gnu_ret, 0)) == TREE_TYPE (gnu_ret)) + gnu_ret = TREE_OPERAND (gnu_ret, 0); + + return gnu_ret; +} diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb new file mode 100644 index 00000000000..27c934bd99c --- /dev/null +++ b/gcc/ada/debug.adb @@ -0,0 +1,577 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.88 $ +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package body Debug is + + --------------------------------- + -- Summary of Debug Flag Usage -- + --------------------------------- + + -- Debug flags for compiler (GNAT1 and GNATF) + + -- da Generate messages tracking semantic analyzer progress + -- db Show encoding of type names for debug output + -- dc List names of units as they are compiled + -- dd Dynamic allocation of tables messages generated + -- de List the entity table + -- df Full tree/source print (includes withed units) + -- dg Print source from tree (generated code only) + -- dh Generate listing showing loading of name table hash chains + -- di Generate messages for visibility linking/delinking + -- dj Suppress "junk null check" for access parameter values + -- dk Generate GNATBUG message on abort, even if previous errors + -- dl Generate unit load trace messages + -- dm Allow VMS features even if not OpenVMS version + -- dn Generate messages for node/list allocation + -- do Print source from tree (original code only) + -- dp Generate messages for parser scope stack push/pops + -- dq + -- dr Generate parser resynchronization messages + -- ds Print source from tree (including original and generated stuff) + -- dt Print full tree + -- du Uncheck categorization pragmas + -- dv Output trace of overload resolution + -- dw Print trace of semantic scope stack + -- dx Force expansion on, even if no code being generated + -- dy Print tree of package Standard + -- dz Print source of package Standard + + -- dA All entities included in representation information output + -- dB Output debug encoding of type names and variants + -- dC + -- dD Delete elaboration checks in inner level routines + -- dE Apply elaboration checks to predefined units + -- dF Front end data layout enabled. + -- dG Generate input showing file creating info for debug file + -- dH Hold (kill) call to gigi + -- dI Inhibit internal name numbering in gnatG listing + -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) + -- dK Kill all error messages + -- dL Output trace information on elaboration checking + -- dM + -- dN Do not generate file/line exception messages + -- dO Output immediate error messages + -- dP Do not check for controlled objects in preelaborable packages + -- dQ + -- dR Bypass check for correct version of s-rpc + -- dS Never convert numbers to machine numbers in Sem_Eval + -- dT Convert to machine numbers only for constant declarations + -- dU Enable garbage collection of unreachable entities + -- dV Enable viewing of all symbols in debugger + -- dW + -- dX Enable Frontend ZCX even when it is not supported + -- dY + -- dZ + + -- d1 Error msgs have node numbers where possible + -- d2 Eliminate error flags in verbose form error messages + -- d3 Dump bad node in Comperr on an abort + -- d4 Inhibit automatic krunch of predefined library unit files + -- d5 Debug output for tree read/write + -- d6 Default access unconstrained to thin pointers + -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode + -- d8 Force opposite endianness in packed stuff + -- d9 + + -- Debug flags for binder (GNATBIND) + + -- da + -- db + -- dc List units as they are chosen + -- dd + -- de Elaboration dependencies including system units + -- df + -- dg + -- dh + -- di + -- dj + -- dk + -- dl + -- dm + -- dn List details of manipulation of Num_Pred values + -- do + -- dp + -- dq + -- dr List additional restrictions that may be specified + -- ds + -- dt + -- du List units as they are acquired + -- dv + -- dw + -- dx + -- dy + -- dz + + -- d1 + -- d2 + -- d3 + -- d4 + -- d5 + -- d6 + -- d7 + -- d8 + -- d9 + + -- Debug flags used in package Make and its clients (e.g. GNATMAKE) + + -- da + -- db + -- dc + -- dd + -- de + -- df + -- dg + -- dh + -- di + -- dj + -- dk + -- dl + -- dm + -- dn + -- do + -- dp Prints the contents of the Q used by Make.Compile_Sources + -- dq Prints source files as they are enqueued and dequeued + -- dr + -- ds + -- dt + -- du + -- dv + -- dw Prints the list of units withed by the unit currently explored + -- dx + -- dy + -- dz + + -- d1 + -- d2 + -- d3 + -- d4 + -- d5 + -- d6 + -- d7 + -- d8 + -- d9 + + -------------------------------------------- + -- Documentation for Compiler Debug Flags -- + -------------------------------------------- + + -- da Generate messages tracking semantic analyzer progress. A message + -- is output showing each node as it gets analyzed, expanded, + -- resolved, or evaluated. This option is useful for finding out + -- exactly where a bomb during semantic analysis is occurring. + + -- db In Exp_Dbug, certain type names are encoded to include debugging + -- information. This debug switch causes lines to be output showing + -- the encodings used. + + -- dc List names of units as they are compiled. One line of output will + -- be generated at the start of compiling each unit (package or + -- subprogram). + + -- dd Dynamic allocation of tables messages generated. Each time a + -- table is reallocated, a line is output indicating the expansion. + + -- dD Delete new elaboration checks. This flag causes GNAT to return + -- to the 3.13a elaboration semantics, and to suppress the fixing + -- of two bugs. The first is in the context of inner routines in + -- dynamic elaboration mode, when the subprogram we are in was + -- called at elaboration time by a unit that was also compiled with + -- dynamic elaboration checks. In this case, if A calls B calls C, + -- and all are in different units, we need an elaboration check at + -- each call. These nested checks were only put in recently (see + -- version 1.80 of Sem_Elab) and we provide this debug flag to + -- revert to the previous behavior in case of regressions. The + -- other behavior reverted by this flag is the treatment of the + -- Elaborate_Body pragma in static elaboration mode. This used to + -- be treated as not needing elaboration checking, but in fact in + -- general Elaborate_All is still required because of nested calls. + + -- de List the entity table + + -- df Full tree/source print (includes withed units). Normally the tree + -- output (dt) or recreated source output (dg,do,ds) includes only + -- the main unit. If df is set, then the output in either case + -- includes all compiled units (see also dg,do,ds,dt). Note that to + -- be effective, this swich must be used in combination with one or + -- more of dt, dg, do or ds. + + -- dF Front end data layout enabled. Normally front end data layout + -- is only enabled if the target parameter Backend_Layout is False. + -- This debugging switch enables it unconditionally. + + -- dg Print the source recreated from the generated tree. In the case + -- where the tree has been rewritten this output includes only the + -- generated code, not the original code (see also df,do,ds,dz). + -- This flag differs from -gnatG in that the output also includes + -- non-source generated null statements, and freeze nodes, which + -- are normally omitted in -gnatG mode. + + -- dG Print trace information showing calls to Create_Debug_Source and + -- Write_Debug_Line. Used for debugging -gnatD operation problems. + + -- dh Generates a table at the end of a compilation showing how the hash + -- table chains built by the Namet package are loaded. This is useful + -- in ensuring that the hashing algorithm (in Namet.Hash) is working + -- effectively with typical sets of program identifiers. + + -- dH Inhibit call to gigi. This is useful for testing front end data + -- layout, and may be useful in other debugging situations where + -- you do not want gigi to intefere with the testing. + + -- di Generate messages for visibility linking/delinking + + -- dj Suppress "junk null check" for access parameters. This flag permits + -- Ada programs to pass null parameters to access parameters, and to + -- explicitly check such access values against the null literal. + -- Neither of these is valid Ada, but both were allowed in versions of + -- GNAT before 3.10, so this switch can ease the transition process. + + -- dJ Generate debugging trace output for the JGNAT back end. This + -- consists of symbolic Java Byte Code sequences for all generated + -- classes plus additional information to indicate local variables + -- and methods. + + -- dk Immediate kill on abort. Normally on an abort (i.e. a call to + -- Comperr.Compiler_Abort), the GNATBUG message is not given if + -- there is a previous error. This debug switch bypasses this test + -- and gives the message unconditionally (useful for debugging). + + -- dK Kill all error messages. This debug flag suppresses the output + -- of all error messages. It is used in regression tests where the + -- error messages are target dependent and irrelevant. + + -- dl Generate unit load trace messages. A line of traceback output is + -- generated each time a request is made to the library manager to + -- load a new unit. + + -- dm Some features are permitted only in OpenVMS ports of GNAT (e.g. + -- the specification of passing by descriptor). Normally any use + -- of these features will be flagged as an error, but this debug + -- flag allows acceptance of these features in non OpenVMS ports. + -- Of course they may not have any useful effect, and in particular + -- attempting to generate code with this flag set may blow up. + -- The flag also forces the use of 64-bits for Long_Integer. + + -- dn Generate messages for node/list allocation. Each time a node or + -- list header is allocated, a line of output is generated. Certain + -- other basic tree operations also cause a line of output to be + -- generated. This option is useful in seeing where the parser is + -- blowing up.; + + -- dN Do not generate file/line exception messages. Normally we do the + -- explicit generation of these messages, but since these can only + -- be disabled using pragma Discard_Names, this switch may be useful. + + -- do Print the source recreated from the generated tree. In the case + -- where the tree has been rewritten, this output includes only the + -- original code, not the generated code (see also df,dg,ds,dz). + + -- dp Generate messages for parser scope stack push/pops. A line of + -- output by the parser each time the parser scope stack is either + -- pushed or popped. Useful in debugging situations where the + -- parser scope stack ends up incorrectly synchronized + + -- dr Generate parser resynchronization messages. Normally the parser + -- resynchronizes quietly. With this debug option, two messages + -- are generated, one when the parser starts a resynchronization + -- skip, and another when it resumes parsing. Useful in debugging + -- inadequate error recovery situations. + + -- ds Print the source recreated from the generated tree. In the case + -- where the tree has been rewritten this output includes both the + -- generated code and the original code with the generated code + -- being enlosed in curly brackets (see also df,do,ds,dz) + + -- dt Print full tree. The generated tree is output (see also df,dy) + + -- du Uncheck categorization pragmas. This debug switch causes the + -- categorization pragmas (Pure, Preelaborate etc) to be ignored + -- so that normal checks are not made (this is particularly useful + -- for adding temporary debugging code to units that have pragmas + -- that are inconsistent with the debugging code added. + + -- dw Write semantic scope stack messages. Each time a scope is created + -- or removed, a message is output (see the Sem_Ch8.New_Scope and + -- Sem_Ch8.Pop_Scope subprograms). + + -- dx Force expansion on, even if no code being generated. Normally the + -- expander is inhibited if no code is generated. This switch forces + -- expansion to proceed normally even if the backend is not being + -- called. This is particularly useful for debugging purposes when + -- using the front-end only version of the compiler (which normally + -- would never do any expansion). + + -- dy Print tree of package Standard. Normally the tree print out does + -- not include package Standard, even if the -df switch is set. This + -- switch forces output of the internal tree built for Standard. + + -- dz Print source of package Standard. Normally the source print out + -- does not include package Standard, even if the -df switch is set. + -- This switch forces output of the source recreated from the internal + -- tree built for Standard. + + -- dA Forces output of representation information, including full + -- information for all internal type and object entities, as well + -- as all user defined type and object entities. + + -- dB Output debug encodings for types and variants. See Exp_Dbug for + -- exact form of the generated output. + + -- dE Apply compile time elaboration checking for with relations between + -- predefined units. Normally no checks are made (it seems that at + -- least on the SGI, such checks run into trouble). + + -- dI Inhibit internal name numbering in gnatDG listing. For internal + -- names of the form <uppercase-letters><digits><suffix>, the output + -- will be modified to <uppercase-letters>...<suffix>. This is used + -- in the fixed bugs run to minimize system and version dependency + -- in filed -gnatDG output. + + -- dL Output trace information on elaboration checking. This debug + -- switch causes output to be generated showing each call or + -- instantiation as it is checked, and the progress of the recursive + -- trace through calls at elaboration time. + + -- dO Output immediate error messages. This causes error messages to + -- be output as soon as they are generated (disconnecting several + -- circuits for improvement of messages, deletion of duplicate + -- messages etc). Useful to diagnose compiler bombs caused by + -- erroneous handling of error situations + + -- dP Do not check for controlled objects in preelaborable packages. + -- RM 10.2.1(9) forbids the use of library level controlled objects + -- in preelaborable packages, but this restriction is a huge pain, + -- especially in the predefined library units. + + -- dR Bypass the check for a proper version of s-rpc being present + -- to use the -gnatz? switch. This allows debugging of the use + -- of stubs generation without needing to have GLADE (or some + -- other PCS installed). + + -- dS Omit conversion of fpt numbers to exact machine numbers in + -- non-static evaluation contexts (see Check_Non_Static_Context). + -- This is intended for testing out timing problems with this + -- conversion circuit. + + -- dT Similar to dS, but omits the conversions only in the case where + -- the parent is not a constant declaration. + + -- dU Enable garbage collection of unreachable entities. This enables + -- both the reachability analysis and changing the Is_Public and + -- Is_Eliminated flags. + + -- dV Enable viewing of all symbols in debugger. Causes debug information + -- to be generated for all symbols, including internal symbols. This + -- is enabled by default for -gnatD, but this switch allows this to + -- be enabled without generating modified source files. Note that the + -- use of -gnatdV ensures in the dwarf/elf case that all symbols that + -- are present in the elf tables are also in the dwarf tables (which + -- seems to be required by some tools). + + -- dX Enable frontend ZCX even when it is not supported. Equivalent to + -- -gnatZ but without verifying that System.Front_End_ZCX_Support + -- is set. This causes the front end to generate suitable tables + -- for ZCX handling even when the runtime cannot handle ZCX. This + -- is used for testing the front end for correct ZCX operation, and + -- in particular is useful for multi-target testing. + + -- d1 Error msgs have node numbers where possible. Normally error + -- messages have only source locations. This option is useful when + -- debugging errors caused by expanded code, where the source location + -- does not give enough information. + + -- d2 Suppress output of the error position flags for verbose form error + -- messages. The messages are still interspersed in the listing, but + -- without any error flags or extra blank lines. Also causes an extra + -- <<< to be output at the right margin. This is intended to be the + -- easiest format for checking conformance of ACVC B tests. + + -- d3 Causes Comperr to dump the contents of the node for which an abort + -- was detected (normally only the Node_Id of the node is output). + + -- d4 Inhibits automatic krunching of predefined library unit file names. + -- Normally, as described in the spec of package Krunch, such files + -- are automatically krunched to 8 characters, with special treatment + -- of the prefixes Ada, System, and Interfaces. Setting this debug + -- switch disables this special treatment. + + -- d6 Normally access-to-unconstrained-array types are represented + -- using fat (double) pointers. Using this debug flag causes them + -- to default to thin. This can be used to test the performance + -- implications of using thin pointers, and also to test that the + -- compiler functions correctly with this choice. + + -- d7 Normally a -gnatl or -gnatv listing includes the time stamp + -- of the source file. This debug flag suppresses this output, + -- and also suppresses the message with the version number. + -- This is useful in certain regression tests. + + -- d8 This forces the packed stuff to generate code assuming the + -- opposite endianness from the actual correct value. Useful in + -- testing out code generation from the packed routines. + + ------------------------------------------ + -- Documentation for Binder Debug Flags -- + ------------------------------------------ + + -- dc List units as they are chosen. As units are selected for addition to + -- the elaboration order, a line of output is generated showing which + -- unit has been selected. + + -- de Similar to the effect of -e (output complete list of elaboration + -- dependencies) except that internal units are included in the + -- listing. + + -- dn List details of manipulation of Num_Pred values during execution of + -- the algorithm used to determine a correct order of elaboration. This + -- is useful in diagnosing any problems in its behavior. + + -- dr List restrictions which have not been specified, but could have + -- been without causing bind errors. + + -- du List unit name and file name for each unit as it is read in + + ------------------------------------------------------------ + -- Documentation for the Debug Flags used in package Make -- + ------------------------------------------------------------ + + -- Please note that such flags apply to all of Make clients, + -- such as gnatmake. + + -- dp Prints the Q used by routine Make.Compile_Sources every time + -- we go around the main compile loop of Make.Compile_Sources + + -- dq Prints source files as they are enqueued and dequeued in the Q + -- used by routine Make.Compile_Sources. Useful to figure out the + -- order in which sources are recompiled. + + -- dw Prints the list of units withed by the unit currently explored + -- during the main loop of Make.Compile_Sources. + + ---------------------- + -- Get_Debug_Flag_K -- + ---------------------- + + function Get_Debug_Flag_K return Boolean is + begin + return Debug_Flag_K; + end Get_Debug_Flag_K; + + -------------------- + -- Set_Debug_Flag -- + -------------------- + + procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is + subtype Dig is Character range '1' .. '9'; + subtype LLet is Character range 'a' .. 'z'; + subtype ULet is Character range 'A' .. 'Z'; + + begin + if C in Dig then + case Dig (C) is + when '1' => Debug_Flag_1 := Val; + when '2' => Debug_Flag_2 := Val; + when '3' => Debug_Flag_3 := Val; + when '4' => Debug_Flag_4 := Val; + when '5' => Debug_Flag_5 := Val; + when '6' => Debug_Flag_6 := Val; + when '7' => Debug_Flag_7 := Val; + when '8' => Debug_Flag_8 := Val; + when '9' => Debug_Flag_9 := Val; + end case; + + elsif C in ULet then + case ULet (C) is + when 'A' => Debug_Flag_AA := Val; + when 'B' => Debug_Flag_BB := Val; + when 'C' => Debug_Flag_CC := Val; + when 'D' => Debug_Flag_DD := Val; + when 'E' => Debug_Flag_EE := Val; + when 'F' => Debug_Flag_FF := Val; + when 'G' => Debug_Flag_GG := Val; + when 'H' => Debug_Flag_HH := Val; + when 'I' => Debug_Flag_II := Val; + when 'J' => Debug_Flag_JJ := Val; + when 'K' => Debug_Flag_KK := Val; + when 'L' => Debug_Flag_LL := Val; + when 'M' => Debug_Flag_MM := Val; + when 'N' => Debug_Flag_NN := Val; + when 'O' => Debug_Flag_OO := Val; + when 'P' => Debug_Flag_PP := Val; + when 'Q' => Debug_Flag_QQ := Val; + when 'R' => Debug_Flag_RR := Val; + when 'S' => Debug_Flag_SS := Val; + when 'T' => Debug_Flag_TT := Val; + when 'U' => Debug_Flag_UU := Val; + when 'V' => Debug_Flag_VV := Val; + when 'W' => Debug_Flag_WW := Val; + when 'X' => Debug_Flag_XX := Val; + when 'Y' => Debug_Flag_YY := Val; + when 'Z' => Debug_Flag_ZZ := Val; + end case; + + else + case LLet (C) is + when 'a' => Debug_Flag_A := Val; + when 'b' => Debug_Flag_B := Val; + when 'c' => Debug_Flag_C := Val; + when 'd' => Debug_Flag_D := Val; + when 'e' => Debug_Flag_E := Val; + when 'f' => Debug_Flag_F := Val; + when 'g' => Debug_Flag_G := Val; + when 'h' => Debug_Flag_H := Val; + when 'i' => Debug_Flag_I := Val; + when 'j' => Debug_Flag_J := Val; + when 'k' => Debug_Flag_K := Val; + when 'l' => Debug_Flag_L := Val; + when 'm' => Debug_Flag_M := Val; + when 'n' => Debug_Flag_N := Val; + when 'o' => Debug_Flag_O := Val; + when 'p' => Debug_Flag_P := Val; + when 'q' => Debug_Flag_Q := Val; + when 'r' => Debug_Flag_R := Val; + when 's' => Debug_Flag_S := Val; + when 't' => Debug_Flag_T := Val; + when 'u' => Debug_Flag_U := Val; + when 'v' => Debug_Flag_V := Val; + when 'w' => Debug_Flag_W := Val; + when 'x' => Debug_Flag_X := Val; + when 'y' => Debug_Flag_Y := Val; + when 'z' => Debug_Flag_Z := Val; + end case; + end if; + end Set_Debug_Flag; + +end Debug; diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads new file mode 100644 index 00000000000..dcc849bafbf --- /dev/null +++ b/gcc/ada/debug.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.31 $ +-- -- +-- Copyright (C) 1992-1999 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package Debug is +pragma Preelaborate (Debug); + +-- This package contains global flags used to control the inclusion +-- of debugging code in various phases of the compiler. + + ------------------------- + -- Dynamic Debug Flags -- + ------------------------- + + -- Thirty six flags that can be used to active various specialized + -- debugging output information. The flags are preset to False, which + -- corresponds to the given output being suppressed. The individual + -- flags can be turned on using the undocumented switch /dxxx where + -- xxx is a string of letters for flags to be turned on. Documentation + -- on the current usage of these flags is contained in the body of Debug + -- rather than the spec, so that we don't have to recompile the world + -- when a new debug flag is added + + Debug_Flag_A : Boolean := False; + Debug_Flag_B : Boolean := False; + Debug_Flag_C : Boolean := False; + Debug_Flag_D : Boolean := False; + Debug_Flag_E : Boolean := False; + Debug_Flag_F : Boolean := False; + Debug_Flag_G : Boolean := False; + Debug_Flag_H : Boolean := False; + Debug_Flag_I : Boolean := False; + Debug_Flag_J : Boolean := False; + Debug_Flag_K : Boolean := False; + Debug_Flag_L : Boolean := False; + Debug_Flag_M : Boolean := False; + Debug_Flag_N : Boolean := False; + Debug_Flag_O : Boolean := False; + Debug_Flag_P : Boolean := False; + Debug_Flag_Q : Boolean := False; + Debug_Flag_R : Boolean := False; + Debug_Flag_S : Boolean := False; + Debug_Flag_T : Boolean := False; + Debug_Flag_U : Boolean := False; + Debug_Flag_V : Boolean := False; + Debug_Flag_W : Boolean := False; + Debug_Flag_X : Boolean := False; + Debug_Flag_Y : Boolean := False; + Debug_Flag_Z : Boolean := False; + + Debug_Flag_AA : Boolean := False; + Debug_Flag_BB : Boolean := False; + Debug_Flag_CC : Boolean := False; + Debug_Flag_DD : Boolean := False; + Debug_Flag_EE : Boolean := False; + Debug_Flag_FF : Boolean := False; + Debug_Flag_GG : Boolean := False; + Debug_Flag_HH : Boolean := False; + Debug_Flag_II : Boolean := False; + Debug_Flag_JJ : Boolean := False; + Debug_Flag_KK : Boolean := False; + Debug_Flag_LL : Boolean := False; + Debug_Flag_MM : Boolean := False; + Debug_Flag_NN : Boolean := False; + Debug_Flag_OO : Boolean := False; + Debug_Flag_PP : Boolean := False; + Debug_Flag_QQ : Boolean := False; + Debug_Flag_RR : Boolean := False; + Debug_Flag_SS : Boolean := False; + Debug_Flag_TT : Boolean := False; + Debug_Flag_UU : Boolean := False; + Debug_Flag_VV : Boolean := False; + Debug_Flag_WW : Boolean := False; + Debug_Flag_XX : Boolean := False; + Debug_Flag_YY : Boolean := False; + Debug_Flag_ZZ : Boolean := False; + + Debug_Flag_1 : Boolean := False; + Debug_Flag_2 : Boolean := False; + Debug_Flag_3 : Boolean := False; + Debug_Flag_4 : Boolean := False; + Debug_Flag_5 : Boolean := False; + Debug_Flag_6 : Boolean := False; + Debug_Flag_7 : Boolean := False; + Debug_Flag_8 : Boolean := False; + Debug_Flag_9 : Boolean := False; + + function Get_Debug_Flag_K return Boolean; + -- This function is called from C code to get the setting of the K flag + -- (it does not work to try to access a constant object directly). + + procedure Set_Debug_Flag (C : Character; Val : Boolean := True); + -- Where C is 0-9, A-Z, or a-z, sets the corresponding debug flag to + -- the given value. In the checks off version of debug, the call to + -- Set_Debug_Flag is always a null operation. + +end Debug; diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb new file mode 100644 index 00000000000..ccb9e772afd --- /dev/null +++ b/gcc/ada/debug_a.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G _ A -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.11 $ -- +-- -- +-- Copyright (C) 1992-1998 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 Debug; use Debug; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Output; use Output; + +package body Debug_A is + + Debug_A_Depth : Natural := 0; + -- Output for the debug A flag is preceded by a sequence of vertical bar + -- characters corresponding to the recursion depth of the actions being + -- recorded (analysis, expansion, resolution and evaluation of nodes) + -- This variable records the depth. + + Max_Node_Ids : constant := 200; + -- Maximum number of Node_Id values that get stacked + + Node_Ids : array (1 .. Max_Node_Ids) of Node_Id; + -- A stack used to keep track of Node_Id values for setting the value of + -- Current_Error_Node correctly. Note that if we have more than 200 + -- recursion levels, we just don't reset the right value on exit, which + -- is not crucial, since this is only for debugging! + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Debug_Output_Astring; + -- Outputs Debug_A_Depth number of vertical bars, used to preface messages + + ------------------- + -- Debug_A_Entry -- + ------------------- + + procedure Debug_A_Entry (S : String; N : Node_Id) is + begin + if Debug_Flag_A then + Debug_Output_Astring; + Write_Str (S); + Write_Str ("Node_Id = "); + Write_Int (Int (N)); + Write_Str (" "); + Write_Location (Sloc (N)); + Write_Str (" "); + Write_Str (Node_Kind'Image (Nkind (N))); + Write_Eol; + end if; + + Debug_A_Depth := Debug_A_Depth + 1; + Current_Error_Node := N; + + if Debug_A_Depth <= Max_Node_Ids then + Node_Ids (Debug_A_Depth) := N; + end if; + end Debug_A_Entry; + + ------------------ + -- Debug_A_Exit -- + ------------------ + + procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is + begin + Debug_A_Depth := Debug_A_Depth - 1; + + if Debug_A_Depth in 1 .. Max_Node_Ids then + Current_Error_Node := Node_Ids (Debug_A_Depth); + end if; + + if Debug_Flag_A then + Debug_Output_Astring; + Write_Str (S); + Write_Str ("Node_Id = "); + Write_Int (Int (N)); + Write_Str (Comment); + Write_Eol; + end if; + end Debug_A_Exit; + + -------------------------- + -- Debug_Output_Astring -- + -------------------------- + + procedure Debug_Output_Astring is + Vbars : String := "|||||||||||||||||||||||||"; + -- Should be constant, removed because of GNAT 1.78 bug ??? + + begin + if Debug_A_Depth > Vbars'Length then + for I in Vbars'Length .. Debug_A_Depth loop + Write_Char ('|'); + end loop; + + Write_Str (Vbars); + + else + Write_Str (Vbars (1 .. Debug_A_Depth)); + end if; + end Debug_Output_Astring; + +end Debug_A; diff --git a/gcc/ada/debug_a.ads b/gcc/ada/debug_a.ads new file mode 100644 index 00000000000..cc62a03b6d2 --- /dev/null +++ b/gcc/ada/debug_a.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G _ A -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- Copyright (C) 1992-1998 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains data and subprograms to support the A debug switch +-- that is used to generate output showing what node is being analyzed, +-- resolved, evaluated, or expanded. + +with Types; use Types; + +package Debug_A is + + -- Note: the following subprograms are used in a stack like manner, with + -- an exit call matching each entry call. This means that they can keep + -- track of the current node being worked on, with the entry call setting + -- a new value, by pushing the Node_Id value on a stack, and the exit call + -- popping this value off. Comperr.Current_Error_Node is set by both the + -- entry and exit routines to point to the current node so that an abort + -- message indicates the node involved as accurately as possible. + + procedure Debug_A_Entry (S : String; N : Node_Id); + pragma Inline (Debug_A_Entry); + -- Generates a message prefixed by a sequence of bars showing the nesting + -- depth (depth increases by 1 for a Debug_A_Entry call and is decreased + -- by the corresponding Debug_A_Exit call). Then the string is output + -- (analyzing, expanding etc), followed by the node number and its kind. + -- This output is generated only if the debug A flag is set. If the debug + -- A flag is not set, then no output is generated. This call also sets the + -- Node_Id value in Comperr.Current_Error_Node in case a bomb occurs. This + -- is done unconditionally, whether or not the debug A flag is set. + + procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String); + pragma Inline (Debug_A_Exit); + -- Generates the corresponding termination message. The message is preceded + -- by a sequence of bars, followed by the string S, the node number, and + -- a trailing comment (e.g. " (already evaluated)"). This output is + -- generated only if the debug A flag is set. If the debug A flag is not + -- set, then no output is generated. This call also resets the value in + -- Comperr.Current_Error_Node to what it was before the corresponding call + -- to Debug_A_Entry. + +end Debug_A; diff --git a/gcc/ada/dec-io.adb b/gcc/ada/dec-io.adb new file mode 100644 index 00000000000..2a063370dde --- /dev/null +++ b/gcc/ada/dec-io.adb @@ -0,0 +1,211 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- D E C . I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This is an AlphaVMS package that provides the interface between +-- GNAT, DECLib IO packages and the DECLib Bliss library. + +pragma Extend_System (Aux_DEC); + +with System; use System; +with System.Task_Primitives; use System.Task_Primitives; +with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; +with IO_Exceptions; use IO_Exceptions; +with Aux_IO_Exceptions; use Aux_IO_Exceptions; + +package body DEC.IO is + + type File_Type is record + FCB : Integer := 0; -- Temporary + SEQ : Integer := 0; + end record; + + for File_Type'Size use 64; + for File_Type'Alignment use 8; + + for File_Type use record + FCB at 0 range 0 .. 31; + SEQ at 4 range 0 .. 31; + end record; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function GNAT_Name_64 (File : File_Type) return String; + pragma Export_Function (GNAT_Name_64, "GNAT$NAME_64"); + -- ??? comment + + function GNAT_Form_64 (File : File_Type) return String; + pragma Export_Function (GNAT_Form_64, "GNAT$FORM_64"); + -- ??? comment + + procedure Init_IO; + pragma Interface (C, Init_IO); + pragma Import_Procedure (Init_IO, "GNAT$$INIT_IO"); + -- ??? comment + + ---------------- + -- IO_Locking -- + ---------------- + + package body IO_Locking is + + ------------------ + -- Create_Mutex -- + ------------------ + + function Create_Mutex return Access_Mutex is + M : constant Access_Mutex := new RTS_Lock; + + begin + Initialize_Lock (M, Global_Task_Level); + return M; + end Create_Mutex; + + ------------- + -- Acquire -- + ------------- + + procedure Acquire (M : Access_Mutex) is + begin + Write_Lock (M); + end Acquire; + + ------------- + -- Release -- + ------------- + + procedure Release (M : Access_Mutex) is + begin + Unlock (M); + end Release; + + end IO_Locking; + + ------------------ + -- GNAT_Name_64 -- + ------------------ + + function GNAT_Name_64 (File : File_Type) return String is + subtype Buffer_Subtype is String (1 .. 8192); + + Buffer : Buffer_Subtype; + Length : System.Integer_32; + + procedure Get_Name + (File : System.Address; + MaxLen : System.Integer_32; + Buffer : out Buffer_Subtype; + Length : out System.Integer_32); + pragma Interface (C, Get_Name); + pragma Import_Procedure + (Get_Name, "GNAT$FILE_NAME", + Mechanism => (Value, Value, Reference, Reference)); + + begin + Get_Name (File'Address, Buffer'Length, Buffer, Length); + return Buffer (1 .. Integer (Length)); + end GNAT_Name_64; + + ------------------ + -- GNAT_Form_64 -- + ------------------ + + function GNAT_Form_64 (File : File_Type) return String is + subtype Buffer_Subtype is String (1 .. 8192); + + Buffer : Buffer_Subtype; + Length : System.Integer_32; + + procedure Get_Form + (File : System.Address; + MaxLen : System.Integer_32; + Buffer : out Buffer_Subtype; + Length : out System.Integer_32); + pragma Interface (C, Get_Form); + pragma Import_Procedure + (Get_Form, "GNAT$FILE_FORM", + Mechanism => (Value, Value, Reference, Reference)); + + begin + Get_Form (File'Address, Buffer'Length, Buffer, Length); + return Buffer (1 .. Integer (Length)); + end GNAT_Form_64; + + ------------------------ + -- Raise_IO_Exception -- + ------------------------ + + procedure Raise_IO_Exception (EN : Exception_Number) is + begin + case EN is + when GNAT_EN_LOCK_ERROR => raise LOCK_ERROR; + when GNAT_EN_EXISTENCE_ERROR => raise EXISTENCE_ERROR; + when GNAT_EN_KEY_ERROR => raise KEY_ERROR; + when GNAT_EN_KEYSIZERR => raise PROGRAM_ERROR; -- KEYSIZERR; + when GNAT_EN_STAOVF => raise STORAGE_ERROR; -- STAOVF; + when GNAT_EN_CONSTRAINT_ERRO => raise CONSTRAINT_ERROR; + when GNAT_EN_IOSYSFAILED => raise DEVICE_ERROR; -- IOSYSFAILED; + when GNAT_EN_LAYOUT_ERROR => raise LAYOUT_ERROR; + when GNAT_EN_STORAGE_ERROR => raise STORAGE_ERROR; + when GNAT_EN_DATA_ERROR => raise DATA_ERROR; + when GNAT_EN_DEVICE_ERROR => raise DEVICE_ERROR; + when GNAT_EN_END_ERROR => raise END_ERROR; + when GNAT_EN_MODE_ERROR => raise MODE_ERROR; + when GNAT_EN_NAME_ERROR => raise NAME_ERROR; + when GNAT_EN_STATUS_ERROR => raise STATUS_ERROR; + when GNAT_EN_NOT_OPEN => raise USE_ERROR; -- NOT_OPEN; + when GNAT_EN_ALREADY_OPEN => raise USE_ERROR; -- ALREADY_OPEN; + when GNAT_EN_USE_ERROR => raise USE_ERROR; + when GNAT_EN_UNSUPPORTED => raise USE_ERROR; -- UNSUPPORTED; + when GNAT_EN_FAC_MODE_MISMAT => raise USE_ERROR; -- FAC_MODE_MISMAT; + when GNAT_EN_ORG_MISMATCH => raise USE_ERROR; -- ORG_MISMATCH; + when GNAT_EN_RFM_MISMATCH => raise USE_ERROR; -- RFM_MISMATCH; + when GNAT_EN_RAT_MISMATCH => raise USE_ERROR; -- RAT_MISMATCH; + when GNAT_EN_MRS_MISMATCH => raise USE_ERROR; -- MRS_MISMATCH; + when GNAT_EN_MRN_MISMATCH => raise USE_ERROR; -- MRN_MISMATCH; + when GNAT_EN_KEY_MISMATCH => raise USE_ERROR; -- KEY_MISMATCH; + when GNAT_EN_MAXLINEXC => raise CONSTRAINT_ERROR; -- MAXLINEXC; + when GNAT_EN_LINEXCMRS => raise CONSTRAINT_ERROR; -- LINEXCMRS; + end case; + end Raise_IO_Exception; + +------------------------- +-- Package Elaboration -- +------------------------- + +begin + Init_IO; +end DEC.IO; diff --git a/gcc/ada/dec-io.ads b/gcc/ada/dec-io.ads new file mode 100644 index 00000000000..ab1e6932747 --- /dev/null +++ b/gcc/ada/dec-io.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- D E C . I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This is an AlphaVMS package that contains the declarations and +-- function specifications needed by the DECLib IO packages. + +with System.Task_Primitives; +package DEC.IO is +private + + type Exception_Number is ( + GNAT_EN_LOCK_ERROR, + GNAT_EN_EXISTENCE_ERROR, + GNAT_EN_KEY_ERROR, + GNAT_EN_KEYSIZERR, + GNAT_EN_STAOVF, + GNAT_EN_CONSTRAINT_ERRO, + GNAT_EN_IOSYSFAILED, + GNAT_EN_LAYOUT_ERROR, + GNAT_EN_STORAGE_ERROR, + GNAT_EN_DATA_ERROR, + GNAT_EN_DEVICE_ERROR, + GNAT_EN_END_ERROR, + GNAT_EN_MODE_ERROR, + GNAT_EN_NAME_ERROR, + GNAT_EN_STATUS_ERROR, + GNAT_EN_NOT_OPEN, + GNAT_EN_ALREADY_OPEN, + GNAT_EN_USE_ERROR, + GNAT_EN_UNSUPPORTED, + GNAT_EN_FAC_MODE_MISMAT, + GNAT_EN_ORG_MISMATCH, + GNAT_EN_RFM_MISMATCH, + GNAT_EN_RAT_MISMATCH, + GNAT_EN_MRS_MISMATCH, + GNAT_EN_MRN_MISMATCH, + GNAT_EN_KEY_MISMATCH, + GNAT_EN_MAXLINEXC, + GNAT_EN_LINEXCMRS); + + for Exception_Number'Size use 32; + + for Exception_Number use ( + GNAT_EN_LOCK_ERROR => 1, + GNAT_EN_EXISTENCE_ERROR => 2, + GNAT_EN_KEY_ERROR => 3, + GNAT_EN_KEYSIZERR => 4, + GNAT_EN_STAOVF => 5, + GNAT_EN_CONSTRAINT_ERRO => 6, + GNAT_EN_IOSYSFAILED => 7, + GNAT_EN_LAYOUT_ERROR => 8, + GNAT_EN_STORAGE_ERROR => 9, + GNAT_EN_DATA_ERROR => 10, + GNAT_EN_DEVICE_ERROR => 11, + GNAT_EN_END_ERROR => 12, + GNAT_EN_MODE_ERROR => 13, + GNAT_EN_NAME_ERROR => 14, + GNAT_EN_STATUS_ERROR => 15, + GNAT_EN_NOT_OPEN => 16, + GNAT_EN_ALREADY_OPEN => 17, + GNAT_EN_USE_ERROR => 18, + GNAT_EN_UNSUPPORTED => 19, + GNAT_EN_FAC_MODE_MISMAT => 20, + GNAT_EN_ORG_MISMATCH => 21, + GNAT_EN_RFM_MISMATCH => 22, + GNAT_EN_RAT_MISMATCH => 23, + GNAT_EN_MRS_MISMATCH => 24, + GNAT_EN_MRN_MISMATCH => 25, + GNAT_EN_KEY_MISMATCH => 26, + GNAT_EN_MAXLINEXC => 27, + GNAT_EN_LINEXCMRS => 28); + + procedure Raise_IO_Exception (EN : Exception_Number); + pragma Export_Procedure (Raise_IO_Exception, "GNAT$RAISE_IO_EXCEPTION", + Mechanism => Value); + + package IO_Locking is + type Access_Mutex is private; + function Create_Mutex return Access_Mutex; + procedure Acquire (M : Access_Mutex); + procedure Release (M : Access_Mutex); + + private + type Access_Mutex is access System.Task_Primitives.RTS_Lock; + pragma Export_Function (Create_Mutex, "GNAT$CREATE_MUTEX", + Mechanism => Value); + pragma Export_Procedure (Acquire, "GNAT$ACQUIRE_MUTEX", + Mechanism => Value); + pragma Export_Procedure (Release, "GNAT$RELEASE_MUTEX", + Mechanism => Value); + end IO_Locking; + +end DEC.IO; diff --git a/gcc/ada/dec.ads b/gcc/ada/dec.ads new file mode 100644 index 00000000000..b3af42a9cd4 --- /dev/null +++ b/gcc/ada/dec.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- D E C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This is an AlphaVMS package, which is imported by every package in +-- DECLib and tested for in gnatbind, in order to add "-ldecgnat" to +-- the bind. It is also a convenient parent for all DEC IO child packages. + +package DEC is +pragma Pure (DEC); +end DEC; diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c new file mode 100644 index 00000000000..c2acdbcfc25 --- /dev/null +++ b/gcc/ada/decl.c @@ -0,0 +1,6133 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * D E C L * + * * + * C Implementation File * + * * + * $Revision: 1.3 $ + * * + * Copyright (C) 1992-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). * + * * + ****************************************************************************/ + +#include "config.h" +#include "system.h" +#include "tree.h" +#include "flags.h" +#include "toplev.h" +#include "convert.h" +#include "ggc.h" +#include "obstack.h" + +#include "ada.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "repinfo.h" +#include "snames.h" +#include "stringt.h" +#include "uintp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "ada-tree.h" +#include "gigi.h" + +/* Setting this to 1 suppresses hashing of types. */ +extern int debug_no_type_hash; + +/* Provide default values for the macros controlling stack checking. + This is copied from GCC's expr.h. */ + +#ifndef STACK_CHECK_BUILTIN +#define STACK_CHECK_BUILTIN 0 +#endif +#ifndef STACK_CHECK_PROBE_INTERVAL +#define STACK_CHECK_PROBE_INTERVAL 4096 +#endif +#ifndef STACK_CHECK_MAX_FRAME_SIZE +#define STACK_CHECK_MAX_FRAME_SIZE \ + (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD) +#endif +#ifndef STACK_CHECK_MAX_VAR_SIZE +#define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100) +#endif + +/* These two variables are used to defer recursively expanding incomplete + types while we are processing a record or subprogram type. */ + +static int defer_incomplete_level = 0; +static struct incomplete +{ + struct incomplete *next; + tree old_type; + Entity_Id full_type; +} *defer_incomplete_list = 0; + +static tree substitution_list PARAMS ((Entity_Id, Entity_Id, + tree, int)); +static int allocatable_size_p PARAMS ((tree, int)); +static struct attrib *build_attr_list PARAMS ((Entity_Id)); +static tree elaborate_expression PARAMS ((Node_Id, Entity_Id, tree, + int, int, int)); +static tree elaborate_expression_1 PARAMS ((Node_Id, Entity_Id, tree, + tree, int, int)); +static tree make_packable_type PARAMS ((tree)); +static tree maybe_pad_type PARAMS ((tree, tree, unsigned int, + Entity_Id, const char *, int, + int, int)); +static tree gnat_to_gnu_field PARAMS ((Entity_Id, tree, int, int)); +static void components_to_record PARAMS ((tree, Node_Id, tree, int, + int, tree *, int, int)); +static int compare_field_bitpos PARAMS ((const PTR, const PTR)); +static Uint annotate_value PARAMS ((tree)); +static void annotate_rep PARAMS ((Entity_Id, tree)); +static tree compute_field_positions PARAMS ((tree, tree, tree, tree)); +static tree validate_size PARAMS ((Uint, tree, Entity_Id, + enum tree_code, int, int)); +static void set_rm_size PARAMS ((Uint, tree, Entity_Id)); +static tree make_type_from_size PARAMS ((tree, tree, int)); +static unsigned int validate_alignment PARAMS ((Uint, Entity_Id, + unsigned int)); +static void check_ok_for_atomic PARAMS ((tree, Entity_Id, int)); + +/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a + GCC type corresponding to that entity. GNAT_ENTITY is assumed to + refer to an Ada type. */ + +tree +gnat_to_gnu_type (gnat_entity) + Entity_Id gnat_entity; +{ + tree gnu_decl; + + /* Convert the ada entity type into a GCC TYPE_DECL node. */ + gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + if (TREE_CODE (gnu_decl) != TYPE_DECL) + gigi_abort (101); + + return TREE_TYPE (gnu_decl); +} + +/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada + entity, this routine returns the equivalent GCC tree for that entity + (an ..._DECL node) and associates the ..._DECL node with the input GNAT + defining identifier. + + If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its + initial value (in GCC tree form). This is optional for variables. + For renamed entities, GNU_EXPR gives the object being renamed. + + DEFINITION is nonzero if this call is intended for a definition. This is + used for separate compilation where it necessary to know whether an + external declaration or a definition should be created if the GCC equivalent + was not created previously. The value of 1 is normally used for a non-zero + DEFINITION, but a value of 2 is used in special circumstances, defined in + the code. */ + +tree +gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) + Entity_Id gnat_entity; + tree gnu_expr; + int definition; +{ + tree gnu_entity_id; + tree gnu_type = 0; + /* Contains the gnu XXXX_DECL tree node which is equivalent to the input + GNAT tree. This node will be associated with the GNAT node by calling + the save_gnu_tree routine at the end of the `switch' statement. */ + tree gnu_decl = 0; + /* Nonzero if we have already saved gnu_decl as a gnat association. */ + int saved = 0; + /* Nonzero if we incremented defer_incomplete_level. */ + int this_deferred = 0; + /* Nonzero if we incremented force_global. */ + int this_global = 0; + /* Nonzero if we should check to see if elaborated during processing. */ + int maybe_present = 0; + /* Nonzero if we made GNU_DECL and its type here. */ + int this_made_decl = 0; + struct attrib *attr_list = 0; + int debug_info_p = (Needs_Debug_Info (gnat_entity) + || debug_info_level == DINFO_LEVEL_VERBOSE); + Entity_Kind kind = Ekind (gnat_entity); + Entity_Id gnat_temp; + unsigned int esize + = ((Known_Esize (gnat_entity) + && UI_Is_In_Int_Range (Esize (gnat_entity))) + ? MIN (UI_To_Int (Esize (gnat_entity)), + IN (kind, Float_Kind) + ? LONG_DOUBLE_TYPE_SIZE + : IN (kind, Access_Kind) ? POINTER_SIZE * 2 + : LONG_LONG_TYPE_SIZE) + : LONG_LONG_TYPE_SIZE); + tree gnu_size = 0; + int imported_p + = ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity))) + || From_With_Type (gnat_entity)); + unsigned int align = 0; + + /* Since a use of an Itype is a definition, process it as such if it + is not in a with'ed unit. */ + + if (! definition && Is_Itype (gnat_entity) + && ! present_gnu_tree (gnat_entity) + && In_Extended_Main_Code_Unit (gnat_entity)) + { + /* Ensure that we are in a subprogram mentioned in the Scope + chain of this entity, our current scope is global, + or that we encountered a task or entry (where we can't currently + accurately check scoping). */ + if (current_function_decl == 0 + || DECL_ELABORATION_PROC_P (current_function_decl)) + { + process_type (gnat_entity); + return get_gnu_tree (gnat_entity); + } + + for (gnat_temp = Scope (gnat_entity); + Present (gnat_temp); gnat_temp = Scope (gnat_temp)) + { + if (Is_Type (gnat_temp)) + gnat_temp = Underlying_Type (gnat_temp); + + if (Ekind (gnat_temp) == E_Subprogram_Body) + gnat_temp + = Corresponding_Spec (Parent (Declaration_Node (gnat_temp))); + + if (IN (Ekind (gnat_temp), Subprogram_Kind) + && Present (Protected_Body_Subprogram (gnat_temp))) + gnat_temp = Protected_Body_Subprogram (gnat_temp); + + if (Ekind (gnat_temp) == E_Entry + || Ekind (gnat_temp) == E_Entry_Family + || Ekind (gnat_temp) == E_Task_Type + || (IN (Ekind (gnat_temp), Subprogram_Kind) + && present_gnu_tree (gnat_temp) + && (current_function_decl + == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0)))) + { + process_type (gnat_entity); + return get_gnu_tree (gnat_entity); + } + } + + /* gigi abort 122 means that the entity "gnat_entity" has an incorrect + scope, i.e. that its scope does not correspond to the subprogram + in which it is declared */ + gigi_abort (122); + } + + /* If this is entity 0, something went badly wrong. */ + if (gnat_entity == 0) + gigi_abort (102); + + /* If we've already processed this entity, return what we got last time. + If we are defining the node, we should not have already processed it. + In that case, we will abort below when we try to save a new GCC tree for + this object. We also need to handle the case of getting a dummy type + when a Full_View exists. */ + + if (present_gnu_tree (gnat_entity) + && (! definition + || (Is_Type (gnat_entity) && imported_p))) + { + gnu_decl = get_gnu_tree (gnat_entity); + + if (TREE_CODE (gnu_decl) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) + && IN (kind, Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + { + gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), + NULL_TREE, 0); + + save_gnu_tree (gnat_entity, NULL_TREE, 0); + save_gnu_tree (gnat_entity, gnu_decl, 0); + } + + return gnu_decl; + } + + /* If this is a numeric or enumeral type, or an access type, a nonzero + Esize must be specified unless it was specified by the programmer. */ + if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind) + || (IN (kind, Access_Kind) + && kind != E_Access_Protected_Subprogram_Type + && kind != E_Access_Subtype)) + && Unknown_Esize (gnat_entity) + && ! Has_Size_Clause (gnat_entity)) + gigi_abort (109); + + /* Likewise, RM_Size must be specified for all discrete and fixed-point + types. */ + if (IN (kind, Discrete_Or_Fixed_Point_Kind) + && Unknown_RM_Size (gnat_entity)) + gigi_abort (123); + + /* Get the name of the entity and set up the line number and filename of + the original definition for use in any decl we make. */ + + gnu_entity_id = get_entity_name (gnat_entity); + set_lineno (gnat_entity, 0); + + /* If we get here, it means we have not yet done anything with this + entity. If we are not defining it here, it must be external, + otherwise we should have defined it already. */ + if (! definition && ! Is_Public (gnat_entity) + && ! type_annotate_only + && kind != E_Discriminant && kind != E_Component + && kind != E_Label + && ! (kind == E_Constant && Present (Full_View (gnat_entity))) +#if 1 + && !IN (kind, Type_Kind) +#endif + ) + gigi_abort (116); + + /* For cases when we are not defining (i.e., we are referencing from + another compilation unit) Public entities, show we are at global level + for the purpose of computing sizes. Don't do this for components or + discriminants since the relevant test is whether or not the record is + being defined. */ + if (! definition && Is_Public (gnat_entity) + && ! Is_Statically_Allocated (gnat_entity) + && kind != E_Discriminant && kind != E_Component) + force_global++, this_global = 1; + + /* Handle any attributes. */ + if (Has_Gigi_Rep_Item (gnat_entity)) + attr_list = build_attr_list (gnat_entity); + + switch (kind) + { + case E_Constant: + /* If this is a use of a deferred constant, get its full + declaration. */ + if (! definition && Present (Full_View (gnat_entity))) + { + gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), + gnu_expr, definition); + saved = 1; + break; + } + + /* If we have an external constant that we are not defining, + get the expression that is was defined to represent. We + may throw that expression away later if it is not a + constant. */ + if (! definition + && Present (Expression (Declaration_Node (gnat_entity))) + && ! No_Initialization (Declaration_Node (gnat_entity))) + gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); + + /* Ignore deferred constant definitions; they are processed fully in the + front-end. For deferred constant references, get the full + definition. On the other hand, constants that are renamings are + handled like variable renamings. If No_Initialization is set, this is + not a deferred constant but a constant whose value is built + manually. */ + + if (definition && gnu_expr == 0 + && ! No_Initialization (Declaration_Node (gnat_entity)) + && No (Renamed_Object (gnat_entity))) + { + gnu_decl = error_mark_node; + saved = 1; + break; + } + else if (! definition && IN (kind, Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + { + gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), + NULL_TREE, 0); + saved = 1; + break; + } + + goto object; + + case E_Exception: + /* If this is not a VMS exception, treat it as a normal object. + Otherwise, make an object at the specific address of character + type, point to it, and convert it to integer, and mask off + the lower 3 bits. */ + if (! Is_VMS_Exception (gnat_entity)) + goto object; + + /* Allocate the global object that we use to get the value of the + exception. */ + gnu_decl = create_var_decl (gnu_entity_id, + (Present (Interface_Name (gnat_entity)) + ? create_concat_name (gnat_entity, 0) + : NULL_TREE), + char_type_node, NULL_TREE, 0, 0, 1, 1, + 0); + + /* Now return the expression giving the desired value. */ + gnu_decl + = build_binary_op (BIT_AND_EXPR, integer_type_node, + convert (integer_type_node, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_decl)), + build_unary_op (NEGATE_EXPR, integer_type_node, + build_int_2 (7, 0))); + + save_gnu_tree (gnat_entity, gnu_decl, 1); + saved = 1; + break; + + case E_Discriminant: + case E_Component: + { + /* The GNAT record where the component was defined. */ + Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity)); + + /* If the variable is an inherited record component (in the case of + extended record types), just return the inherited entity, which + must be a FIELD_DECL. Likewise for discriminants. + For discriminants of untagged records which have explicit + girder discriminants, return the entity for the corresponding + girder discriminant. Also use Original_Record_Component + if the record has a private extension. */ + + if ((Base_Type (gnat_record) == gnat_record + || Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private + || Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private) + && Present (Original_Record_Component (gnat_entity)) + && Original_Record_Component (gnat_entity) != gnat_entity) + { + gnu_decl + = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), + gnu_expr, definition); + saved = 1; + break; + } + + /* If the enclosing record has explicit girder discriminants, + then it is an untagged record. If the Corresponding_Discriminant + is not empty then this must be a renamed discriminant and its + Original_Record_Component must point to the corresponding explicit + girder discriminant (i.e., we should have taken the previous + branch). */ + + else if (Present (Corresponding_Discriminant (gnat_entity)) + && Is_Tagged_Type (gnat_record)) + { + /* A tagged record has no explicit girder discriminants. */ + + if (First_Discriminant (gnat_record) + != First_Girder_Discriminant (gnat_record)) + gigi_abort (119); + + gnu_decl + = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), + gnu_expr, definition); + saved = 1; + break; + } + + /* If the enclosing record has explicit girder discriminants, + then it is an untagged record. If the Corresponding_Discriminant + is not empty then this must be a renamed discriminant and its + Original_Record_Component must point to the corresponding explicit + girder discriminant (i.e., we should have taken the first + branch). */ + + else if (Present (Corresponding_Discriminant (gnat_entity)) + && (First_Discriminant (gnat_record) + != First_Girder_Discriminant (gnat_record))) + gigi_abort (120); + + /* Otherwise, if we are not defining this and we have no GCC type + for the containing record, make one for it. Then we should + have made our own equivalent. */ + else if (! definition && ! present_gnu_tree (gnat_record)) + { + /* ??? If this is in a record whose scope is a protected + type and we have an Original_Record_Component, use it. + This is a workaround for major problems in protected type + handling. */ + if (Is_Protected_Type (Scope (Scope (gnat_entity))) + && Present (Original_Record_Component (gnat_entity))) + { + gnu_decl + = gnat_to_gnu_entity (Original_Record_Component + (gnat_entity), + gnu_expr, definition); + saved = 1; + break; + } + + gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0); + gnu_decl = get_gnu_tree (gnat_entity); + saved = 1; + break; + } + + /* Here we have no GCC type and this is a reference rather than a + definition. This should never happen. Most likely the cause is a + reference before declaration in the gnat tree for gnat_entity. */ + else + gigi_abort (103); + } + + case E_Loop_Parameter: + case E_Out_Parameter: + case E_Variable: + + /* Simple variables, loop variables, OUT parameters, and exceptions. */ + object: + { + int used_by_ref = 0; + int const_flag + = ((kind == E_Constant || kind == E_Variable) + && ! Is_Statically_Allocated (gnat_entity) + && Is_True_Constant (gnat_entity) + && (((Nkind (Declaration_Node (gnat_entity)) + == N_Object_Declaration) + && Present (Expression (Declaration_Node (gnat_entity)))) + || Present (Renamed_Object (gnat_entity)))); + int inner_const_flag = const_flag; + int static_p = Is_Statically_Allocated (gnat_entity); + tree gnu_ext_name = NULL_TREE; + + if (Present (Renamed_Object (gnat_entity)) && ! definition) + { + if (kind == E_Exception) + gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), + NULL_TREE, 0); + else + gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity)); + } + + /* Get the type after elaborating the renamed object. */ + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + + /* If this is a loop variable, its type should be the base type. + This is because the code for processing a loop determines whether + a normal loop end test can be done by comparing the bounds of the + loop against those of the base type, which is presumed to be the + size used for computation. But this is not correct when the size + of the subtype is smaller than the type. */ + if (kind == E_Loop_Parameter) + gnu_type = get_base_type (gnu_type); + + /* Reject non-renamed objects whose types are unconstrained arrays or + any object whose type is a dummy type or VOID_TYPE. */ + + if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE + && No (Renamed_Object (gnat_entity))) + || TYPE_IS_DUMMY_P (gnu_type) + || TREE_CODE (gnu_type) == VOID_TYPE) + { + if (type_annotate_only) + return error_mark_node; + else + gigi_abort (104); + } + + /* If we are defining the object, see if it has a Size value and + validate it if so. Then get the new type, if any. */ + if (definition) + gnu_size = validate_size (Esize (gnat_entity), gnu_type, + gnat_entity, VAR_DECL, 0, + Has_Size_Clause (gnat_entity)); + + if (gnu_size != 0) + { + gnu_type + = make_type_from_size (gnu_type, gnu_size, + Has_Biased_Representation (gnat_entity)); + + if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)) + gnu_size = 0; + } + + /* If this object has self-referential size, it must be a record with + a default value. We are supposed to allocate an object of the + maximum size in this case unless it is a constant with an + initializing expression, in which case we can get the size from + that. Note that the resulting size may still be a variable, so + this may end up with an indirect allocation. */ + + if (No (Renamed_Object (gnat_entity)) + && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (gnu_type))) + { + if (gnu_expr != 0 && kind == E_Constant) + { + gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr)); + if (TREE_CODE (gnu_size) != INTEGER_CST + && contains_placeholder_p (gnu_size)) + { + tree gnu_temp = gnu_expr; + + /* Strip off any conversions in GNU_EXPR since + they can't be changing the size to allocate. */ + while (TREE_CODE (gnu_temp) == UNCHECKED_CONVERT_EXPR) + gnu_temp = TREE_OPERAND (gnu_temp, 0); + + gnu_size = TYPE_SIZE (TREE_TYPE (gnu_temp)); + if (TREE_CODE (gnu_size) != INTEGER_CST + && contains_placeholder_p (gnu_size)) + gnu_size = build (WITH_RECORD_EXPR, bitsizetype, + gnu_size, gnu_temp); + } + } + + /* We may have no GNU_EXPR because No_Initialization is + set even though there's an Expression. */ + else if (kind == E_Constant + && (Nkind (Declaration_Node (gnat_entity)) + == N_Object_Declaration) + && Present (Expression (Declaration_Node (gnat_entity)))) + gnu_size + = TYPE_SIZE (gnat_to_gnu_type + (Etype + (Expression (Declaration_Node (gnat_entity))))); + else + gnu_size = max_size (TYPE_SIZE (gnu_type), 1); + } + + /* If the size is zero bytes, make it one byte since some linkers + have trouble with zero-sized objects. But if this will have a + template, that will make it nonzero. */ + if (((gnu_size != 0 && integer_zerop (gnu_size)) + || (TYPE_SIZE (gnu_type) != 0 + && integer_zerop (TYPE_SIZE (gnu_type)))) + && (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + || ! Is_Array_Type (Etype (gnat_entity)))) + gnu_size = bitsize_unit_node; + + /* If an alignment is specified, use it if valid. Note that + exceptions are objects but don't have alignments. */ + if (kind != E_Exception && Known_Alignment (gnat_entity)) + { + if (No (Alignment (gnat_entity))) + gigi_abort (125); + + align + = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (gnu_type)); + } + + /* If this is an atomic object with no specified size and alignment, + but where the size of the type is a constant, set the alignment to + the lowest power of two greater than the size, or to the + biggest meaningful alignment, whichever is smaller. */ + + if (Is_Atomic (gnat_entity) && gnu_size == 0 && align == 0 + && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) + { + if (! host_integerp (TYPE_SIZE (gnu_type), 1) + || 0 <= compare_tree_int (TYPE_SIZE (gnu_type), + BIGGEST_ALIGNMENT)) + align = BIGGEST_ALIGNMENT; + else + align = ((unsigned int) 1 + << (floor_log2 (tree_low_cst + (TYPE_SIZE (gnu_type), 1) - 1) + + 1)); + } + +#ifdef MINIMUM_ATOMIC_ALIGNMENT + /* If the size is a constant and no alignment is specified, force + the alignment to be the minimum valid atomic alignment. The + restriction on constant size avoids problems with variable-size + temporaries; if the size is variable, there's no issue with + atomic access. Also don't do this for a constant, since it isn't + necessary and can interfere with constant replacement. Finally, + do not do it for Out parameters since that creates an + size inconsistency with In parameters. */ + if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) + && ! FLOAT_TYPE_P (gnu_type) + && ! const_flag && No (Renamed_Object (gnat_entity)) + && ! imported_p && No (Address_Clause (gnat_entity)) + && kind != E_Out_Parameter + && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST + : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)) + align = MINIMUM_ATOMIC_ALIGNMENT; +#endif + + /* If the object is set to have atomic components, find the component + type and validate it. + + ??? Note that we ignore Has_Volatile_Components on objects; it's + not at all clear what to do in that case. */ + + if (Has_Atomic_Components (gnat_entity)) + { + tree gnu_inner + = (TREE_CODE (gnu_type) == ARRAY_TYPE + ? TREE_TYPE (gnu_type) : gnu_type); + + while (TREE_CODE (gnu_inner) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (gnu_inner)) + gnu_inner = TREE_TYPE (gnu_inner); + + check_ok_for_atomic (gnu_inner, gnat_entity, 1); + } + + /* Make a new type with the desired size and alignment, if needed. */ + gnu_type = maybe_pad_type (gnu_type, gnu_size, align, + gnat_entity, "PAD", 0, definition, 1); + + /* Make a volatile version of this object's type if we are to + make the object volatile. Note that 13.3(19) says that we + should treat other types of objects as volatile as well. */ + if ((Is_Volatile (gnat_entity) + || Is_Exported (gnat_entity) + || Is_Imported (gnat_entity) + || Present (Address_Clause (gnat_entity))) + && ! TYPE_VOLATILE (gnu_type)) + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | TYPE_QUAL_VOLATILE)); + + /* If this is an aliased object with an unconstrained nominal subtype, + make a type that includes the template. */ + if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + && Is_Array_Type (Etype (gnat_entity)) + && ! type_annotate_only) + { + tree gnu_fat + = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity)))); + tree gnu_temp_type + = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat)))); + + gnu_type + = build_unc_object_type (gnu_temp_type, gnu_type, + concat_id_with_name (gnu_entity_id, + "UNC")); + } + + + /* Convert the expression to the type of the object except in the + case where the object's type is unconstrained or the object's type + is a padded record whose field is of self-referential size. In + the former case, converting will generate unnecessary evaluations + of the CONSTRUCTOR to compute the size and in the latter case, we + want to only copy the actual data. */ + if (gnu_expr != 0 + && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE + && ! (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (gnu_type))) + && ! (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && (contains_placeholder_p + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) + gnu_expr = convert (gnu_type, gnu_expr); + + /* See if this is a renaming. If this is a constant renaming, + treat it as a normal variable whose initial value is what + is being renamed. We cannot do this if the type is + unconstrained or class-wide. + + Otherwise, if what we are renaming is a reference, we can simply + return a stabilized version of that reference, after forcing + any SAVE_EXPRs to be evaluated. But, if this is at global level, + we can only do this if we know no SAVE_EXPRs will be made. + Otherwise, make this into a constant pointer to the object we are + to rename. */ + + if (Present (Renamed_Object (gnat_entity))) + { + /* If the renamed object had padding, strip off the reference + to the inner object and reset our type. */ + if (TREE_CODE (gnu_expr) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) + { + gnu_expr = TREE_OPERAND (gnu_expr, 0); + gnu_type = TREE_TYPE (gnu_expr); + } + + if (const_flag + && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE + && TYPE_MODE (gnu_type) != BLKmode + && Ekind (Etype (gnat_entity)) != E_Class_Wide_Type + && !Is_Array_Type (Etype (gnat_entity))) + ; + + /* If this is a declaration or reference, we can just use that + declaration or reference as this entity. */ + else if ((DECL_P (gnu_expr) + || TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r') + && ! Materialize_Entity (gnat_entity) + && (! global_bindings_p () + || (staticp (gnu_expr) + && ! TREE_SIDE_EFFECTS (gnu_expr)))) + { + set_lineno (gnat_entity, ! global_bindings_p ()); + gnu_decl = gnat_stabilize_reference (gnu_expr, 1); + save_gnu_tree (gnat_entity, gnu_decl, 1); + saved = 1; + + if (! global_bindings_p ()) + expand_expr_stmt (build1 (CONVERT_EXPR, void_type_node, + gnu_decl)); + break; + } + else + { + inner_const_flag = TREE_READONLY (gnu_expr); + const_flag = 1; + gnu_type = build_reference_type (gnu_type); + gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr); + gnu_size = 0; + used_by_ref = 1; + } + } + + /* If this is an aliased object whose nominal subtype is unconstrained, + the object is a record that contains both the template and + the object. If there is an initializer, it will have already + been converted to the right type, but we need to create the + template if there is no initializer. */ + else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type) + && gnu_expr == 0) + gnu_expr + = build_constructor + (gnu_type, + tree_cons + (TYPE_FIELDS (gnu_type), + build_template + (TREE_TYPE (TYPE_FIELDS (gnu_type)), + TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))), + NULL_TREE), + NULL_TREE)); + + /* If this is a pointer and it does not have an initializing + expression, initialize it to NULL. */ + if (definition + && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type)) + && gnu_expr == 0) + gnu_expr = integer_zero_node; + + /* If we are defining the object and it has an Address clause we must + get the address expression from the saved GCC tree for the + object if the object has a Freeze_Node. Otherwise, we elaborate + the address expression here since the front-end has guaranteed + in that case that the elaboration has no effects. Note that + only the latter mechanism is currently in use. */ + if (definition && Present (Address_Clause (gnat_entity))) + { + tree gnu_address + = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) + : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); + + save_gnu_tree (gnat_entity, NULL_TREE, 0); + + /* Ignore the size. It's either meaningless or was handled + above. */ + gnu_size = 0; + gnu_type = build_reference_type (gnu_type); + gnu_address = convert (gnu_type, gnu_address); + used_by_ref = 1; + const_flag = ! Is_Public (gnat_entity); + + /* If we don't have an initializing expression for the underlying + variable, the initializing expression for the pointer is the + specified address. Otherwise, we have to make a COMPOUND_EXPR + to assign both the address and the initial value. */ + if (gnu_expr == 0) + gnu_expr = gnu_address; + else + gnu_expr + = build (COMPOUND_EXPR, gnu_type, + build_binary_op + (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_address), + gnu_expr), + gnu_address); + } + + /* If it has an address clause and we are not defining it, mark it + as an indirect object. Likewise for Stdcall objects that are + imported. */ + if ((! definition && Present (Address_Clause (gnat_entity))) + || (Is_Imported (gnat_entity) + && Convention (gnat_entity) == Convention_Stdcall)) + { + gnu_type = build_reference_type (gnu_type); + gnu_size = 0; + used_by_ref = 1; + } + + /* If we are at top level and this object is of variable size, + make the actual type a hidden pointer to the real type and + make the initializer be a memory allocation and initialization. + Likewise for objects we aren't defining (presumed to be + external references from other packages), but there we do + not set up an initialization. + + If the object's size overflows, make an allocator too, so that + Storage_Error gets raised. Note that we will never free + such memory, so we presume it never will get allocated. */ + + if (! allocatable_size_p (TYPE_SIZE_UNIT (gnu_type), + global_bindings_p () || ! definition + || static_p) + || (gnu_size != 0 + && ! allocatable_size_p (gnu_size, + global_bindings_p () || ! definition + || static_p))) + { + gnu_type = build_reference_type (gnu_type); + gnu_size = 0; + used_by_ref = 1; + const_flag = 1; + + /* Get the data part of GNU_EXPR in case this was a + aliased object whose nominal subtype is unconstrained. + In that case the pointer above will be a thin pointer and + build_allocator will automatically make the template and + constructor already made above. */ + + if (definition) + { + tree gnu_alloc_type = TREE_TYPE (gnu_type); + + if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type)) + { + gnu_alloc_type + = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type))); + gnu_expr + = build_component_ref + (gnu_expr, NULL_TREE, + TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr)))); + } + + if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST + && TREE_CONSTANT_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)) + && ! Is_Imported (gnat_entity)) + post_error ("Storage_Error will be raised at run-time?", + gnat_entity); + + gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, + gnu_type, 0, 0); + } + else + { + gnu_expr = 0; + const_flag = 0; + } + } + + /* If this object would go into the stack and has an alignment + larger than the default largest alignment, make a variable + to hold the "aligning type" with a modified initial value, + if any, then point to it and make that the value of this + variable, which is now indirect. */ + + if (! global_bindings_p () && ! static_p && definition + && ! imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) + { + tree gnu_new_type + = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type), + TYPE_SIZE_UNIT (gnu_type)); + tree gnu_new_var; + + if (gnu_expr != 0) + gnu_expr + = build_constructor (gnu_new_type, + tree_cons (TYPE_FIELDS (gnu_new_type), + gnu_expr, NULL_TREE)); + set_lineno (gnat_entity, 1); + gnu_new_var + = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), + NULL_TREE, gnu_new_type, gnu_expr, + 0, 0, 0, 0, 0); + + gnu_type = build_reference_type (gnu_type); + gnu_expr + = build_unary_op + (ADDR_EXPR, gnu_type, + build_component_ref (gnu_new_var, NULL_TREE, + TYPE_FIELDS (gnu_new_type))); + + gnu_size = 0; + used_by_ref = 1; + const_flag = 1; + } + + /* Convert the expression to the type of the object except in the + case where the object's type is unconstrained or the object's type + is a padded record whose field is of self-referential size. In + the former case, converting will generate unnecessary evaluations + of the CONSTRUCTOR to compute the size and in the latter case, we + want to only copy the actual data. */ + if (gnu_expr != 0 + && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE + && ! (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (gnu_type))) + && ! (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && (contains_placeholder_p + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) + gnu_expr = convert (gnu_type, gnu_expr); + + /* This name is external or there was a name specified, use it. + Don't use the Interface_Name if there is an address clause. + (see CD30005). */ + if ((Present (Interface_Name (gnat_entity)) + && No (Address_Clause (gnat_entity))) + || (Is_Public (gnat_entity) + && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))) + gnu_ext_name = create_concat_name (gnat_entity, 0); + + if (const_flag) + gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type) + | TYPE_QUAL_CONST)); + + /* If this is constant initialized to a static constant and the + object has an aggregrate type, force it to be statically + allocated. */ + if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr) + && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1) + && (AGGREGATE_TYPE_P (gnu_type) + && ! (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type)))) + static_p = 1; + + set_lineno (gnat_entity, ! global_bindings_p ()); + gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, + gnu_expr, const_flag, + Is_Public (gnat_entity), + imported_p || !definition, + static_p, attr_list); + + DECL_BY_REF_P (gnu_decl) = used_by_ref; + DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; + + if (definition && DECL_SIZE (gnu_decl) != 0 + && gnu_block_stack != 0 + && TREE_VALUE (gnu_block_stack) != 0 + && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST + || (flag_stack_check && ! STACK_CHECK_BUILTIN + && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl), + STACK_CHECK_MAX_VAR_SIZE)))) + update_setjmp_buf (TREE_VALUE (gnu_block_stack)); + + /* If this is a public constant and we're not making a VAR_DECL for + it, make one just for export or debugger use. Likewise if + the address is taken or if the object or type is aliased. */ + if (definition && TREE_CODE (gnu_decl) == CONST_DECL + && (Is_Public (gnat_entity) + || Address_Taken (gnat_entity) + || Is_Aliased (gnat_entity) + || Is_Aliased (Etype (gnat_entity)))) + DECL_CONST_CORRESPONDING_VAR (gnu_decl) + = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, + gnu_expr, 0, Is_Public (gnat_entity), 0, + static_p, 0); + + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_decl, gnat_entity, 0); + + /* If this is declared in a block that contains an block with an + exception handler, we must force this variable in memory to + suppress an invalid optimization. */ + if (Has_Nested_Block_With_Handler (Scope (gnat_entity))) + { + mark_addressable (gnu_decl); + flush_addressof (gnu_decl); + } + + /* Back-annotate the Alignment of the object if not already in the + tree. Likewise for Esize if the object is of a constant size. */ + if (Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, + UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT)); + + if (Unknown_Esize (gnat_entity) + && DECL_SIZE (gnu_decl) != 0) + { + tree gnu_back_size = DECL_SIZE (gnu_decl); + + if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl))) + gnu_back_size + = TYPE_SIZE (TREE_TYPE (TREE_CHAIN + (TYPE_FIELDS (TREE_TYPE (gnu_decl))))); + + Set_Esize (gnat_entity, annotate_value (gnu_back_size)); + } + } + break; + + case E_Void: + /* Return a TYPE_DECL for "void" that we previously made. */ + gnu_decl = void_type_decl_node; + break; + + case E_Enumeration_Type: + /* A special case, for the types Character and Wide_Character in + Standard, we do not list all the literals. So if the literals + are not specified, make this an unsigned type. */ + if (No (First_Literal (gnat_entity))) + { + gnu_type = make_unsigned_type (esize); + break; + } + + /* Normal case of non-character type, or non-Standard character type */ + { + /* Here we have a list of enumeral constants in First_Literal. + We make a CONST_DECL for each and build into GNU_LITERAL_LIST + the list to be places into TYPE_FIELDS. Each node in the list + is a TREE_LIST node whose TREE_VALUE is the literal name + and whose TREE_PURPOSE is the value of the literal. + + Esize contains the number of bits needed to represent the enumeral + type, Type_Low_Bound also points to the first literal and + Type_High_Bound points to the last literal. */ + + Entity_Id gnat_literal; + tree gnu_literal_list = NULL_TREE; + + if (Is_Unsigned_Type (gnat_entity)) + gnu_type = make_unsigned_type (esize); + else + gnu_type = make_signed_type (esize); + + TREE_SET_CODE (gnu_type, ENUMERAL_TYPE); + + for (gnat_literal = First_Literal (gnat_entity); + Present (gnat_literal); + gnat_literal = Next_Literal (gnat_literal)) + { + tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal), + gnu_type); + tree gnu_literal + = create_var_decl (get_entity_name (gnat_literal), + 0, gnu_type, gnu_value, 1, 0, 0, 0, 0); + + save_gnu_tree (gnat_literal, gnu_literal, 0); + gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), + gnu_value, gnu_literal_list); + } + + TYPE_FIELDS (gnu_type) = nreverse (gnu_literal_list); + + /* Note that the bounds are updated at the end of this function + because to avoid an infinite recursion when we get the bounds of + this type, since those bounds are objects of this type. */ + } + break; + + case E_Signed_Integer_Type: + case E_Ordinary_Fixed_Point_Type: + case E_Decimal_Fixed_Point_Type: + /* For integer types, just make a signed type the appropriate number + of bits. */ + gnu_type = make_signed_type (esize); + break; + + case E_Modular_Integer_Type: + /* For modular types, make the unsigned type of the proper number of + bits and then set up the modulus, if required. */ + { + enum machine_mode mode; + tree gnu_modulus; + tree gnu_high = 0; + + if (Is_Packed_Array_Type (gnat_entity)) + esize = UI_To_Int (RM_Size (gnat_entity)); + + /* Find the smallest mode at least ESIZE bits wide and make a class + using that mode. */ + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); + GET_MODE_BITSIZE (mode) < esize; + mode = GET_MODE_WIDER_MODE (mode)) + ; + + gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode)); + TYPE_PACKED_ARRAY_TYPE_P (gnu_type) + = Is_Packed_Array_Type (gnat_entity); + + /* Get the modulus in this type. If it overflows, assume it is because + it is equal to 2**Esize. Note that there is no overflow checking + done on unsigned type, so we detect the overflow by looking for + a modulus of zero, which is otherwise invalid. */ + gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type); + + if (! integer_zerop (gnu_modulus)) + { + TYPE_MODULAR_P (gnu_type) = 1; + TYPE_MODULUS (gnu_type) = gnu_modulus; + gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus, + convert (gnu_type, integer_one_node))); + } + + /* If we have to set TYPE_PRECISION different from its natural value, + make a subtype to do do. Likewise if there is a modulus and + it is not one greater than TYPE_MAX_VALUE. */ + if (TYPE_PRECISION (gnu_type) != esize + || (TYPE_MODULAR_P (gnu_type) + && ! tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high))) + { + tree gnu_subtype = make_node (INTEGER_TYPE); + + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT"); + TREE_TYPE (gnu_subtype) = gnu_type; + TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type); + TYPE_MAX_VALUE (gnu_subtype) + = TYPE_MODULAR_P (gnu_type) + ? gnu_high : TYPE_MAX_VALUE (gnu_type); + TYPE_PRECISION (gnu_subtype) = esize; + TREE_UNSIGNED (gnu_subtype) = 1; + TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; + TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype) + = Is_Packed_Array_Type (gnat_entity); + layout_type (gnu_subtype); + + gnu_type = gnu_subtype; + } + } + break; + + case E_Signed_Integer_Subtype: + case E_Enumeration_Subtype: + case E_Modular_Integer_Subtype: + case E_Ordinary_Fixed_Point_Subtype: + case E_Decimal_Fixed_Point_Subtype: + + /* For integral subtypes, we make a new INTEGER_TYPE. Note + that we do not want to call build_range_type since we would + like each subtype node to be distinct. This will be important + when memory aliasing is implemented. + + The TREE_TYPE field of the INTEGER_TYPE we make points to the + parent type; this fact is used by the arithmetic conversion + functions. + + We elaborate the Ancestor_Subtype if it is not in the current + unit and one of our bounds is non-static. We do this to ensure + consistent naming in the case where several subtypes share the same + bounds by always elaborating the first such subtype first, thus + using its name. */ + + if (definition == 0 + && Present (Ancestor_Subtype (gnat_entity)) + && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) + && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) + || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) + gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), + gnu_expr, definition); + + gnu_type = make_node (INTEGER_TYPE); + if (Is_Packed_Array_Type (gnat_entity)) + { + + esize = UI_To_Int (RM_Size (gnat_entity)); + TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; + } + + TYPE_PRECISION (gnu_type) = esize; + TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); + + TYPE_MIN_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, + get_identifier ("L"), definition, 1, + Needs_Debug_Info (gnat_entity))); + + TYPE_MAX_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, + get_identifier ("U"), definition, 1, + Needs_Debug_Info (gnat_entity))); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = 1; + break; + } + + TYPE_BIASED_REPRESENTATION_P (gnu_type) + = Has_Biased_Representation (gnat_entity); + + /* This should be an unsigned type if the lower bound is constant + and non-negative or if the base type is unsigned; a signed type + otherwise. */ + TREE_UNSIGNED (gnu_type) + = (TREE_UNSIGNED (TREE_TYPE (gnu_type)) + || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST + && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0) + || TYPE_BIASED_REPRESENTATION_P (gnu_type) + || Is_Unsigned_Type (gnat_entity)); + + layout_type (gnu_type); + + if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN) + { + tree gnu_field_type = gnu_type; + tree gnu_field; + + TYPE_RM_SIZE_INT (gnu_field_type) + = UI_To_gnu (RM_Size (gnat_entity), bitsizetype); + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM"); + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type); + TYPE_PACKED (gnu_type) = 1; + gnu_field = create_field_decl (get_identifier ("OBJECT"), + gnu_field_type, gnu_type, 1, 0, 0, 1), + finish_record_type (gnu_type, gnu_field, 0, 0); + TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1; + TYPE_ADA_SIZE (gnu_type) = bitsize_int (esize); + } + + break; + + case E_Floating_Point_Type: + /* If this is a VAX floating-point type, use an integer of the proper + size. All the operations will be handled with ASM statements. */ + if (Vax_Float (gnat_entity)) + { + gnu_type = make_signed_type (esize); + TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; + TYPE_DIGITS_VALUE (gnu_type) + = UI_To_Int (Digits_Value (gnat_entity)); + break; + } + + /* The type of the Low and High bounds can be our type if this is + a type from Standard, so set them at the end of the function. */ + gnu_type = make_node (REAL_TYPE); + TYPE_PRECISION (gnu_type) = esize; + layout_type (gnu_type); + break; + + case E_Floating_Point_Subtype: + if (Vax_Float (gnat_entity)) + { + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + break; + } + + { + enum machine_mode mode; + + if (definition == 0 + && Present (Ancestor_Subtype (gnat_entity)) + && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) + && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) + || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) + gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), + gnu_expr, definition); + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); + (GET_MODE_WIDER_MODE (mode) != VOIDmode + && GET_MODE_BITSIZE (GET_MODE_WIDER_MODE (mode)) <= esize); + mode = GET_MODE_WIDER_MODE (mode)) + ; + + gnu_type = make_node (REAL_TYPE); + TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); + TYPE_PRECISION (gnu_type) = GET_MODE_BITSIZE (mode); + + TYPE_MIN_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, get_identifier ("L"), + definition, 1, + Needs_Debug_Info (gnat_entity))); + + TYPE_MAX_VALUE (gnu_type) + = convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, get_identifier ("U"), + definition, 1, + Needs_Debug_Info (gnat_entity))); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = 1; + break; + } + + layout_type (gnu_type); + } + break; + + /* Array and String Types and Subtypes + + Unconstrained array types are represented by E_Array_Type and + constrained array types are represented by E_Array_Subtype. There + are no actual objects of an unconstrained array type; all we have + are pointers to that type. + + The following fields are defined on array types and subtypes: + + Component_Type Component type of the array. + Number_Dimensions Number of dimensions (an int). + First_Index Type of first index. */ + + case E_String_Type: + case E_Array_Type: + { + tree gnu_template_fields = NULL_TREE; + tree gnu_template_type = make_node (RECORD_TYPE); + tree gnu_ptr_template = build_pointer_type (gnu_template_type); + tree gnu_fat_type = make_node (RECORD_TYPE); + int ndim = Number_Dimensions (gnat_entity); + int firstdim + = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0; + int nextdim + = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1; + tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *)); + tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *)); + tree gnu_comp_size = 0; + tree gnu_max_size = size_one_node; + tree gnu_max_size_unit; + int index; + Entity_Id gnat_ind_subtype; + Entity_Id gnat_ind_base_subtype; + tree gnu_template_reference; + tree tem; + + TYPE_NAME (gnu_template_type) + = create_concat_name (gnat_entity, "XUB"); + TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP"); + TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1; + TREE_READONLY (gnu_template_type) = 1; + + /* Make a node for the array. If we are not defining the array + suppress expanding incomplete types and save the node as the type + for GNAT_ENTITY. */ + gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); + if (! definition) + { + defer_incomplete_level++; + this_deferred = this_made_decl = 1; + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + save_gnu_tree (gnat_entity, gnu_decl, 0); + saved = 1; + } + + /* Build the fat pointer type. Use a "void *" object instead of + a pointer to the array type since we don't have the array type + yet (it will reference the fat pointer via the bounds). */ + tem = chainon (chainon (NULL_TREE, + create_field_decl (get_identifier ("P_ARRAY"), + ptr_void_type_node, + gnu_fat_type, 0, 0, 0, 0)), + create_field_decl (get_identifier ("P_BOUNDS"), + gnu_ptr_template, + gnu_fat_type, 0, 0, 0, 0)); + + /* Make sure we can put this into a register. */ + TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); + finish_record_type (gnu_fat_type, tem, 0, 1); + + /* Build a reference to the template from a PLACEHOLDER_EXPR that + is the fat pointer. This will be used to access the individual + fields once we build them. */ + tem = build (COMPONENT_REF, gnu_ptr_template, + build (PLACEHOLDER_EXPR, gnu_fat_type), + TREE_CHAIN (TYPE_FIELDS (gnu_fat_type))); + gnu_template_reference + = build_unary_op (INDIRECT_REF, gnu_template_type, tem); + TREE_READONLY (gnu_template_reference) = 1; + + /* Now create the GCC type for each index and add the fields for + that index to the template. */ + for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity), + gnat_ind_base_subtype + = First_Index (Implementation_Base_Type (gnat_entity)); + index < ndim && index >= 0; + index += nextdim, + gnat_ind_subtype = Next_Index (gnat_ind_subtype), + gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) + { + char field_name[10]; + tree gnu_ind_subtype + = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype))); + tree gnu_base_subtype + = get_unpadded_type (Etype (gnat_ind_base_subtype)); + tree gnu_base_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); + tree gnu_base_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); + tree gnu_min_field, gnu_max_field, gnu_min, gnu_max; + + /* Make the FIELD_DECLs for the minimum and maximum of this + type and then make extractions of that field from the + template. */ + set_lineno (gnat_entity, 0); + sprintf (field_name, "LB%d", index); + gnu_min_field = create_field_decl (get_identifier (field_name), + gnu_ind_subtype, + gnu_template_type, 0, 0, 0, 0); + field_name[0] = 'U'; + gnu_max_field = create_field_decl (get_identifier (field_name), + gnu_ind_subtype, + gnu_template_type, 0, 0, 0, 0); + + gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field); + + /* We can't use build_component_ref here since the template + type isn't complete yet. */ + gnu_min = build (COMPONENT_REF, gnu_ind_subtype, + gnu_template_reference, gnu_min_field); + gnu_max = build (COMPONENT_REF, gnu_ind_subtype, + gnu_template_reference, gnu_max_field); + TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1; + + /* Make a range type with the new ranges, but using + the Ada subtype. Then we convert to sizetype. */ + gnu_index_types[index] + = create_index_type (convert (sizetype, gnu_min), + convert (sizetype, gnu_max), + build_range_type (gnu_ind_subtype, + gnu_min, gnu_max)); + /* Update the maximum size of the array, in elements. */ + gnu_max_size + = size_binop (MULT_EXPR, gnu_max_size, + size_binop (PLUS_EXPR, size_one_node, + size_binop (MINUS_EXPR, gnu_base_max, + gnu_base_min))); + + + TYPE_NAME (gnu_index_types[index]) + = create_concat_name (gnat_entity, field_name); + } + + for (index = 0; index < ndim; index++) + gnu_template_fields + = chainon (gnu_template_fields, gnu_temp_fields[index]); + + /* Install all the fields into the template. */ + finish_record_type (gnu_template_type, gnu_template_fields, 0, 0); + TREE_READONLY (gnu_template_type) = 1; + + /* Now make the array of arrays and update the pointer to the array + in the fat pointer. Note that it is the first field. */ + + tem = gnat_to_gnu_type (Component_Type (gnat_entity)); + + /* Get and validate any specified Component_Size, but if Packed, + ignore it since the front end will have taken care of it. Also, + allow sizes not a multiple of Storage_Unit if packed. */ + gnu_comp_size + = validate_size (Component_Size (gnat_entity), tem, + gnat_entity, + (Is_Bit_Packed_Array (gnat_entity) + ? TYPE_DECL : VAR_DECL), 1, + Has_Component_Size_Clause (gnat_entity)); + + if (Has_Atomic_Components (gnat_entity)) + check_ok_for_atomic (tem, gnat_entity, 1); + + /* If the component type is a RECORD_TYPE that has a self-referential + size, use the maxium size. */ + if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE + && TREE_CODE (TYPE_SIZE (tem)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (tem))) + gnu_comp_size = max_size (TYPE_SIZE (tem), 1); + + if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0) + { + tem = make_type_from_size (tem, gnu_comp_size, 0); + tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity, + "C_PAD", 0, definition, 1); + } + + if (Has_Volatile_Components (gnat_entity)) + tem = build_qualified_type (tem, + TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE); + + /* If Component_Size is not already specified, annotate it with the + size of the component. */ + if (Unknown_Component_Size (gnat_entity)) + Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem))); + + gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node, + size_binop (MULT_EXPR, gnu_max_size, + TYPE_SIZE_UNIT (tem))); + gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node, + size_binop (MULT_EXPR, + convert (bitsizetype, + gnu_max_size), + TYPE_SIZE (tem))); + + for (index = ndim - 1; index >= 0; index--) + { + tem = build_array_type (tem, gnu_index_types[index]); + TYPE_MULTI_ARRAY_P (tem) = (index > 0); + TYPE_NONALIASED_COMPONENT (tem) + = ! Has_Aliased_Components (gnat_entity); + } + + /* If an alignment is specified, use it if valid. But ignore it for + types that represent the unpacked base type for packed arrays. */ + if (No (Packed_Array_Type (gnat_entity)) + && Known_Alignment (gnat_entity)) + { + if (No (Alignment (gnat_entity))) + gigi_abort (124); + + TYPE_ALIGN (tem) + = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (tem)); + } + + TYPE_CONVENTION_FORTRAN_P (tem) + = (Convention (gnat_entity) == Convention_Fortran); + TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); + + /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the + corresponding fat pointer. */ + TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) + = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; + TYPE_MODE (gnu_type) = BLKmode; + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); + TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type) = gnu_type; + + /* If the maximum size doesn't overflow, use it. */ + if (TREE_CODE (gnu_max_size) == INTEGER_CST + && ! TREE_OVERFLOW (gnu_max_size)) + { + TYPE_SIZE (tem) + = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); + TYPE_SIZE_UNIT (tem) + = size_binop (MIN_EXPR, gnu_max_size_unit, + TYPE_SIZE_UNIT (tem)); + } + + create_type_decl (create_concat_name (gnat_entity, "XUA"), + tem, 0, ! Comes_From_Source (gnat_entity), + debug_info_p); + rest_of_type_compilation (gnu_fat_type, global_bindings_p ()); + + + /* Create a record type for the object and its template and + set the template at a negative offset. */ + tem = build_unc_object_type (gnu_template_type, tem, + create_concat_name (gnat_entity, "XUT")); + DECL_FIELD_OFFSET (TYPE_FIELDS (tem)) + = size_binop (MINUS_EXPR, size_zero_node, + byte_position (TREE_CHAIN (TYPE_FIELDS (tem)))); + DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node; + DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) + = bitsize_zero_node; + TYPE_UNCONSTRAINED_ARRAY (tem) = gnu_type; + TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; + + /* Give the thin pointer type a name. */ + create_type_decl (create_concat_name (gnat_entity, "XUX"), + build_pointer_type (tem), 0, + ! Comes_From_Source (gnat_entity), debug_info_p); + } + break; + + case E_String_Subtype: + case E_Array_Subtype: + + /* This is the actual data type for array variables. Multidimensional + arrays are implemented in the gnu tree as arrays of arrays. Note + that for the moment arrays which have sparse enumeration subtypes as + index components create sparse arrays, which is obviously space + inefficient but so much easier to code for now. + + Also note that the subtype never refers to the unconstrained + array type, which is somewhat at variance with Ada semantics. + + First check to see if this is simply a renaming of the array + type. If so, the result is the array type. */ + + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + if (! Is_Constrained (gnat_entity)) + break; + else + { + int index; + int array_dim = Number_Dimensions (gnat_entity); + int first_dim + = ((Convention (gnat_entity) == Convention_Fortran) + ? array_dim - 1 : 0); + int next_dim + = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1; + Entity_Id gnat_ind_subtype; + Entity_Id gnat_ind_base_subtype; + tree gnu_base_type = gnu_type; + tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *)); + tree gnu_comp_size = 0; + tree gnu_max_size = size_one_node; + tree gnu_max_size_unit; + int need_index_type_struct = 0; + int max_overflow = 0; + + /* First create the gnu types for each index. Create types for + debugging information to point to the index types if the + are not integer types, have variable bounds, or are + wider than sizetype. */ + + for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity), + gnat_ind_base_subtype + = First_Index (Implementation_Base_Type (gnat_entity)); + index < array_dim && index >= 0; + index += next_dim, + gnat_ind_subtype = Next_Index (gnat_ind_subtype), + gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) + { + tree gnu_index_subtype + = get_unpadded_type (Etype (gnat_ind_subtype)); + tree gnu_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype)); + tree gnu_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype)); + tree gnu_base_subtype + = get_unpadded_type (Etype (gnat_ind_base_subtype)); + tree gnu_base_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); + tree gnu_base_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); + tree gnu_base_type = get_base_type (gnu_base_subtype); + tree gnu_base_base_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type)); + tree gnu_base_base_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type)); + tree gnu_high; + tree gnu_this_max; + + /* If the minimum and maximum values both overflow in + SIZETYPE, but the difference in the original type + does not overflow in SIZETYPE, ignore the overflow + indications. */ + if ((TYPE_PRECISION (gnu_index_subtype) + > TYPE_PRECISION (sizetype)) + && TREE_CODE (gnu_min) == INTEGER_CST + && TREE_CODE (gnu_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max) + && (! TREE_OVERFLOW + (fold (build (MINUS_EXPR, gnu_index_subtype, + TYPE_MAX_VALUE (gnu_index_subtype), + TYPE_MIN_VALUE (gnu_index_subtype)))))) + TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max) + = TREE_CONSTANT_OVERFLOW (gnu_min) + = TREE_CONSTANT_OVERFLOW (gnu_max) = 0; + + /* Similarly, if the range is null, use bounds of 1..0 for + the sizetype bounds. */ + else if ((TYPE_PRECISION (gnu_index_subtype) + > TYPE_PRECISION (sizetype)) + && TREE_CODE (gnu_min) == INTEGER_CST + && TREE_CODE (gnu_max) == INTEGER_CST + && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max)) + && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype), + TYPE_MIN_VALUE (gnu_index_subtype))) + gnu_min = size_one_node, gnu_max = size_zero_node; + + /* Now compute the size of this bound. We need to provide + GCC with an upper bound to use but have to deal with the + "superflat" case. There are three ways to do this. If we + can prove that the array can never be superflat, we can + just use the high bound of the index subtype. If we can + prove that the low bound minus one can't overflow, we + can do this as MAX (hb, lb - 1). Otherwise, we have to use + the expression hb >= lb ? hb : lb - 1. */ + gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node); + + /* See if the base array type is already flat. If it is, we + are probably compiling an ACVC test, but it will cause the + code below to malfunction if we don't handle it specially. */ + if (TREE_CODE (gnu_base_min) == INTEGER_CST + && TREE_CODE (gnu_base_max) == INTEGER_CST + && ! TREE_CONSTANT_OVERFLOW (gnu_base_min) + && ! TREE_CONSTANT_OVERFLOW (gnu_base_max) + && tree_int_cst_lt (gnu_base_max, gnu_base_min)) + gnu_high = size_zero_node, gnu_min = size_one_node; + + /* If gnu_high is now an integer which overflowed, the array + cannot be superflat. */ + else if (TREE_CODE (gnu_high) == INTEGER_CST + && TREE_OVERFLOW (gnu_high)) + gnu_high = gnu_max; + else if (TREE_UNSIGNED (gnu_base_subtype) + || TREE_CODE (gnu_high) == INTEGER_CST) + gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high); + else + gnu_high + = build_cond_expr + (sizetype, build_binary_op (GE_EXPR, integer_type_node, + gnu_max, gnu_min), + gnu_max, gnu_high); + + gnu_index_type[index] + = create_index_type (gnu_min, gnu_high, gnu_index_subtype); + + /* Also compute the maximum size of the array. Here we + see if any constraint on the index type of the base type + can be used in the case of self-referential bound on + the index type of the subtype. We look for a non-"infinite" + and non-self-referential bound from any type involved and + handle each bound separately. */ + + if ((TREE_CODE (gnu_min) == INTEGER_CST + && ! TREE_OVERFLOW (gnu_min) + && ! operand_equal_p (gnu_min, gnu_base_base_min, 0)) + || (TREE_CODE (gnu_min) != INTEGER_CST + && ! contains_placeholder_p (gnu_min))) + gnu_base_min = gnu_min; + + if ((TREE_CODE (gnu_max) == INTEGER_CST + && ! TREE_OVERFLOW (gnu_max) + && ! operand_equal_p (gnu_max, gnu_base_base_max, 0)) + || (TREE_CODE (gnu_max) != INTEGER_CST + && ! contains_placeholder_p (gnu_max))) + gnu_base_max = gnu_max; + + if ((TREE_CODE (gnu_base_min) == INTEGER_CST + && TREE_CONSTANT_OVERFLOW (gnu_base_min)) + || operand_equal_p (gnu_base_min, gnu_base_base_min, 0) + || (TREE_CODE (gnu_base_max) == INTEGER_CST + && TREE_CONSTANT_OVERFLOW (gnu_base_max)) + || operand_equal_p (gnu_base_max, gnu_base_base_max, 0)) + max_overflow = 1; + + gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min); + gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max); + + gnu_this_max + = size_binop (MAX_EXPR, + size_binop (PLUS_EXPR, size_one_node, + size_binop (MINUS_EXPR, gnu_base_max, + gnu_base_min)), + size_zero_node); + + if (TREE_CODE (gnu_this_max) == INTEGER_CST + && TREE_CONSTANT_OVERFLOW (gnu_this_max)) + max_overflow = 1; + + gnu_max_size + = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max); + + if (! integer_onep (TYPE_MIN_VALUE (gnu_index_subtype)) + || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype)) + != INTEGER_CST) + || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE + || (TREE_TYPE (gnu_index_subtype) != 0 + && (TREE_CODE (TREE_TYPE (gnu_index_subtype)) + != INTEGER_TYPE)) + || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype) + || (TYPE_PRECISION (gnu_index_subtype) + > TYPE_PRECISION (sizetype))) + need_index_type_struct = 1; + } + + /* Then flatten: create the array of arrays. */ + + gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity)); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = 1; + break; + } + + /* Get and validate any specified Component_Size, but if Packed, + ignore it since the front end will have taken care of it. Also, + allow sizes not a multiple of Storage_Unit if packed. */ + gnu_comp_size + = validate_size (Component_Size (gnat_entity), gnu_type, + gnat_entity, + (Is_Bit_Packed_Array (gnat_entity) + ? TYPE_DECL : VAR_DECL), + 1, Has_Component_Size_Clause (gnat_entity)); + + /* If the component type is a RECORD_TYPE that has a self-referential + size, use the maxium size. */ + if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE + && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (gnu_type))) + gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1); + + if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0) + { + gnu_type = make_type_from_size (gnu_type, gnu_comp_size, 0); + gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, + gnat_entity, "C_PAD", 0, + definition, 1); + } + + if (Has_Volatile_Components (Base_Type (gnat_entity))) + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | TYPE_QUAL_VOLATILE)); + + gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size, + TYPE_SIZE_UNIT (gnu_type)); + gnu_max_size = size_binop (MULT_EXPR, + convert (bitsizetype, gnu_max_size), + TYPE_SIZE (gnu_type)); + + /* We don't want any array types shared for two reasons: first, + we want to keep differently-named types distinct; second, + setting TYPE_MULTI_ARRAY_TYPE of one type can clobber + another. */ + debug_no_type_hash = 1; + for (index = array_dim - 1; index >= 0; index --) + { + gnu_type = build_array_type (gnu_type, gnu_index_type[index]); + TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); + TYPE_NONALIASED_COMPONENT (gnu_type) + = ! Has_Aliased_Components (gnat_entity); + } + + /* If we are at file level and this is a multi-dimensional array, we + need to make a variable corresponding to the stride of the + inner dimensions. */ + if (global_bindings_p () && array_dim > 1) + { + tree gnu_str_name = get_identifier ("ST"); + tree gnu_arr_type; + + for (gnu_arr_type = TREE_TYPE (gnu_type); + TREE_CODE (gnu_arr_type) == ARRAY_TYPE; + gnu_arr_type = TREE_TYPE (gnu_arr_type), + gnu_str_name = concat_id_with_name (gnu_str_name, "ST")) + { + TYPE_SIZE (gnu_arr_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE (gnu_arr_type), + gnu_str_name, definition, 0); + TYPE_SIZE_UNIT (gnu_arr_type) + = elaborate_expression_1 + (gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type), + concat_id_with_name (gnu_str_name, "U"), definition, 0); + } + } + + /* If we need to write out a record type giving the names of + the bounds, do it now. */ + if (need_index_type_struct && debug_info_p) + { + tree gnu_bound_rec_type = make_node (RECORD_TYPE); + tree gnu_field_list = 0; + tree gnu_field; + + TYPE_NAME (gnu_bound_rec_type) + = create_concat_name (gnat_entity, "XA"); + + for (index = array_dim - 1; index >= 0; index--) + { + tree gnu_type_name + = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index])); + + if (TREE_CODE (gnu_type_name) == TYPE_DECL) + gnu_type_name = DECL_NAME (gnu_type_name); + + gnu_field = create_field_decl (gnu_type_name, + integer_type_node, + gnu_bound_rec_type, + 0, NULL_TREE, NULL_TREE, 0); + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + + finish_record_type (gnu_bound_rec_type, gnu_field_list, 0, 0); + } + + debug_no_type_hash = 0; + TYPE_CONVENTION_FORTRAN_P (gnu_type) + = (Convention (gnat_entity) == Convention_Fortran); + + /* If our size depends on a placeholder and the maximum size doesn't + overflow, use it. */ + if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (gnu_type)) + && ! (TREE_CODE (gnu_max_size) == INTEGER_CST + && TREE_OVERFLOW (gnu_max_size)) + && ! max_overflow) + { + TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, + TYPE_SIZE (gnu_type)); + TYPE_SIZE_UNIT (gnu_type) + = size_binop (MIN_EXPR, gnu_max_size_unit, + TYPE_SIZE_UNIT (gnu_type)); + } + + /* Set our alias set to that of our base type. This gives all + array subtypes the same alias set. */ + TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type); + record_component_aliases (gnu_type); + } + + /* If this is a packed type, make this type the same as the packed + array type, but do some adjusting in the type first. */ + + if (Present (Packed_Array_Type (gnat_entity))) + { + Entity_Id gnat_index; + tree gnu_inner_type; + + /* First finish the type we had been making so that we output + debugging information for it */ + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | (TYPE_QUAL_VOLATILE + * Is_Volatile (gnat_entity)))); + set_lineno (gnat_entity, 0); + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + if (! Comes_From_Source (gnat_entity)) + DECL_ARTIFICIAL (gnu_decl) = 1; + + /* Save it as our equivalent in case the call below elaborates + this type again. */ + save_gnu_tree (gnat_entity, gnu_decl, 0); + + gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity), + NULL_TREE, 0); + this_made_decl = 1; + gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, NULL_TREE, 0); + + if (TREE_CODE (gnu_inner_type) == RECORD_TYPE + && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type) + || TYPE_IS_PADDING_P (gnu_inner_type))) + gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); + + /* We need to point the type we just made to our index type so + the actual bounds can be put into a template. */ + + if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE + && TYPE_ACTUAL_BOUNDS (gnu_inner_type) == 0) + || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE + && ! TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type))) + { + if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE) + { + /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus. + If it is, we need to make another type. */ + if (TYPE_MODULAR_P (gnu_inner_type)) + { + tree gnu_subtype; + + gnu_subtype = make_node (INTEGER_TYPE); + + TREE_TYPE (gnu_subtype) = gnu_inner_type; + TYPE_MIN_VALUE (gnu_subtype) + = TYPE_MIN_VALUE (gnu_inner_type); + TYPE_MAX_VALUE (gnu_subtype) + = TYPE_MAX_VALUE (gnu_inner_type); + TYPE_PRECISION (gnu_subtype) + = TYPE_PRECISION (gnu_inner_type); + TREE_UNSIGNED (gnu_subtype) + = TREE_UNSIGNED (gnu_inner_type); + TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; + layout_type (gnu_subtype); + + gnu_inner_type = gnu_subtype; + } + + TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1; + } + + TYPE_ACTUAL_BOUNDS (gnu_inner_type) = NULL_TREE; + + for (gnat_index = First_Index (gnat_entity); + Present (gnat_index); gnat_index = Next_Index (gnat_index)) + TYPE_ACTUAL_BOUNDS (gnu_inner_type) + = tree_cons (NULL_TREE, + get_unpadded_type (Etype (gnat_index)), + TYPE_ACTUAL_BOUNDS (gnu_inner_type)); + + if (Convention (gnat_entity) != Convention_Fortran) + TYPE_ACTUAL_BOUNDS (gnu_inner_type) + = nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)); + + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type)) + TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type; + } + } + + /* Abort if packed array with no packed array type field set. */ + else if (Is_Packed (gnat_entity)) + gigi_abort (107); + + break; + + case E_String_Literal_Subtype: + /* Create the type for a string literal. */ + { + Entity_Id gnat_full_type + = (IN (Ekind (Etype (gnat_entity)), Private_Kind) + && Present (Full_View (Etype (gnat_entity))) + ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity)); + tree gnu_string_type = get_unpadded_type (gnat_full_type); + tree gnu_string_array_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type)))); + tree gnu_string_index_type + = TREE_TYPE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_string_array_type))); + tree gnu_lower_bound + = convert (gnu_string_index_type, + gnat_to_gnu (String_Literal_Low_Bound (gnat_entity))); + int length = UI_To_Int (String_Literal_Length (gnat_entity)); + tree gnu_length = ssize_int (length - 1); + tree gnu_upper_bound + = build_binary_op (PLUS_EXPR, gnu_string_index_type, + gnu_lower_bound, + convert (gnu_string_index_type, gnu_length)); + tree gnu_range_type + = build_range_type (gnu_string_index_type, + gnu_lower_bound, gnu_upper_bound); + tree gnu_index_type + = create_index_type (convert (sizetype, + TYPE_MIN_VALUE (gnu_range_type)), + convert (sizetype, + TYPE_MAX_VALUE (gnu_range_type)), + gnu_range_type); + + gnu_type + = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), + gnu_index_type); + } + break; + + /* Record Types and Subtypes + + The following fields are defined on record types: + + Has_Discriminants True if the record has discriminants + First_Discriminant Points to head of list of discriminants + First_Entity Points to head of list of fields + Is_Tagged_Type True if the record is tagged + + Implementation of Ada records and discriminated records: + + A record type definition is transformed into the equivalent of a C + struct definition. The fields that are the discriminants which are + found in the Full_Type_Declaration node and the elements of the + Component_List found in the Record_Type_Definition node. The + Component_List can be a recursive structure since each Variant of + the Variant_Part of the Component_List has a Component_List. + + Processing of a record type definition comprises starting the list of + field declarations here from the discriminants and the calling the + function components_to_record to add the rest of the fields from the + component list and return the gnu type node. The function + components_to_record will call itself recursively as it traverses + the tree. */ + + case E_Record_Type: +#if 0 + if (Has_Complex_Representation (gnat_entity)) + { + gnu_type + = build_complex_type + (get_unpadded_type + (Etype (Defining_Entity + (First (Component_Items + (Component_List + (Type_Definition + (Declaration_Node (gnat_entity))))))))); + + /* ??? For now, don't use Complex if the real type is shorter than + a word. */ + if (GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (gnu_type))) + >= BITS_PER_WORD) + break; + } +#endif + + { + Node_Id full_definition = Declaration_Node (gnat_entity); + Node_Id record_definition = Type_Definition (full_definition); + Entity_Id gnat_field; + tree gnu_field; + tree gnu_field_list = NULL_TREE; + tree gnu_get_parent; + int packed = (Is_Packed (gnat_entity) ? 1 + : (Component_Alignment (gnat_entity) + == Calign_Storage_Unit) ? -1 + : 0); + int has_rep = Has_Specified_Layout (gnat_entity); + int all_rep = has_rep; + int is_extension + = (Is_Tagged_Type (gnat_entity) + && Nkind (record_definition) == N_Derived_Type_Definition); + + /* See if all fields have a rep clause. Stop when we find one + that doesn't. */ + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field) && all_rep; + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || Ekind (gnat_field) == E_Discriminant) + && No (Component_Clause (gnat_field))) + all_rep = 0; + + /* If this is a record extension, go a level further to find the + record definition. Also, verify we have a Parent_Subtype. */ + if (is_extension) + { + if (! type_annotate_only + || Present (Record_Extension_Part (record_definition))) + record_definition = Record_Extension_Part (record_definition); + + if (! type_annotate_only && No (Parent_Subtype (gnat_entity))) + gigi_abort (121); + } + + /* Make a node for the record. If we are not defining the record, + suppress expanding incomplete types and save the node as the type + for GNAT_ENTITY. We use the same RECORD_TYPE as was made + for a dummy type and then show it's no longer a dummy. */ + gnu_type = make_dummy_type (gnat_entity); + TYPE_DUMMY_P (gnu_type) = 0; + if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p) + DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0; + + TYPE_ALIGN (gnu_type) = 0; + TYPE_PACKED (gnu_type) = packed != 0 || has_rep; + + if (! definition) + { + defer_incomplete_level++; + this_deferred = 1; + set_lineno (gnat_entity, 0); + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + save_gnu_tree (gnat_entity, gnu_decl, 0); + this_made_decl = saved = 1; + } + + /* If both a size and rep clause was specified, put the size in + the record type now so that it can get the proper mode. */ + if (has_rep && Known_Esize (gnat_entity)) + TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype); + + /* Always set the alignment here so that it can be used to + set the mode, if it is making the alignment stricter. If + it is invalid, it will be checked again below. If this is to + be Atomic, choose a default alignment of a word. */ + + if (Known_Alignment (gnat_entity)) + TYPE_ALIGN (gnu_type) + = validate_alignment (Alignment (gnat_entity), gnat_entity, 0); + else if (Is_Atomic (gnat_entity)) + TYPE_ALIGN (gnu_type) = BITS_PER_WORD; + + /* If we have a Parent_Subtype, make a field for the parent. If + this record has rep clauses, force the position to zero. */ + if (Present (Parent_Subtype (gnat_entity))) + { + tree gnu_parent; + + /* A major complexity here is that the parent subtype will + reference our discriminants. But those must reference + the parent component of this record. So here we will + initialize each of those components to a COMPONENT_REF. + The first operand of that COMPONENT_REF is another + COMPONENT_REF which will be filled in below, once + the parent type can be safely built. */ + + gnu_get_parent = build (COMPONENT_REF, void_type_node, + build (PLACEHOLDER_EXPR, gnu_type), + build_decl (FIELD_DECL, NULL_TREE, + NULL_TREE)); + + if (Has_Discriminants (gnat_entity)) + for (gnat_field = First_Girder_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Girder_Discriminant (gnat_field)) + if (Present (Corresponding_Discriminant (gnat_field))) + save_gnu_tree + (gnat_field, + build (COMPONENT_REF, + get_unpadded_type (Etype (gnat_field)), + gnu_get_parent, + gnat_to_gnu_entity (Corresponding_Discriminant + (gnat_field), + NULL_TREE, 0)), + 1); + + gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity)); + + gnu_field_list + = create_field_decl (get_identifier + (Get_Name_String (Name_uParent)), + gnu_parent, gnu_type, 0, + has_rep ? TYPE_SIZE (gnu_parent) : 0, + has_rep ? bitsize_zero_node : 0, 1); + DECL_INTERNAL_P (gnu_field_list) = 1; + + TREE_TYPE (gnu_get_parent) = gnu_parent; + TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list; + } + + /* Add the fields for the discriminants into the record. */ + if (! Is_Unchecked_Union (gnat_entity) + && Has_Discriminants (gnat_entity)) + for (gnat_field = First_Girder_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Girder_Discriminant (gnat_field)) + { + /* If this is a record extension and this discriminant + is the renaming of another discriminant, we've already + handled the discriminant above. */ + if (Present (Parent_Subtype (gnat_entity)) + && Present (Corresponding_Discriminant (gnat_field))) + continue; + + gnu_field + = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition); + + /* Make an expression using a PLACEHOLDER_EXPR from the + FIELD_DECL node just created and link that with the + corresponding GNAT defining identifier. Then add to the + list of fields. */ + save_gnu_tree (gnat_field, + build (COMPONENT_REF, TREE_TYPE (gnu_field), + build (PLACEHOLDER_EXPR, + DECL_CONTEXT (gnu_field)), + gnu_field), + 1); + + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + + /* Put the discriminants into the record (backwards), so we can + know the appropriate discriminant to use for the names of the + variants. */ + TYPE_FIELDS (gnu_type) = gnu_field_list; + + /* Add the listed fields into the record and finish up. */ + components_to_record (gnu_type, Component_List (record_definition), + gnu_field_list, packed, definition, 0, + 0, all_rep); + + TYPE_DUMMY_P (gnu_type) = 0; + TYPE_VOLATILE (gnu_type) = Is_Volatile (gnat_entity); + TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity); + + /* If this is an extension type, reset the tree for any + inherited discriminants. Also remove the PLACEHOLDER_EXPR + for non-inherited discriminants. */ + if (! Is_Unchecked_Union (gnat_entity) + && Has_Discriminants (gnat_entity)) + for (gnat_field = First_Girder_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Girder_Discriminant (gnat_field)) + { + if (Present (Parent_Subtype (gnat_entity)) + && Present (Corresponding_Discriminant (gnat_field))) + save_gnu_tree (gnat_field, NULL_TREE, 0); + else + { + gnu_field = get_gnu_tree (gnat_field); + save_gnu_tree (gnat_field, NULL_TREE, 0); + save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1), 0); + } + } + + /* If it is a tagged record force the type to BLKmode to insure + that these objects will always be placed in memory. Do the + same thing for limited record types. */ + + if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity)) + TYPE_MODE (gnu_type) = BLKmode; + + /* Fill in locations of fields. */ + annotate_rep (gnat_entity, gnu_type); + + /* If there are any entities in the chain corresponding to + components that we did not elaborate, ensure we elaborate their + types if they are Itypes. */ + for (gnat_temp = First_Entity (gnat_entity); + Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp)) + if ((Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Discriminant) + && Is_Itype (Etype (gnat_temp)) + && ! present_gnu_tree (gnat_temp)) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + } + break; + + case E_Class_Wide_Subtype: + /* If an equivalent type is present, that is what we should use. + Otherwise, fall through to handle this like a record subtype + since it may have constraints. */ + + if (Present (Equivalent_Type (gnat_entity))) + { + gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity)); + maybe_present = 1; + break; + } + + /* ... fall through ... */ + + case E_Record_Subtype: + + /* If Cloned_Subtype is Present it means this record subtype has + identical layout to that type or subtype and we should use + that GCC type for this one. The front end guarantees that + the component list is shared. */ + if (Present (Cloned_Subtype (gnat_entity))) + { + gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), + NULL_TREE, 0); + maybe_present = 1; + } + + /* Otherwise, first ensure the base type is elaborated. Then, if we are + changing the type, make a new type with each field having the + type of the field in the new subtype but having the position + computed by transforming every discriminant reference according + to the constraints. We don't see any difference between + private and nonprivate type here since derivations from types should + have been deferred until the completion of the private type. */ + else + { + Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity); + tree gnu_base_type; + tree gnu_orig_type; + + if (! definition) + defer_incomplete_level++, this_deferred = 1; + + /* Get the base type initially for its alignment and sizes. But + if it is a padded type, we do all the other work with the + unpadded type. */ + gnu_type = gnu_orig_type = gnu_base_type + = gnat_to_gnu_type (gnat_base_type); + + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type)) + gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + + if (present_gnu_tree (gnat_entity)) + { + maybe_present = 1; + break; + } + + /* When the type has discriminants, and these discriminants + affect the shape of what it built, factor them in. + + If we are making a subtype of an Unchecked_Union (must be an + Itype), just return the type. + + We can't just use Is_Constrained because private subtypes without + discriminants of full types with discriminants with default + expressions are Is_Constrained but aren't constrained! */ + + if (IN (Ekind (gnat_base_type), Record_Kind) + && ! Is_For_Access_Subtype (gnat_entity) + && ! Is_Unchecked_Union (gnat_base_type) + && Is_Constrained (gnat_entity) + && Girder_Constraint (gnat_entity) != No_Elist + && Present (Discriminant_Constraint (gnat_entity))) + { + Entity_Id gnat_field; + Entity_Id gnat_root_type; + tree gnu_field_list = 0; + tree gnu_pos_list + = compute_field_positions (gnu_orig_type, NULL_TREE, + size_zero_node, bitsize_zero_node); + tree gnu_subst_list + = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, + definition); + tree gnu_temp; + + /* If this is a derived type, we may be seeing fields from any + original records, so add those positions and discriminant + substitutions to our lists. */ + for (gnat_root_type = gnat_base_type; + Underlying_Type (Etype (gnat_root_type)) != gnat_root_type; + gnat_root_type = Underlying_Type (Etype (gnat_root_type))) + { + gnu_pos_list + = compute_field_positions + (gnat_to_gnu_type (Etype (gnat_root_type)), + gnu_pos_list, size_zero_node, bitsize_zero_node); + + if (Present (Parent_Subtype (gnat_root_type))) + gnu_subst_list + = substitution_list (Parent_Subtype (gnat_root_type), + Empty, gnu_subst_list, definition); + } + + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = gnu_entity_id; + TYPE_STUB_DECL (gnu_type) + = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type)); + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); + + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field); gnat_field = Next_Entity (gnat_field)) + if (Ekind (gnat_field) == E_Component + || Ekind (gnat_field) == E_Discriminant) + { + tree gnu_old_field + = gnat_to_gnu_entity + (Original_Record_Component (gnat_field), NULL_TREE, 0); + tree gnu_offset + = TREE_VALUE (purpose_member (gnu_old_field, + gnu_pos_list)); + tree gnu_pos = TREE_PURPOSE (gnu_offset); + tree gnu_bitpos = TREE_VALUE (gnu_offset); + tree gnu_field_type + = gnat_to_gnu_type (Etype (gnat_field)); + tree gnu_size = TYPE_SIZE (gnu_field_type); + tree gnu_new_pos = 0; + tree gnu_field; + + /* If there was a component clause, the field types must be + the same for the type and subtype, so copy the data from + the old field to avoid recomputation here. */ + if (Present (Component_Clause + (Original_Record_Component (gnat_field)))) + { + gnu_size = DECL_SIZE (gnu_old_field); + gnu_field_type = TREE_TYPE (gnu_old_field); + } + + /* If this was a bitfield, get the size from the old field. + Also ensure the type can be placed into a bitfield. */ + else if (DECL_BIT_FIELD (gnu_old_field)) + { + gnu_size = DECL_SIZE (gnu_old_field); + if (TYPE_MODE (gnu_field_type) == BLKmode + && TREE_CODE (gnu_field_type) == RECORD_TYPE + && host_integerp (TYPE_SIZE (gnu_field_type), 1)) + gnu_field_type = make_packable_type (gnu_field_type); + } + + if (TREE_CODE (gnu_pos) != INTEGER_CST + && contains_placeholder_p (gnu_pos)) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + gnu_pos = substitute_in_expr (gnu_pos, + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp)); + + /* If the size is now a constant, we can set it as the + size of the field when we make it. Otherwise, we need + to deal with it specially. */ + if (TREE_CONSTANT (gnu_pos)) + gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos); + + gnu_field + = create_field_decl + (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type, + 0, gnu_size, gnu_new_pos, + ! DECL_NONADDRESSABLE_P (gnu_old_field)); + + if (! TREE_CONSTANT (gnu_pos)) + { + normalize_offset (&gnu_pos, &gnu_bitpos, + DECL_OFFSET_ALIGN (gnu_old_field)); + DECL_FIELD_OFFSET (gnu_field) = gnu_pos; + DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; + SET_DECL_OFFSET_ALIGN + (gnu_field, DECL_OFFSET_ALIGN (gnu_old_field)); + DECL_SIZE (gnu_field) = gnu_size; + DECL_SIZE_UNIT (gnu_field) + = convert (sizetype, + size_binop (CEIL_DIV_EXPR, gnu_size, + bitsize_unit_node)); + layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field)); + } + + DECL_INTERNAL_P (gnu_field) + = DECL_INTERNAL_P (gnu_old_field); + DECL_ORIGINAL_FIELD (gnu_field) + = DECL_ORIGINAL_FIELD (gnu_old_field) != 0 + ? DECL_ORIGINAL_FIELD (gnu_old_field) : gnu_old_field; + DECL_DISCRIMINANT_NUMBER (gnu_field) + = DECL_DISCRIMINANT_NUMBER (gnu_old_field); + TREE_THIS_VOLATILE (gnu_field) + = TREE_THIS_VOLATILE (gnu_old_field); + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + save_gnu_tree (gnat_field, gnu_field, 0); + } + + finish_record_type (gnu_type, nreverse (gnu_field_list), 1, 0); + + /* Now set the size, alignment and alias set of the new type to + match that of the old one, doing any substitutions, as + above. */ + TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type); + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); + TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type); + TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type); + TYPE_ADA_SIZE (gnu_type) = TYPE_ADA_SIZE (gnu_base_type); + + if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (gnu_type))) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + TYPE_SIZE (gnu_type) + = substitute_in_expr (TYPE_SIZE (gnu_type), + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp)); + + if (TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE_UNIT (gnu_type))) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + TYPE_SIZE_UNIT (gnu_type) + = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type), + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp)); + + if (TYPE_ADA_SIZE (gnu_type) != 0 + && TREE_CODE (TYPE_ADA_SIZE (gnu_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_ADA_SIZE (gnu_type))) + for (gnu_temp = gnu_subst_list; + gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) + TYPE_ADA_SIZE (gnu_type) + = substitute_in_expr (TYPE_ADA_SIZE (gnu_type), + TREE_PURPOSE (gnu_temp), + TREE_VALUE (gnu_temp)); + + /* Recompute the mode of this record type now that we know its + actual size. */ + compute_record_mode (gnu_type); + + /* Fill in locations of fields. */ + annotate_rep (gnat_entity, gnu_type); + } + + /* If we've made a new type, record it and make an XVS type to show + what this is a subtype of. Some debuggers require the XVS + type to be output first, so do it in that order. */ + if (gnu_type != gnu_orig_type) + { + if (debug_info_p) + { + tree gnu_subtype_marker = make_node (RECORD_TYPE); + tree gnu_orig_name = TYPE_NAME (gnu_orig_type); + + if (TREE_CODE (gnu_orig_name) == TYPE_DECL) + gnu_orig_name = DECL_NAME (gnu_orig_name); + + TYPE_NAME (gnu_subtype_marker) + = create_concat_name (gnat_entity, "XVS"); + finish_record_type (gnu_subtype_marker, + create_field_decl (gnu_orig_name, + integer_type_node, + gnu_subtype_marker, + 0, NULL_TREE, + NULL_TREE, 0), + 0, 0); + } + + TYPE_VOLATILE (gnu_type) = Is_Volatile (gnat_entity); + TYPE_NAME (gnu_type) = gnu_entity_id; + TYPE_STUB_DECL (gnu_type) + = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type), + gnu_type)); + DECL_ARTIFICIAL (TYPE_STUB_DECL (gnu_type)) = 1; + DECL_IGNORED_P (TYPE_STUB_DECL (gnu_type)) = ! debug_info_p; + rest_of_type_compilation (gnu_type, global_bindings_p ()); + } + + /* Otherwise, go down all the components in the new type and + make them equivalent to those in the base type. */ + else + for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if ((Ekind (gnat_temp) == E_Discriminant + && ! Is_Unchecked_Union (gnat_base_type)) + || Ekind (gnat_temp) == E_Component) + save_gnu_tree (gnat_temp, + get_gnu_tree + (Original_Record_Component (gnat_temp)), 0); + } + break; + + case E_Access_Subprogram_Type: + /* If we are not defining this entity, and we have incomplete + entities being processed above us, make a dummy type and + fill it in later. */ + if (! definition && defer_incomplete_level != 0) + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof (struct incomplete)); + + gnu_type + = build_pointer_type + (make_dummy_type (Directly_Designated_Type (gnat_entity))); + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + save_gnu_tree (gnat_entity, gnu_decl, 0); + this_made_decl = saved = 1; + + p->old_type = TREE_TYPE (gnu_type); + p->full_type = Directly_Designated_Type (gnat_entity); + p->next = defer_incomplete_list; + defer_incomplete_list = p; + break; + } + + /* ... fall through ... */ + + case E_Allocator_Type: + case E_Access_Type: + case E_Access_Attribute_Type: + case E_Anonymous_Access_Type: + case E_General_Access_Type: + { + Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity); + Entity_Id gnat_desig_full + = ((IN (Ekind (Etype (gnat_desig_type)), + Incomplete_Or_Private_Kind)) + ? Full_View (gnat_desig_type) : 0); + /* We want to know if we'll be seeing the freeze node for any + incomplete type we may be pointing to. */ + int in_main_unit + = (Present (gnat_desig_full) + ? In_Extended_Main_Code_Unit (gnat_desig_full) + : In_Extended_Main_Code_Unit (gnat_desig_type)); + int got_fat_p = 0; + int made_dummy = 0; + + if (No (gnat_desig_full) + && (Ekind (gnat_desig_type) == E_Class_Wide_Type + || (Ekind (gnat_desig_type) == E_Class_Wide_Subtype + && Present (Equivalent_Type (gnat_desig_type))))) + { + if (Present (Equivalent_Type (gnat_desig_type))) + { + gnat_desig_full = Equivalent_Type (gnat_desig_type); + if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind)) + gnat_desig_full = Full_View (gnat_desig_full); + } + else if (IN (Ekind (Root_Type (gnat_desig_type)), + Incomplete_Or_Private_Kind)) + gnat_desig_full = Full_View (Root_Type (gnat_desig_type)); + } + + if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full)) + gnat_desig_full = Corresponding_Record_Type (gnat_desig_full); + + /* If either the designated type or its full view is an + unconstrained array subtype, replace it with the type it's a + subtype of. This avoids problems with multiple copies of + unconstrained array types. */ + if (Ekind (gnat_desig_type) == E_Array_Subtype + && ! Is_Constrained (gnat_desig_type)) + gnat_desig_type = Etype (gnat_desig_type); + if (Present (gnat_desig_full) + && Ekind (gnat_desig_full) == E_Array_Subtype + && ! Is_Constrained (gnat_desig_full)) + gnat_desig_full = Etype (gnat_desig_full); + + /* If we are pointing to an incomplete type whose completion is an + unconstrained array, make a fat pointer type instead of a pointer + to VOID. The two types in our fields will be pointers to VOID and + will be replaced in update_pointer_to. Similiarly, if the type + itself is a dummy type or an unconstrained array. Also make + a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin + pointers to it. */ + + if ((Present (gnat_desig_full) + && Is_Array_Type (gnat_desig_full) + && ! Is_Constrained (gnat_desig_full)) + || (present_gnu_tree (gnat_desig_type) + && TYPE_IS_DUMMY_P (TREE_TYPE + (get_gnu_tree (gnat_desig_type))) + && Is_Array_Type (gnat_desig_type) + && ! Is_Constrained (gnat_desig_type)) + || (present_gnu_tree (gnat_desig_type) + && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type))) + == UNCONSTRAINED_ARRAY_TYPE) + && (TYPE_POINTER_TO (TREE_TYPE + (get_gnu_tree (gnat_desig_type))) + == 0)) + || (No (gnat_desig_full) && ! in_main_unit + && defer_incomplete_level != 0 + && ! present_gnu_tree (gnat_desig_type) + && Is_Array_Type (gnat_desig_type) + && ! Is_Constrained (gnat_desig_type))) + { + tree gnu_old + = (present_gnu_tree (gnat_desig_type) + ? gnat_to_gnu_type (gnat_desig_type) + : make_dummy_type (gnat_desig_type)); + tree fields; + + /* Show the dummy we get will be a fat pointer. */ + got_fat_p = made_dummy = 1; + + /* If the call above got something that has a pointer, that + pointer is our type. This could have happened either + because the type was elaborated or because somebody + else executed the code below. */ + gnu_type = TYPE_POINTER_TO (gnu_old); + if (gnu_type == 0) + { + gnu_type = make_node (RECORD_TYPE); + TYPE_UNCONSTRAINED_ARRAY (gnu_type) = gnu_old; + TYPE_POINTER_TO (gnu_old) = gnu_type; + + set_lineno (gnat_entity, 0); + fields + = chainon (chainon (NULL_TREE, + create_field_decl + (get_identifier ("P_ARRAY"), + ptr_void_type_node, gnu_type, + 0, 0, 0, 0)), + create_field_decl (get_identifier ("P_BOUNDS"), + ptr_void_type_node, + gnu_type, 0, 0, 0, 0)); + + /* Make sure we can place this into a register. */ + TYPE_ALIGN (gnu_type) + = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); + TYPE_IS_FAT_POINTER_P (gnu_type) = 1; + finish_record_type (gnu_type, fields, 0, 1); + + TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE); + TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old)) + = concat_id_with_name (get_entity_name (gnat_desig_type), + "XUT"); + TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1; + } + } + + /* If we already know what the full type is, use it. */ + else if (Present (gnat_desig_full) + && present_gnu_tree (gnat_desig_full)) + gnu_type + = build_pointer_type (TREE_TYPE (get_gnu_tree (gnat_desig_full))); + + /* Get the type of the thing we are to point to and build a pointer + to it. If it is a reference to an incomplete or private type with a + full view that is a record, make a dummy type node and get the + actual type later when we have verified it is safe. */ + else if (! in_main_unit + && ! present_gnu_tree (gnat_desig_type) + && Present (gnat_desig_full) + && ! present_gnu_tree (gnat_desig_full) + && Is_Record_Type (gnat_desig_full)) + { + gnu_type = build_pointer_type (make_dummy_type (gnat_desig_type)); + made_dummy = 1; + } + + /* Likewise if we are pointing to a record or array and we are to defer + elaborating incomplete types. We do this since this access type + may be the full view of some private type. Note that the + unconstrained array case is handled above. */ + else if ((! in_main_unit || imported_p) && defer_incomplete_level != 0 + && ! present_gnu_tree (gnat_desig_type) + && ((Is_Record_Type (gnat_desig_type) + || Is_Array_Type (gnat_desig_type)) + || (Present (gnat_desig_full) + && (Is_Record_Type (gnat_desig_full) + || Is_Array_Type (gnat_desig_full))))) + { + gnu_type = build_pointer_type (make_dummy_type (gnat_desig_type)); + made_dummy = 1; + } + else if (gnat_desig_type == gnat_entity) + { + gnu_type = build_pointer_type (make_node (VOID_TYPE)); + TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type; + } + else + gnu_type = build_pointer_type (gnat_to_gnu_type (gnat_desig_type)); + + /* It is possible that the above call to gnat_to_gnu_type resolved our + type. If so, just return it. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = 1; + break; + } + + /* If we are not defining this object and we made a dummy pointer, + save our current definition, evaluate the actual type, and replace + the tentative type we made with the actual one. If we are to defer + actually looking up the actual type, make an entry in the + deferred list. */ + + if (! in_main_unit && made_dummy) + { + tree gnu_old_type + = TYPE_FAT_POINTER_P (gnu_type) + ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type); + + if (esize == POINTER_SIZE + && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type))) + gnu_type + = build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (gnu_type))); + + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + save_gnu_tree (gnat_entity, gnu_decl, 0); + this_made_decl = saved = 1; + + if (defer_incomplete_level == 0) + update_pointer_to + (gnu_old_type, gnat_to_gnu_type (gnat_desig_type)); + else + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof (struct incomplete)); + + p->old_type = gnu_old_type; + p->full_type = gnat_desig_type; + p->next = defer_incomplete_list; + defer_incomplete_list = p; + } + } + } + break; + + case E_Access_Protected_Subprogram_Type: + if (type_annotate_only && No (Equivalent_Type (gnat_entity))) + gnu_type = build_pointer_type (void_type_node); + else + /* The runtime representation is the equivalent type. */ + gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity)); + + if (Is_Itype (Directly_Designated_Type (gnat_entity)) + && ! present_gnu_tree (Directly_Designated_Type (gnat_entity)) + && No (Freeze_Node (Directly_Designated_Type (gnat_entity))) + && ! Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity)))) + gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), + NULL_TREE, 0); + + break; + + case E_Access_Subtype: + + /* We treat this as identical to its base type; any constraint is + meaningful only to the front end. + + The designated type must be elaborated as well, if it does + not have its own freeze node. Designated (sub)types created + for constrained components of records with discriminants are + not frozen by the front end and thus not elaborated by gigi, + because their use may appear before the base type is frozen, + and because it is not clear that they are needed anywhere in + Gigi. With the current model, there is no correct place where + they could be elaborated. */ + + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + if (Is_Itype (Directly_Designated_Type (gnat_entity)) + && ! present_gnu_tree (Directly_Designated_Type (gnat_entity)) + && Is_Frozen (Directly_Designated_Type (gnat_entity)) + && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) + { + /* If we are not defining this entity, and we have incomplete + entities being processed above us, make a dummy type and + elaborate it later. */ + if (! definition && defer_incomplete_level != 0) + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof (struct incomplete)); + tree gnu_ptr_type + = build_pointer_type + (make_dummy_type (Directly_Designated_Type (gnat_entity))); + + p->old_type = TREE_TYPE (gnu_ptr_type); + p->full_type = Directly_Designated_Type (gnat_entity); + p->next = defer_incomplete_list; + defer_incomplete_list = p; + } + else + gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), + NULL_TREE, 0); + } + + maybe_present = 1; + break; + + /* Subprogram Entities + + The following access functions are defined for subprograms (functions + or procedures): + + First_Formal The first formal parameter. + Is_Imported Indicates that the subprogram has appeared in + an INTERFACE or IMPORT pragma. For now we + assume that the external language is C. + Is_Inlined True if the subprogram is to be inlined. + + In addition for function subprograms we have: + + Etype Return type of the function. + + Each parameter is first checked by calling must_pass_by_ref on its + type to determine if it is passed by reference. For parameters which + are copied in, if they are Ada IN OUT or OUT parameters, their return + value becomes part of a record which becomes the return type of the + function (C function - note that this applies only to Ada procedures + so there is no Ada return type). Additional code to store back the + parameters will be generated on the caller side. This transformation + is done here, not in the front-end. + + The intended result of the transformation can be seen from the + equivalent source rewritings that follow: + + struct temp {int a,b}; + procedure P (A,B: IN OUT ...) is temp P (int A,B) { + .. .. + end P; return {A,B}; + } + procedure call + + { + temp t; + P(X,Y); t = P(X,Y); + X = t.a , Y = t.b; + } + + For subprogram types we need to perform mainly the same conversions to + GCC form that are needed for procedures and function declarations. The + only difference is that at the end, we make a type declaration instead + of a function declaration. */ + + case E_Subprogram_Type: + case E_Function: + case E_Procedure: + { + /* The first GCC parameter declaration (a PARM_DECL node). The + PARM_DECL nodes are chained through the TREE_CHAIN field, so this + actually is the head of this parameter list. */ + tree gnu_param_list = NULL_TREE; + /* The type returned by a function. If the subprogram is a procedure + this type should be void_type_node. */ + tree gnu_return_type = void_type_node; + /* List of fields in return type of procedure with copy in copy out + parameters. */ + tree gnu_field_list = NULL_TREE; + /* Non-null for subprograms containing parameters passed by copy in + copy out (Ada IN OUT or OUT parameters not passed by reference), + in which case it is the list of nodes used to specify the values of + the in out/out parameters that are returned as a record upon + procedure return. The TREE_PURPOSE of an element of this list is + a field of the record and the TREE_VALUE is the PARM_DECL + corresponding to that field. This list will be saved in the + TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ + tree gnu_return_list = NULL_TREE; + Entity_Id gnat_param; + int inline_flag = Is_Inlined (gnat_entity); + int public_flag = Is_Public (gnat_entity); + int extern_flag + = (Is_Public (gnat_entity) && !definition) || imported_p; + int pure_flag = Is_Pure (gnat_entity); + int volatile_flag = No_Return (gnat_entity); + int returns_by_ref = 0; + int returns_unconstrained = 0; + tree gnu_ext_name = NULL_TREE; + int has_copy_in_out = 0; + int parmnum; + + if (kind == E_Subprogram_Type && ! definition) + /* A parameter may refer to this type, so defer completion + of any incomplete types. */ + defer_incomplete_level++, this_deferred = 1; + + /* If the subprogram has an alias, it is probably inherited, so + we can use the original one. If the original "subprogram" + is actually an enumeration literal, it may be the first use + of its type, so we must elaborate that type now. */ + if (Present (Alias (gnat_entity))) + { + if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) + gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0); + + gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), + gnu_expr, 0); + + /* Elaborate any Itypes in the parameters of this entity. */ + for (gnat_temp = First_Formal (gnat_entity); + Present (gnat_temp); + gnat_temp = Next_Formal_With_Extras (gnat_temp)) + if (Is_Itype (Etype (gnat_temp))) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + + break; + } + + if (kind == E_Function || kind == E_Subprogram_Type) + gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity)); + + /* If this function returns by reference, make the actual + return type of this function the pointer and mark the decl. */ + if (Returns_By_Ref (gnat_entity)) + { + returns_by_ref = 1; + + gnu_return_type = build_pointer_type (gnu_return_type); + } + + /* If we are supposed to return an unconstrained array, + actually return a fat pointer and make a note of that. Return + a pointer to an unconstrained record of variable size. */ + else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE) + { + gnu_return_type = TREE_TYPE (gnu_return_type); + returns_unconstrained = 1; + } + + /* If the type requires a transient scope, the result is allocated + on the secondary stack, so the result type of the function is + just a pointer. */ + else if (Requires_Transient_Scope (Etype (gnat_entity))) + { + gnu_return_type = build_pointer_type (gnu_return_type); + returns_unconstrained = 1; + } + + /* If the type is a padded type and the underlying type would not + be passed by reference or this function has a foreign convention, + return the underlying type. */ + else if (TREE_CODE (gnu_return_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_return_type) + && (! default_pass_by_ref (TREE_TYPE + (TYPE_FIELDS (gnu_return_type))) + || Has_Foreign_Convention (gnat_entity))) + gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type)); + + /* Look at all our parameters and get the type of + each. While doing this, build a copy-out structure if + we need one. */ + + for (gnat_param = First_Formal (gnat_entity), parmnum = 0; + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) + { + tree gnu_param_name = get_entity_name (gnat_param); + tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); + tree gnu_param, gnu_field; + int by_ref_p = 0; + int by_descr_p = 0; + int by_component_ptr_p = 0; + int copy_in_copy_out_flag = 0; + int req_by_copy = 0, req_by_ref = 0; + + /* See if a Mechanism was supplied that forced this + parameter to be passed one way or another. */ + if (Is_Valued_Procedure (gnat_entity) && parmnum == 0) + req_by_copy = 1; + else if (Mechanism (gnat_param) == Default) + ; + else if (Mechanism (gnat_param) == By_Copy) + req_by_copy = 1; + else if (Mechanism (gnat_param) == By_Reference) + req_by_ref = 1; + else if (Mechanism (gnat_param) <= By_Descriptor) + by_descr_p = 1; + else if (Mechanism (gnat_param) > 0) + { + if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE + || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST + || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type), + Mechanism (gnat_param))) + req_by_ref = 1; + else + req_by_copy = 1; + } + else + post_error ("unsupported mechanism for&", gnat_param); + + /* If this is either a foreign function or if the + underlying type won't be passed by refererence, strip off + possible padding type. */ + if (TREE_CODE (gnu_param_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_param_type) + && (req_by_ref || Has_Foreign_Convention (gnat_entity) + || ! must_pass_by_ref (TREE_TYPE (TYPE_FIELDS + (gnu_param_type))))) + gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); + + /* If this is an IN parameter it is read-only, so make a variant + of the type that is read-only. + + ??? However, if this is an unconstrained array, that type can + be very complex. So skip it for now. Likewise for any other + self-referential type. */ + if (Ekind (gnat_param) == E_In_Parameter + && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE + && ! (TYPE_SIZE (gnu_param_type) != 0 + && TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST + && contains_placeholder_p (TYPE_SIZE (gnu_param_type)))) + gnu_param_type + = build_qualified_type (gnu_param_type, + (TYPE_QUALS (gnu_param_type) + | TYPE_QUAL_CONST)); + + /* For foreign conventions, pass arrays as a pointer to the + underlying type. First check for unconstrained array and get + the underlying array. Then get the component type and build + a pointer to it. */ + if (Has_Foreign_Convention (gnat_entity) + && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_param_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (gnu_param_type)))); + + if (by_descr_p) + gnu_param_type + = build_pointer_type + (build_vms_descriptor (gnu_param_type, + Mechanism (gnat_param), + gnat_entity)); + + else if (Has_Foreign_Convention (gnat_entity) + && ! req_by_copy + && TREE_CODE (gnu_param_type) == ARRAY_TYPE) + { + /* Strip off any multi-dimensional entries, then strip + off the last array to get the component type. */ + while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type))) + gnu_param_type = TREE_TYPE (gnu_param_type); + + by_component_ptr_p = 1; + gnu_param_type = TREE_TYPE (gnu_param_type); + + if (Ekind (gnat_param) == E_In_Parameter) + gnu_param_type + = build_qualified_type (gnu_param_type, + (TYPE_QUALS (gnu_param_type) + | TYPE_QUAL_CONST)); + + gnu_param_type = build_pointer_type (gnu_param_type); + } + + /* Fat pointers are passed as thin pointers for foreign + conventions. */ + else if (Has_Foreign_Convention (gnat_entity) + && TYPE_FAT_POINTER_P (gnu_param_type)) + gnu_param_type + = make_type_from_size (gnu_param_type, + size_int (POINTER_SIZE), 0); + + /* If we must pass or were requested to pass by reference, do so. + If we were requested to pass by copy, do so. + Otherwise, for foreign conventions, pass all in out parameters + or aggregates by reference. For COBOL and Fortran, pass + all integer and FP types that way too. For Convention Ada, + use the standard Ada default. */ + else if (must_pass_by_ref (gnu_param_type) || req_by_ref + || (! req_by_copy + && ((Has_Foreign_Convention (gnat_entity) + && (Ekind (gnat_param) != E_In_Parameter + || AGGREGATE_TYPE_P (gnu_param_type))) + || (((Convention (gnat_entity) + == Convention_Fortran) + || (Convention (gnat_entity) + == Convention_COBOL)) + && (INTEGRAL_TYPE_P (gnu_param_type) + || FLOAT_TYPE_P (gnu_param_type))) + /* For convention Ada, see if we pass by reference + by default. */ + || (! Has_Foreign_Convention (gnat_entity) + && default_pass_by_ref (gnu_param_type))))) + { + gnu_param_type = build_reference_type (gnu_param_type); + by_ref_p = 1; + } + + else if (Ekind (gnat_param) != E_In_Parameter) + copy_in_copy_out_flag = 1; + + if (req_by_copy && (by_ref_p || by_component_ptr_p)) + post_error ("?cannot pass & by copy", gnat_param); + + /* If this is an OUT parameter that isn't passed by reference + and isn't a pointer or aggregate, we don't make a PARM_DECL + for it. Instead, it will be a VAR_DECL created when we process + the procedure. For the special parameter of Valued_Procedure, + never pass it in. */ + if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p + && ((Is_Valued_Procedure (gnat_entity) && parmnum == 0) + || (! by_descr_p + && ! POINTER_TYPE_P (gnu_param_type) + && ! AGGREGATE_TYPE_P (gnu_param_type)))) + gnu_param = 0; + else + { + set_lineno (gnat_param, 0); + gnu_param + = create_param_decl + (gnu_param_name, gnu_param_type, + by_ref_p || by_component_ptr_p + || Ekind (gnat_param) == E_In_Parameter); + + DECL_BY_REF_P (gnu_param) = by_ref_p; + DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p; + DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p; + DECL_POINTS_TO_READONLY_P (gnu_param) + = (Ekind (gnat_param) == E_In_Parameter + && (by_ref_p || by_component_ptr_p)); + save_gnu_tree (gnat_param, gnu_param, 0); + gnu_param_list = chainon (gnu_param, gnu_param_list); + + /* If a parameter is a pointer, this function may modify + memory through it and thus shouldn't be considered + a pure function. Also, the memory may be modified + between two calls, so they can't be CSE'ed. The latter + case also handles by-ref parameters. */ + if (POINTER_TYPE_P (gnu_param_type) + || TYPE_FAT_POINTER_P (gnu_param_type)) + pure_flag = 0; + } + + if (copy_in_copy_out_flag) + { + if (! has_copy_in_out) + { + if (TREE_CODE (gnu_return_type) != VOID_TYPE) + gigi_abort (111); + + gnu_return_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_return_type) = get_identifier ("RETURN"); + has_copy_in_out = 1; + } + + set_lineno (gnat_param, 0); + gnu_field = create_field_decl (gnu_param_name, gnu_param_type, + gnu_return_type, 0, 0, 0, 0); + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + gnu_return_list = tree_cons (gnu_field, gnu_param, + gnu_return_list); + } + } + + /* Do not compute record for out parameters if subprogram is + stubbed since structures are incomplete for the back-end. */ + if (gnu_field_list != 0 + && Convention (gnat_entity) != Convention_Stubbed) + finish_record_type (gnu_return_type, nreverse (gnu_field_list), + 0, 0); + + /* If we have a CICO list but it has only one entry, we convert + this function into a function that simply returns that one + object. */ + if (list_length (gnu_return_list) == 1) + gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list)); + + if (Convention (gnat_entity) == Convention_Stdcall) + { + struct attrib *attr + = (struct attrib *) xmalloc (sizeof (struct attrib)); + + attr->next = attr_list; + attr->type = ATTR_MACHINE_ATTRIBUTE; + attr->name = get_identifier ("stdcall"); + attr->arg = NULL_TREE; + attr->error_point = gnat_entity; + attr_list = attr; + } + + /* Both lists ware built in reverse. */ + gnu_param_list = nreverse (gnu_param_list); + gnu_return_list = nreverse (gnu_return_list); + + gnu_type + = create_subprog_type (gnu_return_type, gnu_param_list, + gnu_return_list, returns_unconstrained, + returns_by_ref, + Function_Returns_With_DSP (gnat_entity)); + + /* ??? For now, don't consider nested fuctions pure. */ + if (! global_bindings_p ()) + pure_flag = 0; + + gnu_type + = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | (TYPE_QUAL_CONST * pure_flag) + | (TYPE_QUAL_VOLATILE * volatile_flag))); + + /* Top-level or external functions need to have an assembler name. + This is passed to create_subprog_decl through the ext_name argument. + For Pragma Interface subprograms with no Pragma Interface_Name, the + simple name already in entity_name is correct, and this is what is + gotten when ext_name is NULL. If Interface_Name is specified, then + the name is extracted from the N_String_Literal node containing the + string specified in the Pragma. If there is no Pragma Interface, + then the Ada fully qualified name is created. */ + + if (Present (Interface_Name (gnat_entity)) + || ! (Is_Imported (gnat_entity) || Is_Exported (gnat_entity))) + gnu_ext_name = create_concat_name (gnat_entity, 0); + + set_lineno (gnat_entity, 0); + + /* If we are defining the subprogram and it has an Address clause + we must get the address expression from the saved GCC tree for the + subprogram if it has a Freeze_Node. Otherwise, we elaborate + the address expression here since the front-end has guaranteed + in that case that the elaboration has no effects. If there is + an Address clause and we are not defining the object, just + make it a constant. */ + if (Present (Address_Clause (gnat_entity))) + { + tree gnu_address = 0; + + if (definition) + gnu_address + = (present_gnu_tree (gnat_entity) + ? get_gnu_tree (gnat_entity) + : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); + + save_gnu_tree (gnat_entity, NULL_TREE, 0); + + gnu_type = build_reference_type (gnu_type); + if (gnu_address != 0) + gnu_address = convert (gnu_type, gnu_address); + + gnu_decl + = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, + gnu_address, 0, Is_Public (gnat_entity), + extern_flag, 0, 0); + DECL_BY_REF_P (gnu_decl) = 1; + } + + else if (kind == E_Subprogram_Type) + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + else + { + gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name, + gnu_type, gnu_param_list, + inline_flag, public_flag, + extern_flag, attr_list); + DECL_STUBBED_P (gnu_decl) + = Convention (gnat_entity) == Convention_Stubbed; + } + } + break; + + case E_Incomplete_Type: + case E_Private_Type: + case E_Limited_Private_Type: + case E_Record_Type_With_Private: + case E_Private_Subtype: + case E_Limited_Private_Subtype: + case E_Record_Subtype_With_Private: + + /* If this type does not have a full view in the unit we are + compiling, then just get the type from its Etype. */ + if (No (Full_View (gnat_entity))) + { + /* If this is an incomplete type with no full view, it must + be a Taft Amendement type, so just return a dummy type. */ + if (kind == E_Incomplete_Type) + gnu_type = make_dummy_type (gnat_entity); + + else if (Present (Underlying_Full_View (gnat_entity))) + gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity), + NULL_TREE, 0); + else + { + gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), + NULL_TREE, 0); + maybe_present = 1; + } + + break; + } + + /* Otherwise, if we are not defining the type now, get the + type from the full view. But always get the type from the full + view for define on use types, since otherwise we won't see them! */ + + else if (! definition + || (Is_Itype (Full_View (gnat_entity)) + && No (Freeze_Node (gnat_entity))) + || (Is_Itype (gnat_entity) + && No (Freeze_Node (Full_View (gnat_entity))))) + { + gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), + NULL_TREE, 0); + maybe_present = 1; + break; + } + + /* For incomplete types, make a dummy type entry which will be + replaced later. */ + gnu_type = make_dummy_type (gnat_entity); + + /* Save this type as the full declaration's type so we can do any needed + updates when we see it. */ + set_lineno (gnat_entity, 0); + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0); + break; + + /* Simple class_wide types are always viewed as their root_type + by Gigi unless an Equivalent_Type is specified. */ + case E_Class_Wide_Type: + if (Present (Equivalent_Type (gnat_entity))) + gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity)); + else + gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity)); + + maybe_present = 1; + break; + + case E_Task_Type: + case E_Task_Subtype: + case E_Protected_Type: + case E_Protected_Subtype: + if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity))) + gnu_type = void_type_node; + else + gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity)); + + maybe_present = 1; + break; + + case E_Label: + gnu_decl = create_label_decl (gnu_entity_id); + break; + + case E_Block: + case E_Loop: + /* Nothing at all to do here, so just return an ERROR_MARK and claim + we've already saved it, so we don't try to. */ + gnu_decl = error_mark_node; + saved = 1; + break; + + default: + gigi_abort (113); + } + + /* If we had a case where we evaluated another type and it might have + defined this one, handle it here. */ + if (maybe_present && present_gnu_tree (gnat_entity)) + { + gnu_decl = get_gnu_tree (gnat_entity); + saved = 1; + } + + /* If we are processing a type and there is either no decl for it or + we just made one, do some common processing for the type, such as + handling alignment and possible padding. */ + + if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind)) + { + if (Is_Tagged_Type (gnat_entity)) + TYPE_ALIGN_OK_P (gnu_type) = 1; + + if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) + TYPE_BY_REFERENCE_P (gnu_type) = 1; + + /* ??? Don't set the size for a String_Literal since it is either + confirming or we don't handle it properly (if the low bound is + non-constant). */ + if (gnu_size == 0 && kind != E_String_Literal_Subtype) + gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, + TYPE_DECL, 0, Has_Size_Clause (gnat_entity)); + + /* If a size was specified, see if we can make a new type of that size + by rearranging the type, for example from a fat to a thin pointer. */ + if (gnu_size != 0) + { + gnu_type + = make_type_from_size (gnu_type, gnu_size, + Has_Biased_Representation (gnat_entity)); + + if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0) + && operand_equal_p (rm_size (gnu_type), gnu_size, 0)) + gnu_size = 0; + } + + /* If the alignment hasn't already been processed and this is + not an unconstrained array, see if an alignment is specified. + If not, we pick a default alignment for atomic objects. */ + if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + ; + else if (Known_Alignment (gnat_entity)) + align = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (gnu_type)); + else if (Is_Atomic (gnat_entity) && gnu_size == 0 + && host_integerp (TYPE_SIZE (gnu_type), 1) + && integer_pow2p (TYPE_SIZE (gnu_type))) + align = MIN (BIGGEST_ALIGNMENT, + tree_low_cst (TYPE_SIZE (gnu_type), 1)); + else if (Is_Atomic (gnat_entity) && gnu_size != 0 + && host_integerp (gnu_size, 1) + && integer_pow2p (gnu_size)) + align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1)); + + /* See if we need to pad the type. If we did, and made a record, + the name of the new type may be changed. So get it back for + us when we make the new TYPE_DECL below. */ + gnu_type = maybe_pad_type (gnu_type, gnu_size, align, + gnat_entity, "PAD", 1, definition, 0); + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type)) + { + gnu_entity_id = TYPE_NAME (gnu_type); + if (TREE_CODE (gnu_entity_id) == TYPE_DECL) + gnu_entity_id = DECL_NAME (gnu_entity_id); + } + + set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); + + /* If we are at global level, GCC will have applied variable_size to + the type, but that won't have done anything. So, if it's not + a constant or self-referential, call elaborate_expression_1 to + make a variable for the size rather than calculating it each time. + Handle both the RM size and the actual size. */ + if (global_bindings_p () + && TYPE_SIZE (gnu_type) != 0 + && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST + && ! contains_placeholder_p (TYPE_SIZE (gnu_type))) + { + if (TREE_CODE (gnu_type) == RECORD_TYPE + && operand_equal_p (TYPE_ADA_SIZE (gnu_type), + TYPE_SIZE (gnu_type), 0)) + TYPE_ADA_SIZE (gnu_type) = TYPE_SIZE (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE (gnu_type), + get_identifier ("SIZE"), + definition, 0); + else if (TREE_CODE (gnu_type) == RECORD_TYPE) + { + TYPE_ADA_SIZE (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_ADA_SIZE (gnu_type), + get_identifier ("RM_SIZE"), + definition, 0); + TYPE_SIZE (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE (gnu_type), + get_identifier ("SIZE"), + definition, 0); + TYPE_SIZE_UNIT (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE_UNIT (gnu_type), + get_identifier ("SIZE_UNIT"), + definition, 0); + } + else + { + TYPE_SIZE (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE (gnu_type), + get_identifier ("SIZE"), + definition, 0); + TYPE_SIZE_UNIT (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_SIZE_UNIT (gnu_type), + get_identifier ("SIZE_UNIT"), + definition, 0); + } + } + + /* If this is a record type or subtype, call elaborate_expression_1 on + any field position. Do this for both global and local types. + Skip any fields that we haven't made trees for to avoid problems with + class wide types. */ + if (IN (kind, Record_Kind)) + for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp)) + { + tree gnu_field = get_gnu_tree (gnat_temp); + + if (TREE_CODE (DECL_FIELD_OFFSET (gnu_field)) != INTEGER_CST + && ! contains_placeholder_p (DECL_FIELD_OFFSET (gnu_field))) + DECL_FIELD_OFFSET (gnu_field) + = elaborate_expression_1 (gnat_temp, gnat_temp, + DECL_FIELD_OFFSET (gnu_field), + get_identifier ("OFFSET"), + definition, 0); + } + + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | (TYPE_QUAL_VOLATILE + * Is_Volatile (gnat_entity)))); + + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_type, gnat_entity, 0); + + if (Known_Alignment (gnat_entity)) + TYPE_USER_ALIGN (gnu_type) = 1; + + if (gnu_decl == 0) + { + set_lineno (gnat_entity, 0); + gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, + ! Comes_From_Source (gnat_entity), + debug_info_p); + } + else + TREE_TYPE (gnu_decl) = gnu_type; + } + + if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) + { + gnu_type = TREE_TYPE (gnu_decl); + + /* Back-annotate the Alignment of the type if not already in the + tree. Likewise for sizes. */ + if (Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, + UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); + + if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type) != 0) + { + /* If the size is self-referential, we annotate the maximum + value of that size. */ + tree gnu_size = TYPE_SIZE (gnu_type); + + if (contains_placeholder_p (gnu_size)) + gnu_size = max_size (gnu_size, 1); + + Set_Esize (gnat_entity, annotate_value (gnu_size)); + } + + if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0) + Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); + } + + if (! Comes_From_Source (gnat_entity) && DECL_P (gnu_decl)) + DECL_ARTIFICIAL (gnu_decl) = 1; + + if (! debug_info_p && DECL_P (gnu_decl) + && TREE_CODE (gnu_decl) != FUNCTION_DECL) + DECL_IGNORED_P (gnu_decl) = 1; + + /* If this decl is really indirect, adjust it. */ + if (TREE_CODE (gnu_decl) == VAR_DECL) + adjust_decl_rtl (gnu_decl); + + /* If we haven't already, associate the ..._DECL node that we just made with + the input GNAT entity node. */ + if (! saved) + save_gnu_tree (gnat_entity, gnu_decl, 0); + + /* If this is an enumeral or floating-point type, we were not able to set + the bounds since they refer to the type. These bounds are always static. + + For enumeration types, also write debugging information and declare the + enumeration literal table, if needed. */ + + if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity))) + || (kind == E_Floating_Point_Type && ! Vax_Float (gnat_entity))) + { + tree gnu_scalar_type = gnu_type; + + /* If this is a padded type, we need to use the underlying type. */ + if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_scalar_type)) + gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type)); + + /* If this is a floating point type and we haven't set a floating + point type yet, use this in the evaluation of the bounds. */ + if (longest_float_type_node == 0 && kind == E_Floating_Point_Type) + longest_float_type_node = gnu_type; + + TYPE_MIN_VALUE (gnu_scalar_type) + = gnat_to_gnu (Type_Low_Bound (gnat_entity)); + TYPE_MAX_VALUE (gnu_scalar_type) + = gnat_to_gnu (Type_High_Bound (gnat_entity)); + + if (kind == E_Enumeration_Type) + { + TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl; + + /* Since this has both a typedef and a tag, avoid outputting + the name twice. */ + DECL_ARTIFICIAL (gnu_decl) = 1; + rest_of_type_compilation (gnu_scalar_type, global_bindings_p ()); + } + } + + /* If we deferred processing of incomplete types, re-enable it. If there + were no other disables and we have some to process, do so. */ + if (this_deferred && --defer_incomplete_level == 0 + && defer_incomplete_list != 0) + { + struct incomplete *incp = defer_incomplete_list; + struct incomplete *next; + + defer_incomplete_list = 0; + for (; incp; incp = next) + { + next = incp->next; + + if (incp->old_type != 0) + update_pointer_to (incp->old_type, + gnat_to_gnu_type (incp->full_type)); + free (incp); + } + } + + /* If we are not defining this type, see if it's in the incomplete list. + If so, handle that list entry now. */ + else if (! definition) + { + struct incomplete *incp; + + for (incp = defer_incomplete_list; incp; incp = incp->next) + if (incp->old_type != 0 && incp->full_type == gnat_entity) + { + update_pointer_to (incp->old_type, TREE_TYPE (gnu_decl)); + incp->old_type = 0; + } + } + + if (this_global) + force_global--; + + if (Is_Packed_Array_Type (gnat_entity) + && Is_Itype (Associated_Node_For_Itype (gnat_entity)) + && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity))) + && ! present_gnu_tree (Associated_Node_For_Itype (gnat_entity))) + gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0); + + return gnu_decl; +} + +/* Given GNAT_ENTITY, elaborate all expressions that are required to + be elaborated at the point of its definition, but do nothing else. */ + +void +elaborate_entity (gnat_entity) + Entity_Id gnat_entity; +{ + switch (Ekind (gnat_entity)) + { + case E_Signed_Integer_Subtype: + case E_Modular_Integer_Subtype: + case E_Enumeration_Subtype: + case E_Ordinary_Fixed_Point_Subtype: + case E_Decimal_Fixed_Point_Subtype: + case E_Floating_Point_Subtype: + { + Node_Id gnat_lb = Type_Low_Bound (gnat_entity); + Node_Id gnat_hb = Type_High_Bound (gnat_entity); + + /* ??? Tests for avoiding static constaint error expression + is needed until the front stops generating bogus conversions + on bounds of real types. */ + + if (! Raises_Constraint_Error (gnat_lb)) + elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"), + 1, 0, Needs_Debug_Info (gnat_entity)); + if (! Raises_Constraint_Error (gnat_hb)) + elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"), + 1, 0, Needs_Debug_Info (gnat_entity)); + break; + } + + case E_Record_Type: + { + Node_Id full_definition = Declaration_Node (gnat_entity); + Node_Id record_definition = Type_Definition (full_definition); + + /* If this is a record extension, go a level further to find the + record definition. */ + if (Nkind (record_definition) == N_Derived_Type_Definition) + record_definition = Record_Extension_Part (record_definition); + } + break; + + case E_Record_Subtype: + case E_Private_Subtype: + case E_Limited_Private_Subtype: + case E_Record_Subtype_With_Private: + if (Is_Constrained (gnat_entity) + && Has_Discriminants (Base_Type (gnat_entity)) + && Present (Discriminant_Constraint (gnat_entity))) + { + Node_Id gnat_discriminant_expr; + Entity_Id gnat_field; + + for (gnat_field = First_Discriminant (Base_Type (gnat_entity)), + gnat_discriminant_expr + = First_Elmt (Discriminant_Constraint (gnat_entity)); + Present (gnat_field); + gnat_field = Next_Discriminant (gnat_field), + gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) + /* ??? For now, ignore access discriminants. */ + if (! Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) + elaborate_expression (Node (gnat_discriminant_expr), + gnat_entity, + get_entity_name (gnat_field), 1, 0, 0); + } + break; + + } +} + +/* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark + any entities on its entity chain similarly. */ + +void +mark_out_of_scope (gnat_entity) + Entity_Id gnat_entity; +{ + Entity_Id gnat_sub_entity; + unsigned int kind = Ekind (gnat_entity); + + /* If this has an entity list, process all in the list. */ + if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind) + || IN (kind, Private_Kind) + || kind == E_Block || kind == E_Entry || kind == E_Entry_Family + || kind == E_Function || kind == E_Generic_Function + || kind == E_Generic_Package || kind == E_Generic_Procedure + || kind == E_Loop || kind == E_Operator || kind == E_Package + || kind == E_Package_Body || kind == E_Procedure + || kind == E_Record_Type || kind == E_Record_Subtype + || kind == E_Subprogram_Body || kind == E_Subprogram_Type) + for (gnat_sub_entity = First_Entity (gnat_entity); + Present (gnat_sub_entity); + gnat_sub_entity = Next_Entity (gnat_sub_entity)) + if (Scope (gnat_sub_entity) == gnat_entity + && gnat_sub_entity != gnat_entity) + mark_out_of_scope (gnat_sub_entity); + + /* Now clear this if it has been defined, but only do so if it isn't + a subprogram or parameter. We could refine this, but it isn't + worth it. If this is statically allocated, it is supposed to + hang around out of cope. */ + if (present_gnu_tree (gnat_entity) && ! Is_Statically_Allocated (gnat_entity) + && kind != E_Procedure && kind != E_Function && ! IN (kind, Formal_Kind)) + { + save_gnu_tree (gnat_entity, NULL_TREE, 1); + save_gnu_tree (gnat_entity, error_mark_node, 1); + } +} + +/* Return a TREE_LIST describing the substitutions needed to reflect + discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add + them to GNU_LIST. If GNAT_TYPE is not specified, use the base type + of GNAT_SUBTYPE. The substitions can be in any order. TREE_PURPOSE + gives the tree for the discriminant and TREE_VALUES is the replacement + value. They are in the form of operands to substitute_in_expr. + DEFINITION is as in gnat_to_gnu_entity. */ + +static tree +substitution_list (gnat_subtype, gnat_type, gnu_list, definition) + Entity_Id gnat_subtype; + Entity_Id gnat_type; + tree gnu_list; + int definition; +{ + Entity_Id gnat_discrim; + Node_Id gnat_value; + + if (No (gnat_type)) + gnat_type = Implementation_Base_Type (gnat_subtype); + + if (Has_Discriminants (gnat_type)) + for (gnat_discrim = First_Girder_Discriminant (gnat_type), + gnat_value = First_Elmt (Girder_Constraint (gnat_subtype)); + Present (gnat_discrim); + gnat_discrim = Next_Girder_Discriminant (gnat_discrim), + gnat_value = Next_Elmt (gnat_value)) + /* Ignore access discriminants. */ + if (! Is_Access_Type (Etype (Node (gnat_value)))) + gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0), + elaborate_expression + (Node (gnat_value), gnat_subtype, + get_entity_name (gnat_discrim), definition, + 1, 0), + gnu_list); + + return gnu_list; +} + +/* For the following two functions: for each GNAT entity, the GCC + tree node used as a dummy for that entity, if any. */ + +static tree *dummy_node_table; + +/* Initialize the above table. */ + +void +init_dummy_type () +{ + Node_Id gnat_node; + + dummy_node_table = (tree *) xmalloc (max_gnat_nodes * sizeof (tree)); + ggc_add_tree_root (dummy_node_table, max_gnat_nodes); + + for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++) + dummy_node_table[gnat_node] = NULL_TREE; + + dummy_node_table -= First_Node_Id; +} + +/* Make a dummy type corresponding to GNAT_TYPE. */ + +tree +make_dummy_type (gnat_type) + Entity_Id gnat_type; +{ + Entity_Id gnat_underlying; + tree gnu_type; + + /* Find a full type for GNAT_TYPE, taking into account any class wide + types. */ + if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type))) + gnat_type = Equivalent_Type (gnat_type); + else if (Ekind (gnat_type) == E_Class_Wide_Type) + gnat_type = Root_Type (gnat_type); + + for (gnat_underlying = gnat_type; + (IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_underlying))); + gnat_underlying = Full_View (gnat_underlying)) + ; + + /* If it there already a dummy type, use that one. Else make one. */ + if (dummy_node_table[gnat_underlying]) + return dummy_node_table[gnat_underlying]; + + /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make + it a VOID_TYPE. */ + if (Is_Record_Type (gnat_underlying)) + gnu_type = make_node (Is_Unchecked_Union (gnat_underlying) + ? UNION_TYPE : RECORD_TYPE); + else + gnu_type = make_node (ENUMERAL_TYPE); + + TYPE_NAME (gnu_type) = get_entity_name (gnat_type); + if (AGGREGATE_TYPE_P (gnu_type)) + TYPE_STUB_DECL (gnu_type) + = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type)); + + TYPE_DUMMY_P (gnu_type) = 1; + dummy_node_table[gnat_underlying] = gnu_type; + + return gnu_type; +} + +/* Return 1 if the size represented by GNU_SIZE can be handled by an + allocation. If STATIC_P is non-zero, consider only what can be + done with a static allocation. */ + +static int +allocatable_size_p (gnu_size, static_p) + tree gnu_size; + int static_p; +{ + /* If this is not a static allocation, the only case we want to forbid + is an overflowing size. That will be converted into a raise a + Storage_Error. */ + if (! static_p) + return ! (TREE_CODE (gnu_size) == INTEGER_CST + && TREE_CONSTANT_OVERFLOW (gnu_size)); + + /* Otherwise, we need to deal with both variable sizes and constant + sizes that won't fit in a host int. */ + return host_integerp (gnu_size, 1); +} + +/* Return a list of attributes for GNAT_ENTITY, if any. */ + +static struct attrib * +build_attr_list (gnat_entity) + Entity_Id gnat_entity; +{ + struct attrib *attr_list = 0; + Node_Id gnat_temp; + + for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Rep_Item (gnat_temp)) + if (Nkind (gnat_temp) == N_Pragma) + { + struct attrib *attr; + tree gnu_arg0 = 0, gnu_arg1 = 0; + Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp); + enum attr_type etype; + + if (Present (gnat_assoc) && Present (First (gnat_assoc)) + && Present (Next (First (gnat_assoc))) + && (Nkind (Expression (Next (First (gnat_assoc)))) + == N_String_Literal)) + { + gnu_arg0 = get_identifier (TREE_STRING_POINTER + (gnat_to_gnu + (Expression (Next + (First (gnat_assoc)))))); + if (Present (Next (Next (First (gnat_assoc)))) + && (Nkind (Expression (Next (Next (First (gnat_assoc))))) + == N_String_Literal)) + gnu_arg1 = get_identifier (TREE_STRING_POINTER + (gnat_to_gnu + (Expression + (Next (Next + (First (gnat_assoc))))))); + } + + switch (Get_Pragma_Id (Chars (gnat_temp))) + { + case Pragma_Machine_Attribute: + etype = ATTR_MACHINE_ATTRIBUTE; + break; + + case Pragma_Linker_Alias: + etype = ATTR_LINK_ALIAS; + break; + + case Pragma_Linker_Section: + etype = ATTR_LINK_SECTION; + break; + + case Pragma_Weak_External: + etype = ATTR_WEAK_EXTERNAL; + break; + + default: + continue; + } + + attr = (struct attrib *) xmalloc (sizeof (struct attrib)); + attr->next = attr_list; + attr->type = etype; + attr->name = gnu_arg0; + attr->arg = gnu_arg1; + attr->error_point + = Present (Next (First (gnat_assoc))) + ? Expression (Next (First (gnat_assoc))) : gnat_temp; + attr_list = attr; + } + + return attr_list; +} + +/* Get the unpadded version of a GNAT type. */ + +tree +get_unpadded_type (gnat_entity) + Entity_Id gnat_entity; +{ + tree type = gnat_to_gnu_type (gnat_entity); + + if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + type = TREE_TYPE (TYPE_FIELDS (type)); + + return type; +} + +/* Called when we need to protect a variable object using a save_expr. */ + +tree +maybe_variable (gnu_operand, gnat_node) + tree gnu_operand; + Node_Id gnat_node; +{ + if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand) + || TREE_CODE (gnu_operand) == SAVE_EXPR + || TREE_CODE (gnu_operand) == NULL_EXPR) + return gnu_operand; + + /* If we will be generating code, make sure we are at the proper + line number. */ + if (! global_bindings_p () && ! TREE_CONSTANT (gnu_operand) + && ! contains_placeholder_p (gnu_operand)) + set_lineno (gnat_node, 1); + + if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF) + return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand), + variable_size (TREE_OPERAND (gnu_operand, 0))); + else + return variable_size (gnu_operand); +} + +/* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a + type definition (either a bound or a discriminant value) for GNAT_ENTITY, + return the GCC tree to use for that expression. GNU_NAME is the + qualification to use if an external name is appropriate and DEFINITION is + nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero, + we need a result. Otherwise, we are just elaborating this for + side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging + purposes even if it isn't needed for code generation. */ + +static tree +elaborate_expression (gnat_expr, gnat_entity, gnu_name, definition, + need_value, need_debug) + Node_Id gnat_expr; + Entity_Id gnat_entity; + tree gnu_name; + int definition; + int need_value; + int need_debug; +{ + tree gnu_expr; + + /* If we already elaborated this expression (e.g., it was involved + in the definition of a private type), use the old value. */ + if (present_gnu_tree (gnat_expr)) + return get_gnu_tree (gnat_expr); + + /* If we don't need a value and this is static or a discriment, we + don't need to do anything. */ + else if (! need_value + && (Is_OK_Static_Expression (gnat_expr) + || (Nkind (gnat_expr) == N_Identifier + && Ekind (Entity (gnat_expr)) == E_Discriminant))) + return 0; + + /* Otherwise, convert this tree to its GCC equivalant. */ + gnu_expr + = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr), + gnu_name, definition, need_debug); + + /* Save the expression in case we try to elaborate this entity again. + Since this is not a DECL, don't check it. If this is a constant, + don't save it since GNAT_EXPR might be used more than once. Also, + don't save if it's a discriminant. */ + if (! TREE_CONSTANT (gnu_expr) && ! contains_placeholder_p (gnu_expr)) + save_gnu_tree (gnat_expr, gnu_expr, 1); + + return need_value ? gnu_expr : error_mark_node; +} + +/* Similar, but take a GNU expression. */ + +static tree +elaborate_expression_1 (gnat_expr, gnat_entity, gnu_expr, gnu_name, definition, + need_debug) + Node_Id gnat_expr; + Entity_Id gnat_entity; + tree gnu_expr; + tree gnu_name; + int definition; + int need_debug; +{ + tree gnu_decl = 0; + tree gnu_inner_expr = gnu_expr; + int expr_variable; + int expr_global = Is_Public (gnat_entity) || global_bindings_p (); + + /* Strip any conversions to see if the expression is a readonly variable. + ??? This really should remain readonly, but we have to think about + the typing of the tree here. */ + while (TREE_CODE (gnu_inner_expr) == NOP_EXPR + && TREE_CODE (gnu_inner_expr) == CONVERT_EXPR) + gnu_inner_expr = TREE_OPERAND (gnu_inner_expr, 0); + + /* In most cases, we won't see a naked FIELD_DECL here because a + discriminant reference will have been replaced with a COMPONENT_REF + when the type is being elaborated. However, there are some cases + involving child types where we will. So convert it to a COMPONENT_REF + here. We have to hope it will be at the highest level of the + expression in these cases. */ + if (TREE_CODE (gnu_expr) == FIELD_DECL) + gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr), + build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), + gnu_expr); + + + /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable + that is a constant, make a variable that is initialized to contain the + bound when the package containing the definition is elaborated. If + this entity is defined at top level and a bound or discriminant value + isn't a constant or a reference to a discriminant, replace the bound + by the variable; otherwise use a SAVE_EXPR if needed. Note that we + rely here on the fact that an expression cannot contain both the + discriminant and some other variable. */ + + expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c' + && ! (TREE_CODE (gnu_inner_expr) == VAR_DECL + && TREE_READONLY (gnu_inner_expr)) + && ! contains_placeholder_p (gnu_expr)); + + /* If this is a static expression or contains a discriminant, we don't + need the variable for debugging (and can't elaborate anyway if a + discriminant). */ + if (need_debug + && (Is_OK_Static_Expression (gnat_expr) + || contains_placeholder_p (gnu_expr))) + need_debug = 0; + + /* Now create the variable if we need it. */ + if (need_debug || (expr_variable && expr_global)) + { + set_lineno (gnat_entity, ! global_bindings_p ()); + gnu_decl + = create_var_decl (create_concat_name (gnat_entity, + IDENTIFIER_POINTER (gnu_name)), + NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1, + Is_Public (gnat_entity), ! definition, 0, 0); + } + + /* We only need to use this variable if we are in global context since GCC + can do the right thing in the local case. */ + if (expr_global && expr_variable) + return gnu_decl; + else + return maybe_variable (gnu_expr, gnat_expr); +} + +/* Create a record type that contains a field of TYPE with a starting bit + position so that it is aligned to ALIGN bits and is SIZE bytes long. */ + +tree +make_aligning_type (type, align, size) + tree type; + int align; + tree size; +{ + tree record_type = make_node (RECORD_TYPE); + tree place = build (PLACEHOLDER_EXPR, record_type); + tree size_addr_place = convert (sizetype, + build_unary_op (ADDR_EXPR, NULL_TREE, + place)); + tree name = TYPE_NAME (type); + tree pos, field; + + if (TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + + TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN"); + + /* The bit position is obtained by "and"ing the alignment minus 1 + with the two's complement of the address and multiplying + by the number of bits per unit. Do all this in sizetype. */ + + pos = size_binop (MULT_EXPR, + convert (bitsizetype, + size_binop (BIT_AND_EXPR, + size_diffop (size_zero_node, + size_addr_place), + ssize_int ((align / BITS_PER_UNIT) + - 1))), + bitsize_unit_node); + + field = create_field_decl (get_identifier ("F"), type, record_type, + 1, size, pos, 1); + DECL_BIT_FIELD (field) = 0; + + finish_record_type (record_type, field, 1, 0); + TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT; + TYPE_SIZE (record_type) + = size_binop (PLUS_EXPR, + size_binop (MULT_EXPR, convert (bitsizetype, size), + bitsize_unit_node), + bitsize_int (align)); + TYPE_SIZE_UNIT (record_type) + = size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT)); + + return record_type; +} + +/* TYPE is a RECORD_TYPE with BLKmode that's being used as the field + type of a packed record. See if we can rewrite it as a record that has + a non-BLKmode type, which we can pack tighter. If so, return the + new type. If not, return the original type. */ + +static tree +make_packable_type (type) + tree type; +{ + tree new_type = make_node (RECORD_TYPE); + tree field_list = NULL_TREE; + tree old_field; + + /* Copy the name and flags from the old type to that of the new and set + the alignment to try for an integral type. */ + TYPE_NAME (new_type) = TYPE_NAME (type); + TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type) + = TYPE_LEFT_JUSTIFIED_MODULAR_P (type); + TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); + + TYPE_ALIGN (new_type) + = ((HOST_WIDE_INT) 1 + << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1)); + + /* Now copy the fields, keeping the position and size. */ + for (old_field = TYPE_FIELDS (type); old_field != 0; + old_field = TREE_CHAIN (old_field)) + { + tree new_field + = create_field_decl (DECL_NAME (old_field), TREE_TYPE (old_field), + new_type, TYPE_PACKED (type), + DECL_SIZE (old_field), + bit_position (old_field), + ! DECL_NONADDRESSABLE_P (old_field)); + + DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); + DECL_ORIGINAL_FIELD (new_field) + = (DECL_ORIGINAL_FIELD (old_field) != 0 + ? DECL_ORIGINAL_FIELD (old_field) : old_field); + TREE_CHAIN (new_field) = field_list; + field_list = new_field; + } + + finish_record_type (new_type, nreverse (field_list), 1, 1); + return TYPE_MODE (new_type) == BLKmode ? type : new_type; +} + +/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type + if needed. We have already verified that SIZE and TYPE are large enough. + + GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and + to issue a warning. + + IS_USER_TYPE is nonzero if we must be sure we complete the original type. + + DEFINITION is nonzero if this type is being defined. + + SAME_RM_SIZE is nonzero if the RM_Size of the resulting type is to be + set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original + type. */ + +static tree +maybe_pad_type (type, size, align, gnat_entity, name_trailer, + is_user_type, definition, same_rm_size) + tree type; + tree size; + unsigned int align; + Entity_Id gnat_entity; + const char *name_trailer; + int is_user_type; + int definition; + int same_rm_size; +{ + tree orig_size = TYPE_SIZE (type); + tree record; + tree field; + + /* If TYPE is a padded type, see if it agrees with any size and alignment + we were given. If so, return the original type. Otherwise, strip + off the padding, since we will either be returning the inner type + or repadding it. If no size or alignment is specified, use that of + the original padded type. */ + + if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) + { + if ((size == 0 + || operand_equal_p (round_up (size, + MAX (align, TYPE_ALIGN (type))), + round_up (TYPE_SIZE (type), + MAX (align, TYPE_ALIGN (type))), + 0)) + && (align == 0 || align == TYPE_ALIGN (type))) + return type; + + if (size == 0) + size = TYPE_SIZE (type); + if (align == 0) + align = TYPE_ALIGN (type); + + type = TREE_TYPE (TYPE_FIELDS (type)); + orig_size = TYPE_SIZE (type); + } + + /* If the size is either not being changed or is being made smaller (which + is not done here (and is only valid for bitfields anyway), show the size + isn't changing. Likewise, clear the alignment if it isn't being + changed. Then return if we aren't doing anything. */ + + if (size != 0 + && (operand_equal_p (size, orig_size, 0) + || (TREE_CODE (orig_size) == INTEGER_CST + && tree_int_cst_lt (size, orig_size)))) + size = 0; + + if (align == TYPE_ALIGN (type)) + align = 0; + + if (align == 0 && size == 0) + return type; + + /* We used to modify the record in place in some cases, but that could + generate incorrect debugging information. So make a new record + type and name. */ + record = make_node (RECORD_TYPE); + + if (Present (gnat_entity)) + TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer); + + /* If we were making a type, complete the original type and give it a + name. */ + if (is_user_type) + create_type_decl (get_entity_name (gnat_entity), type, + 0, ! Comes_From_Source (gnat_entity), + ! (TYPE_NAME (type) != 0 + && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL + && DECL_IGNORED_P (TYPE_NAME (type)))); + + /* If we are changing the alignment and the input type is a record with + BLKmode and a small constant size, try to make a form that has an + integral mode. That might allow this record to have an integral mode, + which will be much more efficient. There is no point in doing this if a + size is specified unless it is also smaller than the biggest alignment + and it is incorrect to do this if the size of the original type is not a + multiple of the alignment. */ + if (align != 0 + && TREE_CODE (type) == RECORD_TYPE + && TYPE_MODE (type) == BLKmode + && host_integerp (orig_size, 1) + && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0 + && (size == 0 + || (TREE_CODE (size) == INTEGER_CST + && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0)) + && tree_low_cst (orig_size, 1) % align == 0) + type = make_packable_type (type); + + field = create_field_decl (get_identifier ("F"), type, record, 0, + NULL_TREE, bitsize_zero_node, 1); + + DECL_INTERNAL_P (field) = 1; + TYPE_SIZE (record) = size != 0 ? size : orig_size; + TYPE_SIZE_UNIT (record) + = convert (sizetype, + size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record), + bitsize_unit_node)); + TYPE_ALIGN (record) = align; + TYPE_IS_PADDING_P (record) = 1; + TYPE_VOLATILE (record) + = Present (gnat_entity) && Is_Volatile (gnat_entity); + finish_record_type (record, field, 1, 0); + + /* Keep the RM_Size of the padded record as that of the old record + if requested. */ + TYPE_ADA_SIZE (record) = same_rm_size ? size : rm_size (type); + + /* Unless debugging information isn't being written for the input type, + write a record that shows what we are a subtype of and also make a + variable that indicates our size, if variable. */ + if (TYPE_NAME (record) != 0 + && AGGREGATE_TYPE_P (type) + && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL + || ! DECL_IGNORED_P (TYPE_NAME (type)))) + { + tree marker = make_node (RECORD_TYPE); + tree name = DECL_NAME (TYPE_NAME (record)); + tree orig_name = TYPE_NAME (type); + + if (TREE_CODE (orig_name) == TYPE_DECL) + orig_name = DECL_NAME (orig_name); + + TYPE_NAME (marker) = concat_id_with_name (name, "XVS"); + finish_record_type (marker, + create_field_decl (orig_name, integer_type_node, + marker, 0, NULL_TREE, NULL_TREE, + 0), + 0, 0); + + if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition) + create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE, + sizetype, TYPE_SIZE (record), 0, 0, 0, 0, + 0); + } + + type = record; + + if (TREE_CODE (orig_size) != INTEGER_CST + && contains_placeholder_p (orig_size)) + orig_size = max_size (orig_size, 1); + + /* If the size was widened explicitly, maybe give a warning. */ + if (size != 0 && Present (gnat_entity) + && ! operand_equal_p (size, orig_size, 0) + && ! (TREE_CODE (size) == INTEGER_CST + && TREE_CODE (orig_size) == INTEGER_CST + && tree_int_cst_lt (size, orig_size))) + { + Node_Id gnat_error_node = Empty; + + if (Is_Packed_Array_Type (gnat_entity)) + gnat_entity = Associated_Node_For_Itype (gnat_entity); + + if ((Ekind (gnat_entity) == E_Component + || Ekind (gnat_entity) == E_Discriminant) + && Present (Component_Clause (gnat_entity))) + gnat_error_node = Last_Bit (Component_Clause (gnat_entity)); + else if (Present (Size_Clause (gnat_entity))) + gnat_error_node = Expression (Size_Clause (gnat_entity)); + + /* Generate message only for entities that come from source, since + if we have an entity created by expansion, the message will be + generated for some other corresponding source entity. */ + if (Comes_From_Source (gnat_entity) && Present (gnat_error_node)) + post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node, + gnat_entity, + size_diffop (size, orig_size)); + + else if (*name_trailer == 'C' && ! Is_Internal (gnat_entity)) + post_error_ne_tree ("component of& padded{ by ^ bits}?", + gnat_entity, gnat_entity, + size_diffop (size, orig_size)); + } + + return type; +} + +/* Given a GNU tree and a GNAT list of choices, generate an expression to test + the value passed against the list of choices. */ + +tree +choices_to_gnu (operand, choices) + tree operand; + Node_Id choices; +{ + Node_Id choice; + Node_Id gnat_temp; + tree result = integer_zero_node; + tree this_test, low = 0, high = 0, single = 0; + + for (choice = First (choices); Present (choice); choice = Next (choice)) + { + switch (Nkind (choice)) + { + case N_Range: + low = gnat_to_gnu (Low_Bound (choice)); + high = gnat_to_gnu (High_Bound (choice)); + + /* There's no good type to use here, so we might as well use + integer_type_node. */ + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (GE_EXPR, integer_type_node, + operand, low), + build_binary_op (LE_EXPR, integer_type_node, + operand, high)); + + break; + + case N_Subtype_Indication: + gnat_temp = Range_Expression (Constraint (choice)); + low = gnat_to_gnu (Low_Bound (gnat_temp)); + high = gnat_to_gnu (High_Bound (gnat_temp)); + + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (GE_EXPR, integer_type_node, + operand, low), + build_binary_op (LE_EXPR, integer_type_node, + operand, high)); + break; + + case N_Identifier: + case N_Expanded_Name: + /* This represents either a subtype range, an enumeration + literal, or a constant Ekind says which. If an enumeration + literal or constant, fall through to the next case. */ + if (Ekind (Entity (choice)) != E_Enumeration_Literal + && Ekind (Entity (choice)) != E_Constant) + { + tree type = gnat_to_gnu_type (Entity (choice)); + + low = TYPE_MIN_VALUE (type); + high = TYPE_MAX_VALUE (type); + + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, + build_binary_op (GE_EXPR, integer_type_node, + operand, low), + build_binary_op (LE_EXPR, integer_type_node, + operand, high)); + break; + } + /* ... fall through ... */ + case N_Character_Literal: + case N_Integer_Literal: + single = gnat_to_gnu (choice); + this_test = build_binary_op (EQ_EXPR, integer_type_node, operand, + single); + break; + + case N_Others_Choice: + this_test = integer_one_node; + break; + + default: + gigi_abort (114); + } + + result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + result, this_test); + } + + return result; +} + +/* Return a GCC tree for a field corresponding to GNAT_FIELD to be + placed in GNU_RECORD_TYPE. + + PACKED is 1 if the enclosing record is packed and -1 if the enclosing + record has a Component_Alignment of Storage_Unit. + + DEFINITION is nonzero if this field is for a record being defined. */ + +static tree +gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition) + Entity_Id gnat_field; + tree gnu_record_type; + int packed; + int definition; +{ + tree gnu_field_id = get_entity_name (gnat_field); + tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); + tree gnu_orig_field_type = gnu_field_type; + tree gnu_pos = 0; + tree gnu_size = 0; + tree gnu_field; + int needs_strict_alignment + = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field)) + || Is_Volatile (gnat_field)); + + /* If this field requires strict alignment pretend it isn't packed. */ + if (needs_strict_alignment) + packed = 0; + + /* For packed records, this is one of the few occasions on which we use + the official RM size for discrete or fixed-point components, instead + of the normal GNAT size stored in Esize. See description in Einfo: + "Handling of Type'Size Values" for further details. */ + + if (packed == 1) + gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type, + gnat_field, FIELD_DECL, 0, 1); + + if (Known_Static_Esize (gnat_field)) + gnu_size = validate_size (Esize (gnat_field), gnu_field_type, + gnat_field, FIELD_DECL, 0, 1); + + /* If we are packing this record and the field type is also a record + that's BLKmode and with a small constant size, see if we can get a + better form of the type that allows more packing. If we can, show + a size was specified for it if there wasn't one so we know to + make this a bitfield and avoid making things wider. */ + if (packed && TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_MODE (gnu_field_type) == BLKmode + && host_integerp (TYPE_SIZE (gnu_field_type), 1) + && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0) + { + gnu_field_type = make_packable_type (gnu_field_type); + + if (gnu_field_type != gnu_orig_field_type && gnu_size == 0) + gnu_size = rm_size (gnu_field_type); + } + + if (Present (Component_Clause (gnat_field))) + { + gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); + gnu_size = validate_size (Esize (gnat_field), gnu_field_type, + gnat_field, FIELD_DECL, 0, 1); + + /* Ensure the position does not overlap with the parent subtype, + if there is one. */ + if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field))))) + { + tree gnu_parent + = gnat_to_gnu_type (Parent_Subtype + (Underlying_Type (Scope (gnat_field)))); + + if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST + && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent))) + { + post_error_ne_tree + ("offset of& must be beyond parent{, minimum allowed is ^}", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE_UNIT (gnu_parent)); + } + } + + /* If this field needs strict alignment, ensure the record is + sufficiently aligned and that that position and size are + consistent with the alignment. */ + if (needs_strict_alignment) + { + tree gnu_min_size = round_up (rm_size (gnu_field_type), + TYPE_ALIGN (gnu_field_type)); + + TYPE_ALIGN (gnu_record_type) + = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type)); + + /* If Atomic, the size must match exactly and if aliased, the size + must not be less than the rounded size. */ + if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field))) + && ! operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0)) + { + post_error_ne_tree + ("atomic field& must be natural size of type{ (^)}", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE (gnu_field_type)); + + gnu_size = 0; + } + + else if (Is_Aliased (gnat_field) + && gnu_size != 0 + && tree_int_cst_lt (gnu_size, gnu_min_size)) + { + post_error_ne_tree + ("size of aliased field& too small{, minimum required is ^}", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + gnu_min_size); + gnu_size = 0; + } + + if (! integer_zerop (size_binop + (TRUNC_MOD_EXPR, gnu_pos, + bitsize_int (TYPE_ALIGN (gnu_field_type))))) + { + if (Is_Aliased (gnat_field)) + post_error_ne_num + ("position of aliased field& must be multiple of ^ bits", + Component_Clause (gnat_field), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else if (Is_Volatile (gnat_field)) + post_error_ne_num + ("position of volatile field& must be multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else if (Strict_Alignment (Etype (gnat_field))) + post_error_ne_num + ("position of & with aliased or tagged components not multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + else + gigi_abort (124); + + gnu_pos = 0; + } + + /* If an error set the size to zero, show we have no position + either. */ + if (gnu_size == 0) + gnu_pos = 0; + } + + if (Is_Atomic (gnat_field)) + check_ok_for_atomic (gnu_field_type, gnat_field, 0); + + if (gnu_pos !=0 && TYPE_MODE (gnu_field_type) == BLKmode + && (! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos, + bitsize_unit_node)))) + { + /* Try to see if we can make this a packable type. If we + can, it's OK. */ + if (TREE_CODE (gnu_field_type) == RECORD_TYPE) + gnu_field_type = make_packable_type (gnu_field_type); + + if (TYPE_MODE (gnu_field_type) == BLKmode) + { + post_error_ne ("fields of& must start at storage unit boundary", + First_Bit (Component_Clause (gnat_field)), + Etype (gnat_field)); + gnu_pos = 0; + } + } + } + + /* If the record has rep clauses and this is the tag field, make a rep + clause for it as well. */ + else if (Has_Specified_Layout (Scope (gnat_field)) + && Chars (gnat_field) == Name_uTag) + { + gnu_pos = bitsize_zero_node; + gnu_size = TYPE_SIZE (gnu_field_type); + } + + /* We need to make the size the maximum for the type if it is + self-referential and an unconstrained type. */ + if (TREE_CODE (gnu_field_type) == RECORD_TYPE + && gnu_size == 0 + && ! TREE_CONSTANT (TYPE_SIZE (gnu_field_type)) + && contains_placeholder_p (TYPE_SIZE (gnu_field_type)) + && ! Is_Constrained (Underlying_Type (Etype (gnat_field)))) + gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1); + + /* If no size is specified (or if there was an error), don't specify a + position. */ + if (gnu_size == 0) + gnu_pos = 0; + else + { + /* Unless this field is aliased, we can remove any left-justified + modular type since it's only needed in the unchecked conversion + case, which doesn't apply here. */ + if (! needs_strict_alignment + && TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type)) + gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); + + gnu_field_type + = make_type_from_size (gnu_field_type, gnu_size, + Has_Biased_Representation (gnat_field)); + gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, + gnat_field, "PAD", 0, definition, 1); + } + + if (TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_field_type)) + gigi_abort (118); + + set_lineno (gnat_field, 0); + gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type, + packed, gnu_size, gnu_pos, + Is_Aliased (gnat_field)); + + TREE_THIS_VOLATILE (gnu_field) = Is_Volatile (gnat_field); + + if (Ekind (gnat_field) == E_Discriminant) + DECL_DISCRIMINANT_NUMBER (gnu_field) + = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); + + return gnu_field; +} + +/* Return a GCC tree for a record type given a GNAT Component_List and a chain + of GCC trees for fields that are in the record and have already been + processed. When called from gnat_to_gnu_entity during the processing of a + record type definition, the GCC nodes for the discriminants will be on + the chain. The other calls to this function are recursive calls from + itself for the Component_List of a variant and the chain is empty. + + PACKED is 1 if this is for a record with "pragma pack" and -1 is this is + for a record type with "pragma component_alignment (storage_unit)". + + FINISH_RECORD is nonzero if this call will supply all of the remaining + fields of the record. + + P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field + with a rep clause is to be added. If it is nonzero, that is all that + should be done with such fields. + + CANCEL_ALIGNMENT, if nonzero, means the alignment should be zeroed + before laying out the record. This means the alignment only serves + to force fields to be bitfields, but not require the record to be + that aligned. This is used for variants. + + ALL_REP, if nonzero, means that a rep clause was found for all the + fields. This simplifies the logic since we know we're not in the mixed + case. + + The processing of the component list fills in the chain with all of the + fields of the record and then the record type is finished. */ + +static void +components_to_record (gnu_record_type, component_list, gnu_field_list, packed, + definition, p_gnu_rep_list, cancel_alignment, all_rep) + tree gnu_record_type; + Node_Id component_list; + tree gnu_field_list; + int packed; + int definition; + tree *p_gnu_rep_list; + int cancel_alignment; + int all_rep; +{ + Node_Id component_decl; + Entity_Id gnat_field; + Node_Id variant_part; + Node_Id variant; + tree gnu_our_rep_list = NULL_TREE; + tree gnu_field, gnu_last; + int layout_with_rep = 0; + + /* For each variable within each component declaration create a GCC field + and add it to the list, skipping any pragmas in the list. */ + + if (Present (Component_Items (component_list))) + for (component_decl = First_Non_Pragma (Component_Items (component_list)); + Present (component_decl); + component_decl = Next_Non_Pragma (component_decl)) + { + gnat_field = Defining_Entity (component_decl); + + if (Chars (gnat_field) == Name_uParent) + gnu_field = tree_last (TYPE_FIELDS (gnu_record_type)); + else + { + gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, + packed, definition); + + /* If this is the _Tag field, put it before any discriminants, + instead of after them as is the case for all other fields. */ + if (Chars (gnat_field) == Name_uTag) + gnu_field_list = chainon (gnu_field_list, gnu_field); + else + { + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + } + + save_gnu_tree (gnat_field, gnu_field, 0); + } + + /* At the end of the component list there may be a variant part. */ + variant_part = Variant_Part (component_list); + + /* If this is an unchecked union, each variant must have exactly one + component, each of which becomes one component of this union. */ + if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part)) + for (variant = First_Non_Pragma (Variants (variant_part)); + Present (variant); + variant = Next_Non_Pragma (variant)) + { + component_decl + = First_Non_Pragma (Component_Items (Component_List (variant))); + gnat_field = Defining_Entity (component_decl); + gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed, + definition); + TREE_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + save_gnu_tree (gnat_field, gnu_field, 0); + } + + /* We create a QUAL_UNION_TYPE for the variant part since the variants are + mutually exclusive and should go in the same memory. To do this we need + to treat each variant as a record whose elements are created from the + component list for the variant. So here we create the records from the + lists for the variants and put them all into the QUAL_UNION_TYPE. */ + else if (Present (variant_part)) + { + tree gnu_discriminant = gnat_to_gnu (Name (variant_part)); + Node_Id variant; + tree gnu_union_type = make_node (QUAL_UNION_TYPE); + tree gnu_union_field; + tree gnu_variant_list = NULL_TREE; + tree gnu_name = TYPE_NAME (gnu_record_type); + tree gnu_var_name + = concat_id_with_name + (get_identifier (Get_Name_String (Chars (Name (variant_part)))), + "XVN"); + + if (TREE_CODE (gnu_name) == TYPE_DECL) + gnu_name = DECL_NAME (gnu_name); + + TYPE_NAME (gnu_union_type) + = concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name)); + TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); + + for (variant = First_Non_Pragma (Variants (variant_part)); + Present (variant); + variant = Next_Non_Pragma (variant)) + { + tree gnu_variant_type = make_node (RECORD_TYPE); + tree gnu_inner_name; + tree gnu_qual; + + Get_Variant_Encoding (variant); + gnu_inner_name = get_identifier (Name_Buffer); + TYPE_NAME (gnu_variant_type) + = concat_id_with_name (TYPE_NAME (gnu_union_type), + IDENTIFIER_POINTER (gnu_inner_name)); + + /* Set the alignment of the inner type in case we need to make + inner objects into bitfields, but then clear it out + so the record actually gets only the alignment required. */ + TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type); + TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); + components_to_record (gnu_variant_type, Component_List (variant), + NULL_TREE, packed, definition, + &gnu_our_rep_list, 1, all_rep); + + gnu_qual = choices_to_gnu (gnu_discriminant, + Discrete_Choices (variant)); + + Set_Present_Expr (variant, annotate_value (gnu_qual)); + gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type, + gnu_union_type, 0, 0, 0, 1); + DECL_INTERNAL_P (gnu_field) = 1; + DECL_QUALIFIER (gnu_field) = gnu_qual; + TREE_CHAIN (gnu_field) = gnu_variant_list; + gnu_variant_list = gnu_field; + } + + /* We can delete any empty variants from the end. This may leave none + left. Note we cannot delete variants from anywhere else. */ + while (gnu_variant_list != 0 + && TYPE_FIELDS (TREE_TYPE (gnu_variant_list)) == 0) + gnu_variant_list = TREE_CHAIN (gnu_variant_list); + + /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */ + if (gnu_variant_list != 0) + { + finish_record_type (gnu_union_type, nreverse (gnu_variant_list), + 0, 0); + + gnu_union_field + = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, + packed, + all_rep ? TYPE_SIZE (gnu_union_type) : 0, + all_rep ? bitsize_zero_node : 0, 1); + + DECL_INTERNAL_P (gnu_union_field) = 1; + TREE_CHAIN (gnu_union_field) = gnu_field_list; + gnu_field_list = gnu_union_field; + } + } + + /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they + do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this + in a separate pass since we want to handle the discriminants but can't + play with them until we've used them in debugging data above. + + ??? Note: if we then reorder them, debugging information will be wrong, + but there's nothing that can be done about this at the moment. */ + + for (gnu_field = gnu_field_list, gnu_last = 0; gnu_field; ) + { + if (DECL_FIELD_OFFSET (gnu_field) != 0) + { + tree gnu_next = TREE_CHAIN (gnu_field); + + if (gnu_last == 0) + gnu_field_list = gnu_next; + else + TREE_CHAIN (gnu_last) = gnu_next; + + TREE_CHAIN (gnu_field) = gnu_our_rep_list; + gnu_our_rep_list = gnu_field; + gnu_field = gnu_next; + } + else + { + gnu_last = gnu_field; + gnu_field = TREE_CHAIN (gnu_field); + } + } + + /* If we have any items in our rep'ed field list, it is not the case that all + the fields in the record have rep clauses, and P_REP_LIST is nonzero, + set it and ignore the items. Otherwise, sort the fields by bit position + and put them into their own record if we have any fields without + rep clauses. */ + if (gnu_our_rep_list != 0 && p_gnu_rep_list != 0 && ! all_rep) + *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list); + else if (gnu_our_rep_list != 0) + { + tree gnu_rep_type + = gnu_field_list == 0 ? gnu_record_type : make_node (RECORD_TYPE); + int len = list_length (gnu_our_rep_list); + tree *gnu_arr = (tree *) alloca (sizeof (tree) * len); + int i; + + /* Set DECL_SECTION_NAME to increasing integers so we have a + stable sort. */ + for (i = 0, gnu_field = gnu_our_rep_list; gnu_field; + gnu_field = TREE_CHAIN (gnu_field), i++) + { + gnu_arr[i] = gnu_field; + DECL_SECTION_NAME (gnu_field) = size_int (i); + } + + qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos); + + /* Put the fields in the list in order of increasing position, which + means we start from the end. */ + gnu_our_rep_list = NULL_TREE; + for (i = len - 1; i >= 0; i--) + { + TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list; + gnu_our_rep_list = gnu_arr[i]; + DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type; + DECL_SECTION_NAME (gnu_arr[i]) = 0; + } + + if (gnu_field_list != 0) + { + finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, 0); + gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type, + gnu_record_type, 0, 0, 0, 1); + DECL_INTERNAL_P (gnu_field) = 1; + gnu_field_list = chainon (gnu_field_list, gnu_field); + } + else + { + layout_with_rep = 1; + gnu_field_list = nreverse (gnu_our_rep_list); + } + } + + if (cancel_alignment) + TYPE_ALIGN (gnu_record_type) = 0; + + finish_record_type (gnu_record_type, nreverse (gnu_field_list), + layout_with_rep, 0); +} + +/* Called via qsort from the above. Returns -1, 1, depending on the + bit positions and ordinals of the two fields. */ + +static int +compare_field_bitpos (rt1, rt2) + const PTR rt1; + const PTR rt2; +{ + tree *t1 = (tree *) rt1; + tree *t2 = (tree *) rt2; + + if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2))) + return + (tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2)) + ? -1 : 1); + else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2))) + return -1; + else + return 1; +} + +/* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be + placed into an Esize, Component_Bit_Offset, or Component_Size value + in the GNAT tree. */ + +static Uint +annotate_value (gnu_size) + tree gnu_size; +{ + int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size)); + TCode tcode; + Node_Ref_Or_Val ops[3]; + int i; + unsigned int size; + + /* If we do not return inside this switch, TCODE will be set to the + code to use for a Create_Node operand and LEN (set above) will be + the number of recursive calls for us to make. */ + + switch (TREE_CODE (gnu_size)) + { + case INTEGER_CST: + if (TREE_OVERFLOW (gnu_size)) + return No_Uint; + + /* This may have come from a conversion from some smaller type, + so ensure this is in bitsizetype. */ + gnu_size = convert (bitsizetype, gnu_size); + + /* For negative values, use NEGATE_EXPR of the supplied value. */ + if (tree_int_cst_sgn (gnu_size) < 0) + { + /* The rediculous code below is to handle the case of the largest + negative integer. */ + tree negative_size = size_diffop (bitsize_zero_node, gnu_size); + int adjust = 0; + tree temp; + + if (TREE_CONSTANT_OVERFLOW (negative_size)) + { + negative_size + = size_binop (MINUS_EXPR, bitsize_zero_node, + size_binop (PLUS_EXPR, gnu_size, + bitsize_one_node)); + adjust = 1; + } + + temp = build1 (NEGATE_EXPR, bitsizetype, negative_size); + if (adjust) + temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node); + + return annotate_value (temp); + } + + if (! host_integerp (gnu_size, 1)) + return No_Uint; + + size = tree_low_cst (gnu_size, 1); + + /* This peculiar test is to make sure that the size fits in an int + on machines where HOST_WIDE_INT is not "int". */ + if (tree_low_cst (gnu_size, 1) == size) + return UI_From_Int (size); + else + return No_Uint; + + case COMPONENT_REF: + /* The only case we handle here is a simple discriminant reference. */ + if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR + && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL + && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)) != 0) + return Create_Node (Discrim_Val, + annotate_value (DECL_DISCRIMINANT_NUMBER + (TREE_OPERAND (gnu_size, 1))), + No_Uint, No_Uint); + else + return No_Uint; + + case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR: + return annotate_value (TREE_OPERAND (gnu_size, 0)); + + /* Now just list the operations we handle. */ + case COND_EXPR: tcode = Cond_Expr; break; + case PLUS_EXPR: tcode = Plus_Expr; break; + case MINUS_EXPR: tcode = Minus_Expr; break; + case MULT_EXPR: tcode = Mult_Expr; break; + case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break; + case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break; + case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break; + case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break; + case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break; + case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break; + case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break; + case NEGATE_EXPR: tcode = Negate_Expr; break; + case MIN_EXPR: tcode = Min_Expr; break; + case MAX_EXPR: tcode = Max_Expr; break; + case ABS_EXPR: tcode = Abs_Expr; break; + case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break; + case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break; + case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break; + case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break; + case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break; + case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break; + case LT_EXPR: tcode = Lt_Expr; break; + case LE_EXPR: tcode = Le_Expr; break; + case GT_EXPR: tcode = Gt_Expr; break; + case GE_EXPR: tcode = Ge_Expr; break; + case EQ_EXPR: tcode = Eq_Expr; break; + case NE_EXPR: tcode = Ne_Expr; break; + + default: + return No_Uint; + } + + /* Now get each of the operands that's relevant for this code. If any + cannot be expressed as a repinfo node, say we can't. */ + for (i = 0; i < 3; i++) + ops[i] = No_Uint; + + for (i = 0; i < len; i++) + { + ops[i] = annotate_value (TREE_OPERAND (gnu_size, i)); + if (ops[i] == No_Uint) + return No_Uint; + } + + return Create_Node (tcode, ops[0], ops[1], ops[2]); +} + +/* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding + GCC type, set Component_Bit_Offset and Esize to the position and size + used by Gigi. */ + +static void +annotate_rep (gnat_entity, gnu_type) + Entity_Id gnat_entity; + tree gnu_type; +{ + tree gnu_list; + tree gnu_entry; + Entity_Id gnat_field; + + /* We operate by first making a list of all field and their positions + (we can get the sizes easily at any time) by a recursive call + and then update all the sizes into the tree. */ + gnu_list = compute_field_positions (gnu_type, NULL_TREE, + size_zero_node, bitsize_zero_node); + + for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || (Ekind (gnat_field) == E_Discriminant + && ! Is_Unchecked_Union (Scope (gnat_field)))) + && 0 != (gnu_entry = purpose_member (gnat_to_gnu_entity (gnat_field, + NULL_TREE, 0), + gnu_list))) + { + Set_Component_Bit_Offset + (gnat_field, + annotate_value (bit_from_pos + (TREE_PURPOSE (TREE_VALUE (gnu_entry)), + TREE_VALUE (TREE_VALUE (gnu_entry))))); + + Set_Esize (gnat_field, + annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); + } +} + +/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is + the FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the + byte position and TREE_VALUE being the bit position. GNU_POS is to + be added to the position, GNU_BITPOS to the bit position, and GNU_LIST + is the entries so far. */ + +static tree +compute_field_positions (gnu_type, gnu_list, gnu_pos, gnu_bitpos) + tree gnu_type; + tree gnu_list; + tree gnu_pos; + tree gnu_bitpos; +{ + tree gnu_field; + tree gnu_result = gnu_list; + + for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field; + gnu_field = TREE_CHAIN (gnu_field)) + { + tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, + DECL_FIELD_BIT_OFFSET (gnu_field)); + tree gnu_our_pos = size_binop (PLUS_EXPR, gnu_pos, + DECL_FIELD_OFFSET (gnu_field)); + + gnu_result + = tree_cons (gnu_field, + tree_cons (gnu_our_pos, gnu_our_bitpos, NULL_TREE), + gnu_result); + + if (DECL_INTERNAL_P (gnu_field)) + gnu_result + = compute_field_positions (TREE_TYPE (gnu_field), + gnu_result, gnu_our_pos, gnu_our_bitpos); + } + + return gnu_result; +} + +/* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE + corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding + to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying + the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL + for the size of a field. COMPONENT_P is true if we are being called + to process the Component_Size of GNAT_OBJECT. This is used for error + message handling and to indicate to use the object size of GNU_TYPE. + ZERO_OK is nonzero if a size of zero is permitted; if ZERO_OK is zero, + it means that a size of zero should be treated as an unspecified size. */ + +static tree +validate_size (uint_size, gnu_type, gnat_object, kind, component_p, zero_ok) + Uint uint_size; + tree gnu_type; + Entity_Id gnat_object; + enum tree_code kind; + int component_p; + int zero_ok; +{ + Node_Id gnat_error_node; + tree type_size + = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type); + tree size; + + if (type_size != 0 && TREE_CODE (type_size) != INTEGER_CST + && contains_placeholder_p (type_size)) + type_size = max_size (type_size, 1); + + if (TYPE_FAT_POINTER_P (gnu_type)) + type_size = bitsize_int (POINTER_SIZE); + + if ((Ekind (gnat_object) == E_Component + || Ekind (gnat_object) == E_Discriminant) + && Present (Component_Clause (gnat_object))) + gnat_error_node = Last_Bit (Component_Clause (gnat_object)); + else if (Present (Size_Clause (gnat_object))) + gnat_error_node = Expression (Size_Clause (gnat_object)); + else + gnat_error_node = gnat_object; + + /* Don't give errors on packed array types; we'll be giving the error on + the type itself soon enough. */ + if (Is_Packed_Array_Type (gnat_object)) + gnat_error_node = Empty; + + /* Get the size as a tree. Return 0 if none was specified, either because + Esize was not Present or if the specified size was zero. Give an error + if a size was specified, but cannot be represented as in sizetype. If + the size is negative, it was a back-annotation of a variable size and + should be treated as not specified. */ + if (No (uint_size) || uint_size == No_Uint) + return 0; + + size = UI_To_gnu (uint_size, bitsizetype); + if (TREE_OVERFLOW (size)) + { + if (component_p) + post_error_ne ("component size of & is too large", + gnat_error_node, gnat_object); + else + post_error_ne ("size of & is too large", gnat_error_node, gnat_object); + + return 0; + } + + /* Ignore a negative size since that corresponds to our back-annotation. + Also ignore a zero size unless a size clause exists. */ + else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok)) + return 0; + + /* The size of objects is always a multiple of a byte. */ + if (kind == VAR_DECL + && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, size, + bitsize_unit_node))) + { + if (component_p) + post_error_ne ("component size for& is not a multiple of Storage_Unit", + gnat_error_node, gnat_object); + else + post_error_ne ("size for& is not a multiple of Storage_Unit", + gnat_error_node, gnat_object); + return 0; + } + + /* If this is an integral type, the front-end has verified the size, so we + need not do it here (which would entail checking against the bounds). + However, if this is an aliased object, it may not be smaller than the + type of the object. */ + if (INTEGRAL_TYPE_P (gnu_type) + && ! (kind == VAR_DECL && Is_Aliased (gnat_object))) + return size; + + /* If the object is a record that contains a template, add the size of + the template to the specified size. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size); + + /* If the size of the object is a constant, the new size must not be + smaller. */ + if (TREE_CODE (type_size) != INTEGER_CST + || TREE_OVERFLOW (type_size) + || tree_int_cst_lt (size, type_size)) + { + if (component_p) + post_error_ne_tree + ("component size for& too small{, minimum allowed is ^}", + gnat_error_node, gnat_object, type_size); + else + post_error_ne_tree ("size for& too small{, minimum allowed is ^}", + gnat_error_node, gnat_object, type_size); + + if (kind == VAR_DECL && ! component_p + && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST + && ! tree_int_cst_lt (size, rm_size (gnu_type))) + post_error_ne_tree_2 + ("\\size of ^ rounded up to multiple of alignment (^ bits)", + gnat_error_node, gnat_object, rm_size (gnu_type), + TYPE_ALIGN (gnu_type)); + + else if (INTEGRAL_TYPE_P (gnu_type)) + post_error_ne ("\\size would be legal if & were not aliased!", + gnat_error_node, gnat_object); + + return 0; + } + + return size; +} + +/* Similarly, but both validate and process a value of RM_Size. This + routine is only called for types. */ + +static void +set_rm_size (uint_size, gnu_type, gnat_entity) + Uint uint_size; + tree gnu_type; + Entity_Id gnat_entity; +{ + /* Only give an error if a Value_Size clause was explicitly given. + Otherwise, we'd be duplicating an error on the Size clause. */ + Node_Id gnat_attr_node + = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size); + tree old_size = rm_size (gnu_type); + tree size; + + /* Get the size as a tree. Do nothing if none was specified, either + because RM_Size was not Present or if the specified size was zero. + Give an error if a size was specified, but cannot be represented as + in sizetype. */ + if (No (uint_size) || uint_size == No_Uint) + return; + + size = UI_To_gnu (uint_size, bitsizetype); + if (TREE_OVERFLOW (size)) + { + if (Present (gnat_attr_node)) + post_error_ne ("Value_Size of & is too large", gnat_attr_node, + gnat_entity); + + return; + } + + /* Ignore a negative size since that corresponds to our back-annotation. + Also ignore a zero size unless a size clause exists, a Value_Size + clause exists, or this is an integer type, in which case the + front end will have always set it. */ + else if (tree_int_cst_sgn (size) < 0 + || (integer_zerop (size) && No (gnat_attr_node) + && ! Has_Size_Clause (gnat_entity) + && ! Is_Discrete_Or_Fixed_Point_Type (gnat_entity))) + return; + + /* If the old size is self-referential, get the maximum size. */ + if (TREE_CODE (old_size) != INTEGER_CST + && contains_placeholder_p (old_size)) + old_size = max_size (old_size, 1); + + /* If the size of the object is a constant, the new size must not be + smaller (the front end checks this for scalar types). */ + if (TREE_CODE (old_size) != INTEGER_CST + || TREE_OVERFLOW (old_size) + || (AGGREGATE_TYPE_P (gnu_type) + && tree_int_cst_lt (size, old_size))) + { + if (Present (gnat_attr_node)) + post_error_ne_tree + ("Value_Size for& too small{, minimum allowed is ^}", + gnat_attr_node, gnat_entity, old_size); + + return; + } + + /* Otherwise, set the RM_Size. */ + if (TREE_CODE (gnu_type) == INTEGER_TYPE + && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) + TYPE_RM_SIZE_INT (gnu_type) = size; + else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE) + TYPE_RM_SIZE_ENUM (gnu_type) = size; + else if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && ! TYPE_IS_FAT_POINTER_P (gnu_type)) + TYPE_ADA_SIZE (gnu_type) = size; +} + +/* Given a type TYPE, return a new type whose size is appropriate for SIZE. + If TYPE is the best type, return it. Otherwise, make a new type. We + only support new integral and pointer types. BIASED_P is nonzero if + we are making a biased type. */ + +static tree +make_type_from_size (type, size_tree, biased_p) + tree type; + tree size_tree; + int biased_p; +{ + tree new_type; + unsigned HOST_WIDE_INT size; + + /* If size indicates an error, just return TYPE to avoid propagating the + error. Likewise if it's too large to represent. */ + if (size_tree == 0 || ! host_integerp (size_tree, 1)) + return type; + + size = tree_low_cst (size_tree, 1); + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + /* Only do something if the type is not already the proper size and is + not a packed array type. */ + if (TYPE_PACKED_ARRAY_TYPE_P (type) + || (TYPE_PRECISION (type) == size + && biased_p == (TREE_CODE (type) == INTEGER_CST + && TYPE_BIASED_REPRESENTATION_P (type)))) + break; + + size = MIN (size, LONG_LONG_TYPE_SIZE); + new_type = make_signed_type (size); + TREE_TYPE (new_type) + = TREE_TYPE (type) != 0 ? TREE_TYPE (type) : type; + TYPE_MIN_VALUE (new_type) + = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type)); + TYPE_MAX_VALUE (new_type) + = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type)); + TYPE_BIASED_REPRESENTATION_P (new_type) + = ((TREE_CODE (type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (type)) + || biased_p); + TREE_UNSIGNED (new_type) + = TREE_UNSIGNED (type) | TYPE_BIASED_REPRESENTATION_P (new_type); + TYPE_RM_SIZE_INT (new_type) = bitsize_int (size); + return new_type; + + case RECORD_TYPE: + /* Do something if this is a fat pointer, in which case we + may need to return the thin pointer. */ + if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) + return + build_pointer_type + (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type))); + break; + + case POINTER_TYPE: + /* Only do something if this is a thin pointer, in which case we + may need to return the fat pointer. */ + if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) + return + build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); + + break; + + default: + break; + } + + return type; +} + +/* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY, + a type or object whose present alignment is ALIGN. If this alignment is + valid, return it. Otherwise, give an error and return ALIGN. */ + +static unsigned int +validate_alignment (alignment, gnat_entity, align) + Uint alignment; + Entity_Id gnat_entity; + unsigned int align; +{ + Node_Id gnat_error_node = gnat_entity; + unsigned int new_align; + +#ifndef MAX_OFILE_ALIGNMENT +#define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT +#endif + + if (Present (Alignment_Clause (gnat_entity))) + gnat_error_node = Expression (Alignment_Clause (gnat_entity)); + + /* Within GCC, an alignment is an integer, so we must make sure a + value is specified that fits in that range. Also, alignments of + more than MAX_OFILE_ALIGNMENT can't be supported. */ + + if (! UI_Is_In_Int_Range (alignment) + || ((new_align = UI_To_Int (alignment)) + > MAX_OFILE_ALIGNMENT / BITS_PER_UNIT)) + post_error_ne_num ("largest supported alignment for& is ^", + gnat_error_node, gnat_entity, + MAX_OFILE_ALIGNMENT / BITS_PER_UNIT); + else if (! (Present (Alignment_Clause (gnat_entity)) + && From_At_Mod (Alignment_Clause (gnat_entity))) + && new_align * BITS_PER_UNIT < align) + post_error_ne_num ("alignment for& must be at least ^", + gnat_error_node, gnat_entity, + align / BITS_PER_UNIT); + else + align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT); + + return align; +} + +/* Verify that OBJECT, a type or decl, is something we can implement + atomically. If not, give an error for GNAT_ENTITY. COMP_P is nonzero + if we require atomic components. */ + +static void +check_ok_for_atomic (object, gnat_entity, comp_p) + tree object; + Entity_Id gnat_entity; + int comp_p; +{ + Node_Id gnat_error_point = gnat_entity; + Node_Id gnat_node; + enum machine_mode mode; + unsigned int align; + tree size; + + /* There are three case of what OBJECT can be. It can be a type, in which + case we take the size, alignment and mode from the type. It can be a + declaration that was indirect, in which case the relevant values are + that of the type being pointed to, or it can be a normal declaration, + in which case the values are of the decl. The code below assumes that + OBJECT is either a type or a decl. */ + if (TYPE_P (object)) + { + mode = TYPE_MODE (object); + align = TYPE_ALIGN (object); + size = TYPE_SIZE (object); + } + else if (DECL_BY_REF_P (object)) + { + mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object))); + align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object))); + size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object))); + } + else + { + mode = DECL_MODE (object); + align = DECL_ALIGN (object); + size = DECL_SIZE (object); + } + + /* Consider all floating-point types atomic and any types that that are + represented by integers no wider than a machine word. */ + if (GET_MODE_CLASS (mode) == MODE_FLOAT + || ((GET_MODE_CLASS (mode) == MODE_INT + || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT) + && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD)) + return; + + /* For the moment, also allow anything that has an alignment equal + to its size and which is smaller than a word. */ + if (TREE_CODE (size) == INTEGER_CST + && compare_tree_int (size, align) == 0 + && align <= BITS_PER_WORD) + return; + + for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node); + gnat_node = Next_Rep_Item (gnat_node)) + { + if (! comp_p && Nkind (gnat_node) == N_Pragma + && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic) + gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); + else if (comp_p && Nkind (gnat_node) == N_Pragma + && (Get_Pragma_Id (Chars (gnat_node)) + == Pragma_Atomic_Components)) + gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); + } + + if (comp_p) + post_error_ne ("atomic access to component of & cannot be guaranteed", + gnat_error_point, gnat_entity); + else + post_error_ne ("atomic access to & cannot be guaranteed", + gnat_error_point, gnat_entity); +} + +/* Given a type T, a FIELD_DECL F, and a replacement value R, + return a new type with all size expressions that contain F + updated by replacing F with R. This is identical to GCC's + substitute_in_type except that it knows about TYPE_INDEX_TYPE. + If F is NULL_TREE, always make a new RECORD_TYPE, even if nothing has + changed. */ + +tree +gnat_substitute_in_type (t, f, r) + tree t, f, r; +{ + tree new = t; + tree tem; + + switch (TREE_CODE (t)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + case CHAR_TYPE: + if ((TREE_CODE (TYPE_MIN_VALUE (t)) != INTEGER_CST + && contains_placeholder_p (TYPE_MIN_VALUE (t))) + || (TREE_CODE (TYPE_MAX_VALUE (t)) != INTEGER_CST + && contains_placeholder_p (TYPE_MAX_VALUE (t)))) + { + tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); + tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); + + if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) + return t; + + new = build_range_type (TREE_TYPE (t), low, high); + if (TYPE_INDEX_TYPE (t)) + TYPE_INDEX_TYPE (new) + = gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r); + return new; + } + + return t; + + case REAL_TYPE: + if ((TYPE_MIN_VALUE (t) != 0 + && TREE_CODE (TYPE_MIN_VALUE (t)) != REAL_CST + && contains_placeholder_p (TYPE_MIN_VALUE (t))) + || (TYPE_MAX_VALUE (t) != 0 + && TREE_CODE (TYPE_MAX_VALUE (t)) != REAL_CST + && contains_placeholder_p (TYPE_MAX_VALUE (t)))) + { + tree low = 0, high = 0; + + if (TYPE_MIN_VALUE (t)) + low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); + if (TYPE_MAX_VALUE (t)) + high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); + + if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) + return t; + + t = copy_type (t); + TYPE_MIN_VALUE (t) = low; + TYPE_MAX_VALUE (t) = high; + } + return t; + + case COMPLEX_TYPE: + tem = gnat_substitute_in_type (TREE_TYPE (t), f, r); + if (tem == TREE_TYPE (t)) + return t; + + return build_complex_type (tem); + + case OFFSET_TYPE: + case METHOD_TYPE: + case FILE_TYPE: + case SET_TYPE: + case FUNCTION_TYPE: + case LANG_TYPE: + /* Don't know how to do these yet. */ + abort (); + + case ARRAY_TYPE: + { + tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r); + tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r); + + if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t)) + return t; + + new = build_array_type (component, domain); + TYPE_SIZE (new) = 0; + TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t); + TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t); + layout_type (new); + TYPE_ALIGN (new) = TYPE_ALIGN (t); + return new; + } + + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + { + tree field; + int changed_field + = (f == NULL_TREE && ! TREE_CONSTANT (TYPE_SIZE (t))); + int field_has_rep = 0; + tree last_field = 0; + + tree new = copy_type (t); + + /* Start out with no fields, make new fields, and chain them + in. If we haven't actually changed the type of any field, + discard everything we've done and return the old type. */ + + TYPE_FIELDS (new) = 0; + TYPE_SIZE (new) = 0; + + for (field = TYPE_FIELDS (t); field; + field = TREE_CHAIN (field)) + { + tree new_field = copy_node (field); + + TREE_TYPE (new_field) + = gnat_substitute_in_type (TREE_TYPE (new_field), f, r); + + if (DECL_HAS_REP_P (field) && ! DECL_INTERNAL_P (field)) + field_has_rep = 1; + else if (TREE_TYPE (new_field) != TREE_TYPE (field)) + changed_field = 1; + + /* If this is an internal field and the type of this field is + a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If + the type just has one element, treat that as the field. + But don't do this if we are processing a QUAL_UNION_TYPE. */ + if (TREE_CODE (t) != QUAL_UNION_TYPE + && DECL_INTERNAL_P (new_field) + && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE + || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE)) + { + if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0) + continue; + + if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0) + { + tree next_new_field + = copy_node (TYPE_FIELDS (TREE_TYPE (new_field))); + + /* Make sure omitting the union doesn't change + the layout. */ + DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field); + new_field = next_new_field; + } + } + + DECL_CONTEXT (new_field) = new; + DECL_ORIGINAL_FIELD (new_field) + = DECL_ORIGINAL_FIELD (field) != 0 + ? DECL_ORIGINAL_FIELD (field) : field; + + /* If the size of the old field was set at a constant, + propagate the size in case the type's size was variable. + (This occurs in the case of a variant or discriminated + record with a default size used as a field of another + record.) */ + DECL_SIZE (new_field) + = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST + ? DECL_SIZE (field) : 0; + DECL_SIZE_UNIT (new_field) + = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST + ? DECL_SIZE_UNIT (field) : 0; + + if (TREE_CODE (t) == QUAL_UNION_TYPE) + { + tree new_q = substitute_in_expr (DECL_QUALIFIER (field), f, r); + + if (new_q != DECL_QUALIFIER (new_field)) + changed_field = 1; + + /* Do the substitution inside the qualifier and if we find + that this field will not be present, omit it. */ + DECL_QUALIFIER (new_field) = new_q; + + if (integer_zerop (DECL_QUALIFIER (new_field))) + continue; + } + + if (last_field == 0) + TYPE_FIELDS (new) = new_field; + else + TREE_CHAIN (last_field) = new_field; + + last_field = new_field; + + /* If this is a qualified type and this field will always be + present, we are done. */ + if (TREE_CODE (t) == QUAL_UNION_TYPE + && integer_onep (DECL_QUALIFIER (new_field))) + break; + } + + /* If this used to be a qualified union type, but we now know what + field will be present, make this a normal union. */ + if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE + && (TYPE_FIELDS (new) == 0 + || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new))))) + TREE_SET_CODE (new, UNION_TYPE); + else if (! changed_field) + return t; + + if (field_has_rep) + gigi_abort (117); + + layout_type (new); + + /* If the size was originally a constant use it. */ + if (TYPE_SIZE (t) != 0 && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST + && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST) + { + TYPE_SIZE (new) = TYPE_SIZE (t); + TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t); + TYPE_ADA_SIZE (new) = TYPE_ADA_SIZE (t); + } + + return new; + } + + default: + return t; + } +} + +/* Return the "RM size" of GNU_TYPE. This is the actual number of bits + needed to represent the object. */ + +tree +rm_size (gnu_type) + tree gnu_type; +{ + /* For integer types, this is the precision. For record types, we store + the size explicitly. For other types, this is just the size. */ + + if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type) != 0) + return TYPE_RM_SIZE (gnu_type); + else if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + /* Return the rm_size of the actual data plus the size of the template. */ + return + size_binop (PLUS_EXPR, + rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))), + DECL_SIZE (TYPE_FIELDS (gnu_type))); + else if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && ! TYPE_IS_FAT_POINTER_P (gnu_type) + && TYPE_ADA_SIZE (gnu_type) != 0) + return TYPE_ADA_SIZE (gnu_type); + else + return TYPE_SIZE (gnu_type); +} + +/* Return an identifier representing the external name to be used for + GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___" + and the specified suffix. */ + +tree +create_concat_name (gnat_entity, suffix) + Entity_Id gnat_entity; + const char *suffix; +{ + const char *str = (suffix == 0 ? "" : suffix); + String_Template temp = {1, strlen (str)}; + Fat_Pointer fp = {str, &temp}; + + Get_External_Name_With_Suffix (gnat_entity, fp); + + return get_identifier (Name_Buffer); +} + +/* Return the name to be used for GNAT_ENTITY. If a type, create a + fully-qualified name, possibly with type information encoding. + Otherwise, return the name. */ + +tree +get_entity_name (gnat_entity) + Entity_Id gnat_entity; +{ + Get_Encoded_Name (gnat_entity); + return get_identifier (Name_Buffer); +} + +/* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a + string, return a new IDENTIFIER_NODE that is the concatenation of + the name in GNU_ID and SUFFIX. */ + +tree +concat_id_with_name (gnu_id, suffix) + tree gnu_id; + const char *suffix; +{ + int len = IDENTIFIER_LENGTH (gnu_id); + + strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), + IDENTIFIER_LENGTH (gnu_id)); + strncpy (Name_Buffer + len, "___", 3); + len += 3; + strcpy (Name_Buffer + len, suffix); + return get_identifier (Name_Buffer); +} diff --git a/gcc/ada/deftarg.c b/gcc/ada/deftarg.c new file mode 100644 index 00000000000..635f5a853ab --- /dev/null +++ b/gcc/ada/deftarg.c @@ -0,0 +1,40 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * D E F T A R G * + * * + * Body * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +/* Include a default definition for TARGET_FLAGS for gnatpsta. */ + +#include "config.h" +#define MIN(X,Y) ((X) < (Y) ? (X) : (Y)) + +int target_flags = TARGET_DEFAULT; diff --git a/gcc/ada/directio.ads b/gcc/ada/directio.ads new file mode 100644 index 00000000000..555ce551b73 --- /dev/null +++ b/gcc/ada/directio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- D I R E C T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_95; +with Ada.Direct_IO; + +generic package Direct_IO renames Ada.Direct_IO; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb new file mode 100644 index 00000000000..55c039431dd --- /dev/null +++ b/gcc/ada/einfo.adb @@ -0,0 +1,6844 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E I N F O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.630 $ +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram ordering, not used for this unit + +with Atree; use Atree; +with Namet; use Namet; +with Nlists; use Nlists; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Output; use Output; + +package body Einfo is + + use Atree.Unchecked_Access; + -- This is one of the packages that is allowed direct untyped access to + -- the fields in a node, since it provides the next level abstraction + -- which incorporates appropriate checks. + + ---------------------------------------------- + -- Usage of Fields in Defining Entity Nodes -- + ---------------------------------------------- + + -- Four of these fields are defined in Sinfo, since they in are the + -- base part of the node. The access routines for these fields and + -- the corresponding set procedures are defined in Sinfo. These fields + -- are present in all entities. + + -- Chars Name1 + -- Next_Entity Node2 + -- Scope Node3 + -- Etype Node5 + + -- The fifth field is also in the base part of the node, but it + -- carries some additional semantic checks and its subprograms are + -- more properly defined in Einfo. + + -- Homonym Node4 + + -- Remaining fields are present only in extended nodes (i.e. entities) + + -- The following fields are present in all entities + + -- First_Rep_Item Node6 + -- Freeze_Node Node7 + + -- The usage of each field (and the entity kinds to which it applies) + -- depends on the particular field (see Einfo spec for details). + + -- Associated_Node_For_Itype Node8 + -- Dependent_Instances Elist8 + -- Hiding_Loop_Variable Node8 + -- Mechanism Uint8 (but returns Mechanism_Type) + -- Normalized_First_Bit Uint8 + + -- Class_Wide_Type Node9 + -- Normalized_Position Uint9 + -- Size_Check_Code Node9 + -- Renaming_Map Uint9 + + -- Discriminal_Link Node10 + -- Handler_Records List10 + -- Normalized_Position_Max Uint10 + -- Referenced_Object Node10 + + -- Component_Bit_Offset Uint11 + -- Full_View Node11 + -- Entry_Component Node11 + -- Enumeration_Pos Uint11 + -- Protected_Body_Subprogram Node11 + -- Block_Node Node11 + + -- Barrier_Function Node12 + -- Enumeration_Rep Uint12 + -- Esize Uint12 + -- Next_Inlined_Subprogram Node12 + + -- Corresponding_Equality Node13 + -- Component_Clause Node13 + -- Debug_Renaming_Link Node13 + -- Elaboration_Entity Node13 + -- Extra_Accessibility Node13 + -- RM_Size Uint13 + + -- Alignment Uint14 + -- First_Optional_Parameter Node14 + -- Shadow_Entities List14 + + -- Discriminant_Number Uint15 + -- DT_Position Uint15 + -- DT_Entry_Count Uint15 + -- Entry_Bodies_Array Node15 + -- Entry_Parameters_Type Node15 + -- Extra_Formal Node15 + -- Lit_Indexes Node15 + -- Primitive_Operations Elist15 + -- Related_Instance Node15 + -- Scale_Value Uint15 + -- Storage_Size_Variable Node15 + -- String_Literal_Low_Bound Node15 + -- Shared_Var_Read_Proc Node15 + + -- Access_Disp_Table Node16 + -- Cloned_Subtype Node16 + -- DTC_Entity Node16 + -- Entry_Formal Node16 + -- First_Private_Entity Node16 + -- Lit_Strings Node16 + -- String_Literal_Length Uint16 + -- Unset_Reference Node16 + + -- Actual_Subtype Node17 + -- Digits_Value Uint17 + -- Discriminal Node17 + -- First_Entity Node17 + -- First_Index Node17 + -- First_Literal Node17 + -- Master_Id Node17 + -- Modulus Uint17 + -- Object_Ref Node17 + -- Prival Node17 + + -- Alias Node18 + -- Corresponding_Concurrent_Type Node18 + -- Corresponding_Record_Type Node18 + -- Delta_Value Ureal18 + -- Enclosing_Scope Node18 + -- Equivalent_Type Node18 + -- Private_Dependents Elist18 + -- Renamed_Entity Node18 + -- Renamed_Object Node18 + + -- Body_Entity Node19 + -- Corresponding_Discriminant Node19 + -- Finalization_Chain_Entity Node19 + -- Parent_Subtype Node19 + -- Related_Array_Object Node19 + -- Spec_Entity Node19 + -- Underlying_Full_View Node19 + + -- Component_Type Node20 + -- Default_Value Node20 + -- Directly_Designated_Type Node20 + -- Discriminant_Checking_Func Node20 + -- Discriminant_Default_Value Node20 + -- Last_Entity Node20 + -- Register_Exception_Call Node20 + -- Scalar_Range Node20 + + -- Accept_Address Elist21 + -- Default_Expr_Function Node21 + -- Discriminant_Constraint Elist21 + -- Small_Value Ureal21 + -- Interface_Name Node21 + + -- Associated_Storage_Pool Node22 + -- Component_Size Uint22 + -- Corresponding_Remote_Type Node22 + -- Enumeration_Rep_Expr Node22 + -- Exception_Code Uint22 + -- Original_Record_Component Node22 + -- Private_View Node22 + -- Protected_Formal Node22 + -- Scope_Depth_Value Uint22 + -- Shared_Var_Assign_Proc Node22 + + -- Associated_Final_Chain Node23 + -- CR_Discriminant Node23 + -- Girder_Constraint Elist23 + -- Entry_Cancel_Parameter Node23 + -- Extra_Constrained Node23 + -- Generic_Renamings Elist23 + -- Inner_Instances Elist23 + -- Enum_Pos_To_Rep Node23 + -- Packed_Array_Type Node23 + -- Privals_Chain Elist23 + -- Protected_Operation Node23 + + --------------------------------------------- + -- Usage of Flags in Defining Entity Nodes -- + --------------------------------------------- + + -- All flags are unique, there is no overlaying, so each flag is physically + -- present in every entity. However, for many of the flags, it only makes + -- sense for them to be set true for certain subsets of entity kinds. See + -- the spec of Einfo for further details. + + -- Note: Flag1-Flag3 are absent from this list, since these flag positions + -- are used for the flags Analyzed, Comes_From_Source, and Error_Posted, + -- which are common to all nodes, including entity nodes. + + -- Is_Frozen Flag4 + -- Has_Discriminants Flag5 + -- Is_Dispatching_Operation Flag6 + -- Is_Immediately_Visible Flag7 + -- In_Use Flag8 + -- Is_Potentially_Use_Visible Flag9 + -- Is_Public Flag10 + -- Is_Inlined Flag11 + -- Is_Constrained Flag12 + -- Is_Generic_Type Flag13 + -- Depends_On_Private Flag14 + -- Is_Aliased Flag15 + -- Is_Volatile Flag16 + -- Is_Internal Flag17 + -- Has_Delayed_Freeze Flag18 + -- Is_Abstract Flag19 + -- Is_Concurrent_Record_Type Flag20 + -- Has_Master_Entity Flag21 + -- Needs_No_Actuals Flag22 + -- Has_Storage_Size_Clause Flag23 + -- Is_Imported Flag24 + -- Is_Limited_Record Flag25 + -- Has_Completion Flag26 + -- Has_Pragma_Controlled Flag27 + -- Is_Statically_Allocated Flag28 + -- Has_Size_Clause Flag29 + -- Has_Task Flag30 + -- Suppress_Access_Checks Flag31 + -- Suppress_Accessibility_Checks Flag32 + -- Suppress_Discriminant_Checks Flag33 + -- Suppress_Division_Checks Flag34 + -- Suppress_Elaboration_Checks Flag35 + -- Suppress_Index_Checks Flag36 + -- Suppress_Length_Checks Flag37 + -- Suppress_Overflow_Checks Flag38 + -- Suppress_Range_Checks Flag39 + -- Suppress_Storage_Checks Flag40 + -- Suppress_Tag_Checks Flag41 + -- Is_Controlled Flag42 + -- Has_Controlled_Component Flag43 + -- Is_Pure Flag44 + -- In_Private_Part Flag45 + -- Has_Alignment_Clause Flag46 + -- Has_Exit Flag47 + -- In_Package_Body Flag48 + -- Reachable Flag49 + -- Delay_Subprogram_Descriptors Flag50 + -- Is_Packed Flag51 + -- Is_Entry_Formal Flag52 + -- Is_Private_Descendant Flag53 + -- Return_Present Flag54 + -- Is_Tagged_Type Flag55 + -- Has_Homonym Flag56 + -- Is_Hidden Flag57 + -- Non_Binary_Modulus Flag58 + -- Is_Preelaborated Flag59 + -- Is_Shared_Passive Flag60 + -- Is_Remote_Types Flag61 + -- Is_Remote_Call_Interface Flag62 + -- Is_Character_Type Flag63 + -- Is_Intrinsic_Subprogram Flag64 + -- Has_Record_Rep_Clause Flag65 + -- Has_Enumeration_Rep_Clause Flag66 + -- Has_Small_Clause Flag67 + -- Has_Component_Size_Clause Flag68 + -- Is_Access_Constant Flag69 + -- Is_First_Subtype Flag70 + -- Has_Completion_In_Body Flag71 + -- Has_Unknown_Discriminants Flag72 + -- Is_Child_Unit Flag73 + -- Is_CPP_Class Flag74 + -- Has_Non_Standard_Rep Flag75 + -- Is_Constructor Flag76 + -- Is_Destructor Flag77 + -- Is_Tag Flag78 + -- Has_All_Calls_Remote Flag79 + -- Is_Constr_Subt_For_U_Nominal Flag80 + -- Is_Asynchronous Flag81 + -- Has_Gigi_Rep_Item Flag82 + -- Has_Machine_Radix_Clause Flag83 + -- Machine_Radix_10 Flag84 + -- Is_Atomic Flag85 + -- Has_Atomic_Components Flag86 + -- Has_Volatile_Components Flag87 + -- Discard_Names Flag88 + -- Is_Interrupt_Handler Flag89 + -- Returns_By_Ref Flag90 + -- Is_Itype Flag91 + -- Size_Known_At_Compile_Time Flag92 + -- Has_Subprogram_Descriptor Flag93 + -- Is_Generic_Actual_Type Flag94 + -- Uses_Sec_Stack Flag95 + -- Warnings_Off Flag96 + -- Is_Controlling_Formal Flag97 + -- Has_Controlling_Result Flag98 + -- Is_Exported Flag99 + -- Has_Specified_Layout Flag100 + -- Has_Nested_Block_With_Handler Flag101 + -- Is_Called Flag102 + -- Is_Completely_Hidden Flag103 + -- Address_Taken Flag104 + -- Suppress_Init_Proc Flag105 + -- Is_Limited_Composite Flag106 + -- Is_Private_Composite Flag107 + -- Default_Expressions_Processed Flag108 + -- Is_Non_Static_Subtype Flag109 + -- Has_External_Tag_Rep_Clause Flag110 + -- Is_Formal_Subprogram Flag111 + -- Is_Renaming_Of_Object Flag112 + -- No_Return Flag113 + -- Delay_Cleanups Flag114 + -- Not_Source_Assigned Flag115 + -- Is_Visible_Child_Unit Flag116 + -- Is_Unchecked_Union Flag117 + -- Is_For_Access_Subtype Flag118 + -- Has_Convention_Pragma Flag119 + -- Has_Primitive_Operations Flag120 + -- Has_Pragma_Pack Flag121 + -- Is_Bit_Packed_Array Flag122 + -- Has_Unchecked_Union Flag123 + -- Is_Eliminated Flag124 + -- C_Pass_By_Copy Flag125 + -- Is_Instantiated Flag126 + -- Is_Valued_Procedure Flag127 + -- (used for Component_Alignment) Flag128 + -- (used for Component_Alignment) Flag129 + -- Is_Generic_Instance Flag130 + -- No_Pool_Assigned Flag131 + -- Is_AST_Entry Flag132 + -- Is_VMS_Exception Flag133 + -- Is_Optional_Parameter Flag134 + -- Has_Aliased_Components Flag135 + -- Is_Machine_Code_Subprogram Flag137 + -- Is_Packed_Array_Type Flag138 + -- Has_Biased_Representation Flag139 + -- Has_Complex_Representation Flag140 + -- Is_Constr_Subt_For_UN_Aliased Flag141 + -- Has_Missing_Return Flag142 + -- Has_Recursive_Call Flag143 + -- Is_Unsigned_Type Flag144 + -- Strict_Alignment Flag145 + -- Elaborate_All_Desirable Flag146 + -- Needs_Debug_Info Flag147 + -- Suppress_Elaboration_Warnings Flag148 + -- Is_Compilation_Unit Flag149 + -- Has_Pragma_Elaborate_Body Flag150 + -- Vax_Float Flag151 + -- Entry_Accepted Flag152 + -- Is_Psected Flag153 + -- Has_Per_Object_Constraint Flag154 + -- Has_Private_Declaration Flag155 + -- Referenced Flag156 + -- Has_Pragma_Inline Flag157 + -- Finalize_Storage_Only Flag158 + -- From_With_Type Flag159 + -- Is_Package_Body_Entity Flag160 + -- Has_Qualified_Name Flag161 + -- Nonzero_Is_True Flag162 + -- Is_True_Constant Flag163 + -- Reverse_Bit_Order Flag164 + -- Suppress_Style_Checks Flag165 + -- Debug_Info_Off Flag166 + -- Sec_Stack_Needed_For_Return Flag167 + -- Materialize_Entity Flag168 + -- Function_Returns_With_DSP Flag169 + -- Is_Known_Valid Flag170 + -- Is_Hidden_Open_Scope Flag171 + -- Has_Object_Size_Clause Flag172 + -- Has_Fully_Qualified_Name Flag173 + -- Elaboration_Entity_Required Flag174 + -- Has_Forward_Instantiation Flag175 + -- Is_Discrim_SO_Function Flag176 + -- Size_Depends_On_Discriminant Flag177 + -- Is_Null_Init_Proc Flag178 + + -- (unused) Flag179 + -- (unused) Flag180 + -- (unused) Flag181 + -- (unused) Flag182 + -- (unused) Flag183 + + -------------------------------- + -- Attribute Access Functions -- + -------------------------------- + + function Accept_Address (Id : E) return L is + begin + return Elist21 (Id); + end Accept_Address; + + function Access_Disp_Table (Id : E) return E is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Node16 (Base_Type (Underlying_Type (Base_Type (Id)))); + end Access_Disp_Table; + + function Actual_Subtype (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable + or else Ekind (Id) = E_Generic_In_Out_Parameter + or else Ekind (Id) in E_In_Parameter .. E_In_Out_Parameter); + return Node17 (Id); + end Actual_Subtype; + + function Address_Taken (Id : E) return B is + begin + return Flag104 (Id); + end Address_Taken; + + function Alias (Id : E) return E is + begin + pragma Assert + (Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type); + return Node18 (Id); + end Alias; + + function Alignment (Id : E) return U is + begin + return Uint14 (Id); + end Alignment; + + function Associated_Final_Chain (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id)); + return Node23 (Id); + end Associated_Final_Chain; + + function Associated_Formal_Package (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Package); + return Node12 (Id); + end Associated_Formal_Package; + + function Associated_Node_For_Itype (Id : E) return N is + begin + return Node8 (Id); + end Associated_Node_For_Itype; + + function Associated_Storage_Pool (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id)); + return Node22 (Id); + end Associated_Storage_Pool; + + function Barrier_Function (Id : E) return N is + begin + pragma Assert (Is_Entry (Id)); + return Node12 (Id); + end Barrier_Function; + + function Block_Node (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Block); + return Node11 (Id); + end Block_Node; + + function Body_Entity (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + return Node19 (Id); + end Body_Entity; + + function C_Pass_By_Copy (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id)); + return Flag125 (Implementation_Base_Type (Id)); + end C_Pass_By_Copy; + + function Class_Wide_Type (Id : E) return E is + begin + pragma Assert (Is_Type (Id)); + return Node9 (Id); + end Class_Wide_Type; + + function Cloned_Subtype (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Class_Wide_Subtype); + return Node16 (Id); + end Cloned_Subtype; + + function Component_Bit_Offset (Id : E) return U is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + return Uint11 (Id); + end Component_Bit_Offset; + + function Component_Clause (Id : E) return N is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + return Node13 (Id); + end Component_Clause; + + function Component_Size (Id : E) return U is + begin + pragma Assert (Is_Array_Type (Id)); + return Uint22 (Implementation_Base_Type (Id)); + end Component_Size; + + function Component_Type (Id : E) return E is + begin + return Node20 (Implementation_Base_Type (Id)); + end Component_Type; + + function Corresponding_Concurrent_Type (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + return Node18 (Id); + end Corresponding_Concurrent_Type; + + function Corresponding_Discriminant (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Node19 (Id); + end Corresponding_Discriminant; + + function Corresponding_Equality (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Function + and then not Comes_From_Source (Id) + and then Chars (Id) = Name_Op_Ne); + return Node13 (Id); + end Corresponding_Equality; + + function Corresponding_Record_Type (Id : E) return E is + begin + pragma Assert (Is_Concurrent_Type (Id)); + return Node18 (Id); + end Corresponding_Record_Type; + + function Corresponding_Remote_Type (Id : E) return E is + begin + return Node22 (Id); + end Corresponding_Remote_Type; + + function CR_Discriminant (Id : E) return E is + begin + return Node23 (Id); + end CR_Discriminant; + + function Debug_Info_Off (Id : E) return B is + begin + return Flag166 (Id); + end Debug_Info_Off; + + function Debug_Renaming_Link (Id : E) return E is + begin + return Node13 (Id); + end Debug_Renaming_Link; + + function Default_Expr_Function (Id : E) return E is + begin + pragma Assert (Is_Formal (Id)); + return Node21 (Id); + end Default_Expr_Function; + + function Default_Expressions_Processed (Id : E) return B is + begin + return Flag108 (Id); + end Default_Expressions_Processed; + + function Default_Value (Id : E) return N is + begin + pragma Assert (Is_Formal (Id)); + return Node20 (Id); + end Default_Value; + + function Delay_Cleanups (Id : E) return B is + begin + return Flag114 (Id); + end Delay_Cleanups; + + function Delay_Subprogram_Descriptors (Id : E) return B is + begin + return Flag50 (Id); + end Delay_Subprogram_Descriptors; + + function Delta_Value (Id : E) return R is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + return Ureal18 (Id); + end Delta_Value; + + function Dependent_Instances (Id : E) return L is + begin + pragma Assert (Is_Generic_Instance (Id)); + return Elist8 (Id); + end Dependent_Instances; + + function Depends_On_Private (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag14 (Id); + end Depends_On_Private; + + function Digits_Value (Id : E) return U is + begin + pragma Assert + (Is_Floating_Point_Type (Id) + or else Is_Decimal_Fixed_Point_Type (Id)); + return Uint17 (Id); + end Digits_Value; + + function Directly_Designated_Type (Id : E) return E is + begin + return Node20 (Id); + end Directly_Designated_Type; + + function Discard_Names (Id : E) return B is + begin + return Flag88 (Id); + end Discard_Names; + + function Discriminal (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Node17 (Id); + end Discriminal; + + function Discriminal_Link (Id : E) return N is + begin + return Node10 (Id); + end Discriminal_Link; + + function Discriminant_Checking_Func (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Component); + return Node20 (Id); + end Discriminant_Checking_Func; + + function Discriminant_Constraint (Id : E) return L is + begin + pragma Assert (Is_Composite_Type (Id) and then Has_Discriminants (Id)); + return Elist21 (Id); + end Discriminant_Constraint; + + function Discriminant_Default_Value (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Node20 (Id); + end Discriminant_Default_Value; + + function Discriminant_Number (Id : E) return U is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Uint15 (Id); + end Discriminant_Number; + + function DT_Entry_Count (Id : E) return U is + begin + pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id)); + return Uint15 (Id); + end DT_Entry_Count; + + function DT_Position (Id : E) return U is + begin + pragma Assert + ((Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure) + and then Present (DTC_Entity (Id))); + return Uint15 (Id); + end DT_Position; + + function DTC_Entity (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Node16 (Id); + end DTC_Entity; + + function Elaborate_All_Desirable (Id : E) return B is + begin + return Flag146 (Id); + end Elaborate_All_Desirable; + + function Elaboration_Entity (Id : E) return E is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + return Node13 (Id); + end Elaboration_Entity; + + function Elaboration_Entity_Required (Id : E) return B is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + return Flag174 (Id); + end Elaboration_Entity_Required; + + function Enclosing_Scope (Id : E) return E is + begin + return Node18 (Id); + end Enclosing_Scope; + + function Entry_Accepted (Id : E) return B is + begin + pragma Assert (Is_Entry (Id)); + return Flag152 (Id); + end Entry_Accepted; + + function Entry_Bodies_Array (Id : E) return E is + begin + return Node15 (Id); + end Entry_Bodies_Array; + + function Entry_Cancel_Parameter (Id : E) return E is + begin + return Node23 (Id); + end Entry_Cancel_Parameter; + + function Entry_Component (Id : E) return E is + begin + return Node11 (Id); + end Entry_Component; + + function Entry_Formal (Id : E) return E is + begin + return Node16 (Id); + end Entry_Formal; + + function Entry_Index_Constant (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Entry_Index_Parameter); + return Node18 (Id); + end Entry_Index_Constant; + + function Entry_Parameters_Type (Id : E) return E is + begin + return Node15 (Id); + end Entry_Parameters_Type; + + function Enum_Pos_To_Rep (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Type); + return Node23 (Id); + end Enum_Pos_To_Rep; + + function Enumeration_Pos (Id : E) return Uint is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + return Uint11 (Id); + end Enumeration_Pos; + + function Enumeration_Rep (Id : E) return U is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + return Uint12 (Id); + end Enumeration_Rep; + + function Enumeration_Rep_Expr (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + return Node22 (Id); + end Enumeration_Rep_Expr; + + function Equivalent_Type (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Class_Wide_Subtype or else + Ekind (Id) = E_Access_Protected_Subprogram_Type or else + Ekind (Id) = E_Access_Subprogram_Type or else + Ekind (Id) = E_Exception_Type); + return Node18 (Id); + end Equivalent_Type; + + function Esize (Id : E) return Uint is + begin + return Uint12 (Id); + end Esize; + + function Exception_Code (Id : E) return Uint is + begin + pragma Assert (Ekind (Id) = E_Exception); + return Uint22 (Id); + end Exception_Code; + + function Extra_Accessibility (Id : E) return E is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + return Node13 (Id); + end Extra_Accessibility; + + function Extra_Constrained (Id : E) return E is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + return Node23 (Id); + end Extra_Constrained; + + function Extra_Formal (Id : E) return E is + begin + return Node15 (Id); + end Extra_Formal; + + function Finalization_Chain_Entity (Id : E) return E is + begin + return Node19 (Id); + end Finalization_Chain_Entity; + + function Finalize_Storage_Only (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag158 (Base_Type (Id)); + end Finalize_Storage_Only; + + function First_Entity (Id : E) return E is + begin + return Node17 (Id); + end First_Entity; + + function First_Index (Id : E) return N is + begin + return Node17 (Id); + end First_Index; + + function First_Literal (Id : E) return E is + begin + return Node17 (Id); + end First_Literal; + + function First_Optional_Parameter (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Node14 (Id); + end First_Optional_Parameter; + + function First_Private_Entity (Id : E) return E is + begin + return Node16 (Id); + end First_Private_Entity; + + function First_Rep_Item (Id : E) return E is + begin + return Node6 (Id); + end First_Rep_Item; + + function Freeze_Node (Id : E) return N is + begin + return Node7 (Id); + end Freeze_Node; + + function From_With_Type (Id : E) return B is + begin + return Flag159 (Id); + end From_With_Type; + + function Full_View (Id : E) return E is + begin + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Constant); + return Node11 (Id); + end Full_View; + + function Function_Returns_With_DSP (Id : E) return B is + begin + pragma Assert + (Is_Subprogram (Id) or else Ekind (Id) = E_Subprogram_Type); + return Flag169 (Id); + end Function_Returns_With_DSP; + + function Generic_Renamings (Id : E) return L is + begin + return Elist23 (Id); + end Generic_Renamings; + + function Girder_Constraint (Id : E) return L is + begin + pragma Assert + (Is_Composite_Type (Id) and then not Is_Array_Type (Id)); + return Elist23 (Id); + end Girder_Constraint; + + function Handler_Records (Id : E) return S is + begin + return List10 (Id); + end Handler_Records; + + function Has_Aliased_Components (Id : E) return B is + begin + return Flag135 (Implementation_Base_Type (Id)); + end Has_Aliased_Components; + + function Has_Alignment_Clause (Id : E) return B is + begin + return Flag46 (Id); + end Has_Alignment_Clause; + + function Has_All_Calls_Remote (Id : E) return B is + begin + return Flag79 (Id); + end Has_All_Calls_Remote; + + function Has_Atomic_Components (Id : E) return B is + begin + return Flag86 (Implementation_Base_Type (Id)); + end Has_Atomic_Components; + + function Has_Biased_Representation (Id : E) return B is + begin + return Flag139 (Id); + end Has_Biased_Representation; + + function Has_Completion (Id : E) return B is + begin + return Flag26 (Id); + end Has_Completion; + + function Has_Completion_In_Body (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag71 (Id); + end Has_Completion_In_Body; + + function Has_Complex_Representation (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag140 (Implementation_Base_Type (Id)); + end Has_Complex_Representation; + + function Has_Component_Size_Clause (Id : E) return B is + begin + pragma Assert (Is_Array_Type (Id)); + return Flag68 (Implementation_Base_Type (Id)); + end Has_Component_Size_Clause; + + function Has_Controlled_Component (Id : E) return B is + begin + return Flag43 (Base_Type (Id)); + end Has_Controlled_Component; + + function Has_Controlling_Result (Id : E) return B is + begin + return Flag98 (Id); + end Has_Controlling_Result; + + function Has_Convention_Pragma (Id : E) return B is + begin + return Flag119 (Id); + end Has_Convention_Pragma; + + function Has_Delayed_Freeze (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag18 (Id); + end Has_Delayed_Freeze; + + function Has_Discriminants (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag5 (Id); + end Has_Discriminants; + + function Has_Enumeration_Rep_Clause (Id : E) return B is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Flag66 (Id); + end Has_Enumeration_Rep_Clause; + + function Has_Exit (Id : E) return B is + begin + return Flag47 (Id); + end Has_Exit; + + function Has_External_Tag_Rep_Clause (Id : E) return B is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Flag110 (Id); + end Has_External_Tag_Rep_Clause; + + function Has_Forward_Instantiation (Id : E) return B is + begin + return Flag175 (Id); + end Has_Forward_Instantiation; + + function Has_Fully_Qualified_Name (Id : E) return B is + begin + return Flag173 (Id); + end Has_Fully_Qualified_Name; + + function Has_Gigi_Rep_Item (Id : E) return B is + begin + return Flag82 (Id); + end Has_Gigi_Rep_Item; + + function Has_Homonym (Id : E) return B is + begin + return Flag56 (Id); + end Has_Homonym; + + function Has_Machine_Radix_Clause (Id : E) return B is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + return Flag83 (Id); + end Has_Machine_Radix_Clause; + + function Has_Master_Entity (Id : E) return B is + begin + return Flag21 (Id); + end Has_Master_Entity; + + function Has_Missing_Return (Id : E) return B is + begin + pragma Assert + (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function); + return Flag142 (Id); + end Has_Missing_Return; + + function Has_Nested_Block_With_Handler (Id : E) return B is + begin + return Flag101 (Id); + end Has_Nested_Block_With_Handler; + + function Has_Non_Standard_Rep (Id : E) return B is + begin + return Flag75 (Implementation_Base_Type (Id)); + end Has_Non_Standard_Rep; + + function Has_Object_Size_Clause (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag172 (Id); + end Has_Object_Size_Clause; + + function Has_Per_Object_Constraint (Id : E) return B is + begin + return Flag154 (Id); + end Has_Per_Object_Constraint; + + function Has_Pragma_Controlled (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag27 (Implementation_Base_Type (Id)); + end Has_Pragma_Controlled; + + function Has_Pragma_Elaborate_Body (Id : E) return B is + begin + return Flag150 (Id); + end Has_Pragma_Elaborate_Body; + + function Has_Pragma_Inline (Id : E) return B is + begin + return Flag157 (Id); + end Has_Pragma_Inline; + + function Has_Pragma_Pack (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id)); + return Flag121 (Implementation_Base_Type (Id)); + end Has_Pragma_Pack; + + function Has_Primitive_Operations (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag120 (Base_Type (Id)); + end Has_Primitive_Operations; + + function Has_Private_Declaration (Id : E) return B is + begin + return Flag155 (Id); + end Has_Private_Declaration; + + function Has_Qualified_Name (Id : E) return B is + begin + return Flag161 (Id); + end Has_Qualified_Name; + + function Has_Record_Rep_Clause (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id)); + return Flag65 (Id); + end Has_Record_Rep_Clause; + + function Has_Recursive_Call (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag143 (Id); + end Has_Recursive_Call; + + function Has_Size_Clause (Id : E) return B is + begin + return Flag29 (Id); + end Has_Size_Clause; + + function Has_Small_Clause (Id : E) return B is + begin + return Flag67 (Id); + end Has_Small_Clause; + + function Has_Specified_Layout (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag100 (Id); + end Has_Specified_Layout; + + function Has_Storage_Size_Clause (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + return Flag23 (Implementation_Base_Type (Id)); + end Has_Storage_Size_Clause; + + function Has_Subprogram_Descriptor (Id : E) return B is + begin + return Flag93 (Id); + end Has_Subprogram_Descriptor; + + function Has_Task (Id : E) return B is + begin + return Flag30 (Base_Type (Id)); + end Has_Task; + + function Has_Unchecked_Union (Id : E) return B is + begin + return Flag123 (Base_Type (Id)); + end Has_Unchecked_Union; + + function Has_Unknown_Discriminants (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag72 (Id); + end Has_Unknown_Discriminants; + + function Has_Volatile_Components (Id : E) return B is + begin + return Flag87 (Implementation_Base_Type (Id)); + end Has_Volatile_Components; + + function Hiding_Loop_Variable (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Variable); + return Node8 (Id); + end Hiding_Loop_Variable; + + function Homonym (Id : E) return E is + begin + return Node4 (Id); + end Homonym; + + function In_Package_Body (Id : E) return B is + begin + return Flag48 (Id); + end In_Package_Body; + + function In_Private_Part (Id : E) return B is + begin + return Flag45 (Id); + end In_Private_Part; + + function In_Use (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag8 (Id); + end In_Use; + + function Inner_Instances (Id : E) return L is + begin + return Elist23 (Id); + end Inner_Instances; + + function Interface_Name (Id : E) return N is + begin + return Node21 (Id); + end Interface_Name; + + function Is_Abstract (Id : E) return B is + begin + return Flag19 (Id); + end Is_Abstract; + + function Is_Access_Constant (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag69 (Id); + end Is_Access_Constant; + + function Is_Aliased (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag15 (Id); + end Is_Aliased; + + function Is_AST_Entry (Id : E) return B is + begin + pragma Assert (Is_Entry (Id)); + return Flag132 (Id); + end Is_AST_Entry; + + function Is_Asynchronous (Id : E) return B is + begin + pragma Assert + (Ekind (Id) = E_Procedure or else Is_Type (Id)); + return Flag81 (Id); + end Is_Asynchronous; + + function Is_Atomic (Id : E) return B is + begin + return Flag85 (Id); + end Is_Atomic; + + function Is_Bit_Packed_Array (Id : E) return B is + begin + return Flag122 (Implementation_Base_Type (Id)); + end Is_Bit_Packed_Array; + + function Is_Called (Id : E) return B is + begin + pragma Assert + (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function); + return Flag102 (Id); + end Is_Called; + + function Is_Character_Type (Id : E) return B is + begin + return Flag63 (Id); + end Is_Character_Type; + + function Is_Child_Unit (Id : E) return B is + begin + return Flag73 (Id); + end Is_Child_Unit; + + function Is_Compilation_Unit (Id : E) return B is + begin + return Flag149 (Id); + end Is_Compilation_Unit; + + function Is_Completely_Hidden (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Flag103 (Id); + end Is_Completely_Hidden; + + function Is_Constr_Subt_For_U_Nominal (Id : E) return B is + begin + return Flag80 (Id); + end Is_Constr_Subt_For_U_Nominal; + + function Is_Constr_Subt_For_UN_Aliased (Id : E) return B is + begin + return Flag141 (Id); + end Is_Constr_Subt_For_UN_Aliased; + + function Is_Constrained (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag12 (Id); + end Is_Constrained; + + function Is_Constructor (Id : E) return B is + begin + return Flag76 (Id); + end Is_Constructor; + + function Is_Controlled (Id : E) return B is + begin + return Flag42 (Base_Type (Id)); + end Is_Controlled; + + function Is_Controlling_Formal (Id : E) return B is + begin + pragma Assert (Is_Formal (Id)); + return Flag97 (Id); + end Is_Controlling_Formal; + + function Is_CPP_Class (Id : E) return B is + begin + return Flag74 (Id); + end Is_CPP_Class; + + function Is_Destructor (Id : E) return B is + begin + return Flag77 (Id); + end Is_Destructor; + + function Is_Discrim_SO_Function (Id : E) return B is + begin + return Flag176 (Id); + end Is_Discrim_SO_Function; + + function Is_Dispatching_Operation (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag6 (Id); + end Is_Dispatching_Operation; + + function Is_Eliminated (Id : E) return B is + begin + return Flag124 (Id); + end Is_Eliminated; + + function Is_Entry_Formal (Id : E) return B is + begin + return Flag52 (Id); + end Is_Entry_Formal; + + function Is_Exported (Id : E) return B is + begin + return Flag99 (Id); + end Is_Exported; + + function Is_First_Subtype (Id : E) return B is + begin + return Flag70 (Id); + end Is_First_Subtype; + + function Is_For_Access_Subtype (Id : E) return B is + begin + pragma Assert + (Ekind (Id) = E_Record_Subtype + or else + Ekind (Id) = E_Private_Subtype); + return Flag118 (Id); + end Is_For_Access_Subtype; + + function Is_Formal_Subprogram (Id : E) return B is + begin + return Flag111 (Id); + end Is_Formal_Subprogram; + + function Is_Frozen (Id : E) return B is + begin + return Flag4 (Id); + end Is_Frozen; + + function Is_Generic_Actual_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag94 (Id); + end Is_Generic_Actual_Type; + + function Is_Generic_Instance (Id : E) return B is + begin + return Flag130 (Id); + end Is_Generic_Instance; + + function Is_Generic_Type (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag13 (Id); + end Is_Generic_Type; + + function Is_Hidden (Id : E) return B is + begin + return Flag57 (Id); + end Is_Hidden; + + function Is_Hidden_Open_Scope (Id : E) return B is + begin + return Flag171 (Id); + end Is_Hidden_Open_Scope; + + function Is_Immediately_Visible (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag7 (Id); + end Is_Immediately_Visible; + + function Is_Imported (Id : E) return B is + begin + return Flag24 (Id); + end Is_Imported; + + function Is_Inlined (Id : E) return B is + begin + return Flag11 (Id); + end Is_Inlined; + + function Is_Instantiated (Id : E) return B is + begin + return Flag126 (Id); + end Is_Instantiated; + + function Is_Internal (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag17 (Id); + end Is_Internal; + + function Is_Interrupt_Handler (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag89 (Id); + end Is_Interrupt_Handler; + + function Is_Intrinsic_Subprogram (Id : E) return B is + begin + return Flag64 (Id); + end Is_Intrinsic_Subprogram; + + function Is_Itype (Id : E) return B is + begin + return Flag91 (Id); + end Is_Itype; + + function Is_Known_Valid (Id : E) return B is + begin + return Flag170 (Id); + end Is_Known_Valid; + + function Is_Limited_Composite (Id : E) return B is + begin + return Flag106 (Id); + end Is_Limited_Composite; + + function Is_Limited_Record (Id : E) return B is + begin + return Flag25 (Id); + end Is_Limited_Record; + + function Is_Machine_Code_Subprogram (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag137 (Id); + end Is_Machine_Code_Subprogram; + + function Is_Non_Static_Subtype (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag109 (Id); + end Is_Non_Static_Subtype; + + function Is_Null_Init_Proc (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Flag178 (Id); + end Is_Null_Init_Proc; + + function Is_Optional_Parameter (Id : E) return B is + begin + pragma Assert (Is_Formal (Id)); + return Flag134 (Id); + end Is_Optional_Parameter; + + function Is_Package_Body_Entity (Id : E) return B is + begin + return Flag160 (Id); + end Is_Package_Body_Entity; + + function Is_Packed (Id : E) return B is + begin + return Flag51 (Implementation_Base_Type (Id)); + end Is_Packed; + + function Is_Packed_Array_Type (Id : E) return B is + begin + return Flag138 (Id); + end Is_Packed_Array_Type; + + function Is_Potentially_Use_Visible (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag9 (Id); + end Is_Potentially_Use_Visible; + + function Is_Preelaborated (Id : E) return B is + begin + return Flag59 (Id); + end Is_Preelaborated; + + function Is_Private_Composite (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag107 (Id); + end Is_Private_Composite; + + function Is_Private_Descendant (Id : E) return B is + begin + return Flag53 (Id); + end Is_Private_Descendant; + + function Is_Psected (Id : E) return B is + begin + return Flag153 (Id); + end Is_Psected; + + function Is_Public (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag10 (Id); + end Is_Public; + + function Is_Pure (Id : E) return B is + begin + return Flag44 (Id); + end Is_Pure; + + function Is_Remote_Call_Interface (Id : E) return B is + begin + return Flag62 (Id); + end Is_Remote_Call_Interface; + + function Is_Remote_Types (Id : E) return B is + begin + return Flag61 (Id); + end Is_Remote_Types; + + function Is_Renaming_Of_Object (Id : E) return B is + begin + return Flag112 (Id); + end Is_Renaming_Of_Object; + + function Is_Shared_Passive (Id : E) return B is + begin + return Flag60 (Id); + end Is_Shared_Passive; + + function Is_Statically_Allocated (Id : E) return B is + begin + return Flag28 (Id); + end Is_Statically_Allocated; + + function Is_Tag (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag78 (Id); + end Is_Tag; + + function Is_Tagged_Type (Id : E) return B is + begin + return Flag55 (Id); + end Is_Tagged_Type; + + function Is_True_Constant (Id : E) return B is + begin + return Flag163 (Id); + end Is_True_Constant; + + function Is_Unchecked_Union (Id : E) return B is + begin + return Flag117 (Id); + end Is_Unchecked_Union; + + function Is_Unsigned_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag144 (Id); + end Is_Unsigned_Type; + + function Is_Valued_Procedure (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Flag127 (Id); + end Is_Valued_Procedure; + + function Is_Visible_Child_Unit (Id : E) return B is + begin + pragma Assert (Is_Child_Unit (Id)); + return Flag116 (Id); + end Is_Visible_Child_Unit; + + function Is_VMS_Exception (Id : E) return B is + begin + return Flag133 (Id); + end Is_VMS_Exception; + + function Is_Volatile (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag16 (Id); + end Is_Volatile; + + function Last_Entity (Id : E) return E is + begin + return Node20 (Id); + end Last_Entity; + + function Lit_Indexes (Id : E) return E is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Node15 (Id); + end Lit_Indexes; + + function Lit_Strings (Id : E) return E is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Node16 (Id); + end Lit_Strings; + + function Machine_Radix_10 (Id : E) return B is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + return Flag84 (Id); + end Machine_Radix_10; + + function Master_Id (Id : E) return E is + begin + return Node17 (Id); + end Master_Id; + + function Materialize_Entity (Id : E) return B is + begin + return Flag168 (Id); + end Materialize_Entity; + + function Mechanism (Id : E) return M is + begin + pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id)); + return UI_To_Int (Uint8 (Id)); + end Mechanism; + + function Modulus (Id : E) return Uint is + begin + pragma Assert (Is_Modular_Integer_Type (Id)); + return Uint17 (Base_Type (Id)); + end Modulus; + + function Needs_Debug_Info (Id : E) return B is + begin + return Flag147 (Id); + end Needs_Debug_Info; + + function Needs_No_Actuals (Id : E) return B is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind (Id) = E_Subprogram_Type + or else Ekind (Id) = E_Entry_Family); + return Flag22 (Id); + end Needs_No_Actuals; + + function Next_Inlined_Subprogram (Id : E) return E is + begin + return Node12 (Id); + end Next_Inlined_Subprogram; + + function No_Pool_Assigned (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag131 (Root_Type (Id)); + end No_Pool_Assigned; + + function No_Return (Id : E) return B is + begin + pragma Assert + (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Generic_Procedure); + return Flag113 (Id); + end No_Return; + + function Non_Binary_Modulus (Id : E) return B is + begin + pragma Assert (Is_Modular_Integer_Type (Id)); + return Flag58 (Base_Type (Id)); + end Non_Binary_Modulus; + + function Nonzero_Is_True (Id : E) return B is + begin + pragma Assert (Root_Type (Id) = Standard_Boolean); + return Flag162 (Base_Type (Id)); + end Nonzero_Is_True; + + function Normalized_First_Bit (Id : E) return U is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + return Uint8 (Id); + end Normalized_First_Bit; + + function Normalized_Position (Id : E) return U is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + return Uint9 (Id); + end Normalized_Position; + + function Normalized_Position_Max (Id : E) return U is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + return Uint10 (Id); + end Normalized_Position_Max; + + function Not_Source_Assigned (Id : E) return B is + begin + return Flag115 (Id); + end Not_Source_Assigned; + + function Object_Ref (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Protected_Body); + return Node17 (Id); + end Object_Ref; + + function Original_Record_Component (Id : E) return E is + begin + return Node22 (Id); + end Original_Record_Component; + + function Packed_Array_Type (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id)); + return Node23 (Id); + end Packed_Array_Type; + + function Parent_Subtype (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + return Node19 (Id); + end Parent_Subtype; + + function Primitive_Operations (Id : E) return L is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Elist15 (Id); + end Primitive_Operations; + + function Prival (Id : E) return E is + begin + pragma Assert (Is_Protected_Private (Id)); + return Node17 (Id); + end Prival; + + function Privals_Chain (Id : E) return L is + begin + pragma Assert (Is_Overloadable (Id) + or else Ekind (Id) = E_Entry_Family); + return Elist23 (Id); + end Privals_Chain; + + function Private_Dependents (Id : E) return L is + begin + pragma Assert (Is_Incomplete_Or_Private_Type (Id)); + return Elist18 (Id); + end Private_Dependents; + + function Private_View (Id : E) return N is + begin + pragma Assert (Is_Private_Type (Id)); + return Node22 (Id); + end Private_View; + + function Protected_Body_Subprogram (Id : E) return E is + begin + pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id)); + return Node11 (Id); + end Protected_Body_Subprogram; + + function Protected_Formal (Id : E) return E is + begin + pragma Assert (Is_Formal (Id)); + return Node22 (Id); + end Protected_Formal; + + function Protected_Operation (Id : E) return N is + begin + pragma Assert (Is_Protected_Private (Id)); + return Node23 (Id); + end Protected_Operation; + + function Reachable (Id : E) return B is + begin + return Flag49 (Id); + end Reachable; + + function Referenced (Id : E) return B is + begin + return Flag156 (Id); + end Referenced; + + function Referenced_Object (Id : E) return N is + begin + pragma Assert (Is_Type (Id)); + return Node10 (Id); + end Referenced_Object; + + function Register_Exception_Call (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Exception); + return Node20 (Id); + end Register_Exception_Call; + + function Related_Array_Object (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id)); + return Node19 (Id); + end Related_Array_Object; + + function Related_Instance (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Package); + return Node15 (Id); + end Related_Instance; + + function Renamed_Entity (Id : E) return N is + begin + return Node18 (Id); + end Renamed_Entity; + + function Renamed_Object (Id : E) return N is + begin + return Node18 (Id); + end Renamed_Object; + + function Renaming_Map (Id : E) return U is + begin + return Uint9 (Id); + end Renaming_Map; + + function Return_Present (Id : E) return B is + begin + return Flag54 (Id); + end Return_Present; + + function Returns_By_Ref (Id : E) return B is + begin + return Flag90 (Id); + end Returns_By_Ref; + + function Reverse_Bit_Order (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id)); + return Flag164 (Base_Type (Id)); + end Reverse_Bit_Order; + + function RM_Size (Id : E) return U is + begin + pragma Assert (Is_Type (Id)); + return Uint13 (Id); + end RM_Size; + + function Scalar_Range (Id : E) return N is + begin + return Node20 (Id); + end Scalar_Range; + + function Scale_Value (Id : E) return U is + begin + return Uint15 (Id); + end Scale_Value; + + function Scope_Depth_Value (Id : E) return U is + begin + return Uint22 (Id); + end Scope_Depth_Value; + + function Sec_Stack_Needed_For_Return (Id : E) return B is + begin + return Flag167 (Id); + end Sec_Stack_Needed_For_Return; + + function Shadow_Entities (Id : E) return S is + begin + pragma Assert + (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + return List14 (Id); + end Shadow_Entities; + + function Shared_Var_Assign_Proc (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Variable); + return Node22 (Id); + end Shared_Var_Assign_Proc; + + function Shared_Var_Read_Proc (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Variable); + return Node15 (Id); + end Shared_Var_Read_Proc; + + function Size_Check_Code (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + return Node9 (Id); + end Size_Check_Code; + + function Size_Depends_On_Discriminant (Id : E) return B is + begin + return Flag177 (Id); + end Size_Depends_On_Discriminant; + + function Size_Known_At_Compile_Time (Id : E) return B is + begin + return Flag92 (Id); + end Size_Known_At_Compile_Time; + + function Small_Value (Id : E) return R is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + return Ureal21 (Id); + end Small_Value; + + function Spec_Entity (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); + return Node19 (Id); + end Spec_Entity; + + function Storage_Size_Variable (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + return Node15 (Implementation_Base_Type (Id)); + end Storage_Size_Variable; + + function Strict_Alignment (Id : E) return B is + begin + return Flag145 (Implementation_Base_Type (Id)); + end Strict_Alignment; + + function String_Literal_Length (Id : E) return U is + begin + return Uint16 (Id); + end String_Literal_Length; + + function String_Literal_Low_Bound (Id : E) return N is + begin + return Node15 (Id); + end String_Literal_Low_Bound; + + function Suppress_Access_Checks (Id : E) return B is + begin + return Flag31 (Id); + end Suppress_Access_Checks; + + function Suppress_Accessibility_Checks (Id : E) return B is + begin + return Flag32 (Id); + end Suppress_Accessibility_Checks; + + function Suppress_Discriminant_Checks (Id : E) return B is + begin + return Flag33 (Id); + end Suppress_Discriminant_Checks; + + function Suppress_Division_Checks (Id : E) return B is + begin + return Flag34 (Id); + end Suppress_Division_Checks; + + function Suppress_Elaboration_Checks (Id : E) return B is + begin + return Flag35 (Id); + end Suppress_Elaboration_Checks; + + function Suppress_Elaboration_Warnings (Id : E) return B is + begin + return Flag148 (Id); + end Suppress_Elaboration_Warnings; + + function Suppress_Index_Checks (Id : E) return B is + begin + return Flag36 (Id); + end Suppress_Index_Checks; + + function Suppress_Init_Proc (Id : E) return B is + begin + return Flag105 (Base_Type (Id)); + end Suppress_Init_Proc; + + function Suppress_Length_Checks (Id : E) return B is + begin + return Flag37 (Id); + end Suppress_Length_Checks; + + function Suppress_Overflow_Checks (Id : E) return B is + begin + return Flag38 (Id); + end Suppress_Overflow_Checks; + + function Suppress_Range_Checks (Id : E) return B is + begin + return Flag39 (Id); + end Suppress_Range_Checks; + + function Suppress_Storage_Checks (Id : E) return B is + begin + return Flag40 (Id); + end Suppress_Storage_Checks; + + function Suppress_Style_Checks (Id : E) return B is + begin + return Flag165 (Id); + end Suppress_Style_Checks; + + function Suppress_Tag_Checks (Id : E) return B is + begin + return Flag41 (Id); + end Suppress_Tag_Checks; + + function Underlying_Full_View (Id : E) return E is + begin + pragma Assert (Ekind (Id) in Private_Kind); + return Node19 (Id); + end Underlying_Full_View; + + function Unset_Reference (Id : E) return N is + begin + return Node16 (Id); + end Unset_Reference; + + function Uses_Sec_Stack (Id : E) return B is + begin + return Flag95 (Id); + end Uses_Sec_Stack; + + function Vax_Float (Id : E) return B is + begin + return Flag151 (Base_Type (Id)); + end Vax_Float; + + function Warnings_Off (Id : E) return B is + begin + return Flag96 (Id); + end Warnings_Off; + + ------------------------------ + -- Classification Functions -- + ------------------------------ + + function Is_Access_Type (Id : E) return B is + begin + return Ekind (Id) in Access_Kind; + end Is_Access_Type; + + function Is_Array_Type (Id : E) return B is + begin + return Ekind (Id) in Array_Kind; + end Is_Array_Type; + + function Is_Class_Wide_Type (Id : E) return B is + begin + return Ekind (Id) in Class_Wide_Kind; + end Is_Class_Wide_Type; + + function Is_Composite_Type (Id : E) return B is + begin + return Ekind (Id) in Composite_Kind; + end Is_Composite_Type; + + function Is_Concurrent_Body (Id : E) return B is + begin + return Ekind (Id) in + Concurrent_Body_Kind; + end Is_Concurrent_Body; + + function Is_Concurrent_Record_Type (Id : E) return B is + begin + return Flag20 (Id); + end Is_Concurrent_Record_Type; + + function Is_Concurrent_Type (Id : E) return B is + begin + return Ekind (Id) in Concurrent_Kind; + end Is_Concurrent_Type; + + function Is_Decimal_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in + Decimal_Fixed_Point_Kind; + end Is_Decimal_Fixed_Point_Type; + + function Is_Digits_Type (Id : E) return B is + begin + return Ekind (Id) in Digits_Kind; + end Is_Digits_Type; + + function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in Discrete_Or_Fixed_Point_Kind; + end Is_Discrete_Or_Fixed_Point_Type; + + function Is_Discrete_Type (Id : E) return B is + begin + return Ekind (Id) in Discrete_Kind; + end Is_Discrete_Type; + + function Is_Elementary_Type (Id : E) return B is + begin + return Ekind (Id) in Elementary_Kind; + end Is_Elementary_Type; + + function Is_Entry (Id : E) return B is + begin + return Ekind (Id) in Entry_Kind; + end Is_Entry; + + function Is_Enumeration_Type (Id : E) return B is + begin + return Ekind (Id) in + Enumeration_Kind; + end Is_Enumeration_Type; + + function Is_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in + Fixed_Point_Kind; + end Is_Fixed_Point_Type; + + function Is_Floating_Point_Type (Id : E) return B is + begin + return Ekind (Id) in Float_Kind; + end Is_Floating_Point_Type; + + function Is_Formal (Id : E) return B is + begin + return Ekind (Id) in Formal_Kind; + end Is_Formal; + + function Is_Generic_Unit (Id : E) return B is + begin + return Ekind (Id) in Generic_Unit_Kind; + end Is_Generic_Unit; + + function Is_Incomplete_Or_Private_Type (Id : E) return B is + begin + return Ekind (Id) in + Incomplete_Or_Private_Kind; + end Is_Incomplete_Or_Private_Type; + + function Is_Integer_Type (Id : E) return B is + begin + return Ekind (Id) in Integer_Kind; + end Is_Integer_Type; + + function Is_Modular_Integer_Type (Id : E) return B is + begin + return Ekind (Id) in + Modular_Integer_Kind; + end Is_Modular_Integer_Type; + + function Is_Named_Number (Id : E) return B is + begin + return Ekind (Id) in Named_Kind; + end Is_Named_Number; + + function Is_Numeric_Type (Id : E) return B is + begin + return Ekind (Id) in Numeric_Kind; + end Is_Numeric_Type; + + function Is_Object (Id : E) return B is + begin + return Ekind (Id) in Object_Kind; + end Is_Object; + + function Is_Ordinary_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in + Ordinary_Fixed_Point_Kind; + end Is_Ordinary_Fixed_Point_Type; + + function Is_Overloadable (Id : E) return B is + begin + return Ekind (Id) in Overloadable_Kind; + end Is_Overloadable; + + function Is_Private_Type (Id : E) return B is + begin + return Ekind (Id) in Private_Kind; + end Is_Private_Type; + + function Is_Protected_Type (Id : E) return B is + begin + return Ekind (Id) in Protected_Kind; + end Is_Protected_Type; + + function Is_Real_Type (Id : E) return B is + begin + return Ekind (Id) in Real_Kind; + end Is_Real_Type; + + function Is_Record_Type (Id : E) return B is + begin + return Ekind (Id) in Record_Kind; + end Is_Record_Type; + + function Is_Scalar_Type (Id : E) return B is + begin + return Ekind (Id) in Scalar_Kind; + end Is_Scalar_Type; + + function Is_Signed_Integer_Type (Id : E) return B is + begin + return Ekind (Id) in + Signed_Integer_Kind; + end Is_Signed_Integer_Type; + + function Is_Subprogram (Id : E) return B is + begin + return Ekind (Id) in Subprogram_Kind; + end Is_Subprogram; + + function Is_Task_Type (Id : E) return B is + begin + return Ekind (Id) in Task_Kind; + end Is_Task_Type; + + function Is_Type (Id : E) return B is + begin + return Ekind (Id) in Type_Kind; + end Is_Type; + + ------------------------------ + -- Attribute Set Procedures -- + ------------------------------ + + procedure Set_Accept_Address (Id : E; V : L) is + begin + Set_Elist21 (Id, V); + end Set_Accept_Address; + + procedure Set_Access_Disp_Table (Id : E; V : E) is + begin + pragma Assert (Is_Tagged_Type (Id)); + Set_Node16 (Base_Type (Id), V); + end Set_Access_Disp_Table; + + procedure Set_Associated_Final_Chain (Id : E; V : E) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Node23 (Id, V); + end Set_Associated_Final_Chain; + + procedure Set_Associated_Formal_Package (Id : E; V : E) is + begin + Set_Node12 (Id, V); + end Set_Associated_Formal_Package; + + procedure Set_Associated_Node_For_Itype (Id : E; V : E) is + begin + Set_Node8 (Id, V); + end Set_Associated_Node_For_Itype; + + procedure Set_Associated_Storage_Pool (Id : E; V : E) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Node22 (Id, V); + end Set_Associated_Storage_Pool; + + procedure Set_Actual_Subtype (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable + or else Ekind (Id) = E_Generic_In_Out_Parameter + or else Ekind (Id) in E_In_Parameter .. E_In_Out_Parameter); + Set_Node17 (Id, V); + end Set_Actual_Subtype; + + procedure Set_Address_Taken (Id : E; V : B := True) is + begin + Set_Flag104 (Id, V); + end Set_Address_Taken; + + procedure Set_Alias (Id : E; V : E) is + begin + pragma Assert + (Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type); + Set_Node18 (Id, V); + end Set_Alias; + + procedure Set_Alignment (Id : E; V : U) is + begin + Set_Uint14 (Id, V); + end Set_Alignment; + + procedure Set_Barrier_Function (Id : E; V : N) is + begin + pragma Assert (Is_Entry (Id)); + Set_Node12 (Id, V); + end Set_Barrier_Function; + + procedure Set_Block_Node (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Block); + Set_Node11 (Id, V); + end Set_Block_Node; + + procedure Set_Body_Entity (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + Set_Node19 (Id, V); + end Set_Body_Entity; + + procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is + begin + pragma Assert (Is_Record_Type (Id) and then Id = Base_Type (Id)); + Set_Flag125 (Id, V); + end Set_C_Pass_By_Copy; + + procedure Set_Class_Wide_Type (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id)); + Set_Node9 (Id, V); + end Set_Class_Wide_Type; + + procedure Set_Cloned_Subtype (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Class_Wide_Subtype); + Set_Node16 (Id, V); + end Set_Cloned_Subtype; + + procedure Set_Component_Bit_Offset (Id : E; V : U) is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + Set_Uint11 (Id, V); + end Set_Component_Bit_Offset; + + procedure Set_Component_Clause (Id : E; V : N) is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + Set_Node13 (Id, V); + end Set_Component_Clause; + + procedure Set_Component_Size (Id : E; V : U) is + begin + pragma Assert (Is_Array_Type (Id)); + Set_Uint22 (Base_Type (Id), V); + end Set_Component_Size; + + procedure Set_Component_Type (Id : E; V : E) is + begin + Set_Node20 (Id, V); + end Set_Component_Type; + + procedure Set_Corresponding_Concurrent_Type (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Record_Type and then Is_Concurrent_Type (V)); + Set_Node18 (Id, V); + end Set_Corresponding_Concurrent_Type; + + procedure Set_Corresponding_Discriminant (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + Set_Node19 (Id, V); + end Set_Corresponding_Discriminant; + + procedure Set_Corresponding_Equality (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Function + and then not Comes_From_Source (Id) + and then Chars (Id) = Name_Op_Ne); + Set_Node13 (Id, V); + end Set_Corresponding_Equality; + + procedure Set_Corresponding_Record_Type (Id : E; V : E) is + begin + pragma Assert (Is_Concurrent_Type (Id)); + Set_Node18 (Id, V); + end Set_Corresponding_Record_Type; + + procedure Set_Corresponding_Remote_Type (Id : E; V : E) is + begin + Set_Node22 (Id, V); + end Set_Corresponding_Remote_Type; + + procedure Set_CR_Discriminant (Id : E; V : E) is + begin + Set_Node23 (Id, V); + end Set_CR_Discriminant; + + procedure Set_Debug_Info_Off (Id : E; V : B := True) is + begin + Set_Flag166 (Id, V); + end Set_Debug_Info_Off; + + procedure Set_Debug_Renaming_Link (Id : E; V : E) is + begin + Set_Node13 (Id, V); + end Set_Debug_Renaming_Link; + + procedure Set_Default_Expr_Function (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id)); + Set_Node21 (Id, V); + end Set_Default_Expr_Function; + + procedure Set_Default_Expressions_Processed (Id : E; V : B := True) is + begin + Set_Flag108 (Id, V); + end Set_Default_Expressions_Processed; + + procedure Set_Default_Value (Id : E; V : N) is + begin + pragma Assert (Is_Formal (Id)); + Set_Node20 (Id, V); + end Set_Default_Value; + + procedure Set_Delay_Cleanups (Id : E; V : B := True) is + begin + pragma Assert + (Is_Subprogram (Id) + or else Is_Task_Type (Id) + or else Ekind (Id) = E_Block); + Set_Flag114 (Id, V); + end Set_Delay_Cleanups; + + procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is + begin + pragma Assert + (Is_Subprogram (Id) + or else Ekind (Id) = E_Package + or else Ekind (Id) = E_Package_Body); + Set_Flag50 (Id, V); + end Set_Delay_Subprogram_Descriptors; + + procedure Set_Delta_Value (Id : E; V : R) is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + Set_Ureal18 (Id, V); + end Set_Delta_Value; + + procedure Set_Dependent_Instances (Id : E; V : L) is + begin + pragma Assert (Is_Generic_Instance (Id)); + Set_Elist8 (Id, V); + end Set_Dependent_Instances; + + procedure Set_Depends_On_Private (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag14 (Id, V); + end Set_Depends_On_Private; + + procedure Set_Digits_Value (Id : E; V : U) is + begin + pragma Assert + (Is_Floating_Point_Type (Id) + or else Is_Decimal_Fixed_Point_Type (Id)); + Set_Uint17 (Id, V); + end Set_Digits_Value; + + procedure Set_Directly_Designated_Type (Id : E; V : E) is + begin + Set_Node20 (Id, V); + end Set_Directly_Designated_Type; + + procedure Set_Discard_Names (Id : E; V : B := True) is + begin + Set_Flag88 (Id, V); + end Set_Discard_Names; + + procedure Set_Discriminal (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + Set_Node17 (Id, V); + end Set_Discriminal; + + procedure Set_Discriminal_Link (Id : E; V : E) is + begin + Set_Node10 (Id, V); + end Set_Discriminal_Link; + + procedure Set_Discriminant_Checking_Func (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Component and Ekind (Scope (Id)) in Record_Kind); + Set_Node20 (Id, V); + end Set_Discriminant_Checking_Func; + + procedure Set_Discriminant_Constraint (Id : E; V : L) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Elist21 (Id, V); + end Set_Discriminant_Constraint; + + procedure Set_Discriminant_Default_Value (Id : E; V : N) is + begin + Set_Node20 (Id, V); + end Set_Discriminant_Default_Value; + + procedure Set_Discriminant_Number (Id : E; V : U) is + begin + Set_Uint15 (Id, V); + end Set_Discriminant_Number; + + procedure Set_DT_Entry_Count (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Component); + Set_Uint15 (Id, V); + end Set_DT_Entry_Count; + + procedure Set_DT_Position (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Uint15 (Id, V); + end Set_DT_Position; + + procedure Set_DTC_Entity (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Node16 (Id, V); + end Set_DTC_Entity; + + procedure Set_Elaborate_All_Desirable (Id : E; V : B := True) is + begin + Set_Flag146 (Id, V); + end Set_Elaborate_All_Desirable; + + procedure Set_Elaboration_Entity (Id : E; V : E) is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + Set_Node13 (Id, V); + end Set_Elaboration_Entity; + + procedure Set_Elaboration_Entity_Required (Id : E; V : B := True) is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + Set_Flag174 (Id, V); + end Set_Elaboration_Entity_Required; + + procedure Set_Enclosing_Scope (Id : E; V : E) is + begin + Set_Node18 (Id, V); + end Set_Enclosing_Scope; + + procedure Set_Entry_Accepted (Id : E; V : B := True) is + begin + pragma Assert (Is_Entry (Id)); + Set_Flag152 (Id, V); + end Set_Entry_Accepted; + + procedure Set_Entry_Bodies_Array (Id : E; V : E) is + begin + Set_Node15 (Id, V); + end Set_Entry_Bodies_Array; + + procedure Set_Entry_Cancel_Parameter (Id : E; V : E) is + begin + Set_Node23 (Id, V); + end Set_Entry_Cancel_Parameter; + + procedure Set_Entry_Component (Id : E; V : E) is + begin + Set_Node11 (Id, V); + end Set_Entry_Component; + + procedure Set_Entry_Formal (Id : E; V : E) is + begin + Set_Node16 (Id, V); + end Set_Entry_Formal; + + procedure Set_Entry_Index_Constant (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Entry_Index_Parameter); + Set_Node18 (Id, V); + end Set_Entry_Index_Constant; + + procedure Set_Entry_Parameters_Type (Id : E; V : E) is + begin + Set_Node15 (Id, V); + end Set_Entry_Parameters_Type; + + procedure Set_Enum_Pos_To_Rep (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Type); + Set_Node23 (Id, V); + end Set_Enum_Pos_To_Rep; + + procedure Set_Enumeration_Pos (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + Set_Uint11 (Id, V); + end Set_Enumeration_Pos; + + procedure Set_Enumeration_Rep (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + Set_Uint12 (Id, V); + end Set_Enumeration_Rep; + + procedure Set_Enumeration_Rep_Expr (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + Set_Node22 (Id, V); + end Set_Enumeration_Rep_Expr; + + procedure Set_Equivalent_Type (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Class_Wide_Type or else + Ekind (Id) = E_Class_Wide_Subtype or else + Ekind (Id) = E_Access_Protected_Subprogram_Type or else + Ekind (Id) = E_Access_Subprogram_Type or else + Ekind (Id) = E_Exception_Type); + Set_Node18 (Id, V); + end Set_Equivalent_Type; + + procedure Set_Esize (Id : E; V : U) is + begin + Set_Uint12 (Id, V); + end Set_Esize; + + procedure Set_Exception_Code (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Exception); + Set_Uint22 (Id, V); + end Set_Exception_Code; + + procedure Set_Extra_Accessibility (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + Set_Node13 (Id, V); + end Set_Extra_Accessibility; + + procedure Set_Extra_Constrained (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + Set_Node23 (Id, V); + end Set_Extra_Constrained; + + procedure Set_Extra_Formal (Id : E; V : E) is + begin + Set_Node15 (Id, V); + end Set_Extra_Formal; + + procedure Set_Finalization_Chain_Entity (Id : E; V : E) is + begin + Set_Node19 (Id, V); + end Set_Finalization_Chain_Entity; + + procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag158 (Base_Type (Id), V); + end Set_Finalize_Storage_Only; + + procedure Set_First_Entity (Id : E; V : E) is + begin + Set_Node17 (Id, V); + end Set_First_Entity; + + procedure Set_First_Index (Id : E; V : N) is + begin + Set_Node17 (Id, V); + end Set_First_Index; + + procedure Set_First_Literal (Id : E; V : E) is + begin + Set_Node17 (Id, V); + end Set_First_Literal; + + procedure Set_First_Optional_Parameter (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Node14 (Id, V); + end Set_First_Optional_Parameter; + + procedure Set_First_Private_Entity (Id : E; V : E) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Node16 (Id, V); + end Set_First_Private_Entity; + + procedure Set_First_Rep_Item (Id : E; V : N) is + begin + Set_Node6 (Id, V); + end Set_First_Rep_Item; + + procedure Set_Freeze_Node (Id : E; V : N) is + begin + Set_Node7 (Id, V); + end Set_Freeze_Node; + + procedure Set_From_With_Type (Id : E; V : B := True) is + begin + pragma Assert + (Is_Type (Id) + or else Ekind (Id) = E_Package); + Set_Flag159 (Id, V); + end Set_From_With_Type; + + procedure Set_Full_View (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Constant); + Set_Node11 (Id, V); + end Set_Full_View; + + procedure Set_Function_Returns_With_DSP (Id : E; V : B := True) is + begin + pragma Assert + (Is_Subprogram (Id) or else Ekind (Id) = E_Subprogram_Type); + Set_Flag169 (Id, V); + end Set_Function_Returns_With_DSP; + + procedure Set_Generic_Renamings (Id : E; V : L) is + begin + Set_Elist23 (Id, V); + end Set_Generic_Renamings; + + procedure Set_Girder_Constraint (Id : E; V : L) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Elist23 (Id, V); + end Set_Girder_Constraint; + + procedure Set_Handler_Records (Id : E; V : S) is + begin + Set_List10 (Id, V); + end Set_Handler_Records; + + procedure Set_Has_Aliased_Components (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag135 (Id, V); + end Set_Has_Aliased_Components; + + procedure Set_Has_Alignment_Clause (Id : E; V : B := True) is + begin + Set_Flag46 (Id, V); + end Set_Has_Alignment_Clause; + + procedure Set_Has_All_Calls_Remote (Id : E; V : B := True) is + begin + Set_Flag79 (Id, V); + end Set_Has_All_Calls_Remote; + + procedure Set_Has_Atomic_Components (Id : E; V : B := True) is + begin + pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id); + Set_Flag86 (Id, V); + end Set_Has_Atomic_Components; + + procedure Set_Has_Biased_Representation (Id : E; V : B := True) is + begin + pragma Assert + ((V = False) or else (Is_Discrete_Type (Id) or Is_Object (Id))); + Set_Flag139 (Id, V); + end Set_Has_Biased_Representation; + + procedure Set_Has_Completion (Id : E; V : B := True) is + begin + Set_Flag26 (Id, V); + end Set_Has_Completion; + + procedure Set_Has_Completion_In_Body (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Incomplete_Type); + Set_Flag71 (Id, V); + end Set_Has_Completion_In_Body; + + procedure Set_Has_Complex_Representation (Id : E; V : B := True) is + begin + pragma Assert (Is_Record_Type (Id)); + Set_Flag140 (Implementation_Base_Type (Id), V); + end Set_Has_Complex_Representation; + + procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Array_Type (Id)); + Set_Flag68 (Implementation_Base_Type (Id), V); + end Set_Has_Component_Size_Clause; + + procedure Set_Has_Controlled_Component (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag43 (Id, V); + end Set_Has_Controlled_Component; + + procedure Set_Has_Controlling_Result (Id : E; V : B := True) is + begin + Set_Flag98 (Id, V); + end Set_Has_Controlling_Result; + + procedure Set_Has_Convention_Pragma (Id : E; V : B := True) is + begin + Set_Flag119 (Id, V); + end Set_Has_Convention_Pragma; + + procedure Set_Has_Delayed_Freeze (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag18 (Id, V); + end Set_Has_Delayed_Freeze; + + procedure Set_Has_Discriminants (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag5 (Id, V); + end Set_Has_Discriminants; + + procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Enumeration_Type (Id)); + Set_Flag66 (Id, V); + end Set_Has_Enumeration_Rep_Clause; + + procedure Set_Has_Exit (Id : E; V : B := True) is + begin + Set_Flag47 (Id, V); + end Set_Has_Exit; + + procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Tagged_Type (Id)); + Set_Flag110 (Id, V); + end Set_Has_External_Tag_Rep_Clause; + + procedure Set_Has_Forward_Instantiation (Id : E; V : B := True) is + begin + Set_Flag175 (Id, V); + end Set_Has_Forward_Instantiation; + + procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True) is + begin + Set_Flag173 (Id, V); + end Set_Has_Fully_Qualified_Name; + + procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True) is + begin + Set_Flag82 (Id, V); + end Set_Has_Gigi_Rep_Item; + + procedure Set_Has_Homonym (Id : E; V : B := True) is + begin + Set_Flag56 (Id, V); + end Set_Has_Homonym; + + procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + Set_Flag83 (Id, V); + end Set_Has_Machine_Radix_Clause; + + procedure Set_Has_Master_Entity (Id : E; V : B := True) is + begin + Set_Flag21 (Id, V); + end Set_Has_Master_Entity; + + procedure Set_Has_Missing_Return (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function); + Set_Flag142 (Id, V); + end Set_Has_Missing_Return; + + procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True) is + begin + Set_Flag101 (Id, V); + end Set_Has_Nested_Block_With_Handler; + + procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag75 (Id, V); + end Set_Has_Non_Standard_Rep; + + procedure Set_Has_Object_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag172 (Id, V); + end Set_Has_Object_Size_Clause; + + procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True) is + begin + Set_Flag154 (Id, V); + end Set_Has_Per_Object_Constraint; + + procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag27 (Base_Type (Id), V); + end Set_Has_Pragma_Controlled; + + procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True) is + begin + Set_Flag150 (Id, V); + end Set_Has_Pragma_Elaborate_Body; + + procedure Set_Has_Pragma_Inline (Id : E; V : B := True) is + begin + Set_Flag157 (Id, V); + end Set_Has_Pragma_Inline; + + procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); + Set_Flag121 (Implementation_Base_Type (Id), V); + end Set_Has_Pragma_Pack; + + procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag120 (Base_Type (Id), V); + end Set_Has_Primitive_Operations; + + procedure Set_Has_Private_Declaration (Id : E; V : B := True) is + begin + Set_Flag155 (Id, V); + end Set_Has_Private_Declaration; + + procedure Set_Has_Qualified_Name (Id : E; V : B := True) is + begin + Set_Flag161 (Id, V); + end Set_Has_Qualified_Name; + + procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Record_Type (Id)); + Set_Flag65 (Id, V); + end Set_Has_Record_Rep_Clause; + + procedure Set_Has_Recursive_Call (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag143 (Id, V); + end Set_Has_Recursive_Call; + + procedure Set_Has_Size_Clause (Id : E; V : B := True) is + begin + Set_Flag29 (Id, V); + end Set_Has_Size_Clause; + + procedure Set_Has_Small_Clause (Id : E; V : B := True) is + begin + Set_Flag67 (Id, V); + end Set_Has_Small_Clause; + + procedure Set_Has_Specified_Layout (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag100 (Id, V); + end Set_Has_Specified_Layout; + + procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + pragma Assert (Base_Type (Id) = Id); + Set_Flag23 (Id, V); + end Set_Has_Storage_Size_Clause; + + procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True) is + begin + Set_Flag93 (Id, V); + end Set_Has_Subprogram_Descriptor; + + procedure Set_Has_Task (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag30 (Id, V); + end Set_Has_Task; + + procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag123 (Id, V); + end Set_Has_Unchecked_Union; + + procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag72 (Id, V); + end Set_Has_Unknown_Discriminants; + + procedure Set_Has_Volatile_Components (Id : E; V : B := True) is + begin + pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id); + Set_Flag87 (Id, V); + end Set_Has_Volatile_Components; + + procedure Set_Hiding_Loop_Variable (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Node8 (Id, V); + end Set_Hiding_Loop_Variable; + + procedure Set_Homonym (Id : E; V : E) is + begin + pragma Assert (Id /= V); + Set_Node4 (Id, V); + end Set_Homonym; + procedure Set_In_Package_Body (Id : E; V : B := True) is + begin + Set_Flag48 (Id, V); + end Set_In_Package_Body; + + procedure Set_In_Private_Part (Id : E; V : B := True) is + begin + Set_Flag45 (Id, V); + end Set_In_Private_Part; + + procedure Set_In_Use (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag8 (Id, V); + end Set_In_Use; + + procedure Set_Inner_Instances (Id : E; V : L) is + begin + Set_Elist23 (Id, V); + end Set_Inner_Instances; + + procedure Set_Interface_Name (Id : E; V : N) is + begin + Set_Node21 (Id, V); + end Set_Interface_Name; + + procedure Set_Is_Abstract (Id : E; V : B := True) is + begin + Set_Flag19 (Id, V); + end Set_Is_Abstract; + + procedure Set_Is_Access_Constant (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag69 (Id, V); + end Set_Is_Access_Constant; + + procedure Set_Is_Aliased (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag15 (Id, V); + end Set_Is_Aliased; + + procedure Set_Is_AST_Entry (Id : E; V : B := True) is + begin + pragma Assert (Is_Entry (Id)); + Set_Flag132 (Id, V); + end Set_Is_AST_Entry; + + procedure Set_Is_Asynchronous (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Procedure or else Is_Type (Id)); + Set_Flag81 (Id, V); + end Set_Is_Asynchronous; + + procedure Set_Is_Atomic (Id : E; V : B := True) is + begin + Set_Flag85 (Id, V); + end Set_Is_Atomic; + + procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is + begin + Set_Flag122 (Implementation_Base_Type (Id), V); + end Set_Is_Bit_Packed_Array; + + procedure Set_Is_Called (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function); + Set_Flag102 (Id, V); + end Set_Is_Called; + + procedure Set_Is_Character_Type (Id : E; V : B := True) is + begin + Set_Flag63 (Id, V); + end Set_Is_Character_Type; + + procedure Set_Is_Child_Unit (Id : E; V : B := True) is + begin + Set_Flag73 (Id, V); + end Set_Is_Child_Unit; + + procedure Set_Is_Compilation_Unit (Id : E; V : B := True) is + begin + Set_Flag149 (Id, V); + end Set_Is_Compilation_Unit; + + procedure Set_Is_Completely_Hidden (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + Set_Flag103 (Id, V); + end Set_Is_Completely_Hidden; + + procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True) is + begin + Set_Flag20 (Id, V); + end Set_Is_Concurrent_Record_Type; + + procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True) is + begin + Set_Flag80 (Id, V); + end Set_Is_Constr_Subt_For_U_Nominal; + + procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True) is + begin + Set_Flag141 (Id, V); + end Set_Is_Constr_Subt_For_UN_Aliased; + + procedure Set_Is_Constrained (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag12 (Id, V); + end Set_Is_Constrained; + + procedure Set_Is_Constructor (Id : E; V : B := True) is + begin + Set_Flag76 (Id, V); + end Set_Is_Constructor; + + procedure Set_Is_Controlled (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag42 (Id, V); + end Set_Is_Controlled; + + procedure Set_Is_Controlling_Formal (Id : E; V : B := True) is + begin + pragma Assert (Is_Formal (Id)); + Set_Flag97 (Id, V); + end Set_Is_Controlling_Formal; + + procedure Set_Is_CPP_Class (Id : E; V : B := True) is + begin + Set_Flag74 (Id, V); + end Set_Is_CPP_Class; + + procedure Set_Is_Destructor (Id : E; V : B := True) is + begin + Set_Flag77 (Id, V); + end Set_Is_Destructor; + + procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True) is + begin + Set_Flag176 (Id, V); + end Set_Is_Discrim_SO_Function; + + procedure Set_Is_Dispatching_Operation (Id : E; V : B := True) is + begin + pragma Assert + (V = False + or else + Is_Overloadable (Id) + or else + Ekind (Id) = E_Subprogram_Type); + + Set_Flag6 (Id, V); + end Set_Is_Dispatching_Operation; + + procedure Set_Is_Eliminated (Id : E; V : B := True) is + begin + Set_Flag124 (Id, V); + end Set_Is_Eliminated; + + procedure Set_Is_Entry_Formal (Id : E; V : B := True) is + begin + Set_Flag52 (Id, V); + end Set_Is_Entry_Formal; + + procedure Set_Is_Exported (Id : E; V : B := True) is + begin + Set_Flag99 (Id, V); + end Set_Is_Exported; + + procedure Set_Is_First_Subtype (Id : E; V : B := True) is + begin + Set_Flag70 (Id, V); + end Set_Is_First_Subtype; + + procedure Set_Is_For_Access_Subtype (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Record_Subtype + or else + Ekind (Id) = E_Private_Subtype); + Set_Flag118 (Id, V); + end Set_Is_For_Access_Subtype; + + procedure Set_Is_Formal_Subprogram (Id : E; V : B := True) is + begin + Set_Flag111 (Id, V); + end Set_Is_Formal_Subprogram; + + procedure Set_Is_Frozen (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag4 (Id, V); + end Set_Is_Frozen; + + procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag94 (Id, V); + end Set_Is_Generic_Actual_Type; + + procedure Set_Is_Generic_Instance (Id : E; V : B := True) is + begin + Set_Flag130 (Id, V); + end Set_Is_Generic_Instance; + + procedure Set_Is_Generic_Type (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag13 (Id, V); + end Set_Is_Generic_Type; + + procedure Set_Is_Hidden (Id : E; V : B := True) is + begin + Set_Flag57 (Id, V); + end Set_Is_Hidden; + + procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True) is + begin + Set_Flag171 (Id, V); + end Set_Is_Hidden_Open_Scope; + + procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag7 (Id, V); + end Set_Is_Immediately_Visible; + + procedure Set_Is_Imported (Id : E; V : B := True) is + begin + Set_Flag24 (Id, V); + end Set_Is_Imported; + + procedure Set_Is_Inlined (Id : E; V : B := True) is + begin + Set_Flag11 (Id, V); + end Set_Is_Inlined; + + procedure Set_Is_Instantiated (Id : E; V : B := True) is + begin + Set_Flag126 (Id, V); + end Set_Is_Instantiated; + + procedure Set_Is_Internal (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag17 (Id, V); + end Set_Is_Internal; + + procedure Set_Is_Interrupt_Handler (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag89 (Id, V); + end Set_Is_Interrupt_Handler; + + procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True) is + begin + Set_Flag64 (Id, V); + end Set_Is_Intrinsic_Subprogram; + + procedure Set_Is_Itype (Id : E; V : B := True) is + begin + Set_Flag91 (Id, V); + end Set_Is_Itype; + + procedure Set_Is_Known_Valid (Id : E; V : B := True) is + begin + Set_Flag170 (Id, V); + end Set_Is_Known_Valid; + + procedure Set_Is_Limited_Composite (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag106 (Id, V); + end Set_Is_Limited_Composite; + + procedure Set_Is_Limited_Record (Id : E; V : B := True) is + begin + Set_Flag25 (Id, V); + end Set_Is_Limited_Record; + + procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag137 (Id, V); + end Set_Is_Machine_Code_Subprogram; + + procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag109 (Id, V); + end Set_Is_Non_Static_Subtype; + + procedure Set_Is_Null_Init_Proc (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Flag178 (Id, V); + end Set_Is_Null_Init_Proc; + + procedure Set_Is_Optional_Parameter (Id : E; V : B := True) is + begin + pragma Assert (Is_Formal (Id)); + Set_Flag134 (Id, V); + end Set_Is_Optional_Parameter; + + procedure Set_Is_Package_Body_Entity (Id : E; V : B := True) is + begin + Set_Flag160 (Id, V); + end Set_Is_Package_Body_Entity; + + procedure Set_Is_Packed (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag51 (Id, V); + end Set_Is_Packed; + + procedure Set_Is_Packed_Array_Type (Id : E; V : B := True) is + begin + Set_Flag138 (Id, V); + end Set_Is_Packed_Array_Type; + + procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag9 (Id, V); + end Set_Is_Potentially_Use_Visible; + + procedure Set_Is_Preelaborated (Id : E; V : B := True) is + begin + Set_Flag59 (Id, V); + end Set_Is_Preelaborated; + + procedure Set_Is_Private_Composite (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag107 (Id, V); + end Set_Is_Private_Composite; + + procedure Set_Is_Private_Descendant (Id : E; V : B := True) is + begin + Set_Flag53 (Id, V); + end Set_Is_Private_Descendant; + + procedure Set_Is_Psected (Id : E; V : B := True) is + begin + Set_Flag153 (Id, V); + end Set_Is_Psected; + + procedure Set_Is_Public (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag10 (Id, V); + end Set_Is_Public; + + procedure Set_Is_Pure (Id : E; V : B := True) is + begin + Set_Flag44 (Id, V); + end Set_Is_Pure; + + procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True) is + begin + Set_Flag62 (Id, V); + end Set_Is_Remote_Call_Interface; + + procedure Set_Is_Remote_Types (Id : E; V : B := True) is + begin + Set_Flag61 (Id, V); + end Set_Is_Remote_Types; + + procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True) is + begin + Set_Flag112 (Id, V); + end Set_Is_Renaming_Of_Object; + + procedure Set_Is_Shared_Passive (Id : E; V : B := True) is + begin + Set_Flag60 (Id, V); + end Set_Is_Shared_Passive; + + procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Exception + or else Ekind (Id) = E_Variable + or else Ekind (Id) = E_Constant + or else Is_Type (Id) + or else Ekind (Id) = E_Void); + Set_Flag28 (Id, V); + end Set_Is_Statically_Allocated; + + procedure Set_Is_Tag (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag78 (Id, V); + end Set_Is_Tag; + + procedure Set_Is_Tagged_Type (Id : E; V : B := True) is + begin + Set_Flag55 (Id, V); + end Set_Is_Tagged_Type; + + procedure Set_Is_True_Constant (Id : E; V : B := True) is + begin + Set_Flag163 (Id, V); + end Set_Is_True_Constant; + + procedure Set_Is_Unchecked_Union (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag117 (Id, V); + end Set_Is_Unchecked_Union; + + procedure Set_Is_Unsigned_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Discrete_Or_Fixed_Point_Type (Id)); + Set_Flag144 (Id, V); + end Set_Is_Unsigned_Type; + + procedure Set_Is_Valued_Procedure (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Flag127 (Id, V); + end Set_Is_Valued_Procedure; + + procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True) is + begin + pragma Assert (Is_Child_Unit (Id)); + Set_Flag116 (Id, V); + end Set_Is_Visible_Child_Unit; + + procedure Set_Is_VMS_Exception (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Exception); + Set_Flag133 (Id, V); + end Set_Is_VMS_Exception; + + procedure Set_Is_Volatile (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag16 (Id, V); + end Set_Is_Volatile; + + procedure Set_Last_Entity (Id : E; V : E) is + begin + Set_Node20 (Id, V); + end Set_Last_Entity; + + procedure Set_Lit_Indexes (Id : E; V : E) is + begin + pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id); + Set_Node15 (Id, V); + end Set_Lit_Indexes; + + procedure Set_Lit_Strings (Id : E; V : E) is + begin + pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id); + Set_Node16 (Id, V); + end Set_Lit_Strings; + + procedure Set_Machine_Radix_10 (Id : E; V : B := True) is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + Set_Flag84 (Id, V); + end Set_Machine_Radix_10; + + procedure Set_Master_Id (Id : E; V : E) is + begin + Set_Node17 (Id, V); + end Set_Master_Id; + + procedure Set_Materialize_Entity (Id : E; V : B := True) is + begin + Set_Flag168 (Id, V); + end Set_Materialize_Entity; + + procedure Set_Mechanism (Id : E; V : M) is + begin + pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id)); + Set_Uint8 (Id, UI_From_Int (V)); + end Set_Mechanism; + + procedure Set_Modulus (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Modular_Integer_Type); + Set_Uint17 (Id, V); + end Set_Modulus; + + procedure Set_Needs_Debug_Info (Id : E; V : B := True) is + begin + Set_Flag147 (Id, V); + end Set_Needs_Debug_Info; + + procedure Set_Needs_No_Actuals (Id : E; V : B := True) is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind (Id) = E_Subprogram_Type + or else Ekind (Id) = E_Entry_Family); + Set_Flag22 (Id, V); + end Set_Needs_No_Actuals; + + procedure Set_Next_Inlined_Subprogram (Id : E; V : E) is + begin + Set_Node12 (Id, V); + end Set_Next_Inlined_Subprogram; + + procedure Set_No_Pool_Assigned (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id) and then Root_Type (Id) = Id); + Set_Flag131 (Id, V); + end Set_No_Pool_Assigned; + + procedure Set_No_Return (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Generic_Procedure); + Set_Flag113 (Id, V); + end Set_No_Return; + + procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Modular_Integer_Type); + Set_Flag58 (Id, V); + end Set_Non_Binary_Modulus; + + procedure Set_Nonzero_Is_True (Id : E; V : B := True) is + begin + pragma Assert + (Root_Type (Id) = Standard_Boolean + and then Ekind (Id) = E_Enumeration_Type); + Set_Flag162 (Id, V); + end Set_Nonzero_Is_True; + + procedure Set_Normalized_First_Bit (Id : E; V : U) is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + Set_Uint8 (Id, V); + end Set_Normalized_First_Bit; + + procedure Set_Normalized_Position (Id : E; V : U) is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + Set_Uint9 (Id, V); + end Set_Normalized_Position; + + procedure Set_Normalized_Position_Max (Id : E; V : U) is + begin + pragma Assert + (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + Set_Uint10 (Id, V); + end Set_Normalized_Position_Max; + + procedure Set_Not_Source_Assigned (Id : E; V : B := True) is + begin + Set_Flag115 (Id, V); + end Set_Not_Source_Assigned; + + procedure Set_Object_Ref (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Protected_Body); + Set_Node17 (Id, V); + end Set_Object_Ref; + + procedure Set_Original_Record_Component (Id : E; V : E) is + begin + Set_Node22 (Id, V); + end Set_Original_Record_Component; + + procedure Set_Packed_Array_Type (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id)); + Set_Node23 (Id, V); + end Set_Packed_Array_Type; + + procedure Set_Parent_Subtype (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + Set_Node19 (Id, V); + end Set_Parent_Subtype; + + procedure Set_Primitive_Operations (Id : E; V : L) is + begin + pragma Assert (Is_Tagged_Type (Id)); + Set_Elist15 (Id, V); + end Set_Primitive_Operations; + + procedure Set_Prival (Id : E; V : E) is + begin + pragma Assert (Is_Protected_Private (Id)); + Set_Node17 (Id, V); + end Set_Prival; + + procedure Set_Privals_Chain (Id : E; V : L) is + begin + pragma Assert (Is_Overloadable (Id) + or else Ekind (Id) = E_Entry_Family); + Set_Elist23 (Id, V); + end Set_Privals_Chain; + + procedure Set_Private_Dependents (Id : E; V : L) is + begin + pragma Assert (Is_Incomplete_Or_Private_Type (Id)); + Set_Elist18 (Id, V); + end Set_Private_Dependents; + + procedure Set_Private_View (Id : E; V : N) is + begin + pragma Assert (Is_Private_Type (Id)); + Set_Node22 (Id, V); + end Set_Private_View; + + procedure Set_Protected_Body_Subprogram (Id : E; V : E) is + begin + pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id)); + Set_Node11 (Id, V); + end Set_Protected_Body_Subprogram; + + procedure Set_Protected_Formal (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id)); + Set_Node22 (Id, V); + end Set_Protected_Formal; + + procedure Set_Protected_Operation (Id : E; V : N) is + begin + pragma Assert (Is_Protected_Private (Id)); + Set_Node23 (Id, V); + end Set_Protected_Operation; + + procedure Set_Reachable (Id : E; V : B := True) is + begin + Set_Flag49 (Id, V); + end Set_Reachable; + + procedure Set_Referenced (Id : E; V : B := True) is + begin + Set_Flag156 (Id, V); + end Set_Referenced; + + procedure Set_Referenced_Object (Id : E; V : N) is + begin + pragma Assert (Is_Type (Id)); + Set_Node10 (Id, V); + end Set_Referenced_Object; + + procedure Set_Register_Exception_Call (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Exception); + Set_Node20 (Id, V); + end Set_Register_Exception_Call; + + procedure Set_Related_Array_Object (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id)); + Set_Node19 (Id, V); + end Set_Related_Array_Object; + + procedure Set_Related_Instance (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Node15 (Id, V); + end Set_Related_Instance; + + procedure Set_Renamed_Entity (Id : E; V : N) is + begin + Set_Node18 (Id, V); + end Set_Renamed_Entity; + + procedure Set_Renamed_Object (Id : E; V : N) is + begin + Set_Node18 (Id, V); + end Set_Renamed_Object; + + procedure Set_Renaming_Map (Id : E; V : U) is + begin + Set_Uint9 (Id, V); + end Set_Renaming_Map; + + procedure Set_Return_Present (Id : E; V : B := True) is + begin + Set_Flag54 (Id, V); + end Set_Return_Present; + + procedure Set_Returns_By_Ref (Id : E; V : B := True) is + begin + Set_Flag90 (Id, V); + end Set_Returns_By_Ref; + + procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is + begin + pragma Assert + (Is_Record_Type (Id) and then Id = Base_Type (Id)); + Set_Flag164 (Id, V); + end Set_Reverse_Bit_Order; + + procedure Set_RM_Size (Id : E; V : U) is + begin + pragma Assert (Is_Type (Id)); + Set_Uint13 (Id, V); + end Set_RM_Size; + + procedure Set_Scalar_Range (Id : E; V : N) is + begin + Set_Node20 (Id, V); + end Set_Scalar_Range; + + procedure Set_Scale_Value (Id : E; V : U) is + begin + Set_Uint15 (Id, V); + end Set_Scale_Value; + + procedure Set_Scope_Depth_Value (Id : E; V : U) is + begin + pragma Assert (not Is_Record_Type (Id)); + Set_Uint22 (Id, V); + end Set_Scope_Depth_Value; + + procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True) is + begin + Set_Flag167 (Id, V); + end Set_Sec_Stack_Needed_For_Return; + + procedure Set_Shadow_Entities (Id : E; V : S) is + begin + pragma Assert + (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + Set_List14 (Id, V); + end Set_Shadow_Entities; + + procedure Set_Shared_Var_Assign_Proc (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Node22 (Id, V); + end Set_Shared_Var_Assign_Proc; + + procedure Set_Shared_Var_Read_Proc (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Node15 (Id, V); + end Set_Shared_Var_Read_Proc; + + procedure Set_Size_Check_Code (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + Set_Node9 (Id, V); + end Set_Size_Check_Code; + + procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True) is + begin + Set_Flag177 (Id, V); + end Set_Size_Depends_On_Discriminant; + + procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True) is + begin + Set_Flag92 (Id, V); + end Set_Size_Known_At_Compile_Time; + + procedure Set_Small_Value (Id : E; V : R) is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + Set_Ureal21 (Id, V); + end Set_Small_Value; + + procedure Set_Spec_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); + Set_Node19 (Id, V); + end Set_Spec_Entity; + + procedure Set_Storage_Size_Variable (Id : E; V : E) is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + pragma Assert (Base_Type (Id) = Id); + Set_Node15 (Id, V); + end Set_Storage_Size_Variable; + + procedure Set_Strict_Alignment (Id : E; V : B := True) is + begin + pragma Assert (Base_Type (Id) = Id); + Set_Flag145 (Id, V); + end Set_Strict_Alignment; + + procedure Set_String_Literal_Length (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_String_Literal_Subtype); + Set_Uint16 (Id, V); + end Set_String_Literal_Length; + + procedure Set_String_Literal_Low_Bound (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_String_Literal_Subtype); + Set_Node15 (Id, V); + end Set_String_Literal_Low_Bound; + + procedure Set_Suppress_Access_Checks (Id : E; V : B := True) is + begin + Set_Flag31 (Id, V); + end Set_Suppress_Access_Checks; + + procedure Set_Suppress_Accessibility_Checks (Id : E; V : B := True) is + begin + Set_Flag32 (Id, V); + end Set_Suppress_Accessibility_Checks; + + procedure Set_Suppress_Discriminant_Checks (Id : E; V : B := True) is + begin + Set_Flag33 (Id, V); + end Set_Suppress_Discriminant_Checks; + + procedure Set_Suppress_Division_Checks (Id : E; V : B := True) is + begin + Set_Flag34 (Id, V); + end Set_Suppress_Division_Checks; + + procedure Set_Suppress_Elaboration_Checks (Id : E; V : B := True) is + begin + Set_Flag35 (Id, V); + end Set_Suppress_Elaboration_Checks; + + procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is + begin + Set_Flag148 (Id, V); + end Set_Suppress_Elaboration_Warnings; + + procedure Set_Suppress_Index_Checks (Id : E; V : B := True) is + begin + Set_Flag36 (Id, V); + end Set_Suppress_Index_Checks; + + procedure Set_Suppress_Init_Proc (Id : E; V : B := True) is + begin + Set_Flag105 (Id, V); + end Set_Suppress_Init_Proc; + + procedure Set_Suppress_Length_Checks (Id : E; V : B := True) is + begin + Set_Flag37 (Id, V); + end Set_Suppress_Length_Checks; + + procedure Set_Suppress_Overflow_Checks (Id : E; V : B := True) is + begin + Set_Flag38 (Id, V); + end Set_Suppress_Overflow_Checks; + + procedure Set_Suppress_Range_Checks (Id : E; V : B := True) is + begin + Set_Flag39 (Id, V); + end Set_Suppress_Range_Checks; + + procedure Set_Suppress_Storage_Checks (Id : E; V : B := True) is + begin + Set_Flag40 (Id, V); + end Set_Suppress_Storage_Checks; + + procedure Set_Suppress_Style_Checks (Id : E; V : B := True) is + begin + Set_Flag165 (Id, V); + end Set_Suppress_Style_Checks; + + procedure Set_Suppress_Tag_Checks (Id : E; V : B := True) is + begin + Set_Flag41 (Id, V); + end Set_Suppress_Tag_Checks; + + procedure Set_Underlying_Full_View (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) in Private_Kind); + Set_Node19 (Id, V); + end Set_Underlying_Full_View; + + procedure Set_Unset_Reference (Id : E; V : N) is + begin + Set_Node16 (Id, V); + end Set_Unset_Reference; + + procedure Set_Uses_Sec_Stack (Id : E; V : B := True) is + begin + Set_Flag95 (Id, V); + end Set_Uses_Sec_Stack; + + procedure Set_Vax_Float (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag151 (Id, V); + end Set_Vax_Float; + + procedure Set_Warnings_Off (Id : E; V : B := True) is + begin + Set_Flag96 (Id, V); + end Set_Warnings_Off; + + ----------------------------------- + -- Field Initialization Routines -- + ----------------------------------- + + procedure Init_Alignment (Id : E) is + begin + Set_Uint14 (Id, Uint_0); + end Init_Alignment; + + procedure Init_Alignment (Id : E; V : Int) is + begin + Set_Uint14 (Id, UI_From_Int (V)); + end Init_Alignment; + + procedure Init_Component_Bit_Offset (Id : E) is + begin + Set_Uint11 (Id, No_Uint); + end Init_Component_Bit_Offset; + + procedure Init_Component_Bit_Offset (Id : E; V : Int) is + begin + Set_Uint11 (Id, UI_From_Int (V)); + end Init_Component_Bit_Offset; + + procedure Init_Component_Size (Id : E) is + begin + Set_Uint22 (Id, Uint_0); + end Init_Component_Size; + + procedure Init_Component_Size (Id : E; V : Int) is + begin + Set_Uint22 (Id, UI_From_Int (V)); + end Init_Component_Size; + + procedure Init_Digits_Value (Id : E) is + begin + Set_Uint17 (Id, Uint_0); + end Init_Digits_Value; + + procedure Init_Digits_Value (Id : E; V : Int) is + begin + Set_Uint17 (Id, UI_From_Int (V)); + end Init_Digits_Value; + + procedure Init_Esize (Id : E) is + begin + Set_Uint12 (Id, Uint_0); + end Init_Esize; + + procedure Init_Esize (Id : E; V : Int) is + begin + Set_Uint12 (Id, UI_From_Int (V)); + end Init_Esize; + + procedure Init_Normalized_First_Bit (Id : E) is + begin + Set_Uint8 (Id, No_Uint); + end Init_Normalized_First_Bit; + + procedure Init_Normalized_First_Bit (Id : E; V : Int) is + begin + Set_Uint8 (Id, UI_From_Int (V)); + end Init_Normalized_First_Bit; + + procedure Init_Normalized_Position (Id : E) is + begin + Set_Uint9 (Id, No_Uint); + end Init_Normalized_Position; + + procedure Init_Normalized_Position (Id : E; V : Int) is + begin + Set_Uint9 (Id, UI_From_Int (V)); + end Init_Normalized_Position; + + procedure Init_Normalized_Position_Max (Id : E) is + begin + Set_Uint10 (Id, No_Uint); + end Init_Normalized_Position_Max; + + procedure Init_Normalized_Position_Max (Id : E; V : Int) is + begin + Set_Uint10 (Id, UI_From_Int (V)); + end Init_Normalized_Position_Max; + + procedure Init_RM_Size (Id : E) is + begin + Set_Uint13 (Id, Uint_0); + end Init_RM_Size; + + procedure Init_RM_Size (Id : E; V : Int) is + begin + Set_Uint13 (Id, UI_From_Int (V)); + end Init_RM_Size; + + ----------------------------- + -- Init_Component_Location -- + ----------------------------- + + procedure Init_Component_Location (Id : E) is + begin + Set_Uint8 (Id, No_Uint); -- Normalized_First_Bit + Set_Uint9 (Id, No_Uint); -- Normalized_Position + Set_Uint11 (Id, No_Uint); -- Component_First_Bit + Set_Uint12 (Id, Uint_0); -- Esize + Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max + end Init_Component_Location; + + --------------- + -- Init_Size -- + --------------- + + procedure Init_Size (Id : E; V : Int) is + begin + Set_Uint12 (Id, UI_From_Int (V)); -- Esize + Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size + end Init_Size; + + --------------------- + -- Init_Size_Align -- + --------------------- + + procedure Init_Size_Align (Id : E) is + begin + Set_Uint12 (Id, Uint_0); -- Esize + Set_Uint13 (Id, Uint_0); -- RM_Size + Set_Uint14 (Id, Uint_0); -- Alignment + end Init_Size_Align; + + ---------------------------------------------- + -- Type Representation Attribute Predicates -- + ---------------------------------------------- + + function Known_Alignment (E : Entity_Id) return B is + begin + return Uint14 (E) /= Uint_0; + end Known_Alignment; + + function Known_Component_Bit_Offset (E : Entity_Id) return B is + begin + return Uint11 (E) /= No_Uint; + end Known_Component_Bit_Offset; + + function Known_Component_Size (E : Entity_Id) return B is + begin + return Uint22 (Base_Type (E)) /= Uint_0; + end Known_Component_Size; + + function Known_Esize (E : Entity_Id) return B is + begin + return Uint12 (E) /= Uint_0; + end Known_Esize; + + function Known_Normalized_First_Bit (E : Entity_Id) return B is + begin + return Uint8 (E) /= No_Uint; + end Known_Normalized_First_Bit; + + function Known_Normalized_Position (E : Entity_Id) return B is + begin + return Uint9 (E) /= No_Uint; + end Known_Normalized_Position; + + function Known_Normalized_Position_Max (E : Entity_Id) return B is + begin + return Uint10 (E) /= No_Uint; + end Known_Normalized_Position_Max; + + function Known_RM_Size (E : Entity_Id) return B is + begin + return Uint13 (E) /= Uint_0 + or else Is_Discrete_Type (E); + end Known_RM_Size; + + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is + begin + return Uint11 (E) /= No_Uint + and then Uint11 (E) >= Uint_0; + end Known_Static_Component_Bit_Offset; + + function Known_Static_Component_Size (E : Entity_Id) return B is + begin + return Uint22 (Base_Type (E)) > Uint_0; + end Known_Static_Component_Size; + + function Known_Static_Esize (E : Entity_Id) return B is + begin + return Uint12 (E) > Uint_0; + end Known_Static_Esize; + + function Known_Static_Normalized_Position (E : Entity_Id) return B is + begin + return Uint9 (E) /= No_Uint + and then Uint9 (E) >= Uint_0; + end Known_Static_Normalized_Position; + + function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is + begin + return Uint10 (E) /= No_Uint + and then Uint10 (E) >= Uint_0; + end Known_Static_Normalized_Position_Max; + + function Known_Static_RM_Size (E : Entity_Id) return B is + begin + return Uint13 (E) > Uint_0 + or else Is_Discrete_Type (E); + end Known_Static_RM_Size; + + function Unknown_Alignment (E : Entity_Id) return B is + begin + return Uint14 (E) = Uint_0; + end Unknown_Alignment; + + function Unknown_Component_Bit_Offset (E : Entity_Id) return B is + begin + return Uint11 (E) = No_Uint; + end Unknown_Component_Bit_Offset; + + function Unknown_Component_Size (E : Entity_Id) return B is + begin + return Uint22 (Base_Type (E)) = Uint_0; + end Unknown_Component_Size; + + function Unknown_Esize (E : Entity_Id) return B is + begin + return Uint12 (E) = Uint_0; + end Unknown_Esize; + + function Unknown_Normalized_First_Bit (E : Entity_Id) return B is + begin + return Uint8 (E) = No_Uint; + end Unknown_Normalized_First_Bit; + + function Unknown_Normalized_Position (E : Entity_Id) return B is + begin + return Uint9 (E) = No_Uint; + end Unknown_Normalized_Position; + + function Unknown_Normalized_Position_Max (E : Entity_Id) return B is + begin + return Uint10 (E) = No_Uint; + end Unknown_Normalized_Position_Max; + + function Unknown_RM_Size (E : Entity_Id) return B is + begin + return Uint13 (E) = Uint_0 + and then not Is_Discrete_Type (E); + end Unknown_RM_Size; + + -------------------- + -- Address_Clause -- + -------------------- + + function Address_Clause (Id : E) return N is + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Attribute_Definition_Clause + and then Chars (Ritem) = Name_Address + then + return Ritem; + else + Ritem := Next_Rep_Item (Ritem); + end if; + end loop; + + return Empty; + end Address_Clause; + + ---------------------- + -- Alignment_Clause -- + ---------------------- + + function Alignment_Clause (Id : E) return N is + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Attribute_Definition_Clause + and then Chars (Ritem) = Name_Alignment + then + return Ritem; + else + Ritem := Next_Rep_Item (Ritem); + end if; + end loop; + + return Empty; + end Alignment_Clause; + + ---------------------- + -- Ancestor_Subtype -- + ---------------------- + + function Ancestor_Subtype (Id : E) return E is + begin + -- If this is first subtype, or is a base type, then there is no + -- ancestor subtype, so we return Empty to indicate this fact. + + if Is_First_Subtype (Id) + or else Id = Base_Type (Id) + then + return Empty; + end if; + + declare + D : constant Node_Id := Declaration_Node (Id); + + begin + -- If we have a subtype declaration, get the ancestor subtype + + if Nkind (D) = N_Subtype_Declaration then + if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then + return Entity (Subtype_Mark (Subtype_Indication (D))); + else + return Entity (Subtype_Indication (D)); + end if; + + -- If not, then no subtype indication is available + + else + return Empty; + end if; + end; + end Ancestor_Subtype; + + ------------------- + -- Append_Entity -- + ------------------- + + procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is + begin + if Last_Entity (V) = Empty then + Set_First_Entity (V, Id); + else + Set_Next_Entity (Last_Entity (V), Id); + end if; + + Set_Next_Entity (Id, Empty); + Set_Scope (Id, V); + Set_Last_Entity (V, Id); + end Append_Entity; + + --------------- + -- Base_Type -- + --------------- + + function Base_Type (Id : E) return E is + begin + case Ekind (Id) is + when E_Enumeration_Subtype | + E_Signed_Integer_Subtype | + E_Modular_Integer_Subtype | + E_Floating_Point_Subtype | + E_Ordinary_Fixed_Point_Subtype | + E_Decimal_Fixed_Point_Subtype | + E_Array_Subtype | + E_String_Subtype | + E_Record_Subtype | + E_Private_Subtype | + E_Record_Subtype_With_Private | + E_Limited_Private_Subtype | + E_Access_Subtype | + E_Protected_Subtype | + E_Task_Subtype | + E_String_Literal_Subtype | + E_Class_Wide_Subtype => + return Etype (Id); + + when E_Incomplete_Type => + if Present (Etype (Id)) then + return Etype (Id); + else + return Id; + end if; + + when others => + return Id; + end case; + end Base_Type; + + ------------------------- + -- Component_Alignment -- + ------------------------- + + -- Component Alignment is encoded using two flags, Flag128/129 as + -- follows. Note that both flags False = Align_Default, so that the + -- default initialization of flags to False initializes component + -- alignment to the default value as required. + + -- Flag128 Flag129 Value + -- ------- ------- ----- + -- False False Calign_Default + -- False True Calign_Component_Size + -- True False Calign_Component_Size_4 + -- True True Calign_Storage_Unit + + function Component_Alignment (Id : E) return C is + BT : Node_Id := Base_Type (Id); + + begin + pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); + + if Flag128 (BT) then + if Flag129 (BT) then + return Calign_Storage_Unit; + else + return Calign_Component_Size_4; + end if; + + else + if Flag129 (BT) then + return Calign_Component_Size; + else + return Calign_Default; + end if; + end if; + end Component_Alignment; + + -------------------- + -- Constant_Value -- + -------------------- + + function Constant_Value (Id : E) return N is + D : constant Node_Id := Declaration_Node (Id); + Full_D : Node_Id; + + begin + -- If we have no declaration node, then return no constant value. + -- Not clear how this can happen, but it does sometimes ??? + -- To investigate, remove this check and compile discrim_po.adb. + + if No (D) then + return Empty; + + -- Normal case where a declaration node is present + + elsif Nkind (D) = N_Object_Renaming_Declaration then + return Renamed_Object (Id); + + -- If this is a component declaration whose entity is constant, it + -- is a prival within a protected function. It does not have + -- a constant value. + + elsif Nkind (D) = N_Component_Declaration then + return Empty; + + else + if Present (Expression (D)) then + return (Expression (D)); + + elsif Present (Full_View (Id)) then + Full_D := Parent (Full_View (Id)); + + -- The full view may have been rewritten as an object renaming. + + if Nkind (Full_D) = N_Object_Renaming_Declaration then + return Name (Full_D); + else + return Expression (Full_D); + end if; + else + return Empty; + end if; + end if; + end Constant_Value; + + ---------------------- + -- Declaration_Node -- + ---------------------- + + function Declaration_Node (Id : E) return N is + P : Node_Id; + + begin + if Ekind (Id) = E_Incomplete_Type + and then Present (Full_View (Id)) + then + P := Parent (Full_View (Id)); + else + P := Parent (Id); + end if; + + loop + if Nkind (P) /= N_Selected_Component + and then Nkind (P) /= N_Expanded_Name + and then + not (Nkind (P) = N_Defining_Program_Unit_Name + and then Is_Child_Unit (Id)) + then + return P; + else + P := Parent (P); + end if; + end loop; + + end Declaration_Node; + + --------------------- + -- Designated_Type -- + --------------------- + + function Designated_Type (Id : E) return E is + Desig_Type : E; + + begin + Desig_Type := Directly_Designated_Type (Id); + + if (Ekind (Desig_Type) = E_Incomplete_Type + and then Present (Full_View (Desig_Type))) + then + return Full_View (Desig_Type); + + elsif Is_Class_Wide_Type (Desig_Type) + and then Ekind (Etype (Desig_Type)) = E_Incomplete_Type + and then Present (Full_View (Etype (Desig_Type))) + and then Present (Class_Wide_Type (Full_View (Etype (Desig_Type)))) + then + return Class_Wide_Type (Full_View (Etype (Desig_Type))); + + else + return Desig_Type; + end if; + end Designated_Type; + + ----------------------------- + -- Enclosing_Dynamic_Scope -- + ----------------------------- + + function Enclosing_Dynamic_Scope (Id : E) return E is + S : Entity_Id; + + begin + S := Scope (Id); + while S /= Standard_Standard + and then not Is_Dynamic_Scope (S) + loop + S := Scope (S); + end loop; + + return S; + end Enclosing_Dynamic_Scope; + + ---------------------- + -- Entry_Index_Type -- + ---------------------- + + function Entry_Index_Type (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Entry_Family); + return Etype (Discrete_Subtype_Definition (Parent (Id))); + end Entry_Index_Type; + + --------------------- + -- First_Component -- + --------------------- + + function First_Component (Id : E) return E is + Comp_Id : E; + + begin + pragma Assert + (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); + + Comp_Id := First_Entity (Id); + + while Present (Comp_Id) loop + exit when Ekind (Comp_Id) = E_Component; + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end First_Component; + + ------------------------ + -- First_Discriminant -- + ------------------------ + + function First_Discriminant (Id : E) return E is + Ent : Entity_Id; + + begin + pragma Assert + (Has_Discriminants (Id) + or else Has_Unknown_Discriminants (Id)); + + Ent := First_Entity (Id); + + -- The discriminants are not necessarily contiguous, because access + -- discriminants will generate itypes. They are not the first entities + -- either, because tag and controller record must be ahead of them. + + if Chars (Ent) = Name_uTag then + Ent := Next_Entity (Ent); + end if; + + if Chars (Ent) = Name_uController then + Ent := Next_Entity (Ent); + end if; + + -- Skip all hidden girder discriminants if any. + + while Present (Ent) loop + exit when Ekind (Ent) = E_Discriminant + and then not Is_Completely_Hidden (Ent); + + Ent := Next_Entity (Ent); + end loop; + + pragma Assert (Ekind (Ent) = E_Discriminant); + + return Ent; + end First_Discriminant; + + ------------------ + -- First_Formal -- + ------------------ + + function First_Formal (Id : E) return E is + Formal : E; + + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind (Id) = E_Entry_Family + or else Ekind (Id) = E_Subprogram_Body + or else Ekind (Id) = E_Subprogram_Type); + + if Ekind (Id) = E_Enumeration_Literal then + return Empty; + + else + Formal := First_Entity (Id); + + if Present (Formal) and then Is_Formal (Formal) then + return Formal; + else + return Empty; + end if; + end if; + end First_Formal; + + ------------------------------- + -- First_Girder_Discriminant -- + ------------------------------- + + function First_Girder_Discriminant (Id : E) return E is + Ent : Entity_Id; + + function Has_Completely_Hidden_Discriminant (Id : E) return Boolean; + -- Scans the Discriminants to see whether any are Completely_Hidden + -- (the mechanism for describing non-specified girder discriminants) + + function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is + Ent : Entity_Id := Id; + + begin + pragma Assert (Ekind (Id) = E_Discriminant); + + while Present (Ent) and then Ekind (Ent) = E_Discriminant loop + + if Is_Completely_Hidden (Ent) then + return True; + end if; + + Ent := Next_Entity (Ent); + end loop; + + return False; + end Has_Completely_Hidden_Discriminant; + + -- Start of processing for First_Girder_Discriminant + + begin + pragma Assert + (Has_Discriminants (Id) + or else Has_Unknown_Discriminants (Id)); + + Ent := First_Entity (Id); + + if Chars (Ent) = Name_uTag then + Ent := Next_Entity (Ent); + end if; + + if Chars (Ent) = Name_uController then + Ent := Next_Entity (Ent); + end if; + + if Has_Completely_Hidden_Discriminant (Ent) then + + while Present (Ent) loop + exit when Is_Completely_Hidden (Ent); + Ent := Next_Entity (Ent); + end loop; + + end if; + + pragma Assert (Ekind (Ent) = E_Discriminant); + + return Ent; + end First_Girder_Discriminant; + + ------------------- + -- First_Subtype -- + ------------------- + + function First_Subtype (Id : E) return E is + B : constant Entity_Id := Base_Type (Id); + F : constant Node_Id := Freeze_Node (B); + Ent : Entity_Id; + + begin + -- If the base type has no freeze node, it is a type in standard, + -- and always acts as its own first subtype unless it is one of + -- the predefined integer types. If the type is formal, it is also + -- a first subtype, and its base type has no freeze node. On the other + -- hand, a subtype of a generic formal is not its own first_subtype. + -- Its base type, if anonymous, is attached to the formal type decl. + -- from which the first subtype is obtained. + + if No (F) then + + if B = Base_Type (Standard_Integer) then + return Standard_Integer; + + elsif B = Base_Type (Standard_Long_Integer) then + return Standard_Long_Integer; + + elsif B = Base_Type (Standard_Short_Short_Integer) then + return Standard_Short_Short_Integer; + + elsif B = Base_Type (Standard_Short_Integer) then + return Standard_Short_Integer; + + elsif B = Base_Type (Standard_Long_Long_Integer) then + return Standard_Long_Long_Integer; + + elsif Is_Generic_Type (Id) then + if Present (Parent (B)) then + return Defining_Identifier (Parent (B)); + else + return Defining_Identifier (Associated_Node_For_Itype (B)); + end if; + + else + return B; + end if; + + -- Otherwise we check the freeze node, if it has a First_Subtype_Link + -- then we use that link, otherwise (happens with some Itypes), we use + -- the base type itself. + + else + Ent := First_Subtype_Link (F); + + if Present (Ent) then + return Ent; + else + return B; + end if; + end if; + end First_Subtype; + + ------------------------ + -- Has_Attach_Handler -- + ------------------------ + + function Has_Attach_Handler (Id : E) return B is + Ritem : Node_Id; + + begin + pragma Assert (Is_Protected_Type (Id)); + + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Chars (Ritem) = Name_Attach_Handler + then + return True; + else + Ritem := Next_Rep_Item (Ritem); + end if; + end loop; + + return False; + end Has_Attach_Handler; + + ----------------- + -- Has_Entries -- + ----------------- + + function Has_Entries (Id : E) return B is + Result : Boolean := False; + Ent : Entity_Id; + + begin + pragma Assert (Is_Concurrent_Type (Id)); + Ent := First_Entity (Id); + + while Present (Ent) loop + if Is_Entry (Ent) then + Result := True; + exit; + end if; + + Ent := Next_Entity (Ent); + end loop; + + return Result; + end Has_Entries; + + ---------------------------- + -- Has_Foreign_Convention -- + ---------------------------- + + function Has_Foreign_Convention (Id : E) return B is + begin + return Convention (Id) >= Foreign_Convention'First; + end Has_Foreign_Convention; + + --------------------------- + -- Has_Interrupt_Handler -- + --------------------------- + + function Has_Interrupt_Handler (Id : E) return B is + Ritem : Node_Id; + + begin + pragma Assert (Is_Protected_Type (Id)); + + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Chars (Ritem) = Name_Interrupt_Handler + then + return True; + else + Ritem := Next_Rep_Item (Ritem); + end if; + end loop; + + return False; + end Has_Interrupt_Handler; + + -------------------------- + -- Has_Private_Ancestor -- + -------------------------- + + function Has_Private_Ancestor (Id : E) return B is + R : constant Entity_Id := Root_Type (Id); + T1 : Entity_Id := Id; + + begin + loop + if Is_Private_Type (T1) then + return True; + + elsif T1 = R then + return False; + + else + T1 := Etype (T1); + end if; + end loop; + end Has_Private_Ancestor; + + ------------------------------ + -- Implementation_Base_Type -- + ------------------------------ + + function Implementation_Base_Type (Id : E) return E is + Bastyp : Entity_Id; + Imptyp : Entity_Id; + + begin + Bastyp := Base_Type (Id); + + if Is_Incomplete_Or_Private_Type (Bastyp) then + Imptyp := Underlying_Type (Bastyp); + + -- If we have an implementation type, then just return it, + -- otherwise we return the Base_Type anyway. This can only + -- happen in error situations and should avoid some error bombs. + + if Present (Imptyp) then + return Imptyp; + else + return Bastyp; + end if; + + else + return Bastyp; + end if; + end Implementation_Base_Type; + + ----------------------- + -- Is_Always_Inlined -- + ----------------------- + + function Is_Always_Inlined (Id : E) return B is + Item : Node_Id; + + begin + Item := First_Rep_Item (Id); + + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Get_Pragma_Id (Chars (Item)) = Pragma_Inline_Always + then + return True; + end if; + + Next_Rep_Item (Item); + end loop; + + return False; + end Is_Always_Inlined; + + --------------------- + -- Is_Boolean_Type -- + --------------------- + + function Is_Boolean_Type (Id : E) return B is + begin + return Root_Type (Id) = Standard_Boolean; + end Is_Boolean_Type; + + --------------------- + -- Is_By_Copy_Type -- + --------------------- + + function Is_By_Copy_Type (Id : E) return B is + begin + -- If Id is a private type whose full declaration has not been seen, + -- we assume for now that it is not a By_Copy type. Clearly this + -- attribute should not be used before the type is frozen, but it is + -- needed to build the associated record of a protected type. Another + -- place where some lookahead for a full view is needed ??? + + return + Is_Elementary_Type (Id) + or else (Is_Private_Type (Id) + and then Present (Underlying_Type (Id)) + and then Is_Elementary_Type (Underlying_Type (Id))); + end Is_By_Copy_Type; + + -------------------------- + -- Is_By_Reference_Type -- + -------------------------- + + function Is_By_Reference_Type (Id : E) return B is + Btype : constant Entity_Id := Base_Type (Id); + + begin + if Error_Posted (Id) + or else Error_Posted (Btype) + then + return False; + + elsif Is_Private_Type (Btype) then + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + + begin + if No (Utyp) then + return False; + else + return Is_By_Reference_Type (Utyp); + end if; + end; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + + if Is_Limited_Record (Btype) + or else Is_Tagged_Type (Btype) + or else Is_Volatile (Btype) + then + return True; + + else + declare + C : Entity_Id := First_Component (Btype); + + begin + while Present (C) loop + if Is_By_Reference_Type (Etype (C)) + or else Is_Volatile (Etype (C)) + then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return + Is_Volatile (Btype) + or else Is_By_Reference_Type (Component_Type (Btype)) + or else Is_Volatile (Component_Type (Btype)) + or else Has_Volatile_Components (Btype); + + else + return False; + end if; + end Is_By_Reference_Type; + + --------------------- + -- Is_Derived_Type -- + --------------------- + + function Is_Derived_Type (Id : E) return B is + Par : Node_Id; + + begin + if Base_Type (Id) /= Root_Type (Id) + and then not Is_Generic_Type (Id) + and then not Is_Class_Wide_Type (Id) + then + if not Is_Numeric_Type (Root_Type (Id)) then + return True; + + else + Par := Parent (First_Subtype (Id)); + + return Present (Par) + and then Nkind (Par) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Par)) + = N_Derived_Type_Definition; + end if; + + else + return False; + end if; + end Is_Derived_Type; + + ---------------------- + -- Is_Dynamic_Scope -- + ---------------------- + + function Is_Dynamic_Scope (Id : E) return B is + begin + return + Ekind (Id) = E_Block + or else + Ekind (Id) = E_Function + or else + Ekind (Id) = E_Procedure + or else + Ekind (Id) = E_Subprogram_Body + or else + Ekind (Id) = E_Task_Type + or else + Ekind (Id) = E_Entry + or else + Ekind (Id) = E_Entry_Family; + end Is_Dynamic_Scope; + + -------------------- + -- Is_Entity_Name -- + -------------------- + + function Is_Entity_Name (N : Node_Id) return Boolean is + Kind : constant Node_Kind := Nkind (N); + + begin + -- Identifiers, operator symbols, expanded names are entity names + + return Kind = N_Identifier + or else Kind = N_Operator_Symbol + or else Kind = N_Expanded_Name + + -- Attribute references are entity names if they refer to an entity. + -- Note that we don't do this by testing for the presence of the + -- Entity field in the N_Attribute_Reference node, since it may not + -- have been set yet. + + or else (Kind = N_Attribute_Reference + and then Is_Entity_Attribute_Name (Attribute_Name (N))); + end Is_Entity_Name; + + --------------------------- + -- Is_Indefinite_Subtype -- + --------------------------- + + function Is_Indefinite_Subtype (Id : Entity_Id) return B is + K : constant Entity_Kind := Ekind (Id); + + begin + if Is_Constrained (Id) then + return False; + + elsif K in Array_Kind + or else K in Class_Wide_Kind + or else Has_Unknown_Discriminants (Id) + then + return True; + + -- Known discriminants: indefinite if there are no default values + + elsif K in Record_Kind + or else Is_Incomplete_Or_Private_Type (Id) + or else Is_Concurrent_Type (Id) + then + return (Has_Discriminants (Id) + and then No (Discriminant_Default_Value (First_Discriminant (Id)))); + + else + return False; + end if; + end Is_Indefinite_Subtype; + + --------------------- + -- Is_Limited_Type -- + --------------------- + + function Is_Limited_Type (Id : E) return B is + Btype : constant E := Base_Type (Id); + + begin + if not Is_Type (Id) then + return False; + + elsif Ekind (Btype) = E_Limited_Private_Type + or else Is_Limited_Composite (Btype) + then + return True; + + elsif Is_Concurrent_Type (Btype) then + return True; + + -- Otherwise we will look around to see if there is some other reason + -- for it to be limited, except that if an error was posted on the + -- entity, then just assume it is non-limited, because it can cause + -- trouble to recurse into a murky erroneous entity! + + elsif Error_Posted (Id) then + return False; + + elsif Is_Record_Type (Btype) then + if Is_Limited_Record (Root_Type (Btype)) then + return True; + + elsif Is_Class_Wide_Type (Btype) then + return Is_Limited_Type (Root_Type (Btype)); + + else + declare + C : E := First_Component (Btype); + + begin + while Present (C) loop + if Is_Limited_Type (Etype (C)) then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Limited_Type (Component_Type (Btype)); + + else + return False; + end if; + end Is_Limited_Type; + + ---------------- + -- Is_Package -- + ---------------- + + function Is_Package (Id : E) return B is + begin + return + Ekind (Id) = E_Package + or else + Ekind (Id) = E_Generic_Package; + end Is_Package; + + -------------------------- + -- Is_Protected_Private -- + -------------------------- + + function Is_Protected_Private (Id : E) return B is + + begin + pragma Assert (Ekind (Id) = E_Component); + return Is_Protected_Type (Scope (Id)); + end Is_Protected_Private; + + ------------------------------ + -- Is_Protected_Record_Type -- + ------------------------------ + + function Is_Protected_Record_Type (Id : E) return B is + begin + return + Is_Concurrent_Record_Type (Id) + and then Is_Protected_Type (Corresponding_Concurrent_Type (Id)); + end Is_Protected_Record_Type; + + --------------------------------- + -- Is_Return_By_Reference_Type -- + --------------------------------- + + function Is_Return_By_Reference_Type (Id : E) return B is + Btype : constant Entity_Id := Base_Type (Id); + + begin + if Is_Private_Type (Btype) then + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + + begin + if No (Utyp) then + return False; + else + return Is_Return_By_Reference_Type (Utyp); + end if; + end; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + if Is_Limited_Record (Btype) then + return True; + + elsif Is_Class_Wide_Type (Btype) then + return Is_Return_By_Reference_Type (Root_Type (Btype)); + + else + declare + C : Entity_Id := First_Component (Btype); + + begin + while Present (C) loop + if Is_Return_By_Reference_Type (Etype (C)) then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Return_By_Reference_Type (Component_Type (Btype)); + + else + return False; + end if; + end Is_Return_By_Reference_Type; + + -------------------- + -- Is_String_Type -- + -------------------- + + function Is_String_Type (Id : E) return B is + begin + return Ekind (Id) in String_Kind + or else (Is_Array_Type (Id) + and then Number_Dimensions (Id) = 1 + and then Is_Character_Type (Component_Type (Id))); + end Is_String_Type; + + ------------------------- + -- Is_Task_Record_Type -- + ------------------------- + + function Is_Task_Record_Type (Id : E) return B is + begin + return + Is_Concurrent_Record_Type (Id) + and then Is_Task_Type (Corresponding_Concurrent_Type (Id)); + end Is_Task_Record_Type; + + ------------------------ + -- Is_Wrapper_Package -- + ------------------------ + + function Is_Wrapper_Package (Id : E) return B is + begin + return (Ekind (Id) = E_Package + and then Present (Related_Instance (Id))); + end Is_Wrapper_Package; + + -------------------- + -- Next_Component -- + -------------------- + + function Next_Component (Id : E) return E is + Comp_Id : E; + + begin + Comp_Id := Next_Entity (Id); + + while Present (Comp_Id) loop + exit when Ekind (Comp_Id) = E_Component; + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end Next_Component; + + ----------------------- + -- Next_Discriminant -- + ----------------------- + + -- This function actually implements both Next_Discriminant and + -- Next_Girder_Discriminant by making sure that the Discriminant + -- returned is of the same variety as Id. + + function Next_Discriminant (Id : E) return E is + + -- Derived Tagged types with private extensions look like this... + -- + -- E_Discriminant d1 + -- E_Discriminant d2 + -- E_Component _tag + -- E_Discriminant d1 + -- E_Discriminant d2 + -- ... + -- so it is critical not to go past the leading discriminants. + + D : E := Id; + + begin + pragma Assert (Ekind (Id) = E_Discriminant); + + loop + D := Next_Entity (D); + if not Present (D) + or else (Ekind (D) /= E_Discriminant + and then not Is_Itype (D)) + then + return Empty; + end if; + + exit when Ekind (D) = E_Discriminant + and then (Is_Completely_Hidden (D) = Is_Completely_Hidden (Id)); + end loop; + + return D; + end Next_Discriminant; + + ----------------- + -- Next_Formal -- + ----------------- + + function Next_Formal (Id : E) return E is + P : E; + + begin + -- Follow the chain of declared entities as long as the kind of + -- the entity corresponds to a formal parameter. Skip internal + -- entities that may have been created for implicit subtypes, + -- in the process of analyzing default expressions. + + P := Id; + + loop + P := Next_Entity (P); + + if No (P) or else Is_Formal (P) then + return P; + elsif not Is_Internal (P) then + return Empty; + end if; + end loop; + end Next_Formal; + + ----------------------------- + -- Next_Formal_With_Extras -- + ----------------------------- + + function Next_Formal_With_Extras (Id : E) return E is + begin + if Present (Extra_Formal (Id)) then + return Extra_Formal (Id); + + else + return Next_Formal (Id); + end if; + end Next_Formal_With_Extras; + + ------------------------------ + -- Next_Girder_Discriminant -- + ------------------------------ + + function Next_Girder_Discriminant (Id : E) return E is + begin + -- See comment in Next_Discriminant + + return Next_Discriminant (Id); + end Next_Girder_Discriminant; + + ---------------- + -- Next_Index -- + ---------------- + + function Next_Index (Id : Node_Id) return Node_Id is + begin + return Next (Id); + end Next_Index; + + ------------------ + -- Next_Literal -- + ------------------ + + function Next_Literal (Id : E) return E is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Next (Id); + end Next_Literal; + + ----------------------- + -- Number_Dimensions -- + ----------------------- + + function Number_Dimensions (Id : E) return Pos is + N : Int; + T : Node_Id; + + begin + if Ekind (Id) in String_Kind then + return 1; + + else + N := 0; + T := First_Index (Id); + + while Present (T) loop + N := N + 1; + T := Next (T); + end loop; + + return N; + end if; + end Number_Dimensions; + + -------------------------- + -- Number_Discriminants -- + -------------------------- + + function Number_Discriminants (Id : E) return Pos is + N : Int; + Discr : Entity_Id; + + begin + N := 0; + Discr := First_Discriminant (Id); + + while Present (Discr) loop + N := N + 1; + Discr := Next_Discriminant (Discr); + end loop; + + return N; + end Number_Discriminants; + + -------------------- + -- Number_Entries -- + -------------------- + + function Number_Entries (Id : E) return Nat is + N : Int; + Ent : Entity_Id; + + begin + pragma Assert (Is_Concurrent_Type (Id)); + N := 0; + Ent := First_Entity (Id); + + while Present (Ent) loop + if Is_Entry (Ent) then + N := N + 1; + end if; + + Ent := Next_Entity (Ent); + end loop; + + return N; + end Number_Entries; + + -------------------- + -- Number_Formals -- + -------------------- + + function Number_Formals (Id : E) return Pos is + N : Int; + Formal : Entity_Id; + + begin + N := 0; + Formal := First_Formal (Id); + + while Present (Formal) loop + N := N + 1; + Formal := Next_Formal (Formal); + end loop; + + return N; + end Number_Formals; + + -------------------- + -- Parameter_Mode -- + -------------------- + + function Parameter_Mode (Id : E) return Formal_Kind is + begin + return Ekind (Id); + end Parameter_Mode; + + --------------- + -- Root_Type -- + --------------- + + function Root_Type (Id : E) return E is + T, Etyp : E; + + begin + pragma Assert (Nkind (Id) in N_Entity); + + T := Base_Type (Id); + + if Ekind (T) = E_Class_Wide_Type then + return Etype (T); + + -- All other cases + + else + loop + Etyp := Etype (T); + + if T = Etyp then + return T; + + elsif Is_Private_Type (T) and then Etyp = Full_View (T) then + return T; + + elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then + return T; + end if; + + T := Etyp; + end loop; + end if; + + raise Program_Error; + end Root_Type; + + ----------------- + -- Scope_Depth -- + ----------------- + + function Scope_Depth (Id : E) return Uint is + Scop : Entity_Id := Id; + + begin + while Is_Record_Type (Scop) loop + Scop := Scope (Scop); + end loop; + + return Scope_Depth_Value (Scop); + end Scope_Depth; + + --------------------- + -- Scope_Depth_Set -- + --------------------- + + function Scope_Depth_Set (Id : E) return B is + begin + return not Is_Record_Type (Id) + and then Field22 (Id) /= Union_Id (Empty); + end Scope_Depth_Set; + + ----------------------------- + -- Set_Component_Alignment -- + ----------------------------- + + -- Component Alignment is encoded using two flags, Flag128/129 as + -- follows. Note that both flags False = Align_Default, so that the + -- default initialization of flags to False initializes component + -- alignment to the default value as required. + + -- Flag128 Flag129 Value + -- ------- ------- ----- + -- False False Calign_Default + -- False True Calign_Component_Size + -- True False Calign_Component_Size_4 + -- True True Calign_Storage_Unit + + procedure Set_Component_Alignment (Id : E; V : C) is + begin + pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id)) + and then Id = Base_Type (Id)); + + case V is + when Calign_Default => + Set_Flag128 (Id, False); + Set_Flag129 (Id, False); + + when Calign_Component_Size => + Set_Flag128 (Id, False); + Set_Flag129 (Id, True); + + when Calign_Component_Size_4 => + Set_Flag128 (Id, True); + Set_Flag129 (Id, False); + + when Calign_Storage_Unit => + Set_Flag128 (Id, True); + Set_Flag129 (Id, True); + end case; + end Set_Component_Alignment; + + ----------------- + -- Size_Clause -- + ----------------- + + function Size_Clause (Id : E) return N is + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Attribute_Definition_Clause + and then Chars (Ritem) = Name_Size + then + return Ritem; + else + Ritem := Next_Rep_Item (Ritem); + end if; + end loop; + + return Empty; + end Size_Clause; + + ------------------ + -- Subtype_Kind -- + ------------------ + + function Subtype_Kind (K : Entity_Kind) return Entity_Kind is + Kind : Entity_Kind; + + begin + case K is + when Access_Kind => + Kind := E_Access_Subtype; + + when E_Array_Type | + E_Array_Subtype => + Kind := E_Array_Subtype; + + when E_Class_Wide_Type | + E_Class_Wide_Subtype => + Kind := E_Class_Wide_Subtype; + + when E_Decimal_Fixed_Point_Type | + E_Decimal_Fixed_Point_Subtype => + Kind := E_Decimal_Fixed_Point_Subtype; + + when E_Ordinary_Fixed_Point_Type | + E_Ordinary_Fixed_Point_Subtype => + Kind := E_Ordinary_Fixed_Point_Subtype; + + when E_Private_Type | + E_Private_Subtype => + Kind := E_Private_Subtype; + + when E_Limited_Private_Type | + E_Limited_Private_Subtype => + Kind := E_Limited_Private_Subtype; + + when E_Record_Type_With_Private | + E_Record_Subtype_With_Private => + Kind := E_Record_Subtype_With_Private; + + when E_Record_Type | + E_Record_Subtype => + Kind := E_Record_Subtype; + + when E_String_Type | + E_String_Subtype => + Kind := E_String_Subtype; + + when Enumeration_Kind => + Kind := E_Enumeration_Subtype; + + when Float_Kind => + Kind := E_Floating_Point_Subtype; + + when Signed_Integer_Kind => + Kind := E_Signed_Integer_Subtype; + + when Modular_Integer_Kind => + Kind := E_Modular_Integer_Subtype; + + when Protected_Kind => + Kind := E_Protected_Subtype; + + when Task_Kind => + Kind := E_Task_Subtype; + + when others => + Kind := E_Void; + raise Program_Error; + end case; + + return Kind; + end Subtype_Kind; + + ------------------- + -- Tag_Component -- + ------------------- + + function Tag_Component (Id : E) return E is + Comp : Entity_Id; + Typ : Entity_Id := Id; + + begin + pragma Assert (Is_Tagged_Type (Typ)); + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + if Is_Private_Type (Typ) then + Typ := Underlying_Type (Typ); + end if; + + Comp := First_Entity (Typ); + while Present (Comp) loop + if Is_Tag (Comp) then + return Comp; + end if; + + Comp := Next_Entity (Comp); + end loop; + + -- No tag component found + + return Empty; + end Tag_Component; + + --------------------- + -- Type_High_Bound -- + --------------------- + + function Type_High_Bound (Id : E) return Node_Id is + begin + if Nkind (Scalar_Range (Id)) = N_Subtype_Indication then + return High_Bound (Range_Expression (Constraint (Scalar_Range (Id)))); + else + return High_Bound (Scalar_Range (Id)); + end if; + end Type_High_Bound; + + -------------------- + -- Type_Low_Bound -- + -------------------- + + function Type_Low_Bound (Id : E) return Node_Id is + begin + if Nkind (Scalar_Range (Id)) = N_Subtype_Indication then + return Low_Bound (Range_Expression (Constraint (Scalar_Range (Id)))); + else + return Low_Bound (Scalar_Range (Id)); + end if; + end Type_Low_Bound; + + --------------------- + -- Underlying_Type -- + --------------------- + + function Underlying_Type (Id : E) return E is + begin + + -- For record_with_private the underlying type is always the direct + -- full view. Never try to take the full view of the parent it + -- doesn't make sense. + + if Ekind (Id) = E_Record_Type_With_Private then + return Full_View (Id); + + elsif Ekind (Id) in Incomplete_Or_Private_Kind then + + -- If we have an incomplete or private type with a full view, + -- then we return the Underlying_Type of this full view + + if Present (Full_View (Id)) then + return Underlying_Type (Full_View (Id)); + + -- Otherwise check for the case where we have a derived type or + -- subtype, and if so get the Underlying_Type of the parent type. + + elsif Etype (Id) /= Id then + return Underlying_Type (Etype (Id)); + + -- Otherwise we have an incomplete or private type that has + -- no full view, which means that we have not encountered the + -- completion, so return Empty to indicate the underlying type + -- is not yet known. + + else + return Empty; + end if; + + -- For non-incomplete, non-private types, return the type itself + -- Also for entities that are not types at all return the entity + -- itself. + + else + return Id; + end if; + end Underlying_Type; + + ------------------------ + -- Write_Entity_Flags -- + ------------------------ + + procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String) is + + procedure W (Flag_Name : String; Flag : Boolean); + -- Write out given flag if it is set + + procedure W (Flag_Name : String; Flag : Boolean) is + begin + if Flag then + Write_Str (Prefix); + Write_Str (Flag_Name); + Write_Str (" = True"); + Write_Eol; + end if; + end W; + + -- Start of processing for Write_Entity_Flags + + begin + if (Is_Array_Type (Id) or else Is_Record_Type (Id)) + and then Base_Type (Id) = Id + then + Write_Str (Prefix); + Write_Str ("Component_Alignment = "); + + case Component_Alignment (Id) is + when Calign_Default => + Write_Str ("Calign_Default"); + + when Calign_Component_Size => + Write_Str ("Calign_Component_Size"); + + when Calign_Component_Size_4 => + Write_Str ("Calign_Component_Size_4"); + + when Calign_Storage_Unit => + Write_Str ("Calign_Storage_Unit"); + end case; + + Write_Eol; + end if; + + W ("Address_Taken", Flag104 (Id)); + W ("C_Pass_By_Copy", Flag125 (Id)); + W ("Debug_Info_Off", Flag166 (Id)); + W ("Default_Expressions_Processed", Flag108 (Id)); + W ("Delay_Cleanups", Flag114 (Id)); + W ("Delay_Subprogram_Descriptors", Flag50 (Id)); + W ("Depends_On_Private", Flag14 (Id)); + W ("Discard_Names", Flag88 (Id)); + W ("Elaborate_All_Desirable", Flag146 (Id)); + W ("Elaboration_Entity_Required", Flag175 (Id)); + W ("Entry_Accepted", Flag152 (Id)); + W ("Finalize_Storage_Only", Flag158 (Id)); + W ("From_With_Type", Flag159 (Id)); + W ("Function_Returns_With_DSP", Flag169 (Id)); + W ("Has_Aliased_Components", Flag135 (Id)); + W ("Has_Alignment_Clause", Flag46 (Id)); + W ("Has_All_Calls_Remote", Flag79 (Id)); + W ("Has_Atomic_Components", Flag86 (Id)); + W ("Has_Biased_Representation", Flag139 (Id)); + W ("Has_Completion", Flag26 (Id)); + W ("Has_Completion_In_Body", Flag71 (Id)); + W ("Has_Complex_Representation", Flag140 (Id)); + W ("Has_Component_Size_Clause", Flag68 (Id)); + W ("Has_Controlled_Component", Flag43 (Id)); + W ("Has_Controlling_Result", Flag98 (Id)); + W ("Has_Convention_Pragma", Flag119 (Id)); + W ("Has_Delayed_Freeze", Flag18 (Id)); + W ("Has_Discriminants", Flag5 (Id)); + W ("Has_Enumeration_Rep_Clause", Flag66 (Id)); + W ("Has_Exit", Flag47 (Id)); + W ("Has_External_Tag_Rep_Clause", Flag110 (Id)); + W ("Has_Forward_Instantiation", Flag175 (Id)); + W ("Has_Fully_Qualified_Name", Flag173 (Id)); + W ("Has_Gigi_Rep_Item", Flag82 (Id)); + W ("Has_Homonym", Flag56 (Id)); + W ("Has_Machine_Radix_Clause", Flag83 (Id)); + W ("Has_Master_Entity", Flag21 (Id)); + W ("Has_Missing_Return", Flag142 (Id)); + W ("Has_Nested_Block_With_Handler", Flag101 (Id)); + W ("Has_Non_Standard_Rep", Flag75 (Id)); + W ("Has_Object_Size_Clause", Flag172 (Id)); + W ("Has_Per_Object_Constraint", Flag154 (Id)); + W ("Has_Pragma_Controlled", Flag27 (Id)); + W ("Has_Pragma_Elaborate_Body", Flag150 (Id)); + W ("Has_Pragma_Inline", Flag157 (Id)); + W ("Has_Pragma_Pack", Flag121 (Id)); + W ("Has_Primitive_Operations", Flag120 (Id)); + W ("Has_Private_Declaration", Flag155 (Id)); + W ("Has_Qualified_Name", Flag161 (Id)); + W ("Has_Record_Rep_Clause", Flag65 (Id)); + W ("Has_Recursive_Call", Flag143 (Id)); + W ("Has_Size_Clause", Flag29 (Id)); + W ("Has_Small_Clause", Flag67 (Id)); + W ("Has_Specified_Layout", Flag100 (Id)); + W ("Has_Storage_Size_Clause", Flag23 (Id)); + W ("Has_Subprogram_Descriptor", Flag93 (Id)); + W ("Has_Task", Flag30 (Id)); + W ("Has_Unchecked_Union", Flag123 (Id)); + W ("Has_Unknown_Discriminants", Flag72 (Id)); + W ("Has_Volatile_Components", Flag87 (Id)); + W ("In_Package_Body", Flag48 (Id)); + W ("In_Private_Part", Flag45 (Id)); + W ("In_Use", Flag8 (Id)); + W ("Is_AST_Entry", Flag132 (Id)); + W ("Is_Abstract", Flag19 (Id)); + W ("Is_Access_Constant", Flag69 (Id)); + W ("Is_Aliased", Flag15 (Id)); + W ("Is_Asynchronous", Flag81 (Id)); + W ("Is_Atomic", Flag85 (Id)); + W ("Is_Bit_Packed_Array", Flag122 (Id)); + W ("Is_CPP_Class", Flag74 (Id)); + W ("Is_Called", Flag102 (Id)); + W ("Is_Character_Type", Flag63 (Id)); + W ("Is_Child_Unit", Flag73 (Id)); + W ("Is_Compilation_Unit", Flag149 (Id)); + W ("Is_Completely_Hidden", Flag103 (Id)); + W ("Is_Concurrent_Record_Type", Flag20 (Id)); + W ("Is_Constr_Subt_For_UN_Aliased", Flag141 (Id)); + W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id)); + W ("Is_Constrained", Flag12 (Id)); + W ("Is_Constructor", Flag76 (Id)); + W ("Is_Controlled", Flag42 (Id)); + W ("Is_Controlling_Formal", Flag97 (Id)); + W ("Is_Destructor", Flag77 (Id)); + W ("Is_Discrim_SO_Function", Flag176 (Id)); + W ("Is_Dispatching_Operation", Flag6 (Id)); + W ("Is_Eliminated", Flag124 (Id)); + W ("Is_Entry_Formal", Flag52 (Id)); + W ("Is_Exported", Flag99 (Id)); + W ("Is_First_Subtype", Flag70 (Id)); + W ("Is_For_Access_Subtype", Flag118 (Id)); + W ("Is_Formal_Subprogram", Flag111 (Id)); + W ("Is_Frozen", Flag4 (Id)); + W ("Is_Generic_Actual_Type", Flag94 (Id)); + W ("Is_Generic_Instance", Flag130 (Id)); + W ("Is_Generic_Type", Flag13 (Id)); + W ("Is_Hidden", Flag57 (Id)); + W ("Is_Hidden_Open_Scope", Flag171 (Id)); + W ("Is_Immediately_Visible", Flag7 (Id)); + W ("Is_Imported", Flag24 (Id)); + W ("Is_Inlined", Flag11 (Id)); + W ("Is_Instantiated", Flag126 (Id)); + W ("Is_Internal", Flag17 (Id)); + W ("Is_Interrupt_Handler", Flag89 (Id)); + W ("Is_Intrinsic_Subprogram", Flag64 (Id)); + W ("Is_Itype", Flag91 (Id)); + W ("Is_Known_Valid", Flag170 (Id)); + W ("Is_Limited_Composite", Flag106 (Id)); + W ("Is_Limited_Record", Flag25 (Id)); + W ("Is_Non_Static_Subtype", Flag109 (Id)); + W ("Is_Null_Init_Proc", Flag178 (Id)); + W ("Is_Optional_Parameter", Flag134 (Id)); + W ("Is_Package_Body_Entity", Flag160 (Id)); + W ("Is_Packed", Flag51 (Id)); + W ("Is_Packed_Array_Type", Flag138 (Id)); + W ("Is_Potentially_Use_Visible", Flag9 (Id)); + W ("Is_Preelaborated", Flag59 (Id)); + W ("Is_Private_Composite", Flag107 (Id)); + W ("Is_Private_Descendant", Flag53 (Id)); + W ("Is_Psected", Flag153 (Id)); + W ("Is_Public", Flag10 (Id)); + W ("Is_Pure", Flag44 (Id)); + W ("Is_Remote_Call_Interface", Flag62 (Id)); + W ("Is_Remote_Types", Flag61 (Id)); + W ("Is_Renaming_Of_Object", Flag112 (Id)); + W ("Is_Shared_Passive", Flag60 (Id)); + W ("Is_Statically_Allocated", Flag28 (Id)); + W ("Is_Tag", Flag78 (Id)); + W ("Is_Tagged_Type", Flag55 (Id)); + W ("Is_True_Constant", Flag163 (Id)); + W ("Is_Unchecked_Union", Flag117 (Id)); + W ("Is_Unsigned_Type", Flag144 (Id)); + W ("Is_VMS_Exception", Flag133 (Id)); + W ("Is_Valued_Procedure", Flag127 (Id)); + W ("Is_Visible_Child_Unit", Flag116 (Id)); + W ("Is_Volatile", Flag16 (Id)); + W ("Machine_Radix_10", Flag84 (Id)); + W ("Materialize_Entity", Flag168 (Id)); + W ("Needs_Debug_Info", Flag147 (Id)); + W ("Needs_No_Actuals", Flag22 (Id)); + W ("No_Pool_Assigned", Flag131 (Id)); + W ("No_Return", Flag113 (Id)); + W ("Non_Binary_Modulus", Flag58 (Id)); + W ("Nonzero_Is_True", Flag162 (Id)); + W ("Not_Source_Assigned", Flag115 (Id)); + W ("Reachable", Flag49 (Id)); + W ("Referenced", Flag156 (Id)); + W ("Return_Present", Flag54 (Id)); + W ("Returns_By_Ref", Flag90 (Id)); + W ("Reverse_Bit_Order", Flag164 (Id)); + W ("Sec_Stack_Needed_For_Return", Flag167 (Id)); + W ("Size_Depends_On_Discriminant", Flag177 (Id)); + W ("Size_Known_At_Compile_Time", Flag92 (Id)); + W ("Strict_Alignment", Flag145 (Id)); + W ("Suppress_Access_Checks", Flag31 (Id)); + W ("Suppress_Accessibility_Checks", Flag32 (Id)); + W ("Suppress_Discriminant_Checks", Flag33 (Id)); + W ("Suppress_Division_Checks", Flag34 (Id)); + W ("Suppress_Elaboration_Checks", Flag35 (Id)); + W ("Suppress_Elaboration_Warnings", Flag148 (Id)); + W ("Suppress_Index_Checks", Flag36 (Id)); + W ("Suppress_Init_Proc", Flag105 (Id)); + W ("Suppress_Length_Checks", Flag37 (Id)); + W ("Suppress_Overflow_Checks", Flag38 (Id)); + W ("Suppress_Range_Checks", Flag39 (Id)); + W ("Suppress_Storage_Checks", Flag40 (Id)); + W ("Suppress_Style_Checks", Flag165 (Id)); + W ("Suppress_Tag_Checks", Flag41 (Id)); + W ("Uses_Sec_Stack", Flag95 (Id)); + W ("Vax_Float", Flag151 (Id)); + W ("Warnings_Off", Flag96 (Id)); + + end Write_Entity_Flags; + + ----------------------- + -- Write_Entity_Info -- + ----------------------- + + procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is + + procedure Write_Attribute (Which : String; Nam : E); + -- Write attribute value with given string name + + procedure Write_Kind (Id : Entity_Id); + -- Write Ekind field of entity + + procedure Write_Attribute (Which : String; Nam : E) is + begin + Write_Str (Prefix); + Write_Str (Which); + Write_Int (Int (Nam)); + Write_Str (" "); + Write_Name (Chars (Nam)); + Write_Str (" "); + end Write_Attribute; + + procedure Write_Kind (Id : Entity_Id) is + K : constant String := Entity_Kind'Image (Ekind (Id)); + + begin + Write_Str (Prefix); + Write_Str (" Kind "); + + if Is_Type (Id) and then Is_Tagged_Type (Id) then + Write_Str ("TAGGED "); + end if; + + Write_Str (K (3 .. K'Length)); + Write_Str (" "); + + if Is_Type (Id) and then Depends_On_Private (Id) then + Write_Str ("Depends_On_Private "); + end if; + end Write_Kind; + + -- Start of processing for Write_Entity_Info + + begin + Write_Eol; + Write_Attribute ("Name ", Id); + Write_Int (Int (Id)); + Write_Eol; + Write_Kind (Id); + Write_Eol; + Write_Attribute (" Type ", Etype (Id)); + Write_Eol; + Write_Attribute (" Scope ", Scope (Id)); + Write_Eol; + + case Ekind (Id) is + + when Discrete_Kind => + Write_Str ("Bounds: Id = "); + + if Present (Scalar_Range (Id)) then + Write_Int (Int (Type_Low_Bound (Id))); + Write_Str (" .. Id = "); + Write_Int (Int (Type_High_Bound (Id))); + else + Write_Str ("Empty"); + end if; + + Write_Eol; + + when Array_Kind => + declare + Index : E; + + begin + Write_Attribute (" Component Type ", + Component_Type (Id)); + Write_Eol; + Write_Str (Prefix); + Write_Str (" Indices "); + + Index := First_Index (Id); + + while Present (Index) loop + Write_Attribute (" ", Etype (Index)); + Index := Next_Index (Index); + end loop; + + Write_Eol; + end; + + when Access_Kind => + Write_Attribute + (" Directly Designated Type ", + Directly_Designated_Type (Id)); + Write_Eol; + + when Overloadable_Kind => + if Present (Homonym (Id)) then + Write_Str (" Homonym "); + Write_Name (Chars (Homonym (Id))); + Write_Str (" "); + Write_Int (Int (Homonym (Id))); + Write_Eol; + end if; + + Write_Eol; + + when E_Component => + if Ekind (Scope (Id)) in Record_Kind then + Write_Attribute ( + " Original_Record_Component ", + Original_Record_Component (Id)); + Write_Int (Int (Original_Record_Component (Id))); + Write_Eol; + end if; + + when others => null; + end case; + end Write_Entity_Info; + + ----------------------- + -- Write_Field6_Name -- + ----------------------- + + procedure Write_Field6_Name (Id : Entity_Id) is + begin + Write_Str ("First_Rep_Item"); + end Write_Field6_Name; + + ----------------------- + -- Write_Field7_Name -- + ----------------------- + + procedure Write_Field7_Name (Id : Entity_Id) is + begin + Write_Str ("Freeze_Node"); + end Write_Field7_Name; + + ----------------------- + -- Write_Field8_Name -- + ----------------------- + + procedure Write_Field8_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Component | + E_Discriminant => + Write_Str ("Normalized_First_Bit"); + + when Formal_Kind | + E_Function => + Write_Str ("Mechanism"); + + when Type_Kind => + Write_Str ("Associated_Node_For_Itype"); + + when E_Package => + Write_Str ("Dependent_Instances"); + + when E_Variable => + Write_Str ("Hiding_Loop_Variable"); + + when others => + Write_Str ("Field8??"); + end case; + end Write_Field8_Name; + + ----------------------- + -- Write_Field9_Name -- + ----------------------- + + procedure Write_Field9_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind => + Write_Str ("Class_Wide_Type"); + + when E_Constant | E_Variable => + Write_Str ("Size_Check_Code"); + + when E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Package | + E_Procedure => + Write_Str ("Renaming_Map"); + + when E_Component | + E_Discriminant => + Write_Str ("Normalized_Position"); + + when others => + Write_Str ("Field9??"); + end case; + end Write_Field9_Name; + + ------------------------ + -- Write_Field10_Name -- + ------------------------ + + procedure Write_Field10_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind => + Write_Str ("Referenced_Object"); + + when E_In_Parameter | + E_Constant => + Write_Str ("Discriminal_Link"); + + when E_Function | + E_Package | + E_Package_Body | + E_Procedure => + Write_Str ("Handler_Records"); + + when E_Component | + E_Discriminant => + Write_Str ("Normalized_Position_Max"); + + when others => + Write_Str ("Field10??"); + end case; + end Write_Field10_Name; + + ------------------------ + -- Write_Field11_Name -- + ------------------------ + + procedure Write_Field11_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Formal_Kind => + Write_Str ("Entry_Component"); + + when E_Component | + E_Discriminant => + Write_Str ("Component_Bit_Offset"); + + when E_Constant => + Write_Str ("Full_View"); + + when E_Enumeration_Literal => + Write_Str ("Enumeration_Pos"); + + when E_Block => + Write_Str ("Block_Node"); + + when E_Function | + E_Procedure | + E_Entry | + E_Entry_Family => + Write_Str ("Protected_Body_Subprogram"); + + when Type_Kind => + Write_Str ("Full_View"); + + when others => + Write_Str ("Field11??"); + end case; + end Write_Field11_Name; + + ------------------------ + -- Write_Field12_Name -- + ------------------------ + + procedure Write_Field12_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Entry_Kind => + Write_Str ("Barrier_Function"); + + when E_Enumeration_Literal => + Write_Str ("Enumeration_Rep"); + + when Type_Kind | + E_Component | + E_Constant | + E_Discriminant | + E_In_Parameter | + E_In_Out_Parameter | + E_Out_Parameter | + E_Loop_Parameter | + E_Variable => + Write_Str ("Esize"); + + when E_Function | + E_Procedure => + Write_Str ("Next_Inlined_Subprogram"); + + when E_Package => + Write_Str ("Associated_Formal_Package"); + + when others => + Write_Str ("Field12??"); + end case; + end Write_Field12_Name; + + ------------------------ + -- Write_Field13_Name -- + ------------------------ + + procedure Write_Field13_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind => + Write_Str ("RM_Size"); + + when E_Component | + E_Discriminant => + Write_Str ("Component_Clause"); + + when E_Enumeration_Literal => + Write_Str ("Debug_Renaming_Link"); + + when E_Function => + if not Comes_From_Source (Id) + and then + Chars (Id) = Name_Op_Ne + then + Write_Str ("Corresponding_Equality"); + + elsif Comes_From_Source (Id) then + Write_Str ("Elaboration_Entity"); + + else + Write_Str ("Field13??"); + end if; + + when Formal_Kind | + E_Variable => + Write_Str ("Extra_Accessibility"); + + when E_Procedure | + E_Package | + Generic_Unit_Kind => + Write_Str ("Elaboration_Entity"); + + when others => + Write_Str ("Field13??"); + end case; + end Write_Field13_Name; + + ----------------------- + -- Write_Field14_Name -- + ----------------------- + + procedure Write_Field14_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind | + Object_Kind => + Write_Str ("Alignment"); + + when E_Function | + E_Procedure => + Write_Str ("First_Optional_Parameter"); + + when E_Package | + E_Generic_Package => + Write_Str ("Shadow_Entities"); + + when others => + Write_Str ("Field14??"); + end case; + end Write_Field14_Name; + + ------------------------ + -- Write_Field15_Name -- + ------------------------ + + procedure Write_Field15_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Access_Kind | + Task_Kind => + Write_Str ("Storage_Size_Variable"); + + when Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype | + Private_Kind => + Write_Str ("Primitive_Operations"); + + when E_Component => + Write_Str ("DT_Entry_Count"); + + when Decimal_Fixed_Point_Kind => + Write_Str ("Scale_Value"); + + when E_Discriminant => + Write_Str ("Discriminant_Number"); + + when Formal_Kind => + Write_Str ("Extra_Formal"); + + when E_Function | + E_Procedure => + Write_Str ("DT_Position"); + + when Entry_Kind => + Write_Str ("Entry_Parameters_Type"); + + when Enumeration_Kind => + Write_Str ("Lit_Indexes"); + + when E_Package => + Write_Str ("Related_Instance"); + + when E_Protected_Type => + Write_Str ("Entry_Bodies_Array"); + + when E_String_Literal_Subtype => + Write_Str ("String_Literal_Low_Bound"); + + when E_Variable => + Write_Str ("Shared_Var_Read_Proc"); + + when others => + Write_Str ("Field15??"); + end case; + end Write_Field15_Name; + + ------------------------ + -- Write_Field16_Name -- + ------------------------ + + procedure Write_Field16_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Component => + Write_Str ("Entry_Formal"); + + when E_Function | + E_Procedure => + Write_Str ("DTC_Entity"); + + when E_Package | + E_Generic_Package | + Concurrent_Kind => + Write_Str ("First_Private_Entity"); + + when E_Record_Type | + E_Record_Type_With_Private => + Write_Str ("Access_Disp_Table"); + + when E_String_Literal_Subtype => + Write_Str ("String_Literal_Length"); + + when Enumeration_Kind => + Write_Str ("Lit_Strings"); + + when E_Variable | + E_Out_Parameter => + Write_Str ("Unset_Reference"); + + when E_Record_Subtype | + E_Class_Wide_Subtype => + Write_Str ("Cloned_Subtype"); + + when others => + Write_Str ("Field16??"); + end case; + end Write_Field16_Name; + + ------------------------ + -- Write_Field17_Name -- + ------------------------ + + procedure Write_Field17_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Digits_Kind => + Write_Str ("Digits_Value"); + + when E_Component => + Write_Str ("Prival"); + + when E_Discriminant => + Write_Str ("Discriminal"); + + when E_Block | + Class_Wide_Kind | + Concurrent_Kind | + Private_Kind | + E_Entry | + E_Entry_Family | + E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Loop | + E_Operator | + E_Package | + E_Package_Body | + E_Procedure | + E_Record_Type | + E_Record_Subtype | + E_Subprogram_Body | + E_Subprogram_Type => + Write_Str ("First_Entity"); + + when Array_Kind => + Write_Str ("First_Index"); + + when E_Protected_Body => + Write_Str ("Object_Ref"); + + when Enumeration_Kind => + Write_Str ("First_Literal"); + + when Access_Kind => + Write_Str ("Master_Id"); + + when Modular_Integer_Kind => + Write_Str ("Modulus"); + + when Formal_Kind | + E_Constant | + E_Generic_In_Out_Parameter | + E_Variable => + Write_Str ("Actual_Subtype"); + + when others => + Write_Str ("Field17??"); + end case; + end Write_Field17_Name; + + ----------------------- + -- Write_Field18_Name -- + ----------------------- + + procedure Write_Field18_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Enumeration_Literal | + E_Function | + E_Operator | + E_Procedure => + Write_Str ("Alias"); + + when E_Record_Type => + Write_Str ("Corresponding_Concurrent_Type"); + + when E_Entry_Index_Parameter => + Write_Str ("Entry_Index_Constant"); + + when E_Class_Wide_Subtype | + E_Access_Protected_Subprogram_Type | + E_Access_Subprogram_Type | + E_Exception_Type => + Write_Str ("Equivalent_Type"); + + when Fixed_Point_Kind => + Write_Str ("Delta_Value"); + + when E_Constant | + E_Variable => + Write_Str ("Renamed_Object"); + + when E_Exception | + E_Package | + E_Generic_Function | + E_Generic_Procedure | + E_Generic_Package => + Write_Str ("Renamed_Entity"); + + when Incomplete_Or_Private_Kind => + Write_Str ("Private_Dependents"); + + when Concurrent_Kind => + Write_Str ("Corresponding_Record_Type"); + + when E_Label | + E_Loop | + E_Block => + Write_Str ("Enclosing_Scope"); + + when others => + Write_Str ("Field18??"); + end case; + end Write_Field18_Name; + + ----------------------- + -- Write_Field19_Name -- + ----------------------- + + procedure Write_Field19_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Array_Type | + E_Array_Subtype => + Write_Str ("Related_Array_Object"); + + when E_Block | + Concurrent_Kind | + E_Function | + E_Procedure | + Entry_Kind => + Write_Str ("Finalization_Chain_Entity"); + + when E_Discriminant => + Write_Str ("Corresponding_Discriminant"); + + when E_Package => + Write_Str ("Body_Entity"); + + when E_Package_Body | + Formal_Kind => + Write_Str ("Spec_Entity"); + + when Private_Kind => + Write_Str ("Underlying_Full_View"); + + when E_Record_Type => + Write_Str ("Parent_Subtype"); + + when others => + Write_Str ("Field19??"); + end case; + end Write_Field19_Name; + + ----------------------- + -- Write_Field20_Name -- + ----------------------- + + procedure Write_Field20_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Array_Kind => + Write_Str ("Component_Type"); + + when E_In_Parameter | + E_Generic_In_Parameter => + Write_Str ("Default_Value"); + + when Access_Kind => + Write_Str ("Directly_Designated_Type"); + + when E_Component => + Write_Str ("Discriminant_Checking_Func"); + + when E_Discriminant => + Write_Str ("Discriminant_Default_Value"); + + when E_Block | + Class_Wide_Kind | + Concurrent_Kind | + Private_Kind | + E_Entry | + E_Entry_Family | + E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Loop | + E_Operator | + E_Package | + E_Package_Body | + E_Procedure | + E_Record_Type | + E_Record_Subtype | + E_Subprogram_Body | + E_Subprogram_Type => + + Write_Str ("Last_Entity"); + + when Scalar_Kind => + Write_Str ("Scalar_Range"); + + when E_Exception => + Write_Str ("Register_Exception_Call"); + + when others => + Write_Str ("Field20??"); + end case; + end Write_Field20_Name; + + ----------------------- + -- Write_Field21_Name -- + ----------------------- + + procedure Write_Field21_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Constant | + E_Exception | + E_Function | + E_Generic_Function | + E_Procedure | + E_Generic_Procedure | + E_Variable => + Write_Str ("Interface_Name"); + + when Concurrent_Kind | + Incomplete_Or_Private_Kind | + Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype => + Write_Str ("Discriminant_Constraint"); + + when Entry_Kind => + Write_Str ("Accept_Address"); + + when Fixed_Point_Kind => + Write_Str ("Small_Value"); + + when E_In_Parameter => + Write_Str ("Default_Expr_Function"); + + when others => + Write_Str ("Field21??"); + end case; + end Write_Field21_Name; + + ----------------------- + -- Write_Field22_Name -- + ----------------------- + + procedure Write_Field22_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Access_Kind => + Write_Str ("Associated_Storage_Pool"); + + when Array_Kind => + Write_Str ("Component_Size"); + + when E_Component | + E_Discriminant => + Write_Str ("Original_Record_Component"); + + when E_Enumeration_Literal => + Write_Str ("Enumeration_Rep_Expr"); + + when E_Exception => + Write_Str ("Exception_Code"); + + when Formal_Kind => + Write_Str ("Protected_Formal"); + + when E_Record_Type => + Write_Str ("Corresponding_Remote_Type"); + + when E_Block | + E_Entry | + E_Entry_Family | + E_Function | + E_Loop | + E_Package | + E_Package_Body | + E_Generic_Package | + E_Generic_Function | + E_Generic_Procedure | + E_Procedure | + E_Protected_Type | + E_Subprogram_Body | + E_Task_Type => + Write_Str ("Scope_Depth_Value"); + + when E_Record_Type_With_Private | + E_Record_Subtype_With_Private | + E_Private_Type | + E_Private_Subtype | + E_Limited_Private_Type | + E_Limited_Private_Subtype => + Write_Str ("Private_View"); + + when E_Variable => + Write_Str ("Shared_Var_Assign_Proc"); + + when others => + Write_Str ("Field22??"); + end case; + end Write_Field22_Name; + + ------------------------ + -- Write_Field23_Name -- + ------------------------ + + procedure Write_Field23_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Access_Kind => + Write_Str ("Associated_Final_Chain"); + + when Array_Kind => + Write_Str ("Packed_Array_Type"); + + when E_Block => + Write_Str ("Entry_Cancel_Parameter"); + + when E_Component => + Write_Str ("Protected_Operation"); + + when E_Discriminant => + Write_Str ("CR_Discriminant"); + + when E_Enumeration_Type => + Write_Str ("Enum_Pos_To_Rep"); + + when Formal_Kind | + E_Variable => + Write_Str ("Extra_Constrained"); + + when E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure => + Write_Str ("Inner_Instances"); + + when Concurrent_Kind | + Incomplete_Or_Private_Kind | + Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype => + Write_Str ("Girder_Constraint"); + + when E_Function | + E_Package | + E_Procedure => + Write_Str ("Generic_Renamings"); + + -- What about Privals_Chain for protected operations ??? + + when Entry_Kind => + Write_Str ("Privals_Chain"); + + when others => + Write_Str ("Field23??"); + end case; + end Write_Field23_Name; + + ------------------------- + -- Iterator Procedures -- + ------------------------- + + procedure Proc_Next_Component (N : in out Node_Id) is + begin + N := Next_Component (N); + end Proc_Next_Component; + + procedure Proc_Next_Discriminant (N : in out Node_Id) is + begin + N := Next_Discriminant (N); + end Proc_Next_Discriminant; + + procedure Proc_Next_Formal (N : in out Node_Id) is + begin + N := Next_Formal (N); + end Proc_Next_Formal; + + procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is + begin + N := Next_Formal_With_Extras (N); + end Proc_Next_Formal_With_Extras; + + procedure Proc_Next_Girder_Discriminant (N : in out Node_Id) is + begin + N := Next_Girder_Discriminant (N); + end Proc_Next_Girder_Discriminant; + + procedure Proc_Next_Index (N : in out Node_Id) is + begin + N := Next_Index (N); + end Proc_Next_Index; + + procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is + begin + N := Next_Inlined_Subprogram (N); + end Proc_Next_Inlined_Subprogram; + + procedure Proc_Next_Literal (N : in out Node_Id) is + begin + N := Next_Literal (N); + end Proc_Next_Literal; + +end Einfo; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads new file mode 100644 index 00000000000..eaa97c8800c --- /dev/null +++ b/gcc/ada/einfo.ads @@ -0,0 +1,6291 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E I N F O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.640 $ +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Einfo is + +-- This package defines the annotations to the abstract syntax tree that +-- are needed to support semantic processing of an Ada compilation. + +-- These annotations are for the most part attributes of declared entities, +-- and they correspond to conventional symbol table information. Other +-- attributes include sets of meanings for overloaded names, possible +-- types for overloaded expressions, flags to indicate deferred constants, +-- incomplete types, etc. These attributes are stored in available fields +-- in tree nodes (i.e. fields not used by the parser, as defined by the +-- Sinfo package specification), and accessed by means of a set of +-- subprograms which define an abstract interface. + +-- There are two kinds of semantic information + +-- First, the tree nodes with the following Nkind values: + +-- N_Defining_Identifier +-- N_Defining_Character_Literal +-- N_Defining_Operator_Symbol + +-- are called Entities, and constitute the information that would often +-- be stored separately in a symbol table. These nodes are all extended +-- to provide extra space, and contain fields which depend on the entity +-- kind, as defined by the contents of the Ekind field. The use of the +-- Ekind field, and the associated fields in the entity, are defined +-- in this package, as are the access functions to these fields. + +-- Second, in some cases semantic information is stored directly in other +-- kinds of nodes, e.g. the Etype field, used to indicate the type of an +-- expression. The access functions to these fields are defined in the +-- Sinfo package, but their full documentation is to be found in +-- the Einfo package specification. + +-- Declaration processing places information in the nodes of their defining +-- identifiers. Name resolution places in all other occurrences of an +-- identifier a pointer to the corresponding defining occurrence. + +-------------------------------- +-- The XEINFO Utility Program -- +-------------------------------- + +-- XEINFO is a utility program which automatically produces a C header file, +-- a-xeinfo.h from the spec and body of package Einfo. It reads the input +-- files einfo.ads and einfo.adb and produces the output file a-xeinfo.h. + +-- In order for this utility program to operate correctly, the form of the +-- einfo.ads and einfo.adb files must meet certain requirements and be laid +-- out in a specific manner. + +-- The general form of einfo.ads is as follows: + +-- type declaration for type Entity_Kind +-- subtype declarations declaring subranges of Entity_Kind +-- subtype declarations declaring synonyms for some standard types +-- function specs for attributes +-- procedure specs +-- pragma Inline declarations + +-- This order must be observed. There are no restrictions on the procedures, +-- since the C header file only includes functions (Gigi is not allowed to +-- modify the generated tree). However, functions are required to have headers +-- that fit on a single line. + +-- XEINFO reads and processes the function specs and the pragma Inlines. For +-- functions that are declared as inlined, XEINFO reads the corresponding body +-- from xeinfo.adb, and processes it into C code. This results in some strict +-- restrictions on which functions can be inlined: + +-- The function spec must be on a single line + +-- There can only be a single statement, contained on a single line, +-- not counting any pragma Assert statements. + +-- This single statement must either by a function call with simple, +-- single token arguments, or it must be a membership test of the form +-- a in b, where a and b are single tokens. + +-- For functions that are not inlined, there is no restriction on the body, +-- and XEINFO generates a direct reference in the C header file which allows +-- the C code in Gigi to directly call the corresponding Ada body. + +---------------------------------- +-- Handling of Type'Size Values -- +---------------------------------- + +-- The Ada 95 RM contains some rather peculiar (to us!) rules on the value +-- of type'Size (see RM 13.3(55)). We have found that attempting to use +-- these RM Size values generally, and in particular for determining the +-- default size of objects, creates chaos, and major incompatibilies in +-- existing code. + +-- We proceed as follows, for discrete and fixed-point subtypes, we have +-- two separate sizes for each subtype: + +-- The Object_Size, which is used for determining the default size of +-- objects and components. This size value can be referred to using the +-- Object_Size attribute. The phrase "is used" here means that it is +-- the basis of the determination of the size. The backend is free to +-- pad this up if necessary for efficiency, e.g. an 8-bit stand-alone +-- character might be stored in 32 bits on a machine with no efficient +-- byte access instructions such as the Alpha. + +-- The default rules for the value of Object_Size for fixed-point and +-- discrete types are as follows: + +-- The Object_Size for base subtypes reflect the natural hardware +-- size in bits (see Ttypes and Cstand for integer types). For +-- enumeration and fixed-point base subtypes have 8. 16. 32 or 64 +-- bits for this size, depending on the range of values to be stored. + +-- The Object_Size of a subtype is the same as the Object_Size of +-- the subtype from which it is obtained. + +-- The Object_Size of a derived base type is copied from the parent +-- base type, and the Object_Size of a derived first subtype is copied +-- from the parent first subtype. + +-- The Value_Size which is the number of bits required to store a value +-- of the type. This size can be referred to using the Value_Size +-- attribute. This value is used to determine how tightly to pack +-- records or arrays with components of this type, and also affects +-- the semantics of unchecked conversion (unchecked conversions where +-- the Value_Size values differ generate a warning, and are potentially +-- target dependent). + +-- The default rule for the value of Value_Size are as follows: + +-- The Value_Size for a base subtype is the minimum number of bits +-- required to store all values of the type (including the sign bit +-- only if negative values are possible). + +-- If a subtype statically matches the first subtype, then it has +-- by default the same Value_Size as the first subtype. This is a +-- consequence of RM 13.1(14) ("if two subtypes statically match, +-- then their subtype-specific aspects are the same".) + +-- All other subtypes have a Value_Size corresponding to the minimum +-- number of bits required to store all values of the subtype. For +-- dynamic bounds, it is assumed that the value can range down or up +-- to the corresponding bound of the ancestor + +-- The RM defined attribute Size corresponds to the Value_Size attribute. + +-- The Size attribute may be defined for a first-named subtype. This sets +-- the Value_Size of the first-named subtype to the given value, and the +-- Object_Size of this first-named subtype to the given value padded up +-- to an appropriate boundary. It is a consequence of the default rules +-- above that this Object_Size will apply to all further subtypes. On the +-- otyher hand, Value_Size is affected only for the first subtype, any +-- dynamic subtypes obtained from it directly, and any statically matching +-- subtypes. The Value_Size of any other static subtypes is not affected. + +-- Value_Size and Object_Size may be explicitly set for any subtype using +-- an attribute definition clause. Note that the use of these attributes +-- can cause the RM 13.1(14) rule to be violated. If two access types +-- reference aliased objects whose subtypes have differing Object_Size +-- values as a result of explicit attribute definition clauses, then it +-- is erroneous to convert from one access subtype to the other. + +-- At the implementation level, Esize stores the Object_Size and the +-- RM_Size field stores the Value_Size (and hence the value of the +-- Size attribute, which, as noted above, is equivalent to Value_Size). + +-- To get a feel for the difference, consider the following examples (note +-- that in each case the base is short_short_integer with a size of 8): + +-- Object_Size Value_Size + +-- type x1 is range 0..5; 8 3 + +-- type x2 is range 0..5; +-- for x2'size use 12; 12 12 + +-- subtype x3 is x2 range 0 .. 3; 12 2 + +-- subtype x4 is x2'base range 0 .. 10; 8 4 + +-- subtype x5 is x2 range 0 .. dynamic; 12 (7) + +-- subtype x6 is x2'base range 0 .. dynamic; 8 (7) + +-- Note: the entries marked (7) are not actually specified by the Ada 95 RM, +-- but it seems in the spirit of the RM rules to allocate the minimum number +-- of bits known to be large enough to hold the given range of values. + +-- So far, so good, but GNAT has to obey the RM rules, so the question is +-- under what conditions must the RM Size be used. The following is a list +-- of the occasions on which the RM Size must be used: + +-- Component size for packed arrays or records +-- Value of the attribute Size for a type +-- Warning about sizes not matching for unchecked conversion + +-- The RM_Size field keeps track of the RM Size as needed in these +-- three situations. + +-- For types other than discrete and fixed-point types, the Object_Size +-- and Value_Size are the same (and equivalent to the RM attribute Size). +-- Only Size may be specified for such types. + +----------------------- +-- Entity Attributes -- +----------------------- + +-- This section contains a complete list of the attributes that are defined +-- on entities. Some attributes apply to all entities, others only to certain +-- kinds of entities. In the latter case the attribute should only be set or +-- accessed if the Ekind field indicates an appropriate entity. + +-- There are two kinds of attributes that apply to entities, stored and +-- synthesized. Stored attributes correspond to a field or flag in the entity +-- itself. Such attributes are identified in the table below by giving the +-- field or flag in the attribute that is used to hold the attribute value. +-- Synthesized attributes are not stored directly, but are rather computed as +-- needed from other attributes, or from information in the tree. These are +-- marked "synthesized" in the table below. The stored attributes have both +-- access functions and set procedures to set the corresponding values, while +-- synthesized attributes have only access functions. + +-- Note: in the case of Node, Uint, or Elist fields, there are cases where +-- the same physical field is used for different purposes in different +-- entities, so these access functions should only be referenced for the +-- class of entities in which they are defined as being present. Flags are +-- not overlapped in this way, but nevertheless as a matter of style and +-- abstraction (which may or may not be checked by assertions in the body), +-- this restriction should be observed for flag fields as well. + +-- Note: certain of the attributes on types apply only to base types, and +-- are so noted by the notation [base type only]. These are cases where the +-- attribute of any subtype is the same as the attribute of the base type. +-- The attribute can be referenced on a subtype (and automatically retrieves +-- the value from the base type), and if an attempt is made to set them on +-- other than a subtype, they will instead be set on the corresponding base +-- type. + +-- Other attributes are noted as applying the implementation base type only. +-- These are representation attributes which must always apply to a full +-- non-private type, and where the attributes are always on the full type. +-- The attribute can be referenced on a subtype (and automatically retries +-- the value from the implementation base type), and if an attempt is made +-- to set them on other than a subtype, they will instead be set on the +-- corresponding implementation base type. + +-- Accept_Address (Elist21) +-- Present in entries. If an accept has a statement sequence, then an +-- address variable is created, which is used to hold the address of the +-- parameters, as passed by the runtime. Accept_Address holds an element +-- list which represents a stack of entities for these address variables. +-- The current entry is the top of the stack, which is the last element +-- on the list. A stack is required to handle the case of nested select +-- statements referencing the same entry. + +-- Actual_Subtype (Node17) +-- Present in variables, constants, and formal parameters. This is the +-- subtype imposed by the value of the object, as opposed to its nominal +-- subtype, which is imposed by the declaration. The actual subtype +-- differs from the nominal one when the latter is indefinite (as in the +-- case of an unconstrained formal parameter, or a variable declared +-- with an unconstrained type and an initial value). The nominal subtype +-- is the Etype entry for the entity. The Actual_Subtype field is set +-- only if the actual subtype differs from the nominal subtype. If the +-- actual and nominal subtypes are the same, then the Actual_Subtype +-- field is Empty, and Etype indicates both types. +-- For objects, the Actual_Subtype is set only if this is a discriminated +-- type. For arrays, the bounds of the expression are obtained and the +-- Etype of the object is directly the constrained subtype. This is +-- rather irregular, and the semantic checks that depend on the nominal +-- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv). + +-- Access_Disp_Table (Node16) [base type only] +-- Present in record type entities. For a tagged type, points to the +-- dispatch table associated with the tagged type. For a non-tagged +-- record, contains Empty. + +-- Address_Clause (synthesized) +-- Applies to entries, objects and subprograms. Set if an address clause +-- is present which references the object or subprogram and points to +-- the N_Attribute_Definition_Clause node. Empty if no Address clause. +-- The expression in the address clause is always a constant that is +-- defined before the entity to which the address clause applies. +-- Note: Gigi references this field in E_Task_Type entities??? + +-- Address_Taken (Flag104) +-- Present in all entities. Set if the Address or Unrestricted_Access +-- attribute is applied directly to the entity, i.e. the entity is the +-- entity of the prefix of the attribute reference. Used by Gigi to +-- make sure that the address can be meaningfully taken. + +-- Alias (Node18) +-- Present in overloaded entities (literals, subprograms, entries). +-- Points to parent subprogram of a derived subprogram. Also used for +-- a subprogram renaming, where it points to the renamed subprogram. +-- Always empty for entries. + +-- Alignment (Uint14) +-- Present in all entities for types and objects. This indicates the +-- desired alignment for a type, or the actual alignment for an object. +-- A value of zero (Uint_0) indicates that the alignment is not yet set. +-- The alignment can be set by an explicit alignment clause, or set by +-- the front-end in package Layout, or set by the back-end. + +-- Alignment_Clause (synthesized) +-- Appllies to all entities for types and objects. If an alignment +-- attribute definition clause is present for the entity, then this +-- function returns the N_Attribute_Definition clause that specifies the +-- alignment. If no alignment clause applies to the type, then the call +-- to this function returns Empty. Note that the call can return a +-- non-Empty value even if Has_Alignment_Clause is not set (happens with +-- subtype and derived type declarations). Note also that a record +-- definition clause with an (obsolescent) mod clause is converted +-- into an attribute definition clause for this purpose. + +-- Ancestor_Subtype (synthesized) +-- Applies to all type and subtype entities. If the argument is a +-- subtype then it returns the subtype or type from which the subtype +-- was obtained, otherwise it returns Empty. + +-- Associated_Formal_Package (Node12) +-- Present in packages that are the actuals of formal_packages. Points +-- to the entity in the declaration for the formal package. + +-- Associated_Node_For_Itype (Node8) +-- Present in all type and subtype entities. Set non-Empty only for +-- Itypes. Set to point to the associated node for the Itype, i.e. +-- the node whose elaboration generated the Itype. This is used for +-- copying trees, to determine whether or not to copy an Itype. + +-- Associated_Storage_Pool (Node22) +-- Present in simple and general access type entities. References the +-- storage pool to be used for the corresponding collection. A value of +-- Empty means that the default pool is to be used. + +-- Associated_Final_Chain (Node23) +-- Present in simple and general access type entities. References the +-- List_Controller object that holds the finalization chain on which +-- are attached dynamically allocated objects referenced by the access +-- type. Empty when the access type cannot reference a controlled object. + +-- Barrier_Function (Node12) +-- Present in protected entries and entry families. This is the +-- subprogram declaration for the body of the function that returns +-- the value of the entry barrier. + +-- Base_Type (synthesized) +-- Applies to all type entities. Returns the base type of a type or +-- subtype. The base type of a type is the type itself. The base type +-- of a subtype is the type that it constrains (which is always a type +-- entity, not some other subtype). Note that in the case of a subtype +-- of a private type, it is possible for the base type attribute to +-- return a private type, even if the subtype to which it applies is +-- non-private. See also Implementation_Base_Type. Note: it is allowed +-- to apply Base_Type to other than a type, in which case it simply +-- returns the entity unchanged. + +-- Block_Node (Node11) +-- Present in block entities. Points to the Block_Statement itself. + +-- Body_Entity (Node19) +-- Present in package entities, points to the corresponding package +-- body entity if one is present. + +-- C_Pass_By_Copy (Flag125) [implementation base type only] +-- Present in record types. Set if a pragma Convention for the record +-- type specifies convention C_Pass_By_Copy. This convention name is +-- treated as identical in all respects to convention C, except that +-- if it is specified for a record type, then the C_Pass_By_Copy flag +-- is set, and if a foreign convention subprogram has a formal of the +-- corresponding type, then the parameter passing mechanism will be +-- set to By_Copy (unless specifically overridden by an Import or +-- Export pragma). + +-- Chars (Name1) +-- Present in all entities. This field contains an entry into the names +-- table that has the character string of the identifier, character +-- literal or operator symbol. See Namet for further details. Note that +-- throughout the processing of the front end, this name is the simple +-- unqualified name. However, just before gigi is called, a call is made +-- to Qualify_All_Entity_Names. This causes entity names to be qualified +-- using the encoding described in exp_dbug.ads, and from that point on +-- (including post gigi steps such as cross-reference generation), the +-- entities will contain the encoded qualified names. + +-- Class_Wide_Type (Node9) +-- Present in all type entities. For a tagged type or subtype, returns +-- the corresponding implicitly declared class-wide type. Set to Empty +-- for non-tagged types. + +-- Cloned_Subtype (Node16) +-- Present in E_Record_Subtype and E_Class_Wide_Subtype entities. +-- Each such entity can either have a Discriminant_Constraint, in +-- which case it represents a distinct type from the base type (and +-- will have a list of components and discrimants in the list headed by +-- First_Entity) or else no such constraint, in which case it will be a +-- copy of the base type. +-- +-- o Each element of the list in First_Entity is copied from the base +-- type; in that case, this field is Empty. +-- +-- o The list in First_Entity is shared with the base type; in that +-- case, this field points to that entity. +-- +-- A record or classwide subtype may also be a copy of some other +-- subtype and share the entities in the First_Entity with that subtype. +-- In that case, this field points to that subtype. +-- +-- For E_Class_Wide_Subtype, the presence of Equivalent_Type overrides +-- this field. Note that this field ONLY appears in subtype entries, not +-- in type entries, it is not present, and it is an error to reference +-- Cloned_Subtype in an E_Record_Type or E_Class_Wide_Type entity. + +-- Comes_From_Source +-- This flag appears on all nodes, including entities, and indicates +-- that the node was created by the scanner or parser from the original +-- source. Thus for entities, it indicates that the entity is defined +-- in the original source program. + +-- Component_Alignment (special field) [base type only] +-- Present in array and record entities. Contains a value of type +-- Component_Alignment_Kind indicating the alignment of components. +-- Set to Calign_Default normally, but can be overridden by use of +-- the Component_Alignment pragma. Note: this field is currently +-- stored in a non-standard way, see body for details. + +-- Component_Bit_Offset (Uint11) +-- Present in record components (E_Component, E_Discriminant) if a +-- component clause applies to the component. First bit position of +-- given component, computed from the first bit and position values +-- given in the component clause. A value of No_Uint means that the +-- value is not yet known. The value can be set by the appearence of +-- an explicit component clause in a record representation clause, +-- or it can be set by the front-end in package Layout, or it can be +-- set by the backend. By the time backend processing is completed, +-- this field is always set. A negative value is used to represent +-- a value which is not known at compile time, and must be computed +-- at run-time (this happens if fields of a record have variable +-- lengths). See package Layout for details of these values. +-- +-- Note: this field is obsolescent, to be eventually replaced entirely +-- by Normalized_First_Bit and Normalized_Position, but for the moment, +-- gigi is still using (and back annotating) this field, and gigi does +-- not know about the new fields. For the front end layout case, the +-- Component_Bit_Offset field is only set if it is static, and otherwise +-- the new Normalized_First_Bit and Normalized_Position fields are used. + +-- Component_Clause (Node13) +-- Present in record components and discriminants. If a record +-- representation clause is present for the corresponding record +-- type a that specifies a position for the component, then the +-- Component_Clause field of the E_Component entity points to the +-- N_Component_Claue node. Set to Empty if no record representation +-- clause was present, or if there was no specification for this +-- component. + +-- Component_Size (Uint22) [implementation base type only] +-- Present in array types. It contains the component size value for +-- the array. A value of zero means that the value is not yet set. +-- The value can be set by the use of a component size clause, or +-- by the front end in package Layout, or by the backend. A negative +-- value is used to represent a value which is not known at compile +-- time, and must be computed at run-time (this happens if the type +-- of the component has a variable length size). See package Layout +-- for details of these values. + +-- Component_Type (Node20) [implementation base type only] +-- Present in array types and subtypes, and also in the special +-- enumeration table type created for enumeration type. References +-- the entity for the component type. + +-- Constant_Value (synthesized) +-- Applies to constants, named integers, and named reals. Obtains +-- the initialization expression for the entity. Will return Empty for +-- for a deferred constant whose full view is not available or in some +-- other cases of internal entities, which cannot be treated as +-- constants from the point of view of constant folding. + +-- Corresponding_Concurrent_Type (Node18) +-- Present in record types that are constructed by the expander to +-- represent task and protected types (Is_Concurrent_Record_Type flag +-- set True). Points to the entity for the corresponding task type or +-- protected type. + +-- Corresponding_Discriminant (Node19) +-- Present in discriminants of a derived type, when the discriminant is +-- used to constrain a discriminant of the parent type. Points to the +-- corresponding discriminant in the parent type. Otherwise it is Empty. + +-- Corresponding_Equality (Node13) +-- Present in function entities for implicit inequality operators. +-- Denotes the explicit or derived equality operation that creates +-- the implicit inequality. Note that this field is not present in +-- other function entities, only in implicit inequality routines, +-- where Comes_From_Source is always False. + +-- Corresponding_Record_Type (Node18) +-- Present in protected and task types and subtypes. References the +-- entity for the corresponding record type constructed by the expander +-- (see Exp_Ch9). This type is used to represent values of the task type. + +-- Corresponding_Remote_Type (Node22) +-- Present in record types that describe the fat pointer structure for +-- Remote_Access_To_Subrogram types. References the original access type. + +-- CR_Discriminant (Node23) +-- Present in discriminants of concurrent types. Denotes the homologous +-- discriminant of the corresponding record type. The CR_Discriminant is +-- created at the same time as the discriminal, and used to replace +-- occurrences of the discriminant within the type declaration. + +-- Debug_Info_Off (Flag166) +-- Present in all entities. Set if a pragma Suppress_Debug_Info applies +-- to the entity, or if internal processing in the compiler determines +-- that suppression of debug information is desirable. + +-- Debug_Renaming_Link (Node13) +-- Used to link the enumeration literal of a debug renaming declaration +-- to the renamed entity. See Exp_Dbug.Debug_Renaming_Declaration for +-- details of the use of this field. + +-- Declaration_Node (synthesized) +-- Applies to all entities. Returns the tree node for the declaration +-- that declared the entity. Normally this is just the Parent of the +-- entity. One exception arises with child units, where the parent of +-- the entity is a selected component or a defining program unit name. +-- Another exception is that if the entity is an incomplete type that +-- has been completed, then we obtain the declaration node denoted by +-- the full type, i.e. the full type declaration node. + +-- Default_Expr_Function (Node21) +-- Present in parameters. It holds the entity of the parameterless +-- function that is built to evaluate the default expression if it is +-- more complex than a simple identifier or literal. For the latter +-- simple cases or if there is no default value, this field is Empty. + +-- Default_Expressions_Processed (Flag108) +-- A flag in subprograms (functions, operators, procedures) and in +-- entries and entry families used to indicate that default expressions +-- have been processed and to avoid multiple calls to process the +-- default expressions (see Freeze.Process_Default_Expressions), which +-- would not only waste time, but also generate false error messages. + +-- Default_Value (Node20) +-- Present in formal parameters. Points to the node representing the +-- expression for the default value for the parameter. Empty if the +-- parameter has no default value (which is always the case for OUT +-- and IN OUT parameters in the absence of errors). + +-- Delay_Cleanups (Flag114) +-- Present in entities that have finalization lists (subprograms +-- blocks, and tasks). Set if there are pending generic body +-- instantiations for the corresponding entity. If this flag is +-- set, then generation of cleanup actions for the corresponding +-- entity must be delayed, since the insertion of the generic body +-- may affect cleanup generation (see Inline for further details). + +-- Delay_Subprogram_Descriptors (Flag50) +-- Present in entities for which exception subprogram descriptors +-- are generated (subprograms, package declarations and package +-- bodies). Present if there are pending generic body instantiations +-- for the corresponding entity. If this flag is set, then generation +-- of the subprogram descriptor for the corresponding enities must +-- be delayed, since the insertion of the generic body may add entries +-- to the list of handlers. +-- +-- Note: for subprograms, Delay_Subprogram_Descriptors is set if and +-- only if Delay_Cleanups is set. But Delay_Cleanups can be set for a +-- a block (in which case Delay_Subprogram_Descriptors is set for the +-- containing subprogram). In addition Delay_Subprogram_Descriptors is +-- set for a library level package declaration or body which contains +-- delayed instantiations (in this case the descriptor refers to the +-- enclosing elaboration procedure). + +-- Delta_Value (Ureal18) +-- Present in fixed and decimal types. Points to a universal real +-- that holds value of delta for the type, as given in the declaration +-- or as inherited by a subtype or derived type. + +-- Dependent_Instances (Elist8) +-- Present in packages that are instances. Holds list of instances +-- of inner generics. Used to place freeze nodes for those instances +-- after that of the current one, i.e. after the corresponding generic +-- bodies. + +-- Depends_On_Private (Flag14) +-- Present in all type entities. Set if the type is private or if it +-- depends on a private type. + +-- Designated_Type (synthesized) +-- Applies to access types. Returns the designated type. Differs +-- from Directly_Designated_Type in that if the access type refers +-- to an incomplete type, and the full type is available, then this +-- full type is returned instead of the incomplete type. + +-- Digits_Value (Uint17) +-- Present in floating point types and subtypes and decimal types and +-- subtypes. Contains the Digits value specified in the declaration. + +-- Directly_Designated_Type (Node20) +-- Present in access types. This field points to the type that is +-- directly designated by the access type. In the case of an access +-- type to an incomplete type, this field references the incomplete +-- type. Note that in the semantic processing, what is useful in +-- nearly all cases is the full type designated by the access type. +-- The function Designated_Type obtains this full type in the case of +-- access to an incomplete type. + +-- Discard_Names (Flag88) +-- Present in types and exception entities. Set if pragma Discard_Names +-- applies to the entity. It is also set for declarative regions and +-- package specs for which a Discard_Names pragma with zero arguments +-- has been encountered. The purpose of setting this flag is to be able +-- to set the Discard_Names attribute on enumeration types declared +-- after the pragma within the same declarative region. + +-- Discriminal (Node17) +-- Present in discriminants (Discriminant formal: GNAT's first +-- coinage). The entity used as a formal parameter that corresponds +-- to a discriminant. See section "Use of Discriminants" for details. + +-- Discriminal_Link (Node10) +-- Present in discriminals (which have an Ekind of E_In_Parameter, +-- or E_Constant), points back to corresponding discriminant. + +-- Discriminant_Checking_Func (Node20) +-- Present in components. Points to the defining identifier of the +-- function built by the expander returns a Boolean indicating whether +-- the given record component exists for the current discriminant +-- values. + +-- Discriminant_Constraint (Elist21) +-- Present in entities whose Has_Discriminants flag is set (concurrent +-- types, subtypes, record types and subtypes, private types and +-- subtypes, limited private types and subtypes and incomplete types). +-- It is an error to reference the Discriminant_Constraint field if +-- Has_Disciminants is False. +-- +-- If the Is_Constrained flag is set, Discriminant_Constraint points +-- to an element list containing the discriminant constraints in the +-- same order in which the discriminants are declared. +-- +-- If the Is_Constrained flag is not set but the discriminants of the +-- unconstrained type have default initial values then this field +-- points to an element list giving these default initial values in +-- the same order in which the discriminants are declared. Note that +-- in this case the entity cannot be a tagged record type, because +-- discriminants in this case cannot have defaults. +-- +-- If the entity is a tagged record implicit type, then this field is +-- inherited from the first subtype (so that the itype is subtype +-- conformant with its first subtype, which is needed when the first +-- subtype overrides primitive operations inherited by the implicit +-- base type). +-- +-- In all other cases Discriminant_Constraint contains the empty +-- Elist (ie it is initialized with a call to New_Elmt_List). + +-- Discriminant_Default_Value (Node20) +-- Present in discriminants. Points to the node representing the +-- expression for the default value of the discriminant. Set to +-- Empty if the discriminant has no default value. + +-- Discriminant_Number (Uint15) +-- Present in discriminants. Gives the ranking of a discriminant in +-- the list of discriminants of the type, i.e. a sequential integer +-- index starting at 1 and ranging up to Number_Discriminants. + +-- DTC_Entity (Node16) +-- Present in function and procedure entities. Set to Empty unless +-- the subprogram is dispatching in which case it references the +-- Dispatch Table pointer Component. That is to say the component _tag +-- for regular Ada tagged types, for CPP_Class types and their +-- descendants this field points to the component entity in the record +-- that is the Vtable pointer for the Vtable containing the entry that +-- references the subprogram. + +-- DT_Entry_Count (Uint15) +-- Present in E_Component entities. Only used for component marked +-- Is_Tag. Store the number of entries in the Vtable (or Dispatch Table) + +-- DT_Position (Uint15) +-- Present in function and procedure entities which are dispatching +-- (should not be referenced without first checking that flag +-- Is_Dispatching_Operation is True). Contains the offset into +-- the Vtable for the entry that references the subprogram. + +-- Ekind (Ekind) +-- Present in all entities. Contains a value of the enumeration type +-- Entity_Kind declared in a subsequent section in this spec. + +-- Elaborate_All_Desirable (Flag146) +-- Present in package and subprogram entities, and in generic package +-- and subprogram entities. Set if internal analysis of a client that +-- with's this unit determines that Elaborate_All is desirable, i.e. +-- that there is a possibility that Program_Error may be raised if +-- Elaborate_All conditions cannot be met. + +-- Elaboration_Entity (Node13) +-- Present in generic and non-generic package and subprogram +-- entities. This is a boolean entity associated with the unit that +-- is initiallly set to False, and is set True when the unit is +-- elaborated. This is used for two purposes. First, it is used to +-- implement required access before elaboration checks (the flag +-- must be true to call a subprogram at elaboration time). Second, +-- it is used to guard against repeated execution of the generated +-- elaboration code. +-- +-- Note that we always allocate this flag, and set this field, but +-- we do not always actually use it. It is only used if it is needed +-- for access-before-elaboration use (see Elaboration_Entity_Required +-- flag) or if either the spec or the body has elaboration code. If +-- neither of these two conditions holds, then the entity is still +-- allocated (since we don't know early enough whether or not there +-- is elaboration code), but is simply not used for any purpose. + +-- Elaboration_Entity_Required (Flag174) +-- Present in generics and non-generic package and subprogram +-- entities. Set only if Elaboration_Entity is non-Empty to indicate +-- that the boolean is required to be set even if there is no other +-- elaboration code. This occurs when the Elaboration_Entity flag +-- is used for required access-before-elaboration checking. If the +-- flag is only for preventing multiple execution of the elaboration +-- code, then if there is no other elaboration code, obviously there +-- is no need to set the flag. + +-- Enclosing_Dynamic_Scope (synthesized) +-- Appliesa to all entities. Returns the closest dynamic scope in which +-- the entity is declared or Standard_Standard for library-level entities + +-- Enclosing_Scope (Node18) +-- Present in labels. Denotes the innermost enclosing construct that +-- contains the label. Identical to the scope of the label, except for +-- labels declared in the body of an accept statement, in which case the +-- entry_name is the Enclosing_Scope. Used to validate goto's within +-- accept statements. + +-- Entry_Accepted (Flag152) +-- Present in E_Entry and E_Entry_Family entities. Set if there is +-- at least one accept for this entry in the task body. Used to +-- generate warnings for missing accepts. + +-- Entry_Bodies_Array (Node15) +-- Present in protected types for which Has_Entries is true. +-- This is the defining identifier for the array of entry body +-- action procedures and barrier functions used by the runtime to +-- execute the user code associated with each entry. + +-- Entry_Cancel_Parameter (Node23) +-- Present in blocks. This only applies to a block statement for +-- which the Is_Asynchronous_Call_Block flag is set. It +-- contains the defining identifier of an object that must be +-- passed to the Cancel_Task_Entry_Call or Cancel_Protected_Entry_Call +-- call in the cleanup handler added to the block by +-- Exp_Ch7.Expand_Cleanup_Actions. This parameter is a Boolean +-- object for task entry calls and a Communications_Block object +-- in the case of protected entry calls. In both cases the objects +-- are declared in outer scopes to this block. + +-- Entry_Component (Node11) +-- Present in formal parameters (in, in out and out parameters). Used +-- only for formals of entries. References the corresponding component +-- of the entry parameter record for the entry. + +-- Entry_Formal (Node16) +-- Present in components of the record built to correspond to entry +-- parameters. This field points from the component to the formal. It +-- is the back pointer corresponding to Entry_Component. + +-- Entry_Index_Constant (Node18) +-- Present in an entry index parameter. This is an identifier that +-- eventually becomes the name of a constant representing the index +-- of the entry family member whose entry body is being executed. Used +-- to expand references to the entry index specification identifier. + +-- Entry_Index_Type (synthesized) +-- Applies to an entry family. Denotes Etype of the subtype indication +-- in the entry declaration. Used to resolve the index expression in an +-- accept statement for a member of the family, and in the prefix of +-- 'COUNT when it applies to a family member. + +-- Entry_Parameters_Type (Node15) +-- Present in entries. Points to the access-to-record type that is +-- constructed by the expander to hold a reference to the parameter +-- values. This reference is manipulated (as an address) by the +-- tasking runtime. The designated record represents a packaging +-- up of the entry parameters (see Exp_Ch9.Expand_N_Entry_Declaration +-- for further details). Entry_Parameters_Type is Empty if the entry +-- has no parameters. + +-- Enumeration_Pos (Uint11) +-- Present in enumeration literals. Contains the position number +-- corresponding to the value of the enumeration literal. + +-- Enumeration_Rep (Uint12) +-- Present in enumeration literals. Contains the representation that +-- corresponds to the value of the enumeration literal. Note that +-- this is normally the same as Enumeration_Pos except in the presence +-- of representation clauses, where Pos will still represent the +-- position of the literal within the type and Rep will have be the +-- value given in the representation clause. + +-- Enumeration_Rep_Expr (Node22) +-- Present in enumeration literals. Points to the expression in an +-- associated enumeration rep clause that provides the representation +-- value for this literal. Empty if no enumeration rep clause for this +-- literal (or if rep clause does not have an entry for this literal, +-- an error situation). This is also used to catch duplicate entries +-- for the same literal. + +-- Enum_Pos_To_Rep (Node23) +-- Present in enumeration types (but not enumeration subtypes). Set to +-- Empty unless the enumeration type has a non-standard representation +-- (i.e. at least one literal has a representation value different from +-- its pos value). In this case, Enum_Pos_To_Rep is the entity for an +-- array constructed when the type is frozen that maps Pos values to +-- corresponding Rep values. The index type of this array is Natural, +-- and the component type is a suitable integer type that holds the +-- full range of representation values. + +-- Equivalent_Type (Node18) +-- Present in class wide types and subtypes, access to protected +-- subprogram types, and in exception_types. For a classwide type, it +-- is always Empty. For a class wide subtype, it points to an entity +-- created by the expander which gives Gigi an easily understandable +-- equivalent of the class subtype with a known size (given by an +-- initial value). See Exp_Util.Expand_Class_Wide_Subtype for further +-- details. For E_exception_type, this points to the record containing +-- the data necessary to represent exceptions (for further details, see +-- System.Standard_Library. For access_to_protected subprograms, it +-- denotes a record that holds pointers to the operation and to the +-- protected object. For remote Access_To_Subprogram types, it denotes +-- the record that is the fat pointer representation of an RAST. + +-- Esize (Uint12) +-- Present in all types and subtypes, an also for components, constants, +-- and variables. Contains the Object_Size of the type or of the object. +-- A value of zero indicates that the value is not yet known. +-- +-- For the case of components where a component clause is present, the +-- value is the value from the component clause, which must be non- +-- negative (but may be zero, which is acceptable for the case of +-- a type with only one possible value). It is also possible for Esize +-- of a component to be set without a component clause present, which +-- means that the component size is specified, but not the position. +-- See also RM_Size and the section on "Handling of Type'Size Values". +-- During gigi processing, the value is back annotated for all zero +-- values, so that after the call to gigi, the value is properly set. + +-- Etype (Node5) +-- Present in all entities. Represents the type of the entity, which +-- is itself another entity. For a type entity, points to the parent +-- type for a derived type, or if the type is not derived, points to +-- itself. For a subtype entity, Etype points to the base type. + +-- Exception_Code (Uint22) +-- Present in exception entitites. Set to zero unless either an +-- Import_Exception or Export_Exception pragma applies to the +-- pragma and specifies a Code value. See description of these +-- pragmas for details. Note that this field is relevant only if +-- Is_VMS_Exception is set. + +-- Extra_Formal (Node15) +-- Present in formal parameters in the non-generic case. Certain +-- parameters require extra implicit information to be passed +-- (e.g. the flag indicating if an unconstrained variant record +-- argument is constrained, and the accessibility level for +-- access parameters. See description of Extra_Constrained, +-- Extra_Accessibility fields for further details. Extra formal +-- parameters are constructed to represent these values, and +-- chained to the end of the list of formals using the +-- Extra_Formal field (i.e. the Extra_Formal field of the last +-- "real" formal points to the first extra formal, and the +-- Extra_Formal field of each extra formal points to the next +-- one, with Empty indicating the end of the list of extra +-- formals. + +-- Extra_Accessibility (Node13) +-- Present in formal parameters in the non-generic case if +-- expansion is active. Normally Empty, but if a parameter is +-- one for which a dynamic accessibility check is required, then +-- an extra formal of type Natural is created (see description +-- of field Extra_Formal), and the Extra_Accessibility field of +-- the formal parameter points to the entity for this extra +-- formal. Also present in variables when compiling receiving +-- stubs. In this case, a non Empty value means that this +-- variable's accessibility depth has been transmitted by the +-- caller and must be retrieved through the entity designed by +-- this field instead of being computed. + +-- Extra_Constrained (Node23) +-- Present in formal parameters in the non-generic case if +-- expansion is active. Normally Empty, but if a parameter is +-- one for which a dynamic indication of its constrained status +-- is required, then an extra formal of type Boolean is created +-- (see description of field Extra_Formal), and the +-- Extra_Constrained field of the formal parameter points to the +-- entity for this extra formal. Also present in variables when +-- compiling receiving stubs. In this case, a non empty value +-- means that this variable's constrained status has been +-- transmitted by the caller and must be retrieved through the +-- entity designed by this field instead of being computed. + +-- Finalization_Chain_Entity (Node19) +-- Present in scopes which can have finalizable entities (blocks, +-- functions, procedures, tasks, entries). When this field is empty it +-- means that there are no finalization actions to perform on exit of the +-- scope. When this field contains 'Error', it means that no +-- finalization actions should happen at this level and the +-- finalization chain of a parent scope shall be used (??? this is +-- an improper use of 'Error' and should be changed). otherwise it +-- contains an entity of type Finalizable_Ptr that is the head of the +-- list of objects to finalize on exit. See "Finalization Management" +-- section in exp_ch7.adb for more details. + +-- Finalize_Storage_Only (Flag158) [base type only] +-- Present in all types. Set on direct controlled types to which a +-- valid Finalize_Storage_Only pragma applies. This flag is also set on +-- composite types when they have at least one controlled component and +-- all their controlled components are Finalize_Storage_Only. It is also +-- inherited by type derivation except for direct controlled types where +-- the Finalize_Storage_Only pragma is required at each level of +-- derivation. + +-- First_Component (synthesized) +-- Applies to record types. Returns the first component by following +-- the chain of declared entities for the record until a component +-- is found (one with an Ekind of E_Component). The discriminants are +-- skipped. If the record is null, then Empty is returned. + +-- First_Discriminant (synthesized) +-- Applies to types with discriminants. The discriminants are the +-- first entities declared in the type, so normally this is equivalent +-- to First_Entity. The exception arises for tagged types, where the +-- tag itself is prepended to the front of the entity chain, so the +-- First_Discriminant function steps past the tag if it is present. + +-- First_Girder_Discriminant (synthesized) +-- Applies to types with discriminants. For tagged types, and untagged +-- types which are root types or derived types but which do not rename +-- discriminants in their root type, this is the same as +-- First_Discriminant. +-- +-- For derived non-tagged types that rename discriminants in the root +-- type this is the first of the discriminants that occurr in the +-- root type. To be precise, in this case girder discriminants are +-- entities attached to the entity chain of the derived type which +-- are a copy of the discriminants of the root type. Furthermore their +-- Is_Completely_Hidden flag is set. +-- +-- For derived untagged types, girder discriminants are the real +-- discriminants from Gigi's standpoint, ie those that will be stored in +-- actual objects of the type. + +-- First_Entity (Node17) +-- Present in all entities which act as scopes to which a list of +-- associated entities is attached (blocks, class subtypes and types, +-- entries, functions, loops, packages, procedures, protected objects, +-- record types and subtypes, private types, task types and subtypes). +-- Points to a list of associated entities using the Next_Entity field +-- as a chain pointer with Empty marking the end of the list. + +-- First_Formal (synthesized) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns first formal of the subprogram or entry. +-- The formals are the first entities declared in a subprogram or in +-- a subprogram type (the designated type of an Access_To_Subprogram +-- definition) or in an entry. + +-- First_Index (Node17) +-- Present in array types and subtypes and in string types and subtypes. +-- By introducing implicit subtypes for the index constraints, we have +-- the same structure for constrained and unconstrained arrays, subtype +-- marks and discrete ranges are both represented by a subtype. This +-- function returns the tree node corresponding to an occurrence of the +-- first index (NOT the entity for the type). Subsequent indexes are +-- obtained using Next_Index. Note that this field is present for the +-- case of string literal subtypes, but is always Empty. + +-- First_Literal (Node17) +-- Present in all enumeration types, including character and boolean +-- types. This field points to the first enumeration literal entity +-- for the type (i.e. it is set to First (Literals (N)) where N is +-- the enumeration type definition node. A special case occurs with +-- standard character and wide character types, where this field is +-- Empty, since there are no enumeration literal lists in these cases. + +-- First_Optional_Parameter (Node14) +-- Present in (non-generic) function and procedure entities. Set to a +-- non-null value only if a pragma Import_Function, Import_Procedure +-- or Import_Valued_Procedure specifies a First_Optional_Parameter +-- argument, in which case this field points to the parameter entity +-- corresponding to the specified parameter. + +-- First_Private_Entity (Node16) +-- Present in all entities containing private parts (packages, +-- protected types and subtypes, task types and subtypes). The +-- entities on the entity chain are in order of declaration, so the +-- entries for private entities are at the end of the chain. This +-- field points to the first entity for the private part. It is +-- Empty if there are no entities declared in the private part or +-- if there is no private part. + +-- First_Rep_Item (Node6) +-- Present in all entities. If non-empty, points to a linked list of +-- representation pragmas nodes and representation clause nodes that +-- apply to the entity, linked using Next_Rep_Item, with Empty marking +-- the end of the list. In the case of derived types and subtypes, the +-- new entity inherits the chain at the point of declaration. This +-- means that it is possible to have multiple instances of the same +-- kind of rep item on the chain, in which case it is the first one +-- that applies to the entity. +-- +-- For most representation items, the representation information is +-- reflected in other fields and flags in the entity. For example if +-- a record representation clause is present, the component entities +-- reflect the specified information. However, there are some items +-- that are only reflected in the chain. These include: +-- +-- Alignment attribute definition clause +-- Machine_Attribute pragma +-- Link_Alias pragma +-- Link-Section pragma +-- Weak_External pragma +-- +-- If any of these items are present, then the flag Has_Gigi_Rep_Item +-- is set, indicating that Gigi should search the chain. +-- +-- Other representation items are included in the chain so that error +-- messages can easily locate the relevant nodes for posting errors. +-- Note in particular that size clauses are present only for this +-- purpose, and should only be accessed if Has_Size_Clause is set. + +-- First_Subtype (synthesized) +-- Applies to all types and subtypes. For types, yields the first +-- subtype of the type. For subtypes, yields the first subtype of +-- the base type of the subtype. + +-- Freeze_Node (Node7) +-- Present in all entities. If there is an associated freeze node for +-- the entity, this field references this freeze node. If no freeze +-- node is associated with the entity, then this field is Empty. See +-- package Freeze for further details. + +-- From_With_Type (Flag159) +-- Present in package and type entities. Indicates that the entity +-- appears in a With_Type clause in the context of some other unit, +-- either as the prefix (which must be a package), or as a type name. +-- The package can only be used to retrieve such a type, and the type +-- can be used only in component declarations and access definitions. +-- The With_Type clause is used to construct mutually recursive +-- types, i.e. record types (Java classes) that hold pointers to each +-- other. If such a type is an access type, it has no explicit freeze +-- node, so that the back-end does not attempt to elaborate it. + +-- Full_View (Node11) +-- Present in all type and subtype entities and in deferred constants. +-- References the entity for the corresponding full type declaration. +-- For all types other than private and incomplete types, this field +-- always contains Empty. See also Underlying_Type. + +-- Function_Returns_With_DSP (Flag169) +-- Present in all subprogram entities, and type entities for access +-- to subprogram values. Set True if the function (or referenced +-- function in the case of an access value) returns with using the +-- DSP (depressed stack pointer) approach. This can only be set +-- True if Targparm.Functions_Return_By_DSP_On_Target is True and +-- the function returns a value of a type whose size is not known +-- at compile time. + +-- Generic_Renamings (Elist23) +-- Present in package and subprogram instances. Holds mapping that +-- associates generic parameters with the corresponding instances, in +-- those cases where the instance is an entity. + +-- Girder_Constraint (Elist23) +-- Present in entities that can have discriminants (concurrent types +-- subtypes, record types and subtypes, private types and subtypes, +-- limited private types and subtypes and incomplete types). Points +-- to an element list containing the expressions for each of the +-- girder discriminants for the record (sub)type. + +-- Handler_Records (List10) +-- Present in subprogram and package entities. Points to a list of +-- identifiers referencing the handler record entities for the +-- corresponding unit. + +-- Has_Aliased_Components (Flag135) [implementation base type only] +-- Present in array type entities. Indicates that the component type +-- of the array is aliased. + +-- Has_Alignment_Clause (Flag46) +-- Present in all type entities and objects. Indicates if an alignment +-- clause has been given for the entity. If set, then Alignment_Clause +-- returns the N_Attribute_Definition node for the alignment attribute +-- definition clause. Note that it is possible for this flag to be False +-- even when Alignment_Clause returns non_Empty (this happens in the case +-- of derived type declarations). + +-- Has_All_Calls_Remote (Flag79) +-- Present in all library unit entities. Set true if the library unit +-- has an All_Calls_Remote pragma. Note that such entities must also +-- be RCI entities, so the flag Is_Remote_Call_Interface will always +-- be set if this flag is set. + +-- Has_Atomic_Components (Flag86) [implementation base type only] +-- Present in all types and objects. Set only for an array type or +-- an array object if a valid pragma Atomic_Components applies to the +-- type or object. Note that in the case of an object, this flag is +-- only set on the object if there was an explicit pragma for the +-- object. In other words, the proper test for whether an object has +-- atomic components is to see if either the object or its base type +-- has this flag set. Note that in the case of a type, the pragma will +-- be chained to the rep item chain of the first subtype in the usual +-- manner. + +-- Has_Attach_Handler (synthesized) +-- Applies to record types that are constructed by the expander to +-- represent protected types. Returns True if there is at least one +-- Attach_Handler pragma in the corresponding specification. + +-- Has_Biased_Representation (Flag139) +-- Present in discrete types (where it applies to the type'size value), +-- and to objects (both stand-alone and components), where it applies to +-- the size of the object from a size or record component clause. In +-- all cases it indicates that the size in question is smaller than +-- would normally be required, but that the size requirement can be +-- satisfied by using a biased representation, in which stored values +-- have the low bound (Expr_Value (Type_Low_Bound (T)) subtracted to +-- reduce the required size. For example, a type with a range of 1..2 +-- takes one bit, using 0 to represent 1 and 1 to represent 2. +-- +-- Note that in the object and component cases, the flag is only set +-- if the type is unbiased, but the object specifies a smaller size +-- than the size of the type, forcing biased representation for the +-- object, but the subtype is still an unbiased type. + +-- Has_Completion (Flag26) +-- Present in all entities that require a completion (functions, +-- procedures, private types, limited private types, incomplete types, +-- and packages that require a body). Set if the completion has been +-- encountered and analyzed. + +-- Has_Completion_In_Body (Flag71) +-- Present in "Taft amendment types" that is to say incomplete types +-- whose full declaration appears in the package body. + +-- Has_Complex_Representation (Flag140) [implementation base type only] +-- Present in all type entities. Set only for a record base type to +-- which a valid pragma Complex_Representation applies. + +-- Has_Component_Size_Clause (Flag68) [implementation base type only] +-- Present in all type entities. Set if a component size clause is +-- present for the given type. Note that this flag can be False even +-- if Component_Size is non-zero (happens in the case of derived types). + +-- Has_Controlling_Result (Flag98) +-- Present in E_Function entities. True if The function is a primitive +-- function of a tagged type which can dispatch on result + +-- Has_Controlled_Component (Flag43) [base type only] +-- Present in composite type entities. Indicates that the type has a +-- component that either is a controlled type, or itself contains a +-- controlled component (i.e. either Has_Controlled_Component or +-- Is_Controlled is set for at least one component). + +-- Has_Convention_Pragma (Flag119) +-- Present in an entity for which a Convention, Import, or Export +-- pragma has been given. Used to prevent more than one such pragma +-- appearing for a given entity (RM B.1(45)). + +-- Has_Delayed_Freeze (Flag18) +-- Present in all entities. Set to indicate that an explicit freeze +-- node must be generated for the entity at its freezing point. See +-- separate section ("Delayed Freezing and Elaboration") for details. + +-- Has_Discriminants (Flag5) +-- Present in all types and subtypes. For types that are allowed to have +-- discriminants (record types and subtypes, task types and subtypes, +-- protected types and subtypes, private types, limited private types, +-- and incomplete types), indicates if the corresponding type or subtype +-- has a known discriminant part. Always false for all other types. + +-- Has_Entries (synthesized) +-- Applies to concurrent types. True if any entries are declared +-- within the task or protected definition for the type. + +-- Has_Enumeration_Rep_Clause (Flag66) +-- Present in enumeration types. Set if an enumeration representation +-- clause has been given for this enumeration type. Used to prevent more +-- than one enumeration representation clause for a given type. Note +-- that this does not imply a representation with holes, since the rep +-- clause may merely confirm the default 0..N representation. + +-- Has_External_Tag_Rep_Clause (Flag110) +-- Present in tagged types. Set if an external_tag rep. clause has been +-- given for this type. Use to avoid the generation of the default +-- external_tag. + +-- Has_Exit (Flag47) +-- Present in loop entities. Set if the loop contains an exit statement. + +-- Has_Foreign_Convention (synthesized) +-- Applies to all entities. Determines if the Convention for the +-- entity is a foreign convention (i.e. is other than Convention_Ada, +-- Convention_Intrinsic, Convention_Entry or Convention_Protected). + +-- Has_Forward_Instantiation (Flag175) +-- Present in package entities. Set true for packages that contain +-- instantiations of local generic entities, before the corresponding +-- generic body has been seen. If a package has a forward instantiation, +-- we cannot inline subprograms appearing in the same package because +-- the placement requirements of the instance will conflict with the +-- linear elaboration of front-end inlining. + +-- Has_Fully_Qualified_Name (Flag173) +-- Present in all entities. Set True if the name in the Chars field +-- has been replaced by the fully qualified name, as used for debug +-- output. See Exp_Dbug for a full description of the use of this +-- flag and also the related flag Has_Qualified_Name. + +-- Has_Gigi_Rep_Item (Flag82) +-- This flag is set if the rep item chain (referenced by First_Rep_Item +-- and linked through the Next_Rep_Item chain contains a representation +-- item that needs to be specially processed by Gigi, i.e. one of the +-- following items: +-- +-- Machine_Attribute pragma +-- Linker_Alias pragma +-- Linker_Section pragma +-- Weak_External pragma +-- +-- If this flag is set, then Gigi should scan the rep item chain to +-- process any of these items that appear. At least one such item will +-- be present. + +-- Has_Homonym (Flag56) +-- Present in all entities. Set if an entity has a homonym in the same +-- scope. Used by Gigi to generate unique names for such entities. + +-- Has_Interrupt_Handler (synthesized) +-- Applies to all protected types entities. Set if the protected type +-- definition contains at least one procedure to which a pragma +-- Interrupt_Handler applies. + +-- Has_Machine_Radix_Clause (Flag83) +-- Present in decimal types and subtypes, set if a Machine_Radix +-- representation clause is present. This flag is used to detect +-- the error of multiple machine radix clauses for a single type. + +-- Has_Master_Entity (Flag21) +-- Present in entities that can appear in the scope stack (see spec +-- of Sem). It is set if a task master entity (_master) has been +-- declared and initialized in the corresponding scope. + +-- Has_Missing_Return (Flag142) +-- Present in functions and generic functions. Set if there is one or +-- more missing return statements in the function. This is used to +-- control wrapping of the body in Exp_Ch6 to ensure that the program +-- error exeption is correctly raised in this case at runtime. + +-- Has_Nested_Block_With_Handler (Flag101) +-- Present in scope entities. Set if there is a nested block within the +-- scope that has an exception handler and the two scopes are in the +-- same procedure. This is used by the backend for controlling certain +-- optimizations to ensure that they are consistent with exceptions. +-- See documentation in Gigi for further details. + +-- Has_Non_Standard_Rep (Flag75) [implementation base type only] +-- Present in all type entities. Set when some representation clause +-- or pragma causes the representation of the item to be significantly +-- modified. In this category are changes of small or radix for a +-- fixed-point type, change of component size for an array, and record +-- or enumeration representation clauses, as well as packed pragmas. +-- All other representation clauses (e.g. Size and Alignment clauses) +-- are not considered to be significant since they do not affect +-- stored bit patterns. + +-- Has_Object_Size_Clause (Flag172) +-- Present in entities for types and subtypes. Set if an Object_Size +-- clause has been processed for the type Used to prevent multiple +-- Object_Size clauses for a given entity. + +-- Has_Per_Object_Constraint (Flag154) +-- Present in E_Component entities, true if the subtype of the +-- component has a per object constraint, i.e. an actual discriminant +-- value of the form T'Access, where T is the enclosing type. + +-- Has_Pragma_Controlled (Flag27) [implementation base type only] +-- Present in access type entities. It is set if a pragma Controlled +-- applies to the access type. + +-- Has_Pragma_Elaborate_Body (Flag150) +-- Present in all entities. Set in compilation unit entities if a +-- pragma Elaborate_Body applies to the compilation unit. + +-- Has_Pragma_Inline (Flag157) +-- Present in all entities. Set for functions and procedures for which +-- a pragma Inline or Inline_Always applies to the subprogram. Note +-- subprogram. Note that this flag can be set even if Is_Inlined is +-- not set. This happens for pragma Inline (if Inline_Active is False) +-- In other words, the flag Has_Pragma_Inline represents the formal +-- semantic status, and is used for checking semantic correctness. +-- The flag Is_Inlined indicates whether inlining is actually active +-- for the entity. + +-- Has_Pragma_Pack (Flag121) [implementation base type only] +-- Present in all entities. It indicates that a valid pragma Pack was +-- was given for the type. Note that this flag is not inherited by a +-- derived type. See also the Is_Packed flag. + +-- Has_Primitive_Operations (Flag120) [base type only] +-- Present in all type entities. Set if at least one primitive operation +-- is defined on the type. This flag is not yet properly set ??? + +-- Has_Private_Ancestor (synthesized) +-- Applies to all type and subtype entities. Returns True if at least +-- one ancestor is private, and otherwise False if there are no private +-- ancestors. + +-- Has_Private_Declaration (Flag155) +-- Present in all entities. Returns True if it is the defining entity +-- of a private type declaration or its corresponding full declaration. +-- This flag is thus preserved when the full and the partial views are +-- exchanged, to indicate if a full type declaration is a completion. +-- Used for semantic checks in E.4 (18), and elsewhere. + +-- Has_Qualified_Name (Flag161) +-- Present in all entities. Set True if the name in the Chars field +-- has been replaced by its qualified name, as used for debug output. +-- See Exp_Dbug for a full description of qualification requirements. +-- For some entities, the name is the fully qualified name, but there +-- are exceptions. In particular, for local variables in procedures, +-- we do not include the procedure itself or higher scopes. See also +-- the flag Has_Fully_Qualified_Name, which is set if the name does +-- indeed include the fully qualified name. + +-- Has_Record_Rep_Clause (Flag65) +-- Present in record types. Set if a record representation clause has +-- been given for this record type. Used to prevent more than one such +-- clause for a given record type. Note that this is initially cleared +-- for a derived type, even though the representation is inherited. See +-- also the flag Has_Specified_Layout. + +-- Has_Recursive_Call (Flag143) +-- Present in procedures. Set if a direct parameterless recursive call +-- is detected while analyzing the body. Used to activate some error +-- checks for infinite recursion. + +-- Has_Size_Clause (Flag29) +-- Present in entities for types and objects. Set if a size clause is +-- present for the entity. Used to prevent multiple Size clauses for a +-- given entity. Note that it is always initially cleared for a derived +-- type, even though the Size for such a type is inherited from a Size +-- clause given for the parent type. + +-- Has_Small_Clause (Flag67) +-- Present in ordinary fixed point types (but not subtypes). Indicates +-- that a small clause has been given for the entity. Used to prevent +-- multiple Small clauses for a given entity. Note that it is always +-- initially cleared for a derived type, even though the Small for such +-- a type is inherited from a Small clause given for the parent type. + +-- Has_Specified_Layout (Flag100) +-- Present in all type entities. Set for a record type or subtype if +-- the record layout has been specified by a record representation +-- clause. Note that this differs from the flag Has_Record_Rep_Clause +-- in that it is inherited by a derived type. Has_Record_Rep_Clause is +-- used to indicate that the type is mentioned explicitly in a record +-- representation clause, and thus is not inherited by a derived type. +-- This flag is always False for non-record types. + +-- Has_Storage_Size_Clause (Flag23) [implementation base type only] +-- Present in task types and access types. It is set if a Storage_Size +-- clause is present for the type. Used to prevent multiple clauses for +-- one type. Note that this flag is initially cleared for a derived type +-- even though the Storage_Size for such a type is inherited from a +-- Storage_Size clause given for the parent type. Note that in the case +-- of access types, this flag is present only in the root type, since a +-- storage size clause cannot be given to a derived type. + +-- Has_Subprogram_Descriptor (Flag93) +-- This flag is set on entities for which zero-cost exception subprogram +-- descriptors can be generated (subprograms and library level package +-- declarations and bodies). It indicates that a subprogram descriptor +-- has been generated, and is used to suppress generation of multiple +-- descriptors (e.g. when instantiating generic bodies). + +-- Has_Task (Flag30) [base type only] +-- Present in all type entities. Set on task types themselves, and also +-- (recursively) on any composite type which has a component for which +-- Has_Task is set. The meaning is that an allocator of such an object +-- must create the required tasks. Note that the flag is not set on +-- access types, even if they designate an object that Has_Task. + +-- Has_Unchecked_Union (Flag123) [base type only] +-- Present in all type entities. Set on unchecked unions themselves +-- and (recursively) on any composite type which has a component for +-- which Has_Unchecked_Union is set. The meaning is that a comparison +-- operation for the type is not permitted. Note that the flag is not +-- set on access types, even if they designate an object that has +-- the flag Has_Unchecked_Union set. + +-- Has_Unknown_Discriminants (Flag72) +-- Present in all type entities. Types can have unknown discriminants +-- either from their declaration or through type derivation. The use +-- of this flag exactly meets the spec in RM 3.7(26). Note that all +-- class-wide types are considered to have unknown discriminants. + +-- Has_Volatile_Components (Flag87) [implementation base type only] +-- Present in all types and objects. Set only for an array type or +-- array object if a valid pragma Volatile_Components or a valid +-- pragma Atomic_Components applies to the type or object. Note that +-- in the case of an object, this flag is only set on the object if +-- there was an explicit pragma for the object. In other words, the +-- proper test for whether an object has volatile components is to +-- see if either the object or its base type has this flag set. Note +-- that in the case of a type the pragma will be chained to the rep +-- item chain of the first subtype in the usual manner. + +-- Hiding_Loop_Variable (Node8) +-- Present in variables. Set only if a variable of a discrete type is +-- hidden by a loop variable in the same local scope, in which case +-- the Hiding_Loop_Variable field of the hidden variable points to +-- the E_Loop_Variable entity doing the hiding. Used in processing +-- warning messages if the hidden variable turns out to be unused +-- or is referenced without being set. + +-- Homonym (Node4) +-- Present in all entities. Link for list of entities that have the +-- same source name and that are declared in the same or enclosing +-- scopes. Homonyms in the same scope are overloaded. Used for name +-- resolution and for the generation of debugging information. + +-- Implementation_Base_Type (synthesized) +-- Applies to all types. Similar to Base_Type, but never returns a +-- private type when applied to a non-private type. Instead in this +-- case, it always returns the Representation_Type of the base type +-- in this case, so that we still have a concrete type. Note: it is +-- allowed to apply Implementation_Base_Type to other than a type, +-- in which case it simply returns the entity unchanged. + +-- In_Package_Body (Flag48) +-- Set on the entity that denotes the package (the defining occurrence +-- of the package declaration) while analyzing and expanding the package +-- body. Reset on completion of analysis/expansion. + +-- In_Private_Part (Flag45) +-- Present in package entities. Flag is set to indicate that the +-- private part is being analyzed. The flag is reset at the end of the +-- package declaration. + +-- Inner_Instances (Elist23) +-- Present in generic units. Contains element list of units that are +-- instantiated within the given generic. Used to diagnose circular +-- instantiations. + +-- Interface_Name (Node21) +-- Present in exceptions, functions, procedures, variables, constants, +-- and packages. Set to Empty unless an export, import, or interface +-- name pragma has explicitly specified an external name, in which +-- case it references an N_String_Literal node for the specified +-- exteral name. In the case of exceptions, the field is set by +-- Import_Exception/Export_Exception (which can be used in OpenVMS +-- versions only). Note that if this field is Empty, and Is_Imported +-- or Is_Exported is set, then the default interface name is the name +-- of the entity, cased in a manner that is appropriate to the system +-- in use. Note that Interface_Name is ignored if an address clause +-- is present (since it is meaningless in this case). +-- +-- An additional special case usage of this field is in JGNAT for +-- E_Component and E_Discriminant. JGNAT allows these entities to +-- be imported by specifying pragma Import within a component's +-- containing record definition. This supports interfacing to +-- object fields defined within Java classes, and such pragmas +-- are generated by the jvm2ada binding generator tool whenever +-- it processes classes with public object fields. A pragma Import +-- for a component can define the External_Name of the imported +-- Java field (which is generally needed, because Java names are +-- case sensitive). +-- +-- In_Use (Flag8) +-- Present in packages and types. Set when analyzing a use clause for +-- the corresponding entity. Reset at end of corresponding declarative +-- part. The flag on a type is also used to determine the visibility of +-- the primitive operators of the type. + +-- Is_Abstract (Flag19) +-- Present in all types, and also for functions and procedures. Set +-- for abstract types and abstract subprograms. + +-- Is_Access_Constant (Flag69) +-- Present in access types and subtypes. Indicates that the keyword +-- constant was present in the access type definition. + +-- Is_Access_Type (synthesized) +-- Applies to all entities, true for access types and subtypes + +-- Is_Aliased (Flag15) +-- Present in objects whose declarations carry the keyword aliased, +-- and on record components that have the keyword. + +-- Is_Always_Inlined (synthesized) +-- Present in subprograms. True if there is a pragma Inline_Always for +-- the subprogram. + +-- Is_AST_Entry (Flag132) +-- Present in entry entities. Set if a valid pragma AST_Entry applies +-- to the entry. This flag can only be set in OpenVMS versions of GNAT. +-- Note: we also allow the flag to appear in entry families, but given +-- the current implementation of the pragma AST_Entry, this flag will +-- always be False in entry families. + +-- Is_Atomic (Flag85) +-- Present in all type entities, and also in constants, components and +-- variables. Set if a pragma Atomic or Shared applies to the entity. +-- In the case of private and incomplete types, this flag is set in +-- both the partial view and the full view. + +-- Is_Array_Type (synthesized) +-- Applies to all entities, true for array types and subtypes + +-- Is_Asynchronous (Flag81) +-- Present in all type entities and in procedure entities. Set +-- if a pragma Asynchronous applies to the entity. + +-- Is_Bit_Packed_Array (Flag122) +-- Present in all entities. This flag is set for a packed array +-- type that is bit packed (i.e. the component size is known by the +-- front end and is in the range 1-7, 9-15, or 17-31). Is_Packed is +-- always set if Is_Bit_Packed_Array is set, but it is possible for +-- Is_Packed to be set without Is_Bit_Packed_Array or the case of an +-- array having one or more index types that are enumeration types +-- with non-standard enumeration representations. + +-- Is_Boolean_Type (synthesized) +-- Applies to all entities, true for boolean types and subtypes, +-- i.e. Standard.Boolean and all types ultimately derived from it. + +-- Is_By_Copy_Type (synthesized) +-- Applies to all type entities. Returns true if the entity is +-- a by copy type (RM 6.2(3)). + +-- Is_By_Reference_Type (synthesized) +-- Applies to all type entities. True if the type is required to +-- be passed by reference, as defined in (RM 6.2(4-9)). + +-- Is_Called (Flag102) +-- Present in subprograms. Returns true if the subprogram is called +-- in the unit being compiled or in a unit in the context. Used for +-- inlining. + +-- Is_Character_Type (Flag63) +-- Present in all entities, true for character types and subtypes, +-- i.e. enumeration types that have at least one character literal. + +-- Is_Child_Unit (Flag73) +-- Present in all entities. Set only for defining entities of program +-- units that are child units (but False for subunits). + +-- Is_Class_Wide_Type (synthesized) +-- Applies to all entities, true for class wide types and subtypes + +-- Is_Compilation_Unit (Flag149) +-- Present in all entities. Set if the entity is a package or subprogram +-- entity for a compilation unit other than a subunit (since we treat +-- subunits as part of the same compilation operation as the ultimate +-- parent, we do not consider them to be separate units for this flag). + +-- Is_Completely_Hidden (Flag103) +-- A flag set on an E_Discriminant entity. This flag can be set only +-- for girder discriminants of untagged types. When set, the entity +-- is a girder discriminant of a derived untagged type which is not +-- directly visible in the derived type because the derived type or +-- one of its ancestors have renamed the discriminants in the root +-- type. Note that there are girder discriminants which are not +-- Completely_Hidden (eg the discriminants of a root type). + +-- Is_Composite_Type (synthesized) +-- Applies to all entities, true for all composite types and +-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but +-- not both) is true of any type. + +-- Is_Concurrent_Record_Type (Flag20) +-- Present in record types and subtypes. Set if the type was created +-- by the expander to represent a task or protected type. For every +-- concurrent type, such as record type is constructed, and task and +-- protected objects are instances of this record type at runtime +-- (Gigi will replace declarations of the concurrent type using the +-- declarations of the corresponding record type). See package Exp_Ch9 +-- for further details. + +-- Is_Concurrent_Type (synthesized) +-- Applies to all entities, true for task types and subtypes and +-- for protected types and subtypes. + +-- Is_Constrained (Flag12) +-- Present in types or subtypes which may have index, discriminant +-- or range constraint (i.e. array types and subtypes, record types +-- and subtypes, string types and subtypes, and all numeric types). +-- Set if the type or subtype is constrained. + +-- Is_Constr_Subt_For_U_Nominal (Flag80) +-- Present in all types and subtypes. Set true only for the constructed +-- subtype of an object whose nominal subtype is unconstrained. Note +-- that the constructed subtype itself will be constrained. + +-- Is_Constr_Subt_For_UN_Aliased (Flag141) +-- This flag can only be set if Is_Constr_Subt_For_U_Nominal is set. It +-- indicates that in addition the object concerned is aliased. This flag +-- is used by Gigi to determine whether a template must be constructed. + +-- Is_Constructor (Flag76) +-- Present in function and procedure entities. Set if a pragma +-- CPP_Constructor applies to the subprogram. + +-- Is_Controlled (Flag42) [base type only] +-- Present in all type entities. Indicates that the type is controlled, +-- i.e. is either a descendant of Ada.Finalization.Controlled or of +-- Ada.Finalization.Limited_Controlled. + +-- Is_Controlling_Formal (Flag97) +-- Present in all Formal_Kind entity. Marks the controlling parameters +-- of dispatching operations. + +-- Is_CPP_Class (Flag74) +-- Present in all type entities, set only for tagged and untagged +-- record types to which the pragma CPP_Class has been applied. + +-- Is_Decimal_Fixed_Point_Type (synthesized) +-- Applies to all type entities, true for decimal fixed point +-- types and subtypes. + +-- Is_Derived_Type (synthesized) +-- Applies to all type entities. Determine if given entity is a +-- derived type + +-- Is_Destructor (Flag77) +-- Present in function and procedure entities. Set if a pragma +-- CPP_Destructor applies to the subprogram. + +-- Is_Discrete_Type (synthesized) +-- Applies to all entities, true for all discrete types and subtypes + +-- Is_Discrete__Or_Fixed_Point_Type (synthesized) +-- Applies to all entities, true for all discrete types and subtypes +-- and all fixed-point types and subtypes. + +-- Is_Discrim_SO_Function (Flag176) +-- Present in all entities, set only in E_Function entities that Layout +-- creates to compute discriminant-dependent dynamic size/offset values. + +-- Is_Dispatching_Operation (Flag6) +-- Present in all entities. Set true for procedures, functions, +-- generic procedures and generic functions if the corresponding +-- operation is dispatching. + +-- Is_Dynamic_Scope (synthesized) +-- Applies to all Entities. Returns True if the entity is a dynamic +-- scope (i.e. a block, a subprogram a task_type or an entry). + +-- Is_Elementary_Type (synthesized) +-- Applies to all entities, true for all elementary types and +-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but +-- not both) is true of any type. + +-- Is_Eliminated (Flag124) +-- Present in type entities, subprogram entities, and object entities. +-- Indicates that the corresponding entity has been eliminated by use +-- of pragma Eliminate. + +-- Is_Enumeration_Type (synthesized) +-- Present in all entities, true for enumeration types and subtypes + +-- Is_Entry (synthesized) +-- Applies to all entities, True only for entry and entry family +-- entities and False for all other entity kinds. + +-- Is_Entry_Formal (Flag52) +-- Present in all entities. Set only for entry formals (which can +-- only be in, in-out or out parameters). This flag is used to speed +-- up the test for the need to replace references in Exp_Ch2. + +-- Is_Exported (Flag99) +-- Present in all entities. Set if the entity is exported. For now we +-- only allow the export of constants, exceptions, functions, procedures +-- and variables, but that may well change later on. Exceptions can only +-- be exported in the OpenVMS and Java VM implementations of GNAT. + +-- Is_First_Subtype (Flag70) +-- Present in all entities. True for first subtypes (RM 3.2.1(6)), +-- i.e. the entity in the type declaration that introduced the type. +-- This may be the base type itself (e.g. for record declarations and +-- enumeration type declarations), or it may be the first subtype of +-- an anonymous base type (e.g. for integer type declarations or +-- constrained array declarations). + +-- Is_Fixed_Point_Type (synthesized) +-- Applies to all entities, true for decimal and ordinary fixed +-- point types and subtypes + +-- Is_Floating_Point_Type (synthesized) +-- Applies to all entities, true for float types and subtypes + +-- Is_Formal (synthesized) +-- Applies to all entities, true for IN, IN OUT and OUT parameters + +-- Is_Formal_Subprogram (Flag111) +-- Defined on all entities, true for generic formal subprograms. + +-- Is_For_Access_Subtype (Flag118) +-- Present in E_Private_Subtype and E_Record_Subtype entities. +-- Means the sole purpose of the type is to be designated by an +-- Access_Subtype and hence should not be expanded into components +-- because the type may not have been found or frozen yet. + +-- Is_Frozen (Flag4) +-- Present in all type entities. Set if the type has been frozen. + +-- Is_Generic_Actual_Type (Flag94) +-- Present in the subtype declaration that renames the generic formal +-- as a subtype of the actual. Guarantees that the subtype is not static +-- within the instance. + +-- Is_Generic_Instance (Flag130) +-- Present in all entities. Set to indicate that the entity is an +-- instance of a generic unit. + +-- Is_Generic_Type (Flag13) +-- Present in types which are generic formal types. Such types have an +-- Ekind that corresponds to their classification, so the Ekind cannot +-- be used to identify generic types. + +-- Is_Generic_Unit (synthesized) +-- Applies to all entities. Yields True for a generic unit (generic +-- package, generic function, generic procedure), and False for all +-- other entities. + +-- Is_Hidden (Flag57) +-- Present in all entities. Set true for all entities declared in the +-- private part or body of a package. Also marks generic formals of a +-- formal package declared without a box. For library level entities, +-- this flag is set if the entity is not publicly visible. + +-- Is_Hidden_Open_Scope (Flag171) +-- Present in all entities. Set true for a scope that contains the +-- instantiation of a child unit, and whose entities are not visible +-- during analysis of the instance. + +-- Is_Immediately_Visible (Flag7) +-- Present in all entities. Set if entity is immediately visible, i.e. +-- is defined in some currently open scope (RM 8.3(4)). + +-- Is_Imported (Flag24) +-- Present in all entities. Set if the entity is imported. For now we +-- only allow the import of exceptions, functions, procedures, packages. +-- and variables. Exceptions can only be imported in the OpenVMS and +-- Java VM implementations of GNAT. Packages and types can only be +-- imported in the Java VM implementation. + +-- Is_Incomplete_Or_Private_Type (synthesized) +-- Applies to all entities, true for private and incomplete types + +-- Is_Indefinite_Subtype (synthesized) +-- Applies to all entities for types and subtypes. Determines if given +-- entity is an unconstrained array type or subtype, a discriminated +-- record type or subtype with no initial discriminant values or a +-- class wide type or subtype. + +-- Is_Inlined (Flag11) +-- Present in all entities. Set for functions and procedures which are +-- to be inlined. For subprograms created during expansion, this flag +-- may be set directly by the expander to request inlining. Also set +-- for packages that contain inlined subprograms, whose bodies must be +-- be compiled. Is_Inlined is also set on generic subprograms and is +-- inherited by their instances. It is also set on the body entities +-- of inlined subprograms. See also Has_Pragma_Inline. + +-- Is_Instantiated (Flag126) +-- Present in generic packages and generic subprograms. Set if the unit +-- is instantiated from somewhere in the extended main source unit. This +-- flag is used to control warnings about the unit being uninstantiated. +-- Also set in a package that is used as an actual for a generic package +-- formal in an instantiation. Also set on a parent instance, in the +-- instantiation of a child, which is implicitly declared in the parent. + +-- Is_Integer_Type (synthesized) +-- Applies to all entities, true for integer types and subtypes + +-- Is_Internal (Flag17) +-- Present in all entities. Set to indicate an entity created during +-- semantic processing (e.g. an implicit type). Need more documentation +-- on this one! ??? + +-- Is_Interrupt_Handler (Flag89) +-- Present in protected procedures. Set if a pragma Interrupt_Handler +-- applies to the procedure (which must be parameterless). + +-- Is_Intrinsic_Subprogram (Flag64) +-- Present in functions and procedures. It is set if a valid pragma +-- Interface or Import is present for this subprogram specifying pragma +-- Intrinsic. Valid means that the name and profile of the subprogram +-- match the requirements of one of the recognized intrinsic subprograms +-- (see package Sem_Intr for details). Note: the value of Convention for +-- such an entity will be set to Convention_Intrinsic, but it is the +-- setting of Is_Intrinsic_Subprogram, NOT simply having convention set +-- to intrinsic, which causes intrinsic code to be generated. + +-- Is_Itype (Flag91) +-- Present in all entities, set for Itypes. If it is set, then the +-- declaration for the type does not appear explicitly in the tree. +-- Instead gigi will elaborate the type when it is first used. +-- Has_Delayed_Freeze can be set for Itypes, and the meaning is that +-- the first use (the one which causes the type to be defined) will +-- be the freeze node. Note that an important restriction on Itypes +-- is that the first use of such a type (the one that causes it to be +-- defined) must be in the same scope as the type. + +-- Is_Known_Valid (Flag170) +-- Present in all entities. Relevant for types (and subtype) and +-- for objects (and enumeration literals) of a discrete type. +-- +-- The purpose of this flag is to implement the requirement stated +-- in (RM 13.9.1(9-11)) which require that the use of possibly invalid +-- values may not cause programs to become erroneous. See the function +-- Exp_Util.Expr_Known_Valid for further details. Note that the setting +-- is conservative, in the sense that if the flag is set, it must be +-- right. If the flag is not set, nothing is known about the validity. +-- +-- For enumeration literals, the flag is always set, since clearly +-- an enumeration literal represents a valid value. Range checks +-- where necessary will ensure that this valid value is appropriate. +-- +-- For objects, the flag indicates the state of knowledge about the +-- current value of the object. This may be modified during expansion, +-- and thus the final value is not relevant to gigi. +-- +-- For types and subtypes, the flag is set if all possible bit patterns +-- of length Object_Size (i.e. Esize of the type) represent valid values +-- of the type. In general for such tytpes, all values are valid, the +-- only exception being the case where an object of the type has an +-- explicit size that is greater than Object_Size. +-- +-- For non-discrete objects, the setting of the Is_Known_Valid flag is +-- not defined, and is not relevant, since the considerations of the +-- requirement in (RM 13.9.1(9-11)) do not apply. + +-- Is_Limited_Composite (Flag106) +-- Present in all entities. True for composite types that have a +-- limited component. Used to enforce the rule that operations on +-- the composite type that depend on the full view of the component +-- do not become visible until the immediate scope of the composite +-- type itself (RM 7.3.1 (5)). + +-- Is_Limited_Record (Flag25) +-- Present in all entities. Set to true for record (sub)types if the +-- record is declared to be limited. Note that this flag is not set +-- simply because some components of the record are limited. + +-- Is_Limited_Type (synthesized) +-- Applies to all entities. True if entity is a limited type (limited +-- private type, task type, protected type, composite containing a +-- limited component, or a subtype of any of these types). + +-- Is_Machine_Code_Subprogram (Flag137) +-- Present in subprogram entities. Set to indicate that the subprogram +-- is a machine code subprogram (i.e. its body includes at least one +-- code statement). Also indicates that all necessary semantic checks +-- as required by RM 13.8 have been performed. + +-- Is_Non_Static_Subtype (Flag109) +-- This flag is present in all type and subtype entities. It is set in +-- some (but not all) cases in which a subtype is known to be non-static. +-- Before this flag was added, the computation of whether a subtype was +-- static was entirely synthesized, by looking at the bounds, and the +-- immediate subtype parent. However, this method does not work for some +-- Itypes that have no parent set (and the only way to find the immediate +-- subtype parent is to go through the tree). For now, this flay is set +-- conservatively, i.e. if it is set then for sure the subtype is non- +-- static, but if it is not set, then the type may or may not be static. +-- Thus the test for a static subtype is that this flag is clear AND +-- that the bounds are static AND that the parent subtype (if available +-- to be tested) is static. Eventually we should make sure this flag +-- is always set right, at which point, these comments can be removed, +-- and the tests for static subtypes greatly simplified. + +-- Is_Null_Init_Proc (Flag178) +-- Present in procedure entities. Set for generated init_proc procedures +-- (used to initialize composite types), if the code for the procedure +-- is null (i.e. is a return and nothing else). Such null initialization +-- procedures are generated in case some client is compiled using the +-- Initialize_Scalars pragma, generating a call to this null procedure, +-- but there is no need to call such procedures within a compilation +-- unit, and this flag is used to suppress such calls. + +-- Is_Numeric_Type (synthesized) +-- Applies to all entities, true for all numeric types and subtypes +-- (integer, fixed, float). + +-- Is_Object (synthesized) +-- Applies to all entities, true for entities representing objects, +-- including generic formal parameters. + +-- Is_Optional_Parameter (Flag134) +-- Present in parameter entities. Set if the parameter is specified as +-- optional by use of a First_Optional_Parameter argument to one of the +-- extended Import pragmas. Can only be set for OpenVMS versions of GNAT. + +-- Is_Ordinary_Fixed_Point_Type (synthesized) +-- Applies to all entities, true for ordinary fixed point types +-- and subtypes + +-- Is_Package (synthesized) +-- Applies to all entities. True for packages and generic packages. +-- False for all other entities. + +-- Is_Package_Body_Entity (Flag160) +-- Present in all entities. Set for entities defined at the top level +-- of a package body. Used to control externally generated names. + +-- Is_Packed (Flag51) [implementation base type only] +-- Present in all type entities. This flag is set only for record and +-- array types which have a packed representation. There are three +-- cases which cause packing: +-- +-- 1. Explicit use of pragma Pack for an array of package components +-- 2. Explicit use of pragma Pack to pack a record +-- 4. Setting Component_Size of an array to a bit-packable value +-- 3. Indexing an array with a non-standard enumeration type. +-- +-- For records, Is_Packed is always set if Has_Pack_Pragma is set, +-- and can also be set on its own in a derived type which inherited +-- its packed status. +-- +-- For arrays, Is_Packed is set if an array is bit packed (i.e. the +-- component size is known at compile time and is 1-7, 9-15 or 17-31), +-- or if the array has one or more index types that are enumeration +-- types with non-standard representations (in GNAT, we store such +-- arrays compactly, using the Pos of the enumeration type value). +-- +-- As for the case of records, Is_Packed can be set on its own for a +-- derived type, with the same dual before/after freeze meaning. +-- Is_Packed can also be set as the result of an explicit component +-- size clause that specifies an appropriate component size. +-- +-- In the bit packed array case, Is_Bit_Packed_Array will be set in +-- the bit packed case once the array type is frozen. +-- +-- Before an array type is frozen, Is_Packed will always be set if +-- Has_Pack_Pragma is set. Before the freeze point, it is not possible +-- to know the component size, since the component type is not frozen +-- until the array type is frozen. Thus Is_Packed for an array type +-- before it is frozen means that packed is required. Then if it turns +-- out that the component size is not suitable for bit packing, the +-- Is_Packed flag gets turned off. + +-- Is_Packed_Array_Type (Flag138) +-- Present in all entities. This flag is set on the entity for the type +-- used to implement a packed array (either a modular type, or a subtype +-- of Packed_Bytes{1,2,4} as appropriate). The flag is set if and only +-- if the type appears in the Packed_Array_Type field of some other type +-- entity. It is used by Gigi to activate the special processing for such +-- types (unchecked conversions that would not otherwise be allowed are +-- allowed for such types). + +-- Is_Potentially_Use_Visible (Flag9) +-- Present in all entities. Set if entity is potentially use visible, +-- i.e. it is defined in a package that appears in a currently active +-- use clause (RM 8.4(8)). Note that potentially use visible entities +-- are not necessarily use visible (RM 8.4(9-11)). + +-- Is_Preelaborated (Flag59) +-- Present in all entities, set in E_Package and E_Generic_Package +-- entities to which a pragma Preelaborate is applied, and also in +-- all entities within such packages. Note that the fact that this +-- flag is set does not necesarily mean that no elaboration code is +-- generated for the package. + +-- Is_Private_Composite (Flag107) +-- Present in composite types that have a private component. Used to +-- enforce the rule that operations on the composite type that depend +-- on the fulll view of the component, do not become visible until the +-- immediate scope of the composite type itself (7.3.1 (5)). Both this +-- flag and Is_Limited_Composite are needed. + +-- Is_Private_Descendant (Flag53) +-- Present in entities that can represent library units (packages, +-- functions, procedures). Set if the library unit is itself a private +-- child unit, or if it is the descendent of a private child unit. + +-- Is_Private_Type (synthesized) +-- Applies to all entities, true for private types and subtypes, +-- as well as for record with private types as subtypes + +-- Is_Protected_Type (synthesized) +-- Applies to all entities, true for protected types and subtypes + +-- Is_Psected (Flag153) +-- Present in entities for objects, true if a valid Psect_Object +-- pragma applies to the object. Used to detect duplicate pragmas. + +-- Is_Public (Flag10) +-- Present in all entities. Set to indicate that an entity defined in +-- one compilation unit can be referenced from other compilation units. +-- If this reference causes a reference in the generated variable, for +-- example in the case of a variable name, then Gigi will generate an +-- appropriate external name for use by the linker. + +-- Is_Protected_Private (synthesized) +-- Applies to a record component. Returns true if this component +-- is used to represent a private declaration of a protected type. + +-- Is_Protected_Record_Type (synthesized) +-- Applies to all entities, true if Is_Concurrent_Record_Type +-- Corresponding_Concurrent_Type is a protected type. + +-- Is_Pure (Flag44) +-- Present in all entities. Set in all entities of a unit to which a +-- pragma Pure is applied, and also set for the entity of the unit +-- itself. In addition, this flag may be set for any other functions +-- or procedures that are known to be side effect free, so in the case +-- of subprograms, the Is_Pure flag may be used by the optimizer to +-- imply that it can assume freedom from side effects (other than those +-- resulting from assignment to out parameters, or to objects designated +-- by access parameters). + +-- Is_Real_Type (synthesized) +-- Applies to all entities, true for real types and subtypes + +-- Is_Record_Type (synthesized) +-- Applies to all entities, true for record types and subtypes, +-- includes class-wide types and subtypes (which are also records) + +-- Is_Remote_Call_Interface (Flag62) +-- Present in all entities, set in E_Package and E_Generic_Package +-- entities to which a pragma Remote_Call_Interace is applied, and +-- also in all entities within such packages. + +-- Is_Remote_Types (Flag61) +-- Present in all entities, set in E_Package and E_Generic_Package +-- entities to which a pragma Remote_Types is applied, and also in +-- all entities within such packages. + +-- Is_Renaming_Of_Object (Flag112) +-- Present in all entities, set only for a variable or constant for +-- which the Renamed_Object field is non-empty and for which the +-- renaming is handled by the front end, by macro substitution of +-- a copy of the (evaluated) name tree whereever the variable is used. + +-- Is_Return_By_Reference_Type (synthesized) +-- Applies to all type entities. True if the type is required to +-- be returned by reference, as defined in 6.5(11-16). + +-- Is_Scalar_Type (synthesized) +-- Applies to all entities, true for scalar types and subtypes + +-- Is_Shared_Passive (Flag60) +-- Present in all entities, set in E_Package and E_Generic_Package +-- entities to which a pragma Shared_Passive is applied, and also in +-- all entities within such packages. + +-- Is_Statically_Allocated (Flag28) +-- Present in all entities. This can only be set True for exception, +-- variable, constant, and type/subtype entities. If the flag is set, +-- then the variable or constant must be allocated statically rather +-- than on the local stack frame. For exceptions, the meaning is that +-- the exception data should be allocated statically (and indeed this +-- flag is always set for exceptions, since exceptions do not have +-- local scope). For a type, the meaning is that the type must be +-- elaborated at the global level rather than locally. No type marked +-- with this flag may depend on a local variable, or on any other type +-- which does not also have this flag set to True. For a variable or +-- or constant, if the flag is set, then the type of the object must +-- either be declared at the library level, or it must also have the +-- flag set (since to allocate the oject statically, its type must +-- also be elaborated globally). + +-- Is_Subprogram (synthesized) +-- Applies to all entities, true for bodies of functions, procedures +-- and operators. + +-- Is_String_Type (synthesized) +-- Applies to all type entities. Determines if the given type is a +-- string type, i.e. it is directly a string type or string subtype, +-- or a string slice type, or an array type with one dimension and a +-- component type that is a character type. + +-- Is_Tag (Flag78) +-- Present in E_Component. For regular tagged type this flag is set on +-- the tag component (whose name is Name_uTag) and for CPP_Class tagged +-- types, this flag marks the pointer to the main vtable (i.e. the one +-- to be extended by derivation) + +-- Is_Tagged_Type (Flag55) +-- Present in all entities, true for an entity for a tagged type. + +-- Is_Task_Record_Type (synthesized) +-- Applies to all entities, true if Is_Concurrent_Record_Type +-- Corresponding_Concurrent_Type is a task type. + +-- Is_Task_Type (synthesized) +-- Applies to all entities, true for task types and subtypes + +-- Is_True_Constant (Flag163) +-- This flag is set in constants and variables which have an initial +-- value specified but which are never assigned, partially or in the +-- whole. For variables, it means that the variable was initialized +-- but never modified, and hence can be treated as a constant by the +-- code generator. For a constant, it means that the constant was not +-- modified by generated code (e.g. to set a discriminant in an init +-- proc). Assignments by user or generated code will reset this flag. + +-- Is_Type (synthesized) +-- Applies to all entities, true for a type entity + +-- Is_Unchecked_Union (Flag117) +-- Present in all entities. Set only in record types to which the +-- pragma Unchecked_Union has been validly applied. + +-- Is_Unsigned_Type (Flag144) +-- Present in all types, but can be set only for discrete and fixed-point +-- type and subtype entities. This flag is only valid if the entity is +-- frozen. If set it indicates that the representation is known to be +-- unsigned (i.e. that no negative values appear in the range). This is +-- normally just a reflection of the lower bound of the subtype or base +-- type, but there is one case in which the setting is non-obvious, +-- namely the case of an unsigned subtype of a signed type from which +-- a further subtype is obtained using variable bounds. This further +-- subtype is still unsigned, but this cannot be determined by looking +-- at its bounds or the bounds of the corresponding base type. + +-- Is_Valued_Procedure (Flag127) +-- Present in procedure entities. Set if an Import_Valued_Procedure +-- or Export_Valued_Procedure pragma applies to the procedure entity. + +-- Is_Visible_Child_Unit (Flag116) +-- Present in compilation units that are child units. Once compiled, +-- child units remain chained to the entities in the parent unit, and +-- a separate flag must be used to indicate whether the names are +-- visible by selected notation, or not. + +-- Is_VMS_Exception (Flag133) +-- Present in all entities. Set only for exception entities where the +-- exception was specified in an Import_Exception or Export_Exception +-- pragma with the VMS option for Form. See description of these pragmas +-- for details. This flag can only be set in OpenVMS versions of GNAT. + +-- Is_Volatile (Flag16) +-- Present in all type entities, and also in constants, components and +-- variables. Set if a pragma Volatile applies to the entity. Also set +-- if pragma Shared or pragma Atomic applies to entity. In the case of +-- private or incomplete types, this flag is set in both the private +-- and full view. + +-- Is_Wrapper_Package (synthesized) +-- Present in package entities. Indicates that the package has been +-- created as a wrapper for a subprogram instantiation. + +-- Last_Entity (Node20) +-- Present in all entities which act as scopes to which a list of +-- associated entities is attached (blocks, class subtypes and types, +-- entries, functions, loops, packages, procedures, protected objects, +-- record types and subtypes, private types, task types and subtypes). +-- Points to a the last entry in the list of associated entities chained +-- through the Next_Entity field. Empty if no entities are chained. + +-- Lit_Indexes (Node15) +-- Present in enumeration types and subtypes. Non-empty only for the +-- case of an enumeration root type, where it contains the entity for +-- the generated indexes entity. See unit Exp_Imgv for full details of +-- the nature and use of this entity for implkementing the Image and +-- Value attributes for the enumeration type in question. +-- +-- Lit_Strings (Node16) +-- Present in enumeration types and subtypes. Non-empty only for the +-- case of an enumeration root type, where it contains the entity for +-- the literals string entity. See unit Exp_Imgv for full details of +-- the nature and use of this entity for implementing the Image and +-- Value attributes for the enumeration type in question. + +-- Machine_Radix_10 (Flag84) +-- Present in decimal types and subtypes, set if the Machine_Radix +-- is 10, as the result of the specification of a machine radix +-- representation clause. Note that it is possible for this flag +-- to be set without having Has_Machine_Radix_Clause True. This +-- happens when a type is derived from a type with a clause present. + +-- Master_Id (Node17) +-- Present in access types and subtypes. Empty unless Has_Task is +-- set for the designated type, in which case it points to the entity +-- for the Master_Id for the access type master. + +-- Materialize_Entity (Flag168) +-- Present in all entities. Set only for constant or renamed entities +-- which should be materialized for debugging purposes. In the case of +-- a constant, a memory location should be allocated containing the +-- value. In the case of a renaming, a memory location containing the +-- renamed address should be allocated. + +-- Mechanism (Uint8) (returned as Mechanism_Type) +-- Present in functions and non-generic formal parameters. Indicates +-- the mechanism to be used for the function return or for the formal +-- parameter. See separate section on passing mechanisms. + +-- Modulus (Uint17) [base type only] +-- Present in modular types. Contains the modulus. For the binary +-- case, this will be a power of 2, but if Non_Binary_Modulus is +-- set, then it will not be a power of 2. + +-- Needs_Debug_Info (Flag147) +-- Present in all entities. Set if the entity requires debugging +-- information to be generated. This is true of all entities that +-- have Comes_From_Source set, and also transitively for entities +-- associated with such components (e.g. their types). It is true +-- for all entities in Debug_Generated_Code mode (-gnatD switch). + +-- Needs_No_Actuals (Flag22) +-- Present in callable entities (subprograms, entries, access to +-- subprograms) which can be called without actuals because all of +-- their formals (if any) have default values. This flag simplifies the +-- resolution of the syntactic ambiguity involving a call to these +-- entities when the return type is an array type, and a call can be +-- interpreted as an indexing of the result of the call. It is also +-- used to resolve various cases of entry calls. + +-- Not_Source_Assigned (Flag115) +-- Present in all entities, but relevant only for variables and +-- parameters. This flag is set if the object is never assigned a +-- value in user code and was not fully initialized at declaration +-- time. Note however, that an access variable is not considered +-- fully initialized in this sense. +-- +-- This flag is only for the purposes of issuing warnings, it must not +-- be used by the code generator to indicate that the variable is in +-- fact a constant, since some assignments in generated code do not +-- count (for example, the call to an init_proc to assign some but +-- not all of the fields in a patially initialized record). The code +-- generator should instead use the flag Is_True_Constant. +-- +-- In variables and out parameters, if this flag is set after full +-- processing of the corresponding declarative unit, it indicates that +-- the variable or parameter was never set, and a warning message can +-- be issued. +-- +-- Note: this flag is initially set, and then cleared on encountering +-- any construct that might conceivably legitimately set the value. +-- Thus during the analysis of a declarative region and its associated +-- statement sequence, the meaning of the flag is "not assigned yet", +-- and once this analysis is complete the flag means "never assigned". + +-- Note: for variables appearing in package declarations, this flag +-- is never set. That is because there is no way to tell if some +-- client modifies the variable (or in the case of variables in the +-- private part, if some child unit modifies the variables). + +-- Note: in the case of renamed objects, the flag must be set in the +-- ultimate renamed object. Clients noting a possible modification +-- should use the Note_Possible_Modification procedure in Sem_Util +-- rather than Set_Not_Source_Assigned precisely to deal properly with +-- the renaming possibility. + +-- Next_Component (synthesized) +-- Applies to record components. Returns the next component by +-- following the chain of declared entities until one is found which +-- corresponds to a component (Ekind is E_Component). Any internal types +-- generated from the subtype indications of the record components are +-- skipped. Returns Empty if no more components. + +-- Next_Discriminant (synthesized) +-- Applies to discriminants returned by First/Next_Discriminant. +-- Returns the next language-defined (ie: perhaps non-girder) +-- discriminant by following the chain of declared entities as long as +-- the kind of the entity corresponds to a discriminant. Note that the +-- discriminants might be the only components of the record. +-- Returns Empty if there are no more. + +-- Next_Entity (Node2) +-- Present in all entities. The entities of a scope are chained, with +-- the head of the list being in the First_Entity field of the scope +-- entity. All entities use the Next_Entity field as a forward pointer +-- for this list, with Empty indicating the end of the list. Since this +-- field is in the base part of the entity, the access routines for this +-- field are in Sinfo. + +-- Next_Formal (synthesized) +-- Applies to the entity for a formal parameter. Returns the next +-- formal parameter of the subprogram or subprogram type. Returns +-- Empty if there are no more formals. + +-- Next_Formal_With_Extras (synthesized) +-- Applies to the entity for a formal parameter. Returns the next +-- formal parameter of the subprogram or subprogram type. Returns +-- Empty if there are no more formals. The list returned includes +-- all the extra formals (see description of Extra_Formal field) + +-- Next_Girder_Discriminant (synthesized) +-- Applies to discriminants. Set only for a discriminant returned by +-- a call to First/Next_Girder_Discriminant. Returns next girder +-- discriminant, if there are more (see complete description in +-- First_Girder_Discriminant), or Empty if there are no more. + +-- Next_Index (synthesized) +-- Applies to array types and subtypes and to string types and +-- subtypes. Yields the next index. The first index is obtained by +-- using the First_Index attribute, and then subsequent indexes are +-- obtained by applying Next_Index to the previous index. Empty is +-- returned to indicate that there are no more indexes. Note that +-- unlike most attributes in this package, Next_Index applies to +-- nodes for the indexes, not to entities. + +-- Next_Inlined_Subprogram (Node12) +-- Present in subprograms. Used to chain inlined subprograms used in +-- the current compilation, in the order in which they must be compiled +-- by Gigi to insure that all inlinings are performed. + +-- Next_Literal (synthesized) +-- Applies to enumeration literals, returns the next literal, or +-- Empty if applied to the last literal. This is actually a synonym +-- for Next, but its use is preferred in this context. + +-- Non_Binary_Modulus (Flag58) [base type only] +-- Present in modular integer types. Set if the modulus for the type +-- is other than a power of 2. + +-- Nonzero_Is_True (Flag162) [base type only] +-- Present in enumeration types. True if any non-zero value is to be +-- interpreted as true. Currently this is set true for derived Boolean +-- types which have a convention of C, C++ or Fortran. + +-- No_Pool_Assigned (Flag131) [root type only] +-- Present in access types. Set if a storage size clause applies to +-- the variable with a compile time known value of zero. This flag is +-- used to generate warnings if any attempt is made to allocate an +-- instance of such an access type. + +-- No_Return (Flag113) +-- Present in procedure and generic procedure entries. Indicates that +-- a pragma No_Return applies to the procedure. + +-- Normalized_First_Bit (Uint8) +-- Present in components and discriminants. Indicates the normalized +-- value of First_Bit for the component, i.e. the offset within the +-- lowest addressed storage unit containing part or all of the field. + +-- Normalized_Position (Uint9) +-- Present in components and discriminants. Indicates the normalized +-- value of Position for the component, i.e. the offset in storage +-- units from the start of the record to the lowest addressed storage +-- unit containing part or all of the field. + +-- Normalized_Position_Max (Uint10) +-- Present in components and discriminants. For almost all cases, this +-- is the same as Normalized_Position. The one exception is for the case +-- of a discriminated record containing one or more arrays whose length +-- depends on discriminants. In this case, the Normalized_Position_Max +-- field represents the maximum possible value of Normalized_Position +-- assuming min/max values for discriminant subscripts in all fields. +-- This is used by Layout in front end layout mode to properly computed +-- the maximum size such records (needed for allocation purposes when +-- there are default discriminants, and also for the 'Size value). + +-- Number_Dimensions (synthesized) +-- Applies to array types and subtypes. Returns the number of dimensions +-- of the array type or subtype as a value of type Pos. + +-- Number_Discriminants (synthesized) +-- Applies to all types with discriminants. Yields the number of +-- discriminants as a value of type Pos. + +-- Number_Entries (synthesized) +-- Applies to concurrent types. Returns the number of entries that are +-- declared within the task or protected definition for the type. + +-- Number_Formals (synthesized) +-- Applies to subprograms and subprogram types. Yields the number of +-- formals as a value of type Pos. + +-- Object_Ref (Node17) +-- Present in protected bodies. This is an implicit prival for the +-- Protection object associated with a protected object. See Prival +-- for further details on the use of privals. + +-- Original_Record_Component (Node22) +-- Present in components, including discriminants. The usage depends +-- on whether the record is a base type and whether it is tagged. +-- +-- In base tagged types: +-- When the component is inherited in a record extension, it points +-- to the original component (the entity of the ancestor component +-- which is not itself inherited) otherwise it points to itself. +-- Gigi uses this attribute to implement the automatic dereference in +-- the extension and to apply the transformation: +-- +-- Rec_Ext.Comp -> Rec_Ext.Parent. ... .Parent.Comp +-- +-- In base non-tagged types: +-- Always points to itself except for non-girder discriminants, where +-- it points to the girder discriminant it renames. +-- +-- In subtypes (tagged and untagged): +-- Points to the component in the base type. + +-- Packed_Array_Type (Node23) +-- Present in array types and subtypes, including the string literal +-- subtype case, if the corresponding type is packed (either bit packed +-- or packed to eliminate holes in non-contiguous enumeration type +-- index types). References the type used to represent the packed array, +-- which is either a modular type for short static arrays, or an +-- array of System.Unsigned. Note that in some situations (internal +-- types, and references to fields of variant records), it is not +-- always possible to construct this type in advance of its use. If +-- Packed_Array_Type is empty, then the necessary type is declared +-- on the fly for each reference to the array. + +-- Parameter_Mode (synthesized) +-- Applies to formal parameter entities. This is a synonym for Ekind, +-- used when obtaining the formal kind of a formal parameter (the result +-- is one of E_[In/Out/In_Out]_Paramter) + +-- Parent_Subtype (Node19) +-- Present in E_Record_Type. Points to the subtype to use for a +-- field that references the parent record. This is used by Gigi to +-- construct such a field. + +-- Primitive_Operations (Elist15) +-- Present in tagged record types and subtypes and in tagged private +-- types. Points to an element list of entities for primitive operations +-- for the tagged type. Not present (and not set) in untagged types (it +-- is an error to reference the primitive operations field of a type +-- that is not tagged). + +-- Private_Dependents (Elist18) +-- Present in private (sub)types. Records the subtypes of the +-- private type, derivations from it, and records and arrays +-- with components dependent on the type. +-- +-- The subtypes are traversed when installing and deinstalling +-- (the full view of) a private type in order to ensure correct +-- view of the subtypes. +-- +-- Used in similar fashion for incomplete types: holds list of subtypes +-- of these incomplete types that have discriminant constraints. The +-- full views of these subtypes are constructed when the full view of +-- the incomplete type is processed. + +-- In addition, if the incomplete type is the designated type in an +-- access definition for an access parameter, the operation may be +-- a dispatching primitive operation, which is only known when the full +-- declaration of the type is seen. Subprograms that have such an +-- access parameter are also placed in the list of private_dependents. + +-- Prival (Node17) +-- Present in components. Used for representing private declarations +-- of protected objects (private formal: by analogy to Discriminal_Link). +-- Empty unless the synthesized Is_Protected_Private attribute is +-- true. The entity used as a formal parameter that corresponds to +-- the to the private declaration in protected operations. See +-- "Private data in protected objects" for details. + +-- Privals_Chain (Elist23) +-- Present in protected operations (subprograms and entries). Links +-- all occurrences of the Privals in the body of the operation, in +-- order to patch their types at the end of their expansion. See +-- "Private data in protected objects" for details. + +-- Private_View (Node22) +-- For each private type, three entities are allocated, the private view, +-- the full view, and the shadow entity. The shadow entity contains a +-- copy of the private view and is used for restoring the proper private +-- view after a region in which the full view is visible (and is copied +-- into the entity normally used for the private view during this period +-- of visibility). The Private_View field is self-referential when the +-- private view lives in its normal entity, but in the copy that is made +-- in the shadow entity, it points to the proper location in which to +-- restore the private view saved in the shadow. + +-- Protected_Formal (Node22) +-- Present in formal parameters (in, in out and out parameters). Used +-- only for formals of protected operations. References corresponding +-- formal parameter in the unprotected version of the operation that +-- is created during expansion. + +-- Protected_Body_Subprogram (Node11) +-- Present in protected operations. References the entity for the +-- subprogram which implements the body of the operation. + +-- Protected_Operation (Node23) +-- Present in components. Used for representing private declarations +-- of protected objects. Empty unless the synthesized attribute +-- Is_Protected_Private is True. This is the entity corresponding +-- to the body of the protected operation currently being analyzed, +-- and which will eventually use the current Prival associated with +-- this component to refer to the renaming of a private object +-- component. As soon as the expander generates this renaming, this +-- attribute is changed to refer to the next protected subprogram. +-- See "Private data in protected objects" for details. + +-- Reachable (Flag49) +-- Present in labels. The flag is set over the range of statements in +-- which a goto to that label is legal. + +-- Referenced (Flag156) +-- Present in all entities, set if the entity is referenced. + +-- Referenced_Object (Node10) +-- Present in all type entities. Set non-Empty only for type entities +-- constructed for unconstrained objects, or objects that depend on +-- discriminants. Points to the expression from which the actual +-- subtype of the object can be evaluated. + +-- Register_Exception_Call (Node20) +-- Present in exception entities. When an exception is declared, +-- a call is expanded to Register_Exception. This field points to +-- the expanded N_Procedure_Call_Statement node for this call. It +-- is used for Import/Export_Exception processing to modify the +-- register call to make appropriate entries in the special tables +-- used for handling these pragmas at runtime. + +-- Related_Array_Object (Node19) +-- Present in array types and subtypes. Used only for the base type +-- and subtype created for an anonymous array object. Set to point +-- to the entity of the corresponding array object. Currently used +-- only for type-related error messages. + +-- Related_Instance (Node15) +-- Present in the wrapper packages created for subprogram instances. +-- The internal subprogram that implements the instance is inside the +-- wrapper package, but for debugging purposes its external symbol +-- must correspond to the name and scope of the related instance. + +-- Renamed_Entity (Node18) +-- Present in exceptions, packages and generic units that are defined +-- by a renaming declaration. Denotes the renamed entity, or transit- +-- itively the ultimate renamed entity if there is a chain of renaming +-- declarations. + +-- Renamed_Object (Node18) +-- Present in all objects (constants, variables, components, formal +-- parameters, generic formal parameters, and loop parameters. Set +-- non-Empty if the object was declared by a renaming declaration, in +-- which case it references the tree node for the name of the renamed +-- object. This is only possible for the variable and constant cases. +-- For formal parameters, this field is used in the course of inline +-- expansion, to map the formals of a subprogram into the corresponding +-- actuals. The field is Empty otherwise. + +-- Renaming_Map (Uint9) +-- Present in generic subprograms, generic packages, and their +-- instances. Also present in the instances of the corresponding +-- bodies. Denotes the renaming map (generic entities => instance +-- entities) used to construct the instance by givin an index into +-- the tables used to represent these maps. See Sem_Ch12 for further +-- details. The maps for package instances are also used when the +-- instance is the actual corresponding to a formal package. + +-- Return_Present (Flag54) +-- Present in function and generic function entities. Set if the +-- function contains a return statement (used for error checking). +-- This flag can also be set in procedure and generic procedure +-- entities (for convenience in setting it), but is only tested +-- for the function case. + +-- Returns_By_Ref (Flag90) +-- Present in function entities, to indicate that the function +-- returns the result by reference, either because its return typ is a +-- by-reference-type or because it uses explicitly the secondary stack. + +-- Reverse_Bit_Order (Flag164) +-- Present in all record type entities. Set if a valid pragma an +-- attribute represention clause for Bit_Order has reversed the order +-- of bits from the default value. When this flag is set, a component +-- clause must specify a set of bits entirely contained in a single +-- storage unit. + +-- RM_Size (Uint13) +-- Present in all type and subtype entities. Contains the value of +-- type'Size as defined in the RM. See also the Esize field and +-- and the description on "Handling of Type'Size Values". A value +-- of zero for in this field for a non-discrete type means that +-- the front end has not yet determined the size value. For the +-- case of a discrete type, this field is always set by the front +-- end and zero is a legitimate value for a type with one value. + +-- Root_Type (synthesized) +-- Applies to all type entities. For class-wide types, return the root +-- type of the class covered by the CW type, otherwise returns the +-- ultimate derivation ancestor of the given type. This function +-- preserves the view, i.e. the Root_Type of a partial view is the +-- partial view of the ulimate ancestor, the Root_Type of a full view +-- is the full view of the ultimate ancestor. Note that this function +-- does not correspond exactly to the use of root type in the RM, since +-- in the RM root type applies to a class of types, not to a type. + +-- Scalar_Range (Node20) +-- Present in all scalar types (including modular types, where the +-- bounds are 0 .. modulus - 1). References a node in the tree that +-- contains the bounds for the range. Note that this information +-- could be obtained by rummaging around the tree, but it is more +-- convenient to have it immediately at hand in the entity. The +-- contents of Scalar_Range can either be an N_Subtype_Indication +-- node (with a constraint), or a Range node, but not a simple +-- subtype reference (a subtype is converted into a range). + +-- Scale_Value (Uint15) +-- Present in decimal fixed-point types and subtypes. Contains the scale +-- for the type (i.e. the value of type'Scale = the number of decimal +-- digits after the decimal point). + +-- Scope (Node3) +-- Present in all entities. Points to the entity for the scope (block, +-- loop, subprogram, package etc.) in which the entity is declared. +-- Since this field is in the base part of the entity node, the access +-- routines for this field are in Sinfo. + +-- Scope_Depth (synth) +-- Applies to program units, blocks, concurrent types and entries, +-- and also to record types, i.e. to any entity that can appear on +-- the scope stack. Yields the scope depth value, which for those +-- entities other than records is simply the scope depth value, +-- for record entities, it is the Scope_Depth of the record scope. + +-- Scope_Depth_Value (Uint22) +-- Present in program units, blocks, concurrent types and entries. +-- Indicates the number of scopes that statically enclose the +-- declaration of the unit or type. Library units have a depth of zero. +-- Note that record types can act as scopes but do NOT have this field +-- set (see Scope_Depth above) + +-- Scope_Depth_Set (synthesized) +-- Applies to a special predicate function that returns a Boolean value +-- indicating whether or not the Scope_Depth field has been set. It +-- is needed, since returns an invalid value in this case! + +-- Sec_Stack_Needed_For_Return (Flag167) +-- Present in scope entities (blocks,functions, procedures, tasks, +-- entries). Set to True when secondary stack is used to hold +-- the returned value of a function and thus should not be +-- released on scope exit. + +-- Shadow_Entities (List14) +-- Present in package and generic package entities. Points to a list +-- of entities that correspond to private types. For each private type +-- a shadow entity is created that holds a copy of the private view. +-- In regions of the program where the full views of these private +-- entities are visible, the full view is copied into the entity that +-- is normally used to hold the private view, but the shadow entity +-- copy is unchanged. The shadow entities are then used to restore the +-- original private views at the end of the region. This list is a +-- standard format list (i.e. First (Shadow_Entities) is the first +-- entry and subsequent entries are obtained using Next. + +-- Shared_Var_Assign_Proc (Node22) +-- Present in variables. Set non-Empty only if Is_Shared_Passive is +-- set, in which case this is the entity for the shared memory assign +-- routine. See Exp_Smem for full details. + +-- Shared_Var_Read_Proc (Node15) +-- Present in variables. Set non-Empty only if Is_Shared_Passive is +-- set, in which case this is the entity for the shared memory read +-- routine. See Exp_Smem for full details. + +-- Size_Check_Code (Node9) +-- Present in constants and variables. Normally Empty. Set if code is +-- generated to check the size of the variable. This field is used to +-- suppress this code if a subsequent address clause is encountered. + +-- Size_Clause (synthesized) +-- Applies to all entities. If a size clause is present in the rep +-- item chain for an entity then the attribute definition clause node +-- for the size clause is returned. Otherwise Size_Clause returns Empty +-- if no item is present. Usually this is only meaningful if the flag +-- Has_Size_Clause is set. This is because when the representation item +-- chain is copied for a derived type, it can inherit a size clause that +-- is not applicable to the entity. + +-- Size_Depends_On_Discriminant (Flag177) +-- Present in all entities for types and subtypes. Indicates that the +-- size of the type depends on the value of one or more discriminants. +-- Currently, this flag is only set in front end layout mode for arrays +-- which have one or more bounds depending on a discriminant value. + +-- Size_Known_At_Compile_Time (Flag92) +-- Present in all entities for types and subtypes. Indicates that the +-- size of objects of the type is known at compile time. This flag is +-- used to optimize some generated code sequences, and also to enable +-- some error checks (e.g. disallowing component clauses on variable +-- length objects. It is set conservatively (i.e. if it is True, the +-- size is certainly known at compile time, if it is False, then the +-- size may or may not be known at compile time, but the code will +-- assume that it is not known). + +-- Small_Value (Ureal21) +-- Present in fixed point types. Points to the universal real for the +-- Small of the type, either as given in a representation clause, or +-- as computed (as a power of two) by the compiler. + +-- Spec_Entity (Node19) +-- Present in package body entities. Points to corresponding package +-- spec entity. Also present in subprogram body parameters in the +-- case where there is a separate spec, where this field references +-- the corresponding parameter entities in the spec. + +-- Storage_Size_Variable (Node15) [implementation base type only] +-- Present in access types and task type entities. This flag is set +-- if a valid and effective pragma Storage_Size applies to the base +-- type. Points to the entity for a variable that is created to +-- hold the value given in a Storage_Size pragma for an access +-- collection or a task type. Note that in the access type case, +-- this field is present only in the root type (since derived types +-- share the same storage pool). + +-- Strict_Alignment (Flag145) [implementation base type only] +-- Present in all type entities. Indicates that some containing part +-- is either aliased or tagged. This prohibits packing the object +-- tighter than its natural size and alignment. + +-- String_Literal_Length (Uint16) +-- Present in string literal subtypes (which are created to correspond +-- to string literals in the program). Contains the length of the string +-- literal. + +-- String_Literal_Low_Bound (Node15) +-- Present in string literal subtypes (which are created to correspond +-- to string literals in the program). Contains an expression whose +-- value represents the low bound of the literal. This is a copy of +-- the low bound of the applicable index constraint if there is one, +-- or a copy of the low bound of the index base type if not. + +-- Suppress_Access_Checks (Flag31) +-- Present in all entities. Set if access checks associated with this +-- entity are to be suppressed (see separate section on "Handling of +-- Check Suppression") + +-- Suppress_Accessibility_Checks (Flag32) +-- Present in all entities. Set if accessibility checks associated with +-- this entity are to be suppressed (see separate section on "Handling +-- of Check Suppression") + +-- Suppress_Discriminant_Checks (Flag33) +-- Present in all entities. Set if discriminant checks associated with +-- this entity are to be suppressed (see separate section on "Handling +-- of Check Suppression") + +-- Suppress_Division_Checks (Flag34) +-- Present in all entities. Set if division checks associated with +-- this entity are to be suppressed (see separate section on "Handling +-- of Check Suppression") + +-- Suppress_Elaboration_Checks (Flag35) +-- Present in all entities. Set if elaboration checks associated with +-- this entity are to be suppressed (see separate section on "Handling +-- of Check Suppression") + +-- Suppress_Elaboration_Warnings (Flag148) +-- Present in all entities. Set if a pragma Suppress Elaboration_Checks +-- is applied specifically to the entity. If set on a subprogram, all +-- elaboration warnings for calls to the subprogram are suppressed. If +-- set on a package, then all elaboration warnings for calls to any +-- subprograms in the package are suppressed. + +-- Suppress_Index_Checks (Flag36) +-- Present in all entities. Set if index checks associated with this +-- entity are to be suppressed (see separate section on "Handling of +-- Check Suppression") + +-- Suppress_Init_Proc (Flag105) [base type only] +-- Present in all type entities. Set to suppress the generation of +-- initialization procedures where they are known to be not needed. +-- For example, the enumeration image table entity uses this flag. + +-- Suppress_Length_Checks (Flag37) +-- Present in all entities. Set if length checks associated with this +-- entity are to be suppressed (see separate section on "Handling of +-- Check Suppression") + +-- Suppress_Overflow_Checks (Flag38) +-- Present in all entities. Set if overflow checks associated with +-- this entity are to be suppressed (see separate section on "Handling +-- of Check Suppression") + +-- Suppress_Range_Checks (Flag39) +-- Present in all entities. Set if range checks associated with this +-- entity are to be suppressed (see separate section on "Handling of +-- Check Suppression") + +-- Suppress_Storage_Checks (Flag40) +-- Present in all entities. Set if storage checks associated with +-- this entity are to be suppressed (see separate section on "Handling +-- of Check Suppression") + +-- Suppress_Style_Checks (Flag165) +-- Present in all entities. Suppresses any style checks specifically +-- associated with the given entity if set. + +-- Suppress_Tag_Checks (Flag41) +-- Present in all entities. Set if tag checks associated with this +-- entity are to be suppressed (see separate section on "Handling of +-- Check Suppression") + +-- Tag_Component (synthesized) +-- Applies to tagged record types, returns the entity for the _Tag +-- field in this record, which must be present. + +-- Type_High_Bound (synthesized) +-- Applies to scalar types. Returns the tree node (Node_Id) that +-- contains the high bound of a scalar type. The returned value is a +-- literal for a base type, but may be an expression in the case of a +-- scalar type with dynamic bounds. Note that in the case of a fixed +-- point type, the high bound is in units of small, and is an integer. + +-- Type_Low_Bound (synthesized) +-- Applies to scalar types. Returns the tree node (Node_Id) that +-- contains the low bound of a scalar type. The returned value is a +-- literal for a base type, but may be an expression in the case of a +-- scalar type with dynamic bounds. Note that in the case of a fixed +-- point type, the low bound is in units of small, and is an integer. + +-- Underlying_Full_View (Node19) +-- Present in private subtypes that are the completion of other private +-- types, or in private types that are derived from private subtypes. +-- If the full view of a private type T is derived from another +-- private type with discriminants Td, the full view of T is also +-- private, and there is no way to attach to it a further full view that +-- would convey the structure of T to the back end. The Underlying_Full_ +-- View is an attribute of the full view that is a subtype of Td with +-- the same constraint as the declaration for T. The declaration for this +-- subtype is built at the point of the declaration of T, either as a +-- completion, or as a subtype declaration where the base type is private +-- and has a private completion. If Td is already constrained, then its +-- full view can serve directly as the full view of T. + +-- Underlying_Type (synthesized) +-- Applies to all entities. This is the identity function except in +-- the case where it is applied to an incomplete or private type, +-- in which case it is the underlying type of the type declared by +-- the completion, or Empty if the completion has not yet been +-- encountered and analyzed. +-- +-- Note: the reason this attribute applies to all entities, and not +-- just types, is to legitimize code where Underlying_Type is applied +-- to an entity which may or may not be a type, with the intent that +-- if it is a type, its underlying type is taken. + +-- Unset_Reference (Node16) +-- Present in variables and out parameters. This is normally Empty. +-- It is set to point to an identifier that represents a reference +-- to the entity before any value has been set. Only the first such +-- reference is identified. This field is used to generate a warning +-- message if necessary (see Sem_Warn.Check_Unset_Reference). + +-- Uses_Sec_Stack (Flag95) +-- Present in scope entities (blocks,functions, procedures, tasks, +-- entries). Set to True when secondary stack is used in this scope and +-- must be released on exit unless Sec_Stack_Needed_For_Return is set. + +-- Vax_Float (Flag151) [base type only] +-- Present in all type entities. Set only on the base type of float +-- types with Vax format. The particular format is determined by the +-- Digits_Value value which is 6,9,15 for F_Float, D_Float, G_Float. + +-- Warnings_Off (Flag96) +-- Present in all entities. Set if a pragma Warnings (Off, entity-name) +-- is used to suppress warnings for a given entity. It is also used by +-- the compiler in some situations to kill spurious warnings. + + ------------------ + -- Access Kinds -- + ------------------ + + -- The following three entity kinds are introduced by the corresponding + -- type definitions: + + -- E_Access_Type, E_General_Access_Type, E_Anonymous_Access_Type. + + -- In addition, we define the kind E_Allocator_Type to label + -- allocators. This is because special resolution rules apply to this + -- construct. Eventually the constructs are labeled with the access + -- type imposed by the context. Gigi should never see the type + -- E_Allocator. + + -- Similarly, the type E_Access_Attribute_Type is used as the initial + -- kind associated with an access attribute. After resolution a specific + -- access type will be established as determined by the context. + + -- Finally, the type Any_Access is used to label -null- during type + -- resolution. Any_Access is also replaced by the context type after + -- resolution. + + -------------------------------- + -- Classification of Entities -- + -------------------------------- + + -- The classification of program entities which follows is a refinement of + -- the list given in RM 3.1(1). E.g., separate entities denote subtypes of + -- different type classes. Ada 95 entities include class wide types, + -- protected types, subprogram types, generalized access types, generic + -- formal derived types and generic formal packages. + + -- The order chosen for these kinds allows us to classify related entities + -- so that they are contiguous. As a result, they do not appear in the + -- exact same order as their order of first appearance in the LRM (For + -- example, private types are listed before packages). The contiguity + -- allows us to define useful subtypes (see below) such as type entities, + -- overloaded entities, etc. + + -- Each entity (explicitly or implicitly declared) has a kind, which is + -- a value of the following type: + + type Entity_Kind is ( + + E_Void, + -- The initial Ekind value for a newly created entity. Also used as + -- the Ekind for Standard_Void_Type, a type entity in Standard used + -- as a dummy type for the return type of a procedure (the reason we + -- create this type is to share the circuits for performing overload + -- resolution on calls). + + ------------- + -- Objects -- + ------------- + + E_Variable, + -- Variables created by an object declaration with no constant keyword + + E_Component, + -- Components of a record declaration, private declarations of + -- protected objects. + + E_Constant, + -- Constants created by an object declaration with a constant keyword + + E_Discriminant, + -- A discriminant, created by the use of a discriminant in a type + -- declaration. + + E_Loop_Parameter, + -- A loop parameter created by a for loop + + ------------------------ + -- Parameter Entities -- + ------------------------ + + -- Parameters are also objects + + E_In_Parameter, + -- An in parameter of a subprogram or entry + + E_Out_Parameter, + -- An out parameter of a subprogram or entry + + E_In_Out_Parameter, + -- An in-out parameter of a subprogram or entry + + -------------------------------- + -- Generic Parameter Entities -- + -------------------------------- + + -- Generic parameters are also objects + + E_Generic_In_Out_Parameter, + -- A generic in out parameter, created by the use of a generic in out + -- parameter in a generic declaration. + + E_Generic_In_Parameter, + -- A generic in parameter, created by the use of a generic in + -- parameter in a generic declaration. + + ------------------- + -- Named Numbers -- + ------------------- + + E_Named_Integer, + -- Named numbers created by a number declaration with an integer value + + E_Named_Real, + -- Named numbers created by a number declaration with a real value + + ----------------------- + -- Enumeration Types -- + ----------------------- + + E_Enumeration_Type, + -- Enumeration types, created by an enumeration type declaration + + E_Enumeration_Subtype, + -- Enumeration subtypes, created by an explicit or implicit subtype + -- declaration applied to an enumeration type or subtype. + + ------------------- + -- Numeric Types -- + ------------------- + + E_Signed_Integer_Type, + -- Signed integer type, used for the anonymous base type of the + -- integer subtype created by an integer type declaration. + + E_Signed_Integer_Subtype, + -- Signed integer subtype, created by either an integer subtype or + -- integer type declaration (in the latter case an integer type is + -- created for the base type, and this is the first named subtype). + + E_Modular_Integer_Type, + -- Modular integer type, used for the anonymous base type of the + -- integer subtype created by a modular integer type declaration. + + E_Modular_Integer_Subtype, + -- Modular integer subtype, created by either an modular subtype + -- or modular type declaration (in the latter case a modular type + -- is created for the base type, and this is the first named subtype). + + E_Ordinary_Fixed_Point_Type, + -- Ordinary fixed type, used for the anonymous base type of the + -- fixed subtype created by an ordinary fixed point type declaration. + + E_Ordinary_Fixed_Point_Subtype, + -- Ordinary fixed point subtype, created by either an ordinary fixed + -- point subtype or ordinary fixed point type declaration (in the + -- latter case a fixed point type is created for the base type, and + -- this is the first named subtype). + + E_Decimal_Fixed_Point_Type, + -- Decimal fixed type, used for the anonymous base type of the decimal + -- fixed subtype created by an ordinary fixed point type declaration. + + E_Decimal_Fixed_Point_Subtype, + -- Decimal fixed point subtype, created by either a decimal fixed point + -- subtype or decimal fixed point type declaration (in the latter case + -- a fixed point type is created for the base type, and this is the + -- first named subtype). + + E_Floating_Point_Type, + -- Floating point type, used for the anonymous base type of the + -- floating point subtype created by a floating point type declaration. + + E_Floating_Point_Subtype, + -- Floating point subtype, created by either a floating point subtype + -- or floating point type declaration (in the latter case a floating + -- point type is created for the base type, and this is the first + -- named subtype). + + ------------------ + -- Access Types -- + ------------------ + + E_Access_Type, + -- An access type created by an access type declaration with no all + -- keyword present. Note that the predefined type Any_Access, which + -- has E_Access_Type Ekind, is used to label NULL in the upwards pass + -- of type analysis, to be replaced by the true access type in the + -- downwards resolution pass. + + E_Access_Subtype, + -- An access subtype created by a subtype declaration for any access + -- type (whether or not it is a general access type). + + E_Access_Attribute_Type, + -- An access type created for an access attribute (such as 'Access, + -- 'Unrestricted_Access and Unchecked_Access) + + E_Allocator_Type, + -- A special internal type used to label allocators and attribute + -- references using 'Access. This is needed because special resolution + -- rules apply to these constructs. On the resolution pass, this type + -- is always replaced by the actual access type, so Gigi should never + -- see types with this Ekind. + + E_General_Access_Type, + -- An access type created by an access type declaration with the all + -- keyword present. + + E_Access_Subprogram_Type, + -- An access to subprogram type, created by an access to subprogram + -- declaration. + + E_Access_Protected_Subprogram_Type, + -- An access to a protected subprogram, created by the corresponding + -- declaration. Values of such a type denote both a protected object + -- and a protected operation within, and have different compile-time + -- and run-time properties than other access to subprograms. + + E_Anonymous_Access_Type, + -- An anonymous access type created by an access parameter or access + -- discriminant. + + --------------------- + -- Composite Types -- + --------------------- + + E_Array_Type, + -- An array type created by an array type declaration. Includes all + -- cases of arrays, except for string types. + + E_Array_Subtype, + -- An array subtype, created by an explicit array subtype declaration, + -- or the use of an anonymous array subtype. + + E_String_Type, + -- A string type, i.e. an array type whose component type is a character + -- type, and for which string literals can thus be written. + + E_String_Subtype, + -- A string subtype, created by an explicit subtype declaration for a + -- string type, or the use of an anonymous subtype of a string type, + + E_String_Literal_Subtype, + -- A special string subtype, used only to describe the type of a string + -- literal (will always be one dimensional, with literal bounds). + + E_Class_Wide_Type, + -- A class wide type, created by any tagged type declaration (i.e. if + -- a tagged type is declared, the corresponding class type is always + -- created, using this Ekind value). + + E_Class_Wide_Subtype, + -- A subtype of a class wide type, created by a subtype declaration + -- used to declare a subtype of a class type. + + E_Record_Type, + -- A record type, created by a record type declaration + + E_Record_Subtype, + -- A record subtype, created by a record subtype declaration. + + E_Record_Type_With_Private, + -- Used for types defined by a private extension declaration. Includes + -- the fields for both private types and for record types (with the + -- sole exception of Corresponding_Concurrent_Type which is obviously + -- not needed). This entity is considered to be both a record type and + -- a private type. + + E_Record_Subtype_With_Private, + -- A subtype of a type defined by a private extension declaration. + + E_Private_Type, + -- A private type, created by a private type declaration that does + -- not have the keyword limited. + + E_Private_Subtype, + -- A subtype of a private type, created by a subtype declaration used + -- to declare a subtype of a private type. + + E_Limited_Private_Type, + -- A limited private type, created by a private type declaration that + -- has the keyword limited. + + E_Limited_Private_Subtype, + -- A subtype of a limited private type, created by a subtype declaration + -- used to declare a subtype of a limited private type. + + E_Incomplete_Type, + -- An incomplete type, created by an incomplete type declaration + + E_Task_Type, + -- A task type, created by a task type declaration. An entity with this + -- Ekind is also created to describe the anonymous type of a task that + -- is created by a single task declaration. + + E_Task_Subtype, + -- A subtype of a task type, created by a subtype declaration used to + -- declare a subtype of a task type. + + E_Protected_Type, + -- A protected type, created by a protected type declaration. An entity + -- with this Ekind is also created to describe the anonymous type of + -- a protected object created by a single protected declaration. + + E_Protected_Subtype, + -- A subtype of a protected type, created by a subtype declaration used + -- to declare a subtype of a protected type. + + ----------------- + -- Other Types -- + ----------------- + + E_Exception_Type, + -- The type of an exception created by an exception declaration + + E_Subprogram_Type, + -- This is the designated type of an Access_To_Subprogram. Has type + -- and signature like a subprogram entity, so can appear in calls, + -- which are resolved like regular calls, except that such an entity + -- is not overloadable. + + --------------------------- + -- Overloadable Entities -- + --------------------------- + + E_Enumeration_Literal, + -- An enumeration literal, created by the use of the literal in an + -- enumeration type definition. + + E_Function, + -- A function, created by a function declaration or a function body + -- that acts as its own declaration. + + E_Operator, + -- A predefined operator, appearing in Standard, or an implicitly + -- defined concatenation operator created whenever an array is + -- declared. We do not make normal derived operators explicit in + -- the tree, but the concatenation operators are made explicit. + + E_Procedure, + -- A procedure, created by a procedure declaration or a procedure + -- body that acts as its own declaration. + + E_Entry, + -- An entry, created by an entry declaration in a task or protected + -- object. + + -------------------- + -- Other Entities -- + -------------------- + + E_Entry_Family, + -- An entry family, created by an entry family declaration in a + -- task or protected type definition. + + E_Block, + -- A block identifier, created by an explicit or implicit label on + -- a block or declare statement. + + E_Entry_Index_Parameter, + -- An entry index parameter created by an entry index specification + -- for the body of a protected entry family. + + E_Exception, + -- An exception created by an exception declaration. The exception + -- itself uses E_Exception for the Ekind, the implicit type that is + -- created to represent its type uses the Ekind E_Exception_Type. + + E_Generic_Function, + -- A generic function. This is the entity for a generic function + -- created by a generic subprogram declaration. + + E_Generic_Package, + -- A generic package, this is the entity for a generic package created + -- by a generic package declaration. + + E_Generic_Procedure, + -- A generic function. This is the entity for a generic procedure + -- created by a generic subprogram declaration. + + E_Label, + -- The defining entity for a label. Note that this is created by the + -- implicit label declaration, not the occurrence of the label itself, + -- which is simply a direct name referring to the label. + + E_Loop, + -- A loop identifier, created by an explicit or implicit label on a + -- loop statement. + + E_Package, + -- A package, created by a package declaration + + E_Package_Body, + -- A package body. This entity serves only limited functions, since + -- most semantic analysis uses the package entity (E_Package). However + -- there are some attributes that are significant for the body entity. + -- For example, collection of exception handlers. + + E_Protected_Object, + -- A protected object, created by an object declaration that declares + -- an object of a protected type. + + E_Protected_Body, + -- A protected body. This entity serves almost no function, since all + -- semantic analysis uses the protected entity (E_Protected_Type) + + E_Task_Body, + -- A task body. This entity serves almost no function, since all + -- semantic analysis uses the protected entity (E_Task_Type). + + E_Subprogram_Body + -- A subprogram body. Used when a subprogram has a separate declaration + -- to represent the entity for the body. This entity serves almost no + -- function, since all semantic analysis uses the subprogram entity + -- for the declaration (E_Function or E_Procedure). + ); + + for Entity_Kind'Size use 8; + -- The data structures in Atree assume this! + + -------------------------- + -- Subtype Declarations -- + -------------------------- + + -- The above entities are arranged so that they can be conveniently + -- grouped into subtype ranges. Note that for each of the xxx_KInd + -- ranges defined below, there is a corresponding Is_xxx.. predicate + -- which is to be used in preference to direct range tests using the + -- subtype name. However, the subtype names are available for direct + -- use, e.g. as choices in case statements. + + subtype Access_Kind is Entity_Kind range + E_Access_Type .. + -- E_Access_Subtype + -- E_Access_Attribute_Type + -- E_Allocator_Type + -- E_General_Access_Type + -- E_Access_Subprogram_Type + -- E_Access_Protected_Subprogram_Type + E_Anonymous_Access_Type; + + subtype Array_Kind is Entity_Kind range + E_Array_Type .. + -- E_Array_Subtype + -- E_String_Type + -- E_String_Subtype + E_String_Literal_Subtype; + + subtype Class_Wide_Kind is Entity_Kind range + E_Class_Wide_Type .. + E_Class_Wide_Subtype; + + subtype Composite_Kind is Entity_Kind range + E_Array_Type .. + -- E_Array_Subtype + -- E_String_Type + -- E_String_Subtype + -- E_String_Literal_Subtype + -- E_Class_Wide_Type + -- E_Class_Wide_Subtype + -- E_Record_Type + -- E_Record_Subtype + -- E_Record_Type_With_Private + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + -- E_Incomplete_Type + -- E_Task_Type + -- E_Task_Subtype, + -- E_Protected_Type, + E_Protected_Subtype; + + subtype Concurrent_Kind is Entity_Kind range + E_Task_Type .. + -- E_Task_Subtype, + -- E_Protected_Type, + E_Protected_Subtype; + + subtype Concurrent_Body_Kind is Entity_Kind range + E_Protected_Body .. + E_Task_Body; + + subtype Decimal_Fixed_Point_Kind is Entity_Kind range + E_Decimal_Fixed_Point_Type .. + E_Decimal_Fixed_Point_Subtype; + + subtype Digits_Kind is Entity_Kind range + E_Decimal_Fixed_Point_Type .. + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype Discrete_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + E_Modular_Integer_Subtype; + + subtype Discrete_Or_Fixed_Point_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + E_Decimal_Fixed_Point_Subtype; + + subtype Elementary_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + -- E_Floating_Point_Subtype + -- E_Access_Type + -- E_Access_Subtype + -- E_Access_Attribute_Type + -- E_Allocator_Type + -- E_General_Access_Type + -- E_Access_Subprogram_Type + -- E_Access_Protected_Subprogram_Type + E_Anonymous_Access_Type; + + subtype Enumeration_Kind is Entity_Kind range + E_Enumeration_Type .. + E_Enumeration_Subtype; + + subtype Entry_Kind is Entity_Kind range + E_Entry .. + E_Entry_Family; + + subtype Fixed_Point_Kind is Entity_Kind range + E_Ordinary_Fixed_Point_Type .. + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + E_Decimal_Fixed_Point_Subtype; + + subtype Float_Kind is Entity_Kind range + E_Floating_Point_Type .. + E_Floating_Point_Subtype; + + subtype Formal_Kind is Entity_Kind range + E_In_Parameter .. + -- E_Out_Parameter + E_In_Out_Parameter; + + subtype Generic_Unit_Kind is Entity_Kind range + E_Generic_Function .. + -- E_Generic_Package, + E_Generic_Procedure; + + subtype Incomplete_Or_Private_Kind is Entity_Kind range + E_Record_Type_With_Private .. + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + E_Incomplete_Type; + + subtype Integer_Kind is Entity_Kind range + E_Signed_Integer_Type .. + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + E_Modular_Integer_Subtype; + + subtype Modular_Integer_Kind is Entity_Kind range + E_Modular_Integer_Type .. + E_Modular_Integer_Subtype; + + subtype Named_Kind is Entity_Kind range + E_Named_Integer .. + E_Named_Real; + + subtype Numeric_Kind is Entity_Kind range + E_Signed_Integer_Type .. + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype Object_Kind is Entity_Kind range + E_Variable .. + -- E_Component + -- E_Constant + -- E_Discriminant + -- E_Loop_Parameter + -- E_In_Parameter + -- E_Out_Parameter + -- E_In_Out_Parameter + -- E_Generic_In_Out_Parameter + E_Generic_In_Parameter; + + subtype Ordinary_Fixed_Point_Kind is Entity_Kind range + E_Ordinary_Fixed_Point_Type .. + E_Ordinary_Fixed_Point_Subtype; + + subtype Overloadable_Kind is Entity_Kind range + E_Enumeration_Literal .. + -- E_Function + -- E_Operator + -- E_Procedure + E_Entry; + + subtype Private_Kind is Entity_Kind range + E_Record_Type_With_Private .. + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + E_Limited_Private_Subtype; + + subtype Protected_Kind is Entity_Kind range + E_Protected_Type .. + E_Protected_Subtype; + + subtype Real_Kind is Entity_Kind range + E_Ordinary_Fixed_Point_Type .. + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype Record_Kind is Entity_Kind range + E_Class_Wide_Type .. + -- E_Class_Wide_Subtype + -- E_Record_Type + -- E_Record_Subtype + -- E_Record_Type_With_Private + E_Record_Subtype_With_Private; + + subtype Scalar_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype String_Kind is Entity_Kind range + E_String_Type .. + -- E_String_Subtype + E_String_Literal_Subtype; + + subtype Subprogram_Kind is Entity_Kind range + E_Function .. + -- E_Operator + E_Procedure; + + subtype Signed_Integer_Kind is Entity_Kind range + E_Signed_Integer_Type .. + E_Signed_Integer_Subtype; + + subtype Task_Kind is Entity_Kind range + E_Task_Type .. + E_Task_Subtype; + + subtype Type_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + -- E_Floating_Point_Subtype + -- E_Access_Type + -- E_Access_Subtype + -- E_Access_Attribute_Type + -- E_Allocator_Type, + -- E_General_Access_Type + -- E_Access_Subprogram_Type, + -- E_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Type + -- E_Array_Type + -- E_Array_Subtype + -- E_String_Type + -- E_String_Subtype + -- E_String_Literal_Subtype + -- E_Class_Wide_Subtype + -- E_Class_Wide_Type + -- E_Record_Type + -- E_Record_Subtype + -- E_Record_Type_With_Private + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + -- E_Incomplete_Type + -- E_Task_Type + -- E_Task_Subtype + -- E_Protected_Type + -- E_Protected_Subtype + -- E_Exception_Type + E_Subprogram_Type; + + -------------------------------------------------------- + -- Description of Defined Attributes for Entity_Kinds -- + -------------------------------------------------------- + + -- For each enumeration value defined in Entity_Kind we list all the + -- attributes defined in Einfo which can legally be applied to an entity + -- of that kind. The implementation of the attribute functions (and for + -- non-synthesized attributes, or the corresponding set procedures) are + -- in the Einfo body. + + -- The following attributes apply to all entities + + -- Ekind (Ekind) + + -- Chars (Name1) + -- Next_Entity (Node2) + -- Scope (Node3) + -- Homonym (Node4) + -- Etype (Node5) + -- First_Rep_Item (Node6) + -- Freeze_Node (Node7) + + -- Address_Taken (Flag104) + -- Debug_Info_Off (Flag166) + -- Has_Convention_Pragma (Flag119) + -- Has_Delayed_Freeze (Flag18) + -- Has_Fully_Qualified_Name (Flag173) + -- Has_Gigi_Rep_Item (Flag82) + -- Has_Homonym (Flag56) + -- Has_Pragma_Elaborate_Body (Flag150) + -- Has_Pragma_Inline (Flag157) + -- Has_Private_Declaration (Flag155) + -- Has_Qualified_Name (Flag161) + -- Has_Unknown_Discriminants (Flag72) + -- Is_Bit_Packed_Array (Flag122) + -- Is_Child_Unit (Flag73) + -- Is_Compilation_Unit (Flag149) + -- Is_Completely_Hidden (Flag103) + -- Is_Discrim_SO_Function (Flag176) + -- Is_Dispatching_Operation (Flag6) + -- Is_Exported (Flag99) + -- Is_First_Subtype (Flag70) + -- Is_Formal_Subprogram (Flag111) + -- Is_Generic_Instance (Flag130) + -- Is_Hidden (Flag57) + -- Is_Hidden_Open_Scope (Flag171) + -- Is_Immediately_Visible (Flag7) + -- Is_Imported (Flag24) + -- Is_Inlined (Flag11) + -- Is_Internal (Flag17) + -- Is_Itype (Flag91) + -- Is_Known_Valid (Flag170) + -- Is_Limited_Composite (Flag106) + -- Is_Limited_Record (Flag25) + -- Is_Package_Body_Entity (Flag160) + -- Is_Packed_Array_Type (Flag138) + -- Is_Potentially_Use_Visible (Flag9) + -- Is_Preelaborated (Flag59) + -- Is_Public (Flag10) + -- Is_Pure (Flag44) + -- Is_Remote_Call_Interface (Flag62) + -- Is_Remote_Types (Flag61) + -- Is_Shared_Passive (Flag60) + -- Is_Statically_Allocated (Flag28) + -- Is_Unchecked_Union (Flag117) + -- Is_VMS_Exception (Flag133) + -- Materialize_Entity (Flag168) + -- Needs_Debug_Info (Flag147) + -- Referenced (Flag156) + -- Suppress_Access_Checks (Flag31) + -- Suppress_Accessibility_Checks (Flag32) + -- Suppress_Discriminant_Checks (Flag33) + -- Suppress_Division_Checks (Flag34) + -- Suppress_Elaboration_Checks (Flag35) + -- Suppress_Elaboration_Warnings (Flag148) + -- Suppress_Index_Checks (Flag36) + -- Suppress_Length_Checks (Flag37) + -- Suppress_Overflow_Checks (Flag38) + -- Suppress_Range_Checks (Flag39) + -- Suppress_Storage_Checks (Flag40) + -- Suppress_Style_Checks (Flag165) + -- Suppress_Tag_Checks (Flag41) + + -- Declaration_Node (synth) + -- Enclosing_Dynamic_Scope (synth) + -- Has_Foreign_Convention (synth) + -- Is_Dynamic_Scope (synth) + -- Is_Generic_Unit (synth) + -- Is_Limited_Type (synth) + -- Underlying_Type (synth) + -- all classification attributes (synth) + + -- The following list of access functions applies to all entities for + -- types and subtypes. References to this list appear subsequently as + -- as "(plus type attributes)" for each appropriate Entity_Kind. + + -- Associated_Node_For_Itype (Node8) + -- Class_Wide_Type (Node9) + -- Referenced_Object (Node10) + -- Full_View (Node11) + -- Esize (Uint12) + -- RM_Size (Uint13) + -- Alignment (Uint14) + + -- Depends_On_Private (Flag14) + -- Discard_Names (Flag88) + -- Finalize_Storage_Only (Flag158) (base type only) + -- From_With_Type (Flag159) + -- Has_Aliased_Components (Flag135) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) (base type only) + -- Has_Complex_Representation (Flag140) (base type only) + -- Has_Discriminants (Flag5) + -- Has_Non_Standard_Rep (Flag75) + -- Has_Object_Size_Clause (Flag172) + -- Has_Primitive_Operations (Flag120) (base type only) + -- Has_Size_Clause (Flag29) + -- Has_Specified_Layout (Flag100) (base type only) + -- Has_Task (Flag30) (base type only) + -- Has_Unchecked_Union (Flag123) (base type only) + -- Has_Volatile_Components (Flag87) (base type only) + -- In_Use (Flag8) + -- Is_Abstract (Flag19) + -- Is_Asynchronous (Flag81) + -- Is_Atomic (Flag85) + -- Is_Constr_Subt_For_U_Nominal (Flag80) + -- Is_Constr_Subt_For_UN_Aliased (Flag141) + -- Is_Controlled (Flag42) (base type only) + -- Is_Eliminated (Flag124) + -- Is_Frozen (Flag4) + -- Is_Generic_Actual_Type (Flag94) + -- Is_Generic_Type (Flag13) + -- Is_Non_Static_Subtype (Flag109) + -- Is_Packed (Flag51) (base type only) + -- Is_Private_Composite (Flag107) + -- Is_Renaming_Of_Object (Flag112) + -- Is_Tagged_Type (Flag55) + -- Is_Unsigned_Type (Flag144) + -- Is_Volatile (Flag16) + -- Size_Depends_On_Discriminant (Flag177) + -- Size_Known_At_Compile_Time (Flag92) + -- Strict_Alignment (Flag145) + -- Suppress_Init_Proc (Flag105) (base type only) + + -- Alignment_Clause (synth) + -- Ancestor_Subtype (synth) + -- Base_Type (synth) + -- First_Subtype (synth) + -- Has_Private_Ancestor (synth) + -- Implementation_Base_Type (synth) + -- Is_By_Copy_Type (synth) + -- Is_By_Reference_Type (synth) + -- Is_Return_By_Reference_Type (synth) + -- Root_Type (synth) + -- Size_Clause (synth) + + ------------------------------------------ + -- Applicable attributes by entity kind -- + ------------------------------------------ + + -- E_Access_Protected_Subprogram_Type + -- Equivalent_Type (Node18) + -- Directly_Designated_Type (Node20) + -- Needs_No_Actuals (Flag22) + -- (plus type attributes) + + -- E_Access_Subprogram_Type + -- Equivalent_Type (Node18) (remote types only) + -- Directly_Designated_Type (Node20) + -- Needs_No_Actuals (Flag22) + -- (plus type attributes) + + -- E_Access_Type + -- E_Access_Subtype + -- Storage_Size_Variable (Node15) (root type only) + -- Master_Id (Node17) + -- Directly_Designated_Type (Node20) + -- Associated_Storage_Pool (Node22) + -- Associated_Final_Chain (Node23) + -- Has_Pragma_Controlled (Flag27) (base type only) + -- Has_Storage_Size_Clause (Flag23) (root type only) + -- Is_Access_Constant (Flag69) + -- No_Pool_Assigned (Flag131) (root type only) + -- (plus type attributes) + + -- E_Access_Attribute_Type + -- Directly_Designated_Type (Node20) + -- (plus type attributes) + + -- E_Allocator_Type + -- Directly_Designated_Type (Node20) + -- (plus type attributes) + + -- E_Anonymous_Access_Type + -- Storage_Size_Variable (Node15) ??? is this needed ??? + -- Directly_Designated_Type (Node20) + -- (plus type attributes) + + -- E_Array_Type + -- E_Array_Subtype + -- First_Index (Node17) + -- Related_Array_Object (Node19) + -- Component_Type (Node20) (base type only) + -- Component_Size (Uint22) (base type only) + -- Packed_Array_Type (Node23) + -- Component_Alignment (special) (base type only) + -- Has_Component_Size_Clause (Flag68) (base type only) + -- Has_Controlled_Component (Flag43) (base type only) + -- Has_Pragma_Pack (Flag121) (base type only) + -- Is_Aliased (Flag15) + -- Is_Constrained (Flag12) + -- Next_Index (synth) + -- Number_Dimensions (synth) + -- (plus type attributes) + + -- E_Block + -- Block_Node (Node11) + -- First_Entity (Node17) + -- Last_Entity (Node20) + -- Delay_Cleanups (Flag114) + -- Discard_Names (Flag88) + -- Finalization_Chain_Entity (Node19) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Entry_Cancel_Parameter (Node23) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + + -- E_Class_Wide_Type + -- E_Class_Wide_Subtype + -- Cloned_Subtype (Node16) (subtype case only) + -- First_Entity (Node17) + -- Equivalent_Type (Node18) (always Empty in type case) + -- Last_Entity (Node20) + -- Has_Controlled_Component (Flag43) (base type only) + -- First_Component (synth) + -- (plus type attributes) + + -- E_Component + -- Normalized_First_Bit (Uint8) + -- Normalized_Position (Uint9) + -- Normalized_Position_Max (Uint10) + -- Component_Bit_Offset (Uint11) + -- Esize (Uint12) + -- Component_Clause (Node13) + -- DT_Entry_Count (Uint15) + -- Entry_Formal (Node16) + -- Prival (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Discriminant_Checking_Func (Node20) + -- Interface_Name (Node21) (JGNAT usage only) + -- Original_Record_Component (Node22) + -- Protected_Operation (Node23) + -- Has_Biased_Representation (Flag139) + -- Has_Per_Object_Constraint (Flag154) + -- Is_Atomic (Flag85) + -- Is_Tag (Flag78) + -- Is_Volatile (Flag16) + -- Next_Component (synth) + -- Is_Protected_Private (synth) + + -- E_Constant + -- E_Loop_Parameter + -- Size_Check_Code (Node9) + -- Discriminal_Link (Node10) (discriminals only) + -- Full_View (Node11) + -- Esize (Uint12) + -- Alignment (Uint14) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Interface_Name (Node21) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) + -- Has_Biased_Representation (Flag139) + -- Has_Size_Clause (Flag29) + -- Has_Volatile_Components (Flag87) + -- Is_Atomic (Flag85) + -- Is_Eliminated (Flag124) + -- Is_Psected (Flag153) + -- Is_True_Constant (Flag163) + -- Is_Volatile (Flag16) + -- Not_Source_Assigned (Flag115) + -- Address_Clause (synth) + -- Alignment_Clause (synth) + -- Constant_Value (synth) + -- Size_Clause (synth) + + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Subtype + -- Scale_Value (Uint15) + -- Digits_Value (Uint17) + -- Scalar_Range (Node20) + -- Delta_Value (Ureal18) + -- Small_Value (Ureal21) + -- Has_Machine_Radix_Clause (Flag83) + -- Machine_Radix_10 (Flag84) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Discriminant + -- Normalized_First_Bit (Uint8) + -- Normalized_Position (Uint9) + -- Normalized_Position_Max (Uint10) + -- Component_Bit_Offset (Uint11) + -- Esize (Uint12) + -- Component_Clause (Node13) + -- Discriminant_Number (Uint15) + -- Discriminal (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Corresponding_Discriminant (Node19) + -- Discriminant_Default_Value (Node20) + -- Interface_Name (Node21) (JGNAT usage only) + -- Original_Record_Component (Node22) + -- CR_Discriminant (Node23) + -- Next_Discriminant (synth) + -- Next_Girder_Discriminant (synth) + + -- E_Entry + -- E_Entry_Family + -- Protected_Body_Subprogram (Node11) + -- Barrier_Function (Node12) + -- Entry_Parameters_Type (Node15) + -- First_Entity (Node17) + -- Alias (Node18) (Entry only. Always empty) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Accept_Address (Elist21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Privals_Chain (Elist23) (for a protected entry) + -- Default_Expressions_Processed (Flag108) + -- Entry_Accepted (Flag152) + -- Is_AST_Entry (Flag132) (for entry only) + -- Needs_No_Actuals (Flag22) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Address_Clause (synth) + -- First_Formal (synth) + -- Entry_Index_Type (synth) + -- Number_Formals (synth) + + -- E_Entry_Index_Parameter + -- Entry_Index_Constant (Node18) + + -- E_Enumeration_Literal + -- Enumeration_Pos (Uint11) + -- Enumeration_Rep (Uint12) + -- Debug_Renaming_Link (Node13) + -- Alias (Node18) + -- Enumeration_Rep_Expr (Node22) + -- Next_Literal (synth) + + -- E_Enumeration_Type + -- E_Enumeration_Subtype + -- Lit_Indexes (Node15) (root type only) + -- Lit_Strings (Node16) (root type only) + -- First_Literal (Node17) + -- Scalar_Range (Node20) + -- Enum_Pos_To_Rep (Node23) (type only, not subtype) + -- Has_Biased_Representation (Flag139) + -- Has_Enumeration_Rep_Clause (Flag66) + -- Nonzero_Is_True (Flag162) (base type only) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Exception + -- Renamed_Entity (Node18) + -- Register_Exception_Call (Node20) + -- Interface_Name (Node21) + -- Exception_Code (Uint22) + -- Discard_Names (Flag88) + -- Is_VMS_Exception (Flag133) + + -- E_Exception_Type + -- Equivalent_Type (Node18) + -- (plus type attributes) + + -- E_Floating_Point_Type + -- E_Floating_Point_Subtype + -- Digits_Value (Uint17) + -- Type_Low_Bound (synth) + -- Scalar_Range (Node20) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Function + -- E_Generic_Function + -- Mechanism (Uint8) (returns Mechanism_Type) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Protected_Body_Subprogram (Node11) + -- Next_Inlined_Subprogram (Node12) + -- Corresponding_Equality (Node13) (implicit /= only) + -- Elaboration_Entity (Node13) (all other cases) + -- First_Optional_Parameter (Node14) (non-generic case only) + -- DT_Position (Uint15) + -- DTC_Entity (Node16) + -- First_Entity (Node17) + -- Alias (Node18) (non-generic case only) + -- Renamed_Entity (Node18) (generic case only) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (for a generic function) + -- Privals_Chain (Elist23) (for a protected function) + -- Elaboration_Entity_Required (Flag174) + -- Function_Returns_With_DSP (Flag169) + -- Default_Expressions_Processed (Flag108) + -- Delay_Cleanups (Flag114) + -- Delay_Subprogram_Descriptors (Flag50) + -- Discard_Names (Flag88) + -- Elaborate_All_Desirable (Flag146) + -- Has_Completion (Flag26) + -- Has_Controlling_Result (Flag98) + -- Has_Master_Entity (Flag21) + -- Has_Missing_Return (Flag142) + -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Recursive_Call (Flag143) + -- Has_Subprogram_Descriptor (Flag93) + -- Is_Abstract (Flag19) + -- Is_Called (Flag102) (non-generic case only) + -- Is_Constructor (Flag76) + -- Is_Destructor (Flag77) + -- Is_Discrim_SO_Function (Flag176) + -- Is_Eliminated (Flag124) + -- Is_Instantiated (Flag126) (generic case only) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Private_Descendant (Flag53) + -- Is_Pure (Flag44) + -- Is_Visible_Child_Unit (Flag116) + -- Needs_No_Actuals (Flag22) + -- Return_Present (Flag54) + -- Returns_By_Ref (Flag90) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Address_Clause (synth) + -- First_Formal (synth) + -- Number_Formals (synth) + + -- E_General_Access_Type + -- Storage_Size_Variable (Node15) (base type only) + -- Master_Id (Node17) + -- Directly_Designated_Type (Node20) + -- Associated_Storage_Pool (Node22) + -- Associated_Final_Chain (Node23) + -- (plus type attributes) + + -- E_Generic_In_Parameter + -- E_Generic_In_Out_Parameter + -- Entry_Component (Node11) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Default_Value (Node20) + -- Protected_Formal (Node22) + -- Is_Controlling_Formal (Flag97) + -- Is_Entry_Formal (Flag52) + -- Parameter_Mode (synth) + + -- E_Incomplete_Type + -- Private_Dependents (Elist18) + -- Discriminant_Constraint (Elist21) + -- Girder_Constraint (Elist23) + -- First_Discriminant (synth) + -- First_Girder_Discriminant (synth) + -- (plus type attributes) + + -- E_In_Parameter + -- E_In_Out_Parameter + -- E_Out_Parameter + -- Mechanism (Uint8) (returns Mechanism_Type) + -- Discriminal_Link (Node10) (discriminals only) + -- Entry_Component (Node11) + -- Esize (Uint12) + -- Extra_Accessibility (Node13) + -- Alignment (Uint14) + -- Extra_Formal (Node15) + -- Unset_Reference (Node16) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Spec_Entity (Node19) + -- Default_Value (Node20) + -- Default_Expr_Function (Node21) + -- Protected_Formal (Node22) + -- Extra_Constrained (Node23) + -- Is_Controlling_Formal (Flag97) + -- Is_Entry_Formal (Flag52) + -- Is_Optional_Parameter (Flag134) + -- Not_Source_Assigned (Flag115) + -- Parameter_Mode (synth) + + -- E_Label + -- Enclosing_Scope (Node18) + -- Reachable (Flag49) + + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Girder_Constraint (Elist23) + -- Has_Completion (Flag26) + -- Has_Completion_In_Body (Flag71) + -- First_Discriminant (synth) + -- First_Girder_Discriminant (synth) + -- (plus type attributes) + + -- E_Loop + -- Has_Exit (Flag47) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- Modulus (Uint17) (base type only) + -- Scalar_Range (Node20) + -- Non_Binary_Modulus (Flag58) (base type only) + -- Has_Biased_Representation (Flag139) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Named_Integer + -- Constant_Value (synth) + + -- E_Named_Real + -- Constant_Value (synth) + + -- E_Operator + -- First_Entity (Node17) + -- Alias (Node18) + -- Last_Entity (Node20) + -- Is_Machine_Code_Subprogram (Flag137) + -- Is_Pure (Flag44) + -- Is_Intrinsic_Subprogram (Flag64) + -- Default_Expressions_Processed (Flag108) + + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- Delta_Value (Ureal18) + -- Scalar_Range (Node20) + -- Small_Value (Ureal21) + -- Has_Small_Clause (Flag67) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Package + -- E_Generic_Package + -- Dependent_Instances (Elist8) (for an instance) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Associated_Formal_Package (Node12) + -- Elaboration_Entity (Node13) + -- Shadow_Entities (List14) + -- Related_Instance (Node15) (non-generic case only) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Renamed_Entity (Node18) + -- Body_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (generic case only) + -- Delay_Subprogram_Descriptors (Flag50) + -- Discard_Names (Flag88) + -- Elaborate_All_Desirable (Flag146) + -- Elaboration_Entity_Required (Flag174) + -- From_With_Type (Flag159) + -- Has_All_Calls_Remote (Flag79) + -- Has_Completion (Flag26) + -- Has_Forward_Instantiation (Flag175) + -- Has_Master_Entity (Flag21) + -- Has_Subprogram_Descriptor (Flag93) + -- In_Package_Body (Flag48) + -- In_Private_Part (Flag45) + -- In_Use (Flag8) + -- Is_Instantiated (Flag126) + -- Is_Private_Descendant (Flag53) + -- Is_Visible_Child_Unit (Flag116) + -- Is_Wrapper_Package (synth) (non-generic case only) + + -- E_Package_Body + -- Handler_Records (List10) (non-generic case only) + -- First_Entity (Node17) + -- Spec_Entity (Node19) + -- Last_Entity (Node20) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Delay_Subprogram_Descriptors (Flag50) + -- Has_Subprogram_Descriptor (Flag93) + + -- E_Private_Type + -- E_Private_Subtype + -- Primitive_Operations (Elist15) + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Girder_Constraint (Elist23) + -- Has_Completion (Flag26) + -- Has_Completion_In_Body (Flag71) + -- Is_Controlled (Flag42) (base type only) + -- Is_For_Access_Subtype (Flag118) (subtype only) + -- First_Discriminant (synth) + -- First_Girder_Discriminant (synth) + -- (plus type attributes) + + -- E_Procedure + -- E_Generic_Procedure + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Protected_Body_Subprogram (Node11) + -- Next_Inlined_Subprogram (Node12) + -- Elaboration_Entity (Node13) + -- First_Optional_Parameter (Node14) (non-generic case only) + -- DT_Position (Uint15) + -- DTC_Entity (Node16) + -- First_Entity (Node17) + -- Alias (Node18) (non-generic case only) + -- Renamed_Entity (Node18) (generic case only) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (for a generic procedure) + -- Privals_Chain (Elist23) (for a protected procedure) + -- Elaboration_Entity_Required (Flag174) + -- Function_Returns_With_DSP (Flag169) (always False for procedure) + -- Default_Expressions_Processed (Flag108) + -- Delay_Cleanups (Flag114) + -- Delay_Subprogram_Descriptors (Flag50) + -- Discard_Names (Flag88) + -- Elaborate_All_Desirable (Flag146) + -- Has_Completion (Flag26) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Subprogram_Descriptor (Flag93) + -- Is_Visible_Child_Unit (Flag116) + -- Is_Abstract (Flag19) + -- Is_Asynchronous (Flag81) + -- Is_Called (Flag102) (non-generic subprogram) + -- Is_Constructor (Flag76) + -- Is_Destructor (Flag77) + -- Is_Eliminated (Flag124) + -- Is_Instantiated (Flag126) (generic case only) + -- Is_Interrupt_Handler (Flag89) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Null_Init_Proc (Flag178) + -- Is_Private_Descendant (Flag53) + -- Is_Pure (Flag44) + -- Is_Valued_Procedure (Flag127) + -- Is_Visible_Child_Unit (Flag116) + -- Needs_No_Actuals (Flag22) + -- No_Return (Flag113) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Address_Clause (synth) + -- First_Formal (synth) + -- Number_Formals (synth) + + -- E_Protected_Body + -- Object_Ref (Node17) + -- (any others??? First/Last Entity, Scope_Depth???) + + -- E_Protected_Object + + -- E_Protected_Type + -- E_Protected_Subtype + -- Entry_Bodies_Array (Node15) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Corresponding_Record_Type (Node18) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Girder_Constraint (Elist23) + -- Has_Controlled_Component (Flag43) (base type only) + -- Has_Interrupt_Handler (synth) + -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- Uses_Sec_Stack (Flag95) ??? + -- Has_Entries (synth) + -- Number_Entries (synth) + + -- E_Record_Type + -- E_Record_Subtype + -- Primitive_Operations (Elist15) + -- Access_Disp_Table (Node16) (base type only) + -- Cloned_Subtype (Node16) (subtype case only) + -- First_Entity (Node17) + -- Corresponding_Concurrent_Type (Node18) + -- Parent_Subtype (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Corresponding_Remote_Type (Node22) (base type only) + -- Girder_Constraint (Elist23) + -- Component_Alignment (special) (base type only) + -- C_Pass_By_Copy (Flag125) (base type only) + -- Has_Controlled_Component (Flag43) (base type only) + -- Has_External_Tag_Rep_Clause (Flag110) + -- Has_Record_Rep_Clause (Flag65) + -- Is_Concurrent_Record_Type (Flag20) + -- Is_Constrained (Flag12) + -- Is_Controlled (Flag42) (base type only) + -- Reverse_Bit_Order (Flag164) (base type only) + -- First_Component (synth) + -- First_Discriminant (synth) + -- First_Girder_Discriminant (synth) + -- Tag_Component (synth) + -- (plus type attributes) + + -- E_Record_Type_With_Private + -- E_Record_Subtype_With_Private + -- Primitive_Operations (Elist15) + -- Access_Disp_Table (Node16) (base type only) + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Girder_Constraint (Elist23) + -- Has_Completion (Flag26) + -- Has_Completion_In_Body (Flag71) + -- Has_Controlled_Component (Flag43) (base type only) + -- Has_Record_Rep_Clause (Flag65) + -- Has_External_Tag_Rep_Clause (Flag110) + -- Is_Concurrent_Record_Type (Flag20) + -- Is_Constrained (Flag12) + -- Is_Controlled (Flag42) (base type only) + -- Reverse_Bit_Order (Flag164) (base type only) + -- First_Component (synth) + -- First_Discriminant (synth) + -- First_Girder_Discriminant (synth) + -- Tag_Component (synth) + -- (plus type attributes) + + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- Scalar_Range (Node20) + -- Has_Biased_Representation (Flag139) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_String_Type + -- E_String_Subtype + -- First_Index (Node17) + -- Component_Type (Node20) (base type only) + -- Is_Constrained (Flag12) + -- Next_Index (synth) + -- Number_Dimensions (synth) + -- (plus type attributes) + + -- E_String_Literal_Subtype + -- String_Literal_Low_Bound (Node15) + -- String_Literal_Length (Uint16) + -- First_Index (Node17) (always Empty) + -- Component_Type (Node20) (base type only) + -- Packed_Array_Type (Node23) + -- (plus type attributes) + + -- E_Subprogram_Body + -- First_Entity (Node17) + -- Last_Entity (Node20) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + + -- E_Subprogram_Type + -- Directly_Designated_Type (Node20) + -- First_Formal (synth) + -- Number_Formals (synth) + -- Function_Returns_With_DSP (Flag169) + -- (plus type attributes) + + -- E_Task_Body + -- (any others??? First/Last Entity, Scope_Depth???) + + -- E_Task_Type + -- E_Task_Subtype + -- Storage_Size_Variable (Node15) (base type only) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Corresponding_Record_Type (Node18) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Girder_Constraint (Elist23) + -- Delay_Cleanups (Flag114) + -- Has_Master_Entity (Flag21) + -- Has_Storage_Size_Clause (Flag23) (base type only) + -- Uses_Sec_Stack (Flag95) ??? + -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- Has_Entries (synth) + -- Number_Entries (synth) + -- (plus type attributes) + + -- E_Variable + -- Hiding_Loop_Variable (Node8) + -- Size_Check_Code (Node9) + -- Esize (Uint12) + -- Extra_Accessibility (Node13) + -- Alignment (Uint14) + -- Shared_Var_Read_Proc (Node15) + -- Unset_Reference (Node16) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Interface_Name (Node21) + -- Shared_Var_Assign_Proc (Node22) + -- Extra_Constrained (Node23) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) + -- Has_Biased_Representation (Flag139) + -- Has_Size_Clause (Flag29) + -- Has_Volatile_Components (Flag87) + -- Is_Atomic (Flag85) + -- Is_Eliminated (Flag124) + -- Is_Psected (Flag153) + -- Is_Shared_Passive (Flag60) + -- Is_True_Constant (Flag163) + -- Is_Volatile (Flag16) + -- Not_Source_Assigned (Flag115) + -- Address_Clause (synth) + -- Alignment_Clause (synth) + -- Size_Clause (synth) + + -- E_Void + -- Since E_Void is the initial Ekind value of an entity when it is first + -- created, one might expect that no attributes would be defined on such + -- an entity until its Ekind field is set. However, in practice, there + -- are many instances in which fields of an E_Void entity are set in the + -- code prior to setting the Ekind field. This is not well documented or + -- well controlled, and needs cleaning up later. Meanwhile, the access + -- procedures in the body of Einfo permit many, but not all, attributes + -- to be applied to an E_Void entity, precisely so that this kind of + -- pre-setting of attributes works. This is really a hole in the dynamic + -- type checking, since there is no assurance that the eventual Ekind + -- value will be appropriate for the attributes set, and the consequence + -- is that the dynamic type checking in the Einfo body is unnecessarily + -- weak. To be looked at systematically some time ??? + + --------------------------------- + -- Component_Alignment Control -- + --------------------------------- + + -- There are four types of alignment possible for array and record + -- types, and a field in the type entities contains a value of the + -- following type indicating which alignment choice applies. For full + -- details of the meaning of these aligment types, see description + -- of the Component_Alignment pragma + + type Component_Alignment_Kind is ( + Calign_Default, -- default alignment + Calign_Component_Size, -- natural alignment for component size + Calign_Component_Size_4, -- natural for size <= 4, 4 for size >= 4 + Calign_Storage_Unit); -- all components byte aligned + + --------------- + -- Iterators -- + --------------- + + -- In addition to attributes that are stored as plain data, other + -- attributes are procedural, and require some small amount of + -- computation. Of course, from the point of view of a user of this + -- package, the distinction is not visible (even the field information + -- provided below should be disregarded, as it is subject to change + -- without notice!). A number of attributes appear as lists: lists of + -- formals, lists of actuals, of discriminants, etc. For these, pairs + -- of functions are defined, which take the form: + + -- function First_Thing (E : Enclosing_Construct) return Thing; + -- function Next_Thing (T : Thing) return Thing; + + -- The end of iteration is always signaled by a value of Empty, so that + -- loops over these chains invariably have the form: + + -- This : Thing; + -- ... + -- This := First_Thing (E); + + -- while Present (This) loop + -- Do_Something_With (This); + -- ... + -- This := Next_Thing (This); + -- end loop; + + ----------------------------------- + -- Handling of Check Suppression -- + ----------------------------------- + + -- There are three ways that checks can be suppressed: + + -- 1. At the command line level. Package Opt contains global Boolean + -- flags with names Suppress_Options.xxx_Checks, where xxx is the + -- name of one of the checks that can be suppressed (excluding + -- All_Checks, which is simply reflected by setting all the + -- individual flags) + + -- 2. At the scope level. The body of Sem contains flags with names + -- Suppress.xxx_Checks which are set to indicate that the given + -- check is suppressed for the current scope. These flags are + -- saved in the scope stack on entry to a scope and restored on + -- exit from the scope. + + -- 3. At the entity level. Each entity contains a set of flags named + -- Suppress_xxx_Checks which suppress the given check for that + -- particularly entity (of course not all flags are meaningful for + -- all entities). + + ------------------------------- + -- Handling of Discriminants -- + ------------------------------- + + -- During semantic processing, discriminants are separate entities which + -- reflect the semantic properties and allowed usage of discriminants in + -- the language. + + -- In the case of discriminants used as bounds, the references are handled + -- directly, since special processing is needed in any case. However, there + -- are two circumstances in which discriminants are referenced in a quite + -- general manner, like any other variables: + + -- In initialization expressions for records. Note that the expressions + -- used in Priority, Storage_Size, and Task_Info pragmas are effectively + -- in this category, since these pragmas are converted to initialized + -- record fields in the Corresponding_Record_Type. + + -- In task and protected bodies, where the discriminant values may be + -- referenced freely within these bodies. Discriminants can also appear + -- in bounds of entry families and in defaults of operations. + + -- In both these cases, the discriminants must be treated essentially as + -- objects. The following approach is used to simplify and minimize the + -- special processing that is required. + + -- When a record type with discriminants is processed, the semantic + -- processing creates the entities for the discriminants. It also creates + -- an additional set of entities, called discriminals, one for each of + -- the discriminants, and the Discriminal field of the discriminant entity + -- points to this additional entity, which is initially created as an + -- uninitialized (E_Void) entity. + + -- During expansion of expressions, any discriminant reference is replaced + -- by a reference to the corresponding discriminal. When the initialization + -- procedure for the record is created (there will always be one, since + -- discriminants are present, see Exp_Ch3 for further details), the + -- discriminals are used as the entities for the formal parameters of + -- this initialization procedure. The references to these discriminants + -- have already been replaced by references to these discriminals, which + -- are now the formal parameters corresponding to the required objects. + + -- In the case of a task or protected body, the semantics similarly + -- creates a set of discriminals for the discriminants of the task or + -- protected type. When the procedure is created for the task body, + -- the parameter passed in is a reference to the task value type, which + -- contains the required discriminant values. The expander creates a + -- set of declarations of the form: + + -- discriminal : constant dtype renames _Task.discriminant; + + -- where discriminal is the discriminal entity referenced by the task + -- discriminant, and _Task is the task value passed in as the parameter. + -- Again, any references to discriminants in the task body have been + -- replaced by the discriminal reference, which is now an object that + -- contains the required value. + + -- This approach for tasks means that two sets of discriminals are needed + -- for a task type, one for the initialization procedure, and one for the + -- task body. This works out nicely, since the semantics allocates one set + -- for the task itself, and one set for the corresponding record. + + -- The one bit of trickiness arises in making sure that the right set of + -- discriminals is used at the right time. First the task definition is + -- processed. Any references to discriminants here are replaced by the + -- the corresponding *task* discriminals (the record type doesn't even + -- exist yet, since it is constructed as part of the expansion of the + -- task declaration, which happens after the semantic processing of the + -- task definition). The discriminants to be used for the corresponding + -- record are created at the same time as the other discriminals, and + -- held in the CR_Discriminant field of the discriminant. A use of the + -- discriminant in a bound for an entry family is replaced with the CR_ + -- discriminant because it controls the bound of the entry queue array + -- which is a component of the corresponding record. + + -- Just before the record initialization routine is constructed, the + -- expander exchanges the task and record discriminals. This has two + -- effects. First the generation of the record initialization routine + -- uses the discriminals that are now on the record, which is the set + -- that used to be on the task, which is what we want. + + -- Second, a new set of (so far unused) discriminals is now on the task + -- discriminants, and it is this set that will be used for expanding the + -- task body, and also for the discriminal declarations at the start of + -- the task body. + + --------------------------------------- + -- Private data in protected objects -- + --------------------------------------- + + -- Private object declarations in protected types pose problems + -- similar to those of discriminants. They are expanded to components + -- of a record which is passed as the parameter "_object" to expanded + -- forms of all protected operations. As with discriminants, timing + -- of this expansion is a problem. The sequence of statements for a + -- protected operation is expanded before the operation itself, so the + -- formal parameter for the record object containing the private data + -- does not exist when the references to that data are expanded. + + -- For this reason, private data is handled in the same way as + -- discriminants, expanding references to private data in protected + -- operations (which appear as components) to placeholders which will + -- eventually become renamings of the private selected components + -- of the "_object" formal parameter. These placeholders are called + -- "privals", by analogy to the "discriminals" used to implement + -- discriminants. They are attached to the component declaration nodes + -- representing the private object declarations of the protected type. + + -- As with discriminals, each protected subprogram needs a unique set + -- of privals, since they must refer to renamings of components of a + -- formal parameter of that operation. Entry bodies need another set, + -- which they all share and which is associated with renamings in the + -- Service_Entries procedure for the protected type (this is not yet + -- implemented???). This means that we must associate a new set of + -- privals (and discriminals) with the private declarations after + -- the body of a protected subprogram is processed. + + -- The last complication is the presence of discriminants and discriminated + -- components. In the corresponding record, the components are constrained + -- by the discriminants of the record, but within each protected operation + -- they are constrained by the discriminants of the actual. The actual + -- subtypes of those components are constructed as for other unconstrained + -- formals, but the privals are created before the formal object is added + -- to the parameter list of the protected operation, so they carry the + -- nominal subtype of the original component. After the protected operation + -- is actually created (in the expansion of the protected body) we must + -- patch the types of each prival occurrence with the proper actual subtype + -- which is by now set. The Privals_Chain is used for this patching. + + ------------------- + -- Type Synonyms -- + ------------------- + + -- The following type synonyms are used to tidy up the function and + -- procedure declarations that follow, and also to make it possible + -- to meet the requirement for the XEINFO utility that all function + -- specs must fit on a single source line. + + subtype B is Boolean; + subtype C is Component_Alignment_Kind; + subtype E is Entity_Id; + subtype M is Mechanism_Type; + subtype N is Node_Id; + subtype U is Uint; + subtype R is Ureal; + subtype L is Elist_Id; + subtype S is List_Id; + + --------------------------------- + -- Attribute Access Functions -- + --------------------------------- + + -- All attributes are manipulated through a procedural interface. This + -- section contains the functions used to obtain attribute values which + -- correspond to values in fields or flags in the entity itself. + + function Accept_Address (Id : E) return L; + function Access_Disp_Table (Id : E) return E; + function Actual_Subtype (Id : E) return E; + function Address_Taken (Id : E) return B; + function Alias (Id : E) return E; + function Alignment (Id : E) return U; + function Associated_Final_Chain (Id : E) return E; + function Associated_Formal_Package (Id : E) return E; + function Associated_Node_For_Itype (Id : E) return N; + function Associated_Storage_Pool (Id : E) return E; + function Barrier_Function (Id : E) return N; + function Block_Node (Id : E) return N; + function Body_Entity (Id : E) return E; + function CR_Discriminant (Id : E) return E; + function C_Pass_By_Copy (Id : E) return B; + function Class_Wide_Type (Id : E) return E; + function Cloned_Subtype (Id : E) return E; + function Component_Alignment (Id : E) return C; + function Component_Clause (Id : E) return N; + function Component_Bit_Offset (Id : E) return U; + function Component_Size (Id : E) return U; + function Component_Type (Id : E) return E; + function Corresponding_Concurrent_Type (Id : E) return E; + function Corresponding_Discriminant (Id : E) return E; + function Corresponding_Equality (Id : E) return E; + function Corresponding_Record_Type (Id : E) return E; + function Corresponding_Remote_Type (Id : E) return E; + function Debug_Info_Off (Id : E) return B; + function Debug_Renaming_Link (Id : E) return E; + function DTC_Entity (Id : E) return E; + function DT_Entry_Count (Id : E) return U; + function DT_Position (Id : E) return U; + function Default_Expr_Function (Id : E) return E; + function Default_Expressions_Processed (Id : E) return B; + function Default_Value (Id : E) return N; + function Delay_Cleanups (Id : E) return B; + function Delay_Subprogram_Descriptors (Id : E) return B; + function Delta_Value (Id : E) return R; + function Dependent_Instances (Id : E) return L; + function Depends_On_Private (Id : E) return B; + function Digits_Value (Id : E) return U; + function Directly_Designated_Type (Id : E) return E; + function Discard_Names (Id : E) return B; + function Discriminal (Id : E) return E; + function Discriminal_Link (Id : E) return E; + function Discriminant_Checking_Func (Id : E) return E; + function Discriminant_Constraint (Id : E) return L; + function Discriminant_Default_Value (Id : E) return N; + function Discriminant_Number (Id : E) return U; + function Elaborate_All_Desirable (Id : E) return B; + function Elaboration_Entity (Id : E) return E; + function Elaboration_Entity_Required (Id : E) return B; + function Enclosing_Scope (Id : E) return E; + function Entry_Accepted (Id : E) return B; + function Entry_Bodies_Array (Id : E) return E; + function Entry_Cancel_Parameter (Id : E) return E; + function Entry_Component (Id : E) return E; + function Entry_Formal (Id : E) return E; + function Entry_Index_Constant (Id : E) return E; + function Entry_Index_Type (Id : E) return E; + function Entry_Parameters_Type (Id : E) return E; + function Enum_Pos_To_Rep (Id : E) return E; + function Enumeration_Pos (Id : E) return U; + function Enumeration_Rep (Id : E) return U; + function Enumeration_Rep_Expr (Id : E) return N; + function Equivalent_Type (Id : E) return E; + function Esize (Id : E) return U; + function Exception_Code (Id : E) return U; + function Extra_Accessibility (Id : E) return E; + function Extra_Constrained (Id : E) return E; + function Extra_Formal (Id : E) return E; + function Finalization_Chain_Entity (Id : E) return E; + function Finalize_Storage_Only (Id : E) return B; + function First_Entity (Id : E) return E; + function First_Index (Id : E) return N; + function First_Literal (Id : E) return E; + function First_Optional_Parameter (Id : E) return E; + function First_Private_Entity (Id : E) return E; + function First_Rep_Item (Id : E) return N; + function Freeze_Node (Id : E) return N; + function From_With_Type (Id : E) return B; + function Full_View (Id : E) return E; + function Function_Returns_With_DSP (Id : E) return B; + function Generic_Renamings (Id : E) return L; + function Girder_Constraint (Id : E) return L; + function Handler_Records (Id : E) return S; + function Has_Aliased_Components (Id : E) return B; + function Has_Alignment_Clause (Id : E) return B; + function Has_All_Calls_Remote (Id : E) return B; + function Has_Atomic_Components (Id : E) return B; + function Has_Biased_Representation (Id : E) return B; + function Has_Completion (Id : E) return B; + function Has_Completion_In_Body (Id : E) return B; + function Has_Complex_Representation (Id : E) return B; + function Has_Component_Size_Clause (Id : E) return B; + function Has_Controlled_Component (Id : E) return B; + function Has_Controlling_Result (Id : E) return B; + function Has_Convention_Pragma (Id : E) return B; + function Has_Delayed_Freeze (Id : E) return B; + function Has_Discriminants (Id : E) return B; + function Has_Enumeration_Rep_Clause (Id : E) return B; + function Has_Exit (Id : E) return B; + function Has_External_Tag_Rep_Clause (Id : E) return B; + function Has_Fully_Qualified_Name (Id : E) return B; + function Has_Gigi_Rep_Item (Id : E) return B; + function Has_Homonym (Id : E) return B; + function Has_Interrupt_Handler (Id : E) return B; + function Has_Machine_Radix_Clause (Id : E) return B; + function Has_Master_Entity (Id : E) return B; + function Has_Missing_Return (Id : E) return B; + function Has_Nested_Block_With_Handler (Id : E) return B; + function Has_Forward_Instantiation (Id : E) return B; + function Has_Non_Standard_Rep (Id : E) return B; + function Has_Object_Size_Clause (Id : E) return B; + function Has_Per_Object_Constraint (Id : E) return B; + function Has_Pragma_Controlled (Id : E) return B; + function Has_Pragma_Elaborate_Body (Id : E) return B; + function Has_Pragma_Inline (Id : E) return B; + function Has_Pragma_Pack (Id : E) return B; + function Has_Primitive_Operations (Id : E) return B; + function Has_Qualified_Name (Id : E) return B; + function Has_Record_Rep_Clause (Id : E) return B; + function Has_Recursive_Call (Id : E) return B; + function Has_Size_Clause (Id : E) return B; + function Has_Small_Clause (Id : E) return B; + function Has_Specified_Layout (Id : E) return B; + function Has_Storage_Size_Clause (Id : E) return B; + function Has_Subprogram_Descriptor (Id : E) return B; + function Has_Task (Id : E) return B; + function Has_Unchecked_Union (Id : E) return B; + function Has_Unknown_Discriminants (Id : E) return B; + function Has_Volatile_Components (Id : E) return B; + function Homonym (Id : E) return E; + function Hiding_Loop_Variable (Id : E) return E; + function In_Package_Body (Id : E) return B; + function In_Private_Part (Id : E) return B; + function In_Use (Id : E) return B; + function Inner_Instances (Id : E) return L; + function Interface_Name (Id : E) return N; + function Is_AST_Entry (Id : E) return B; + function Is_Abstract (Id : E) return B; + function Is_Access_Constant (Id : E) return B; + function Is_Aliased (Id : E) return B; + function Is_Asynchronous (Id : E) return B; + function Is_Atomic (Id : E) return B; + function Is_Bit_Packed_Array (Id : E) return B; + function Is_CPP_Class (Id : E) return B; + function Is_Called (Id : E) return B; + function Is_Character_Type (Id : E) return B; + function Is_Child_Unit (Id : E) return B; + function Is_Compilation_Unit (Id : E) return B; + function Is_Completely_Hidden (Id : E) return B; + function Is_Constr_Subt_For_UN_Aliased (Id : E) return B; + function Is_Constr_Subt_For_U_Nominal (Id : E) return B; + function Is_Constrained (Id : E) return B; + function Is_Constructor (Id : E) return B; + function Is_Controlled (Id : E) return B; + function Is_Controlling_Formal (Id : E) return B; + function Is_Destructor (Id : E) return B; + function Is_Discrim_SO_Function (Id : E) return B; + function Is_Dispatching_Operation (Id : E) return B; + function Is_Eliminated (Id : E) return B; + function Is_Entry_Formal (Id : E) return B; + function Is_Exported (Id : E) return B; + function Is_First_Subtype (Id : E) return B; + function Is_For_Access_Subtype (Id : E) return B; + function Is_Frozen (Id : E) return B; + function Is_Generic_Instance (Id : E) return B; + function Is_Hidden (Id : E) return B; + function Is_Hidden_Open_Scope (Id : E) return B; + function Is_Immediately_Visible (Id : E) return B; + function Is_Imported (Id : E) return B; + function Is_Inlined (Id : E) return B; + function Is_Instantiated (Id : E) return B; + function Is_Internal (Id : E) return B; + function Is_Interrupt_Handler (Id : E) return B; + function Is_Intrinsic_Subprogram (Id : E) return B; + function Is_Itype (Id : E) return B; + function Is_Known_Valid (Id : E) return B; + function Is_Limited_Composite (Id : E) return B; + function Is_Machine_Code_Subprogram (Id : E) return B; + function Is_Non_Static_Subtype (Id : E) return B; + function Is_Null_Init_Proc (Id : E) return B; + function Is_Optional_Parameter (Id : E) return B; + function Is_Package_Body_Entity (Id : E) return B; + function Is_Packed (Id : E) return B; + function Is_Packed_Array_Type (Id : E) return B; + function Is_Potentially_Use_Visible (Id : E) return B; + function Is_Preelaborated (Id : E) return B; + function Is_Private_Composite (Id : E) return B; + function Is_Private_Descendant (Id : E) return B; + function Is_Psected (Id : E) return B; + function Is_Public (Id : E) return B; + function Is_Pure (Id : E) return B; + function Is_Remote_Call_Interface (Id : E) return B; + function Is_Remote_Types (Id : E) return B; + function Is_Renaming_Of_Object (Id : E) return B; + function Is_Shared_Passive (Id : E) return B; + function Is_Statically_Allocated (Id : E) return B; + function Is_Tag (Id : E) return B; + function Is_Tagged_Type (Id : E) return B; + function Is_True_Constant (Id : E) return B; + function Is_Unchecked_Union (Id : E) return B; + function Is_Unsigned_Type (Id : E) return B; + function Is_VMS_Exception (Id : E) return B; + function Is_Valued_Procedure (Id : E) return B; + function Is_Visible_Child_Unit (Id : E) return B; + function Is_Volatile (Id : E) return B; + function Is_Wrapper_Package (Id : E) return B; + function Last_Entity (Id : E) return E; + function Lit_Indexes (Id : E) return E; + function Lit_Strings (Id : E) return E; + function Machine_Radix_10 (Id : E) return B; + function Master_Id (Id : E) return E; + function Materialize_Entity (Id : E) return B; + function Mechanism (Id : E) return M; + function Modulus (Id : E) return U; + function Needs_Debug_Info (Id : E) return B; + function Needs_No_Actuals (Id : E) return B; + function Next_Inlined_Subprogram (Id : E) return E; + function No_Pool_Assigned (Id : E) return B; + function No_Return (Id : E) return B; + function Non_Binary_Modulus (Id : E) return B; + function Nonzero_Is_True (Id : E) return B; + function Normalized_First_Bit (Id : E) return U; + function Normalized_Position (Id : E) return U; + function Normalized_Position_Max (Id : E) return U; + function Not_Source_Assigned (Id : E) return B; + function Object_Ref (Id : E) return E; + function Original_Record_Component (Id : E) return E; + function Packed_Array_Type (Id : E) return E; + function Parent_Subtype (Id : E) return E; + function Primitive_Operations (Id : E) return L; + function Prival (Id : E) return E; + function Privals_Chain (Id : E) return L; + function Private_Dependents (Id : E) return L; + function Private_View (Id : E) return N; + function Protected_Body_Subprogram (Id : E) return E; + function Protected_Formal (Id : E) return E; + function Protected_Operation (Id : E) return E; + function RM_Size (Id : E) return U; + function Reachable (Id : E) return B; + function Referenced (Id : E) return B; + function Referenced_Object (Id : E) return N; + function Register_Exception_Call (Id : E) return N; + function Related_Array_Object (Id : E) return E; + function Related_Instance (Id : E) return E; + function Renamed_Entity (Id : E) return N; + function Renamed_Object (Id : E) return N; + function Renaming_Map (Id : E) return U; + function Return_Present (Id : E) return B; + function Returns_By_Ref (Id : E) return B; + function Reverse_Bit_Order (Id : E) return B; + function Scalar_Range (Id : E) return N; + function Scale_Value (Id : E) return U; + function Scope_Depth_Value (Id : E) return U; + function Sec_Stack_Needed_For_Return (Id : E) return B; + function Shadow_Entities (Id : E) return S; + function Shared_Var_Assign_Proc (Id : E) return E; + function Shared_Var_Read_Proc (Id : E) return E; + function Size_Check_Code (Id : E) return N; + function Size_Known_At_Compile_Time (Id : E) return B; + function Size_Depends_On_Discriminant (Id : E) return B; + function Small_Value (Id : E) return R; + function Spec_Entity (Id : E) return E; + function Storage_Size_Variable (Id : E) return E; + function Strict_Alignment (Id : E) return B; + function String_Literal_Length (Id : E) return U; + function String_Literal_Low_Bound (Id : E) return N; + function Suppress_Access_Checks (Id : E) return B; + function Suppress_Accessibility_Checks (Id : E) return B; + function Suppress_Discriminant_Checks (Id : E) return B; + function Suppress_Division_Checks (Id : E) return B; + function Suppress_Elaboration_Checks (Id : E) return B; + function Suppress_Elaboration_Warnings (Id : E) return B; + function Suppress_Index_Checks (Id : E) return B; + function Suppress_Init_Proc (Id : E) return B; + function Suppress_Length_Checks (Id : E) return B; + function Suppress_Overflow_Checks (Id : E) return B; + function Suppress_Range_Checks (Id : E) return B; + function Suppress_Storage_Checks (Id : E) return B; + function Suppress_Style_Checks (Id : E) return B; + function Suppress_Tag_Checks (Id : E) return B; + function Underlying_Full_View (Id : E) return E; + function Unset_Reference (Id : E) return N; + function Uses_Sec_Stack (Id : E) return B; + function Vax_Float (Id : E) return B; + function Warnings_Off (Id : E) return B; + + ------------------------------- + -- Classification Attributes -- + ------------------------------- + + -- These functions provide a convenient functional notation for testing + -- whether an Ekind value belongs to a specified kind, for example the + -- function Is_Elementary_Type tests if its argument is in Elementary_Kind. + -- In some cases, the test is of an entity attribute (e.g. in the case of + -- Is_Generic_Type where the Ekind does not provide the needed information) + + function Is_Access_Type (Id : E) return B; + function Is_Array_Type (Id : E) return B; + function Is_Class_Wide_Type (Id : E) return B; + function Is_Composite_Type (Id : E) return B; + function Is_Concurrent_Body (Id : E) return B; + function Is_Concurrent_Record_Type (Id : E) return B; + function Is_Concurrent_Type (Id : E) return B; + function Is_Decimal_Fixed_Point_Type (Id : E) return B; + function Is_Digits_Type (Id : E) return B; + function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B; + function Is_Discrete_Type (Id : E) return B; + function Is_Elementary_Type (Id : E) return B; + function Is_Entry (Id : E) return B; + function Is_Enumeration_Type (Id : E) return B; + function Is_Fixed_Point_Type (Id : E) return B; + function Is_Floating_Point_Type (Id : E) return B; + function Is_Formal (Id : E) return B; + function Is_Formal_Subprogram (Id : E) return B; + function Is_Generic_Actual_Type (Id : E) return B; + function Is_Generic_Type (Id : E) return B; + function Is_Generic_Unit (Id : E) return B; + function Is_Incomplete_Or_Private_Type (Id : E) return B; + function Is_Integer_Type (Id : E) return B; + function Is_Limited_Record (Id : E) return B; + function Is_Modular_Integer_Type (Id : E) return B; + function Is_Named_Number (Id : E) return B; + function Is_Numeric_Type (Id : E) return B; + function Is_Object (Id : E) return B; + function Is_Ordinary_Fixed_Point_Type (Id : E) return B; + function Is_Overloadable (Id : E) return B; + function Is_Private_Type (Id : E) return B; + function Is_Protected_Type (Id : E) return B; + function Is_Real_Type (Id : E) return B; + function Is_Record_Type (Id : E) return B; + function Is_Scalar_Type (Id : E) return B; + function Is_Signed_Integer_Type (Id : E) return B; + function Is_Subprogram (Id : E) return B; + function Is_Task_Type (Id : E) return B; + function Is_Type (Id : E) return B; + + ------------------------------------- + -- Synthesized Attribute Functions -- + ------------------------------------- + + -- The functions in this section synthesize attributes from the tree, + -- so they do not correspond to defined fields in the entity itself. + + function Address_Clause (Id : E) return N; + function Alignment_Clause (Id : E) return N; + function Ancestor_Subtype (Id : E) return E; + function Base_Type (Id : E) return E; + function Constant_Value (Id : E) return N; + function Declaration_Node (Id : E) return N; + function Designated_Type (Id : E) return E; + function Enclosing_Dynamic_Scope (Id : E) return E; + function First_Component (Id : E) return E; + function First_Discriminant (Id : E) return E; + function First_Formal (Id : E) return E; + function First_Girder_Discriminant (Id : E) return E; + function First_Subtype (Id : E) return E; + function Has_Attach_Handler (Id : E) return B; + function Has_Entries (Id : E) return B; + function Has_Foreign_Convention (Id : E) return B; + function Has_Private_Ancestor (Id : E) return B; + function Has_Private_Declaration (Id : E) return B; + function Implementation_Base_Type (Id : E) return E; + function Is_Always_Inlined (Id : E) return B; + function Is_Boolean_Type (Id : E) return B; + function Is_By_Copy_Type (Id : E) return B; + function Is_By_Reference_Type (Id : E) return B; + function Is_Derived_Type (Id : E) return B; + function Is_Dynamic_Scope (Id : E) return B; + function Is_Indefinite_Subtype (Id : E) return B; + function Is_Limited_Type (Id : E) return B; + function Is_Package (Id : E) return B; + function Is_Protected_Private (Id : E) return B; + function Is_Protected_Record_Type (Id : E) return B; + function Is_Return_By_Reference_Type (Id : E) return B; + function Is_String_Type (Id : E) return B; + function Is_Task_Record_Type (Id : E) return B; + function Next_Component (Id : E) return E; + function Next_Discriminant (Id : E) return E; + function Next_Formal (Id : E) return E; + function Next_Formal_With_Extras (Id : E) return E; + function Next_Girder_Discriminant (Id : E) return E; + function Next_Literal (Id : E) return E; + function Number_Dimensions (Id : E) return Pos; + function Number_Discriminants (Id : E) return Pos; + function Number_Entries (Id : E) return Nat; + function Number_Formals (Id : E) return Pos; + function Parameter_Mode (Id : E) return Formal_Kind; + function Root_Type (Id : E) return E; + function Scope_Depth_Set (Id : E) return B; + function Size_Clause (Id : E) return N; + function Tag_Component (Id : E) return E; + function Type_High_Bound (Id : E) return N; + function Type_Low_Bound (Id : E) return N; + function Underlying_Type (Id : E) return E; + + ---------------------------------------------- + -- Type Representation Attribute Predicates -- + ---------------------------------------------- + + -- These predicates test the setting of the indicated attribute. If + -- the value has been set, then Known is True, and Unknown is False. + -- If no value is set, then Known is False and Unknown is True. The + -- Known_Static predicate is true only if the value is set (Known) + -- and is set to a compile time known value. Note that in the case + -- of Alignment and Normalized_First_Bit, dynamic values are not + -- possible, so we do not need a separate Known_Static calls in + -- these cases. The not set (unknown values are as follows: + + -- Alignment Uint_0 + -- Component_Size Uint_0 + -- Component_Bit_Offset No_Uint + -- Digits_Value Uint_0 + -- Esize Uint_0 + -- Normalized_First_Bit No_Uint + -- Normalized_Position No_Uint + -- Normalized_Position_Max No_Uint + -- RM_Size Uint_0 + + -- It would be cleaner to use No_Uint in all these cases, but historically + -- we chose to use Uint_0 at first, and the change over will take time ??? + -- This is particularly true for the RM_Size field, where a value of zero + -- is legitimate. We deal with this by a nasty kludge that knows that the + -- value is always known static for discrete types (and no other types can + -- have an RM_Size value of zero). + + function Known_Alignment (E : Entity_Id) return B; + function Known_Component_Bit_Offset (E : Entity_Id) return B; + function Known_Component_Size (E : Entity_Id) return B; + function Known_Esize (E : Entity_Id) return B; + function Known_Normalized_First_Bit (E : Entity_Id) return B; + function Known_Normalized_Position (E : Entity_Id) return B; + function Known_Normalized_Position_Max (E : Entity_Id) return B; + function Known_RM_Size (E : Entity_Id) return B; + + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B; + function Known_Static_Component_Size (E : Entity_Id) return B; + function Known_Static_Esize (E : Entity_Id) return B; + function Known_Static_Normalized_Position (E : Entity_Id) return B; + function Known_Static_Normalized_Position_Max (E : Entity_Id) return B; + function Known_Static_RM_Size (E : Entity_Id) return B; + + function Unknown_Alignment (E : Entity_Id) return B; + function Unknown_Component_Bit_Offset (E : Entity_Id) return B; + function Unknown_Component_Size (E : Entity_Id) return B; + function Unknown_Esize (E : Entity_Id) return B; + function Unknown_Normalized_First_Bit (E : Entity_Id) return B; + function Unknown_Normalized_Position (E : Entity_Id) return B; + function Unknown_Normalized_Position_Max (E : Entity_Id) return B; + function Unknown_RM_Size (E : Entity_Id) return B; + + ------------------------------ + -- Attribute Set Procedures -- + ------------------------------ + + procedure Set_Accept_Address (Id : E; V : L); + procedure Set_Access_Disp_Table (Id : E; V : E); + procedure Set_Actual_Subtype (Id : E; V : E); + procedure Set_Address_Taken (Id : E; V : B := True); + procedure Set_Alias (Id : E; V : E); + procedure Set_Alignment (Id : E; V : U); + procedure Set_Associated_Final_Chain (Id : E; V : E); + procedure Set_Associated_Formal_Package (Id : E; V : E); + procedure Set_Associated_Node_For_Itype (Id : E; V : N); + procedure Set_Associated_Storage_Pool (Id : E; V : E); + procedure Set_Barrier_Function (Id : E; V : N); + procedure Set_Block_Node (Id : E; V : N); + procedure Set_Body_Entity (Id : E; V : E); + procedure Set_CR_Discriminant (Id : E; V : E); + procedure Set_C_Pass_By_Copy (Id : E; V : B := True); + procedure Set_Class_Wide_Type (Id : E; V : E); + procedure Set_Cloned_Subtype (Id : E; V : E); + procedure Set_Component_Alignment (Id : E; V : C); + procedure Set_Component_Bit_Offset (Id : E; V : U); + procedure Set_Component_Clause (Id : E; V : N); + procedure Set_Component_Size (Id : E; V : U); + procedure Set_Component_Type (Id : E; V : E); + procedure Set_Corresponding_Concurrent_Type (Id : E; V : E); + procedure Set_Corresponding_Discriminant (Id : E; V : E); + procedure Set_Corresponding_Equality (Id : E; V : E); + procedure Set_Corresponding_Record_Type (Id : E; V : E); + procedure Set_Corresponding_Remote_Type (Id : E; V : E); + procedure Set_Debug_Info_Off (Id : E; V : B := True); + procedure Set_Debug_Renaming_Link (Id : E; V : E); + procedure Set_DTC_Entity (Id : E; V : E); + procedure Set_DT_Entry_Count (Id : E; V : U); + procedure Set_DT_Position (Id : E; V : U); + procedure Set_Default_Expr_Function (Id : E; V : E); + procedure Set_Default_Expressions_Processed (Id : E; V : B := True); + procedure Set_Default_Value (Id : E; V : N); + procedure Set_Delay_Cleanups (Id : E; V : B := True); + procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True); + procedure Set_Delta_Value (Id : E; V : R); + procedure Set_Dependent_Instances (Id : E; V : L); + procedure Set_Depends_On_Private (Id : E; V : B := True); + procedure Set_Digits_Value (Id : E; V : U); + procedure Set_Directly_Designated_Type (Id : E; V : E); + procedure Set_Discard_Names (Id : E; V : B := True); + procedure Set_Discriminal (Id : E; V : E); + procedure Set_Discriminal_Link (Id : E; V : E); + procedure Set_Discriminant_Checking_Func (Id : E; V : E); + procedure Set_Discriminant_Constraint (Id : E; V : L); + procedure Set_Discriminant_Default_Value (Id : E; V : N); + procedure Set_Discriminant_Number (Id : E; V : U); + procedure Set_Elaborate_All_Desirable (Id : E; V : B := True); + procedure Set_Elaboration_Entity (Id : E; V : E); + procedure Set_Elaboration_Entity_Required (Id : E; V : B := True); + procedure Set_Enclosing_Scope (Id : E; V : E); + procedure Set_Entry_Accepted (Id : E; V : B := True); + procedure Set_Entry_Bodies_Array (Id : E; V : E); + procedure Set_Entry_Cancel_Parameter (Id : E; V : E); + procedure Set_Entry_Component (Id : E; V : E); + procedure Set_Entry_Formal (Id : E; V : E); + procedure Set_Entry_Index_Constant (Id : E; V : E); + procedure Set_Entry_Parameters_Type (Id : E; V : E); + procedure Set_Enum_Pos_To_Rep (Id : E; V : E); + procedure Set_Enumeration_Pos (Id : E; V : U); + procedure Set_Enumeration_Rep (Id : E; V : U); + procedure Set_Enumeration_Rep_Expr (Id : E; V : N); + procedure Set_Equivalent_Type (Id : E; V : E); + procedure Set_Esize (Id : E; V : U); + procedure Set_Exception_Code (Id : E; V : U); + procedure Set_Extra_Accessibility (Id : E; V : E); + procedure Set_Extra_Constrained (Id : E; V : E); + procedure Set_Extra_Formal (Id : E; V : E); + procedure Set_Finalization_Chain_Entity (Id : E; V : E); + procedure Set_Finalize_Storage_Only (Id : E; V : B := True); + procedure Set_First_Entity (Id : E; V : E); + procedure Set_First_Index (Id : E; V : N); + procedure Set_First_Literal (Id : E; V : E); + procedure Set_First_Optional_Parameter (Id : E; V : E); + procedure Set_First_Private_Entity (Id : E; V : E); + procedure Set_First_Rep_Item (Id : E; V : N); + procedure Set_Freeze_Node (Id : E; V : N); + procedure Set_From_With_Type (Id : E; V : B := True); + procedure Set_Full_View (Id : E; V : E); + procedure Set_Function_Returns_With_DSP (Id : E; V : B := True); + procedure Set_Generic_Renamings (Id : E; V : L); + procedure Set_Girder_Constraint (Id : E; V : L); + procedure Set_Handler_Records (Id : E; V : S); + procedure Set_Has_Aliased_Components (Id : E; V : B := True); + procedure Set_Has_Alignment_Clause (Id : E; V : B := True); + procedure Set_Has_All_Calls_Remote (Id : E; V : B := True); + procedure Set_Has_Atomic_Components (Id : E; V : B := True); + procedure Set_Has_Biased_Representation (Id : E; V : B := True); + procedure Set_Has_Completion (Id : E; V : B := True); + procedure Set_Has_Completion_In_Body (Id : E; V : B := True); + procedure Set_Has_Complex_Representation (Id : E; V : B := True); + procedure Set_Has_Component_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Controlled_Component (Id : E; V : B := True); + procedure Set_Has_Controlling_Result (Id : E; V : B := True); + procedure Set_Has_Convention_Pragma (Id : E; V : B := True); + procedure Set_Has_Delayed_Freeze (Id : E; V : B := True); + procedure Set_Has_Discriminants (Id : E; V : B := True); + procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Exit (Id : E; V : B := True); + procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True); + procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True); + procedure Set_Has_Homonym (Id : E; V : B := True); + procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True); + procedure Set_Has_Master_Entity (Id : E; V : B := True); + procedure Set_Has_Missing_Return (Id : E; V : B := True); + procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True); + procedure Set_Has_Forward_Instantiation (Id : E; V : B := True); + procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True); + procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True); + procedure Set_Has_Pragma_Controlled (Id : E; V : B := True); + procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True); + procedure Set_Has_Pragma_Inline (Id : E; V : B := True); + procedure Set_Has_Pragma_Pack (Id : E; V : B := True); + procedure Set_Has_Primitive_Operations (Id : E; V : B := True); + procedure Set_Has_Private_Declaration (Id : E; V : B := True); + procedure Set_Has_Qualified_Name (Id : E; V : B := True); + procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Recursive_Call (Id : E; V : B := True); + procedure Set_Has_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Small_Clause (Id : E; V : B := True); + procedure Set_Has_Specified_Layout (Id : E; V : B := True); + procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True); + procedure Set_Has_Task (Id : E; V : B := True); + procedure Set_Has_Unchecked_Union (Id : E; V : B := True); + procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); + procedure Set_Has_Volatile_Components (Id : E; V : B := True); + procedure Set_Hiding_Loop_Variable (Id : E; V : E); + procedure Set_Homonym (Id : E; V : E); + procedure Set_In_Package_Body (Id : E; V : B := True); + procedure Set_In_Private_Part (Id : E; V : B := True); + procedure Set_In_Use (Id : E; V : B := True); + procedure Set_Inner_Instances (Id : E; V : L); + procedure Set_Interface_Name (Id : E; V : N); + procedure Set_Is_AST_Entry (Id : E; V : B := True); + procedure Set_Is_Abstract (Id : E; V : B := True); + procedure Set_Is_Access_Constant (Id : E; V : B := True); + procedure Set_Is_Aliased (Id : E; V : B := True); + procedure Set_Is_Asynchronous (Id : E; V : B := True); + procedure Set_Is_Atomic (Id : E; V : B := True); + procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True); + procedure Set_Is_CPP_Class (Id : E; V : B := True); + procedure Set_Is_Called (Id : E; V : B := True); + procedure Set_Is_Character_Type (Id : E; V : B := True); + procedure Set_Is_Child_Unit (Id : E; V : B := True); + procedure Set_Is_Compilation_Unit (Id : E; V : B := True); + procedure Set_Is_Completely_Hidden (Id : E; V : B := True); + procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True); + procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True); + procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True); + procedure Set_Is_Constrained (Id : E; V : B := True); + procedure Set_Is_Constructor (Id : E; V : B := True); + procedure Set_Is_Controlled (Id : E; V : B := True); + procedure Set_Is_Controlling_Formal (Id : E; V : B := True); + procedure Set_Is_Destructor (Id : E; V : B := True); + procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True); + procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); + procedure Set_Is_Eliminated (Id : E; V : B := True); + procedure Set_Is_Entry_Formal (Id : E; V : B := True); + procedure Set_Is_Exported (Id : E; V : B := True); + procedure Set_Is_First_Subtype (Id : E; V : B := True); + procedure Set_Is_For_Access_Subtype (Id : E; V : B := True); + procedure Set_Is_Formal_Subprogram (Id : E; V : B := True); + procedure Set_Is_Frozen (Id : E; V : B := True); + procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True); + procedure Set_Is_Generic_Instance (Id : E; V : B := True); + procedure Set_Is_Generic_Type (Id : E; V : B := True); + procedure Set_Is_Hidden (Id : E; V : B := True); + procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True); + procedure Set_Is_Immediately_Visible (Id : E; V : B := True); + procedure Set_Is_Imported (Id : E; V : B := True); + procedure Set_Is_Inlined (Id : E; V : B := True); + procedure Set_Is_Instantiated (Id : E; V : B := True); + procedure Set_Is_Internal (Id : E; V : B := True); + procedure Set_Is_Interrupt_Handler (Id : E; V : B := True); + procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True); + procedure Set_Is_Itype (Id : E; V : B := True); + procedure Set_Is_Known_Valid (Id : E; V : B := True); + procedure Set_Is_Limited_Composite (Id : E; V : B := True); + procedure Set_Is_Limited_Record (Id : E; V : B := True); + procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True); + procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True); + procedure Set_Is_Null_Init_Proc (Id : E; V : B := True); + procedure Set_Is_Optional_Parameter (Id : E; V : B := True); + procedure Set_Is_Package_Body_Entity (Id : E; V : B := True); + procedure Set_Is_Packed (Id : E; V : B := True); + procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); + procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); + procedure Set_Is_Preelaborated (Id : E; V : B := True); + procedure Set_Is_Private_Composite (Id : E; V : B := True); + procedure Set_Is_Private_Descendant (Id : E; V : B := True); + procedure Set_Is_Psected (Id : E; V : B := True); + procedure Set_Is_Public (Id : E; V : B := True); + procedure Set_Is_Pure (Id : E; V : B := True); + procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); + procedure Set_Is_Remote_Types (Id : E; V : B := True); + procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); + procedure Set_Is_Shared_Passive (Id : E; V : B := True); + procedure Set_Is_Statically_Allocated (Id : E; V : B := True); + procedure Set_Is_Tag (Id : E; V : B := True); + procedure Set_Is_Tagged_Type (Id : E; V : B := True); + procedure Set_Is_True_Constant (Id : E; V : B := True); + procedure Set_Is_Unchecked_Union (Id : E; V : B := True); + procedure Set_Is_Unsigned_Type (Id : E; V : B := True); + procedure Set_Is_VMS_Exception (Id : E; V : B := True); + procedure Set_Is_Valued_Procedure (Id : E; V : B := True); + procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True); + procedure Set_Is_Volatile (Id : E; V : B := True); + procedure Set_Last_Entity (Id : E; V : E); + procedure Set_Lit_Indexes (Id : E; V : E); + procedure Set_Lit_Strings (Id : E; V : E); + procedure Set_Machine_Radix_10 (Id : E; V : B := True); + procedure Set_Master_Id (Id : E; V : E); + procedure Set_Materialize_Entity (Id : E; V : B := True); + procedure Set_Mechanism (Id : E; V : M); + procedure Set_Modulus (Id : E; V : U); + procedure Set_Needs_Debug_Info (Id : E; V : B := True); + procedure Set_Needs_No_Actuals (Id : E; V : B := True); + procedure Set_Next_Inlined_Subprogram (Id : E; V : E); + procedure Set_No_Pool_Assigned (Id : E; V : B := True); + procedure Set_No_Return (Id : E; V : B := True); + procedure Set_Non_Binary_Modulus (Id : E; V : B := True); + procedure Set_Nonzero_Is_True (Id : E; V : B := True); + procedure Set_Normalized_First_Bit (Id : E; V : U); + procedure Set_Normalized_Position (Id : E; V : U); + procedure Set_Normalized_Position_Max (Id : E; V : U); + procedure Set_Not_Source_Assigned (Id : E; V : B := True); + procedure Set_Object_Ref (Id : E; V : E); + procedure Set_Original_Record_Component (Id : E; V : E); + procedure Set_Packed_Array_Type (Id : E; V : E); + procedure Set_Parent_Subtype (Id : E; V : E); + procedure Set_Primitive_Operations (Id : E; V : L); + procedure Set_Prival (Id : E; V : E); + procedure Set_Privals_Chain (Id : E; V : L); + procedure Set_Private_Dependents (Id : E; V : L); + procedure Set_Private_View (Id : E; V : N); + procedure Set_Protected_Body_Subprogram (Id : E; V : E); + procedure Set_Protected_Formal (Id : E; V : E); + procedure Set_Protected_Operation (Id : E; V : N); + procedure Set_RM_Size (Id : E; V : U); + procedure Set_Reachable (Id : E; V : B := True); + procedure Set_Referenced (Id : E; V : B := True); + procedure Set_Referenced_Object (Id : E; V : N); + procedure Set_Register_Exception_Call (Id : E; V : N); + procedure Set_Related_Array_Object (Id : E; V : E); + procedure Set_Related_Instance (Id : E; V : E); + procedure Set_Renamed_Entity (Id : E; V : N); + procedure Set_Renamed_Object (Id : E; V : N); + procedure Set_Renaming_Map (Id : E; V : U); + procedure Set_Return_Present (Id : E; V : B := True); + procedure Set_Returns_By_Ref (Id : E; V : B := True); + procedure Set_Reverse_Bit_Order (Id : E; V : B := True); + procedure Set_Scalar_Range (Id : E; V : N); + procedure Set_Scale_Value (Id : E; V : U); + procedure Set_Scope_Depth_Value (Id : E; V : U); + procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); + procedure Set_Shadow_Entities (Id : E; V : S); + procedure Set_Shared_Var_Assign_Proc (Id : E; V : E); + procedure Set_Shared_Var_Read_Proc (Id : E; V : E); + procedure Set_Size_Check_Code (Id : E; V : N); + procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); + procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); + procedure Set_Small_Value (Id : E; V : R); + procedure Set_Spec_Entity (Id : E; V : E); + procedure Set_Storage_Size_Variable (Id : E; V : E); + procedure Set_Strict_Alignment (Id : E; V : B := True); + procedure Set_String_Literal_Length (Id : E; V : U); + procedure Set_String_Literal_Low_Bound (Id : E; V : N); + procedure Set_Suppress_Access_Checks (Id : E; V : B := True); + procedure Set_Suppress_Accessibility_Checks (Id : E; V : B := True); + procedure Set_Suppress_Discriminant_Checks (Id : E; V : B := True); + procedure Set_Suppress_Division_Checks (Id : E; V : B := True); + procedure Set_Suppress_Elaboration_Checks (Id : E; V : B := True); + procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True); + procedure Set_Suppress_Index_Checks (Id : E; V : B := True); + procedure Set_Suppress_Init_Proc (Id : E; V : B := True); + procedure Set_Suppress_Length_Checks (Id : E; V : B := True); + procedure Set_Suppress_Overflow_Checks (Id : E; V : B := True); + procedure Set_Suppress_Range_Checks (Id : E; V : B := True); + procedure Set_Suppress_Storage_Checks (Id : E; V : B := True); + procedure Set_Suppress_Style_Checks (Id : E; V : B := True); + procedure Set_Suppress_Tag_Checks (Id : E; V : B := True); + procedure Set_Underlying_Full_View (Id : E; V : E); + procedure Set_Unset_Reference (Id : E; V : N); + procedure Set_Uses_Sec_Stack (Id : E; V : B := True); + procedure Set_Vax_Float (Id : E; V : B := True); + procedure Set_Warnings_Off (Id : E; V : B := True); + + ----------------------------------- + -- Field Initialization Routines -- + ----------------------------------- + + -- These routines are overloadings of some of the above Set procedures + -- where the argument is normally a Uint. The overloadings take an Int + -- parameter instead, and appropriately convert it. There are also + -- versions that implicitly initialize to the appropriate "not set" + -- value. The not set (unknown) values are as follows: + + -- Alignment Uint_0 + -- Component_Size Uint_0 + -- Component_Bit_Offset No_Uint + -- Digits_Value Uint_0 + -- Esize Uint_0 + -- Normalized_First_Bit No_Uint + -- Normalized_Position No_Uint + -- Normalized_Position_Max No_Uint + -- RM_Size Uint_0 + + -- It would be cleaner to use No_Uint in all these cases, but historically + -- we chose to use Uint_0 at first, and the change over will take time ??? + -- This is particularly true for the RM_Size field, where a value of zero + -- is legitimate and causes some kludges around the code. + + procedure Init_Alignment (Id : E; V : Int); + procedure Init_Component_Size (Id : E; V : Int); + procedure Init_Component_Bit_Offset (Id : E; V : Int); + procedure Init_Digits_Value (Id : E; V : Int); + procedure Init_Esize (Id : E; V : Int); + procedure Init_Normalized_First_Bit (Id : E; V : Int); + procedure Init_Normalized_Position (Id : E; V : Int); + procedure Init_Normalized_Position_Max (Id : E; V : Int); + procedure Init_RM_Size (Id : E; V : Int); + + procedure Init_Alignment (Id : E); + procedure Init_Component_Size (Id : E); + procedure Init_Component_Bit_Offset (Id : E); + procedure Init_Digits_Value (Id : E); + procedure Init_Esize (Id : E); + procedure Init_Normalized_First_Bit (Id : E); + procedure Init_Normalized_Position (Id : E); + procedure Init_Normalized_Position_Max (Id : E); + procedure Init_RM_Size (Id : E); + + procedure Init_Size_Align (Id : E); + -- This procedure initializes both size fields and the alignment + -- field to all be Unknown. + + procedure Init_Size (Id : E; V : Int); + -- Initialize both the Esize and RM_Size fields of E to V + + procedure Init_Component_Location (Id : E); + -- Initializes all fields describing the location of a component + -- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit, + -- Normalized_Position_Max, Esize) to all be Unknown. + + --------------- + -- Iterators -- + --------------- + + -- The call to Next_xxx (obj) is equivalent to obj := Next_xxx (obj) + -- We define the set of Proc_Next_xxx routines simply for the purposes + -- of inlining them without necessarily inlining the function. + + procedure Proc_Next_Component (N : in out Node_Id); + procedure Proc_Next_Discriminant (N : in out Node_Id); + procedure Proc_Next_Formal (N : in out Node_Id); + procedure Proc_Next_Formal_With_Extras (N : in out Node_Id); + procedure Proc_Next_Girder_Discriminant (N : in out Node_Id); + procedure Proc_Next_Index (N : in out Node_Id); + procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id); + procedure Proc_Next_Literal (N : in out Node_Id); + + pragma Inline (Proc_Next_Component); + pragma Inline (Proc_Next_Discriminant); + pragma Inline (Proc_Next_Formal); + pragma Inline (Proc_Next_Formal_With_Extras); + pragma Inline (Proc_Next_Girder_Discriminant); + pragma Inline (Proc_Next_Index); + pragma Inline (Proc_Next_Inlined_Subprogram); + pragma Inline (Proc_Next_Literal); + + procedure Next_Component (N : in out Node_Id) + renames Proc_Next_Component; + + procedure Next_Discriminant (N : in out Node_Id) + renames Proc_Next_Discriminant; + + procedure Next_Formal (N : in out Node_Id) + renames Proc_Next_Formal; + + procedure Next_Formal_With_Extras (N : in out Node_Id) + renames Proc_Next_Formal_With_Extras; + + procedure Next_Girder_Discriminant (N : in out Node_Id) + renames Proc_Next_Girder_Discriminant; + + procedure Next_Index (N : in out Node_Id) + renames Proc_Next_Index; + + procedure Next_Inlined_Subprogram (N : in out Node_Id) + renames Proc_Next_Inlined_Subprogram; + + procedure Next_Literal (N : in out Node_Id) + renames Proc_Next_Literal; + + ------------------------------- + -- Miscellaneous Subprograms -- + ------------------------------- + + procedure Append_Entity (Id : Entity_Id; V : Entity_Id); + -- Add an entity to the list of entities declared in the scope V + + function Is_Entity_Name (N : Node_Id) return Boolean; + -- Test if the node N is the name of an entity (i.e. is an identifier, + -- expanded name, or an attribute reference that returns an entity). + + function Next_Index (Id : Node_Id) return Node_Id; + -- Given an index from a previous call to First_Index or Next_Index, + -- returns a node representing the occurrence of the next index subtype, + -- or Empty if there are no more index subtypes. + + function Scope_Depth (Id : Entity_Id) return Uint; + -- Returns the scope depth value of the Id, unless the Id is a record + -- type, in which case it returns the scope depth of the record scope. + + function Subtype_Kind (K : Entity_Kind) return Entity_Kind; + -- Given an entity_kind K this function returns the entity_kind + -- corresponding to subtype kind of the type represented by K. For + -- example if K is E_Signed_Integer_Type then E_Signed_Integer_Subtype + -- is returned. If K is already a subtype kind it itself is returned. An + -- internal error is generated if no such correspondence exists for K. + + ---------------------------------- + -- Debugging Output Subprograms -- + ---------------------------------- + + procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String); + -- Writes a series of entries giving a line for each flag that is + -- set to True. Each line is prefixed by the given string + + procedure Write_Entity_Info (Id : Entity_Id; Prefix : String); + -- A debugging procedure to write out information about an entity + + procedure Write_Field6_Name (Id : Entity_Id); + procedure Write_Field7_Name (Id : Entity_Id); + procedure Write_Field8_Name (Id : Entity_Id); + procedure Write_Field9_Name (Id : Entity_Id); + procedure Write_Field10_Name (Id : Entity_Id); + procedure Write_Field11_Name (Id : Entity_Id); + procedure Write_Field12_Name (Id : Entity_Id); + procedure Write_Field13_Name (Id : Entity_Id); + procedure Write_Field14_Name (Id : Entity_Id); + procedure Write_Field15_Name (Id : Entity_Id); + procedure Write_Field16_Name (Id : Entity_Id); + procedure Write_Field17_Name (Id : Entity_Id); + procedure Write_Field18_Name (Id : Entity_Id); + procedure Write_Field19_Name (Id : Entity_Id); + procedure Write_Field20_Name (Id : Entity_Id); + procedure Write_Field21_Name (Id : Entity_Id); + procedure Write_Field22_Name (Id : Entity_Id); + procedure Write_Field23_Name (Id : Entity_Id); + -- These routines are used to output a nice symbolic name for the given + -- field, depending on the Ekind. No blanks or end of lines are output, + -- just the characters of the field name. + + -------------------- + -- Inline Pragmas -- + -------------------- + + -- Note that these inline pragmas are referenced by the XEINFO utility + -- program in preparing the corresponding C header, and only those + -- subprograms meeting the requirements documented in the section on + -- XEINFO may be referenced in this section. + + pragma Inline (Accept_Address); + pragma Inline (Access_Disp_Table); + pragma Inline (Actual_Subtype); + pragma Inline (Address_Taken); + pragma Inline (Alias); + pragma Inline (Alignment); + pragma Inline (Associated_Final_Chain); + pragma Inline (Associated_Formal_Package); + pragma Inline (Associated_Node_For_Itype); + pragma Inline (Associated_Storage_Pool); + pragma Inline (Barrier_Function); + pragma Inline (Block_Node); + pragma Inline (Body_Entity); + pragma Inline (CR_Discriminant); + pragma Inline (C_Pass_By_Copy); + pragma Inline (Class_Wide_Type); + pragma Inline (Cloned_Subtype); + pragma Inline (Component_Bit_Offset); + pragma Inline (Component_Clause); + pragma Inline (Component_Size); + pragma Inline (Component_Type); + pragma Inline (Corresponding_Concurrent_Type); + pragma Inline (Corresponding_Discriminant); + pragma Inline (Corresponding_Equality); + pragma Inline (Corresponding_Record_Type); + pragma Inline (Corresponding_Remote_Type); + pragma Inline (Debug_Info_Off); + pragma Inline (Debug_Renaming_Link); + pragma Inline (DTC_Entity); + pragma Inline (DT_Entry_Count); + pragma Inline (DT_Position); + pragma Inline (Default_Expr_Function); + pragma Inline (Default_Expressions_Processed); + pragma Inline (Default_Value); + pragma Inline (Delay_Cleanups); + pragma Inline (Delay_Subprogram_Descriptors); + pragma Inline (Delta_Value); + pragma Inline (Dependent_Instances); + pragma Inline (Depends_On_Private); + pragma Inline (Digits_Value); + pragma Inline (Directly_Designated_Type); + pragma Inline (Discard_Names); + pragma Inline (Discriminal); + pragma Inline (Discriminal_Link); + pragma Inline (Discriminant_Checking_Func); + pragma Inline (Discriminant_Constraint); + pragma Inline (Discriminant_Default_Value); + pragma Inline (Discriminant_Number); + pragma Inline (Elaborate_All_Desirable); + pragma Inline (Elaboration_Entity); + pragma Inline (Elaboration_Entity_Required); + pragma Inline (Enclosing_Scope); + pragma Inline (Entry_Accepted); + pragma Inline (Entry_Bodies_Array); + pragma Inline (Entry_Cancel_Parameter); + pragma Inline (Entry_Component); + pragma Inline (Entry_Formal); + pragma Inline (Entry_Index_Constant); + pragma Inline (Entry_Index_Type); + pragma Inline (Entry_Parameters_Type); + pragma Inline (Enum_Pos_To_Rep); + pragma Inline (Enumeration_Pos); + pragma Inline (Enumeration_Rep); + pragma Inline (Enumeration_Rep_Expr); + pragma Inline (Equivalent_Type); + pragma Inline (Esize); + pragma Inline (Exception_Code); + pragma Inline (Extra_Accessibility); + pragma Inline (Extra_Constrained); + pragma Inline (Extra_Formal); + pragma Inline (Finalization_Chain_Entity); + pragma Inline (First_Entity); + pragma Inline (First_Index); + pragma Inline (First_Literal); + pragma Inline (First_Optional_Parameter); + pragma Inline (First_Private_Entity); + pragma Inline (First_Rep_Item); + pragma Inline (Freeze_Node); + pragma Inline (From_With_Type); + pragma Inline (Full_View); + pragma Inline (Function_Returns_With_DSP); + pragma Inline (Generic_Renamings); + pragma Inline (Girder_Constraint); + pragma Inline (Handler_Records); + pragma Inline (Has_Aliased_Components); + pragma Inline (Has_Alignment_Clause); + pragma Inline (Has_All_Calls_Remote); + pragma Inline (Has_Atomic_Components); + pragma Inline (Has_Biased_Representation); + pragma Inline (Has_Completion); + pragma Inline (Has_Completion_In_Body); + pragma Inline (Has_Complex_Representation); + pragma Inline (Has_Component_Size_Clause); + pragma Inline (Has_Controlled_Component); + pragma Inline (Has_Controlling_Result); + pragma Inline (Has_Convention_Pragma); + pragma Inline (Has_Delayed_Freeze); + pragma Inline (Has_Discriminants); + pragma Inline (Has_Enumeration_Rep_Clause); + pragma Inline (Has_Exit); + pragma Inline (Has_External_Tag_Rep_Clause); + pragma Inline (Has_Fully_Qualified_Name); + pragma Inline (Has_Gigi_Rep_Item); + pragma Inline (Has_Homonym); + pragma Inline (Has_Machine_Radix_Clause); + pragma Inline (Has_Master_Entity); + pragma Inline (Has_Missing_Return); + pragma Inline (Has_Nested_Block_With_Handler); + pragma Inline (Has_Forward_Instantiation); + pragma Inline (Has_Non_Standard_Rep); + pragma Inline (Has_Object_Size_Clause); + pragma Inline (Has_Per_Object_Constraint); + pragma Inline (Has_Pragma_Controlled); + pragma Inline (Has_Pragma_Elaborate_Body); + pragma Inline (Has_Pragma_Inline); + pragma Inline (Has_Pragma_Pack); + pragma Inline (Has_Primitive_Operations); + pragma Inline (Has_Private_Declaration); + pragma Inline (Has_Qualified_Name); + pragma Inline (Has_Record_Rep_Clause); + pragma Inline (Has_Recursive_Call); + pragma Inline (Has_Size_Clause); + pragma Inline (Has_Small_Clause); + pragma Inline (Has_Specified_Layout); + pragma Inline (Has_Storage_Size_Clause); + pragma Inline (Has_Subprogram_Descriptor); + pragma Inline (Has_Task); + pragma Inline (Has_Unchecked_Union); + pragma Inline (Has_Unknown_Discriminants); + pragma Inline (Has_Volatile_Components); + pragma Inline (Hiding_Loop_Variable); + pragma Inline (Homonym); + pragma Inline (In_Package_Body); + pragma Inline (In_Private_Part); + pragma Inline (In_Use); + pragma Inline (Inner_Instances); + pragma Inline (Interface_Name); + pragma Inline (Is_AST_Entry); + pragma Inline (Is_Abstract); + pragma Inline (Is_Access_Constant); + pragma Inline (Is_Access_Type); + pragma Inline (Is_Aliased); + pragma Inline (Is_Array_Type); + pragma Inline (Is_Asynchronous); + pragma Inline (Is_Atomic); + pragma Inline (Is_Bit_Packed_Array); + pragma Inline (Is_CPP_Class); + pragma Inline (Is_Called); + pragma Inline (Is_Character_Type); + pragma Inline (Is_Child_Unit); + pragma Inline (Is_Class_Wide_Type); + pragma Inline (Is_Compilation_Unit); + pragma Inline (Is_Completely_Hidden); + pragma Inline (Is_Composite_Type); + pragma Inline (Is_Concurrent_Body); + pragma Inline (Is_Concurrent_Record_Type); + pragma Inline (Is_Concurrent_Type); + pragma Inline (Is_Constr_Subt_For_UN_Aliased); + pragma Inline (Is_Constr_Subt_For_U_Nominal); + pragma Inline (Is_Constrained); + pragma Inline (Is_Constructor); + pragma Inline (Is_Controlled); + pragma Inline (Is_Controlling_Formal); + pragma Inline (Is_Decimal_Fixed_Point_Type); + pragma Inline (Is_Destructor); + pragma Inline (Is_Discrim_SO_Function); + pragma Inline (Is_Digits_Type); + pragma Inline (Is_Discrete_Or_Fixed_Point_Type); + pragma Inline (Is_Discrete_Type); + pragma Inline (Is_Dispatching_Operation); + pragma Inline (Is_Elementary_Type); + pragma Inline (Is_Eliminated); + pragma Inline (Is_Entry); + pragma Inline (Is_Entry_Formal); + pragma Inline (Is_Enumeration_Type); + pragma Inline (Is_Exported); + pragma Inline (Is_First_Subtype); + pragma Inline (Is_Fixed_Point_Type); + pragma Inline (Is_Floating_Point_Type); + pragma Inline (Is_For_Access_Subtype); + pragma Inline (Is_Formal); + pragma Inline (Is_Formal_Subprogram); + pragma Inline (Is_Frozen); + pragma Inline (Is_Generic_Actual_Type); + pragma Inline (Is_Generic_Instance); + pragma Inline (Is_Generic_Type); + pragma Inline (Is_Generic_Unit); + pragma Inline (Is_Hidden); + pragma Inline (Is_Hidden_Open_Scope); + pragma Inline (Is_Immediately_Visible); + pragma Inline (Is_Imported); + pragma Inline (Is_Incomplete_Or_Private_Type); + pragma Inline (Is_Inlined); + pragma Inline (Is_Instantiated); + pragma Inline (Is_Integer_Type); + pragma Inline (Is_Internal); + pragma Inline (Is_Interrupt_Handler); + pragma Inline (Is_Intrinsic_Subprogram); + pragma Inline (Is_Itype); + pragma Inline (Is_Known_Valid); + pragma Inline (Is_Limited_Composite); + pragma Inline (Is_Limited_Record); + pragma Inline (Is_Machine_Code_Subprogram); + pragma Inline (Is_Modular_Integer_Type); + pragma Inline (Is_Named_Number); + pragma Inline (Is_Non_Static_Subtype); + pragma Inline (Is_Null_Init_Proc); + pragma Inline (Is_Numeric_Type); + pragma Inline (Is_Object); + pragma Inline (Is_Optional_Parameter); + pragma Inline (Is_Package_Body_Entity); + pragma Inline (Is_Ordinary_Fixed_Point_Type); + pragma Inline (Is_Overloadable); + pragma Inline (Is_Packed); + pragma Inline (Is_Packed_Array_Type); + pragma Inline (Is_Potentially_Use_Visible); + pragma Inline (Is_Preelaborated); + pragma Inline (Is_Private_Composite); + pragma Inline (Is_Private_Descendant); + pragma Inline (Is_Private_Type); + pragma Inline (Is_Protected_Type); + pragma Inline (Is_Psected); + pragma Inline (Is_Public); + pragma Inline (Is_Pure); + pragma Inline (Is_Real_Type); + pragma Inline (Is_Record_Type); + pragma Inline (Is_Remote_Call_Interface); + pragma Inline (Is_Remote_Types); + pragma Inline (Is_Renaming_Of_Object); + pragma Inline (Is_Scalar_Type); + pragma Inline (Is_Shared_Passive); + pragma Inline (Is_Signed_Integer_Type); + pragma Inline (Is_Statically_Allocated); + pragma Inline (Is_Subprogram); + pragma Inline (Is_Tag); + pragma Inline (Is_Tagged_Type); + pragma Inline (Is_True_Constant); + pragma Inline (Is_Task_Type); + pragma Inline (Is_Type); + pragma Inline (Is_Unchecked_Union); + pragma Inline (Is_Unsigned_Type); + pragma Inline (Is_VMS_Exception); + pragma Inline (Is_Valued_Procedure); + pragma Inline (Is_Visible_Child_Unit); + pragma Inline (Is_Volatile); + pragma Inline (Last_Entity); + pragma Inline (Lit_Indexes); + pragma Inline (Lit_Strings); + pragma Inline (Machine_Radix_10); + pragma Inline (Master_Id); + pragma Inline (Materialize_Entity); + pragma Inline (Mechanism); + pragma Inline (Modulus); + pragma Inline (Needs_Debug_Info); + pragma Inline (Needs_No_Actuals); + pragma Inline (Next_Index); + pragma Inline (Next_Inlined_Subprogram); + pragma Inline (Next_Literal); + pragma Inline (No_Pool_Assigned); + pragma Inline (No_Return); + pragma Inline (Non_Binary_Modulus); + pragma Inline (Nonzero_Is_True); + pragma Inline (Normalized_First_Bit); + pragma Inline (Normalized_Position); + pragma Inline (Normalized_Position_Max); + pragma Inline (Not_Source_Assigned); + pragma Inline (Object_Ref); + pragma Inline (Original_Record_Component); + pragma Inline (Packed_Array_Type); + pragma Inline (Parameter_Mode); + pragma Inline (Parent_Subtype); + pragma Inline (Primitive_Operations); + pragma Inline (Prival); + pragma Inline (Privals_Chain); + pragma Inline (Private_Dependents); + pragma Inline (Private_View); + pragma Inline (Protected_Body_Subprogram); + pragma Inline (Protected_Formal); + pragma Inline (Protected_Operation); + pragma Inline (RM_Size); + pragma Inline (Reachable); + pragma Inline (Referenced); + pragma Inline (Referenced_Object); + pragma Inline (Register_Exception_Call); + pragma Inline (Related_Array_Object); + pragma Inline (Related_Instance); + pragma Inline (Renamed_Entity); + pragma Inline (Renamed_Object); + pragma Inline (Renaming_Map); + pragma Inline (Return_Present); + pragma Inline (Returns_By_Ref); + pragma Inline (Reverse_Bit_Order); + pragma Inline (Scalar_Range); + pragma Inline (Scale_Value); + pragma Inline (Scope_Depth_Value); + pragma Inline (Sec_Stack_Needed_For_Return); + pragma Inline (Shadow_Entities); + pragma Inline (Shared_Var_Assign_Proc); + pragma Inline (Shared_Var_Read_Proc); + pragma Inline (Size_Check_Code); + pragma Inline (Size_Depends_On_Discriminant); + pragma Inline (Size_Known_At_Compile_Time); + pragma Inline (Small_Value); + pragma Inline (Spec_Entity); + pragma Inline (Storage_Size_Variable); + pragma Inline (Strict_Alignment); + pragma Inline (String_Literal_Length); + pragma Inline (String_Literal_Low_Bound); + pragma Inline (Suppress_Access_Checks); + pragma Inline (Suppress_Accessibility_Checks); + pragma Inline (Suppress_Discriminant_Checks); + pragma Inline (Suppress_Division_Checks); + pragma Inline (Suppress_Elaboration_Checks); + pragma Inline (Suppress_Elaboration_Warnings); + pragma Inline (Suppress_Index_Checks); + pragma Inline (Suppress_Init_Proc); + pragma Inline (Suppress_Length_Checks); + pragma Inline (Suppress_Overflow_Checks); + pragma Inline (Suppress_Range_Checks); + pragma Inline (Suppress_Storage_Checks); + pragma Inline (Suppress_Style_Checks); + pragma Inline (Suppress_Tag_Checks); + pragma Inline (Underlying_Full_View); + pragma Inline (Unset_Reference); + pragma Inline (Uses_Sec_Stack); + pragma Inline (Vax_Float); + pragma Inline (Warnings_Off); + + pragma Inline (Init_Alignment); + pragma Inline (Init_Component_Bit_Offset); + pragma Inline (Init_Component_Size); + pragma Inline (Init_Digits_Value); + pragma Inline (Init_Esize); + pragma Inline (Init_RM_Size); + + pragma Inline (Known_Alignment); + pragma Inline (Known_Component_Bit_Offset); + pragma Inline (Known_Component_Size); + pragma Inline (Known_Esize); + + pragma Inline (Known_Static_Component_Size); + pragma Inline (Known_Static_Esize); + + pragma Inline (Unknown_Alignment); + pragma Inline (Unknown_Component_Bit_Offset); + pragma Inline (Unknown_Component_Size); + pragma Inline (Unknown_Esize); + + pragma Inline (Set_Accept_Address); + pragma Inline (Set_Access_Disp_Table); + pragma Inline (Set_Actual_Subtype); + pragma Inline (Set_Address_Taken); + pragma Inline (Set_Alias); + pragma Inline (Set_Alignment); + pragma Inline (Set_Associated_Final_Chain); + pragma Inline (Set_Associated_Formal_Package); + pragma Inline (Set_Associated_Node_For_Itype); + pragma Inline (Set_Associated_Storage_Pool); + pragma Inline (Set_Barrier_Function); + pragma Inline (Set_Block_Node); + pragma Inline (Set_Body_Entity); + pragma Inline (Set_CR_Discriminant); + pragma Inline (Set_C_Pass_By_Copy); + pragma Inline (Set_Class_Wide_Type); + pragma Inline (Set_Cloned_Subtype); + pragma Inline (Set_Component_Bit_Offset); + pragma Inline (Set_Component_Clause); + pragma Inline (Set_Component_Size); + pragma Inline (Set_Component_Type); + pragma Inline (Set_Corresponding_Concurrent_Type); + pragma Inline (Set_Corresponding_Discriminant); + pragma Inline (Set_Corresponding_Equality); + pragma Inline (Set_Corresponding_Record_Type); + pragma Inline (Set_Corresponding_Remote_Type); + pragma Inline (Set_Debug_Info_Off); + pragma Inline (Set_Debug_Renaming_Link); + pragma Inline (Set_DTC_Entity); + pragma Inline (Set_DT_Position); + pragma Inline (Set_Default_Expr_Function); + pragma Inline (Set_Default_Expressions_Processed); + pragma Inline (Set_Default_Value); + pragma Inline (Set_Delay_Cleanups); + pragma Inline (Set_Delay_Subprogram_Descriptors); + pragma Inline (Set_Delta_Value); + pragma Inline (Set_Dependent_Instances); + pragma Inline (Set_Depends_On_Private); + pragma Inline (Set_Digits_Value); + pragma Inline (Set_Directly_Designated_Type); + pragma Inline (Set_Discard_Names); + pragma Inline (Set_Discriminal); + pragma Inline (Set_Discriminal_Link); + pragma Inline (Set_Discriminant_Checking_Func); + pragma Inline (Set_Discriminant_Constraint); + pragma Inline (Set_Discriminant_Default_Value); + pragma Inline (Set_Discriminant_Number); + pragma Inline (Set_Elaborate_All_Desirable); + pragma Inline (Set_Elaboration_Entity); + pragma Inline (Set_Elaboration_Entity_Required); + pragma Inline (Set_Enclosing_Scope); + pragma Inline (Set_Entry_Accepted); + pragma Inline (Set_Entry_Bodies_Array); + pragma Inline (Set_Entry_Cancel_Parameter); + pragma Inline (Set_Entry_Component); + pragma Inline (Set_Entry_Formal); + pragma Inline (Set_Entry_Parameters_Type); + pragma Inline (Set_Enum_Pos_To_Rep); + pragma Inline (Set_Enumeration_Pos); + pragma Inline (Set_Enumeration_Rep); + pragma Inline (Set_Enumeration_Rep_Expr); + pragma Inline (Set_Equivalent_Type); + pragma Inline (Set_Esize); + pragma Inline (Set_Exception_Code); + pragma Inline (Set_Extra_Accessibility); + pragma Inline (Set_Extra_Constrained); + pragma Inline (Set_Extra_Formal); + pragma Inline (Set_Finalization_Chain_Entity); + pragma Inline (Set_First_Entity); + pragma Inline (Set_First_Index); + pragma Inline (Set_First_Literal); + pragma Inline (Set_First_Optional_Parameter); + pragma Inline (Set_First_Private_Entity); + pragma Inline (Set_First_Rep_Item); + pragma Inline (Set_Freeze_Node); + pragma Inline (Set_From_With_Type); + pragma Inline (Set_Full_View); + pragma Inline (Set_Function_Returns_With_DSP); + pragma Inline (Set_Generic_Renamings); + pragma Inline (Set_Girder_Constraint); + pragma Inline (Set_Handler_Records); + pragma Inline (Set_Has_Aliased_Components); + pragma Inline (Set_Has_Alignment_Clause); + pragma Inline (Set_Has_All_Calls_Remote); + pragma Inline (Set_Has_Atomic_Components); + pragma Inline (Set_Has_Biased_Representation); + pragma Inline (Set_Has_Completion); + pragma Inline (Set_Has_Completion_In_Body); + pragma Inline (Set_Has_Complex_Representation); + pragma Inline (Set_Has_Component_Size_Clause); + pragma Inline (Set_Has_Controlled_Component); + pragma Inline (Set_Has_Controlling_Result); + pragma Inline (Set_Has_Convention_Pragma); + pragma Inline (Set_Has_Delayed_Freeze); + pragma Inline (Set_Has_Discriminants); + pragma Inline (Set_Has_Enumeration_Rep_Clause); + pragma Inline (Set_Has_Exit); + pragma Inline (Set_Has_External_Tag_Rep_Clause); + pragma Inline (Set_Has_Fully_Qualified_Name); + pragma Inline (Set_Has_Gigi_Rep_Item); + pragma Inline (Set_Has_Homonym); + pragma Inline (Set_Has_Machine_Radix_Clause); + pragma Inline (Set_Has_Master_Entity); + pragma Inline (Set_Has_Missing_Return); + pragma Inline (Set_Has_Nested_Block_With_Handler); + pragma Inline (Set_Has_Forward_Instantiation); + pragma Inline (Set_Has_Non_Standard_Rep); + pragma Inline (Set_Has_Object_Size_Clause); + pragma Inline (Set_Has_Per_Object_Constraint); + pragma Inline (Set_Has_Pragma_Controlled); + pragma Inline (Set_Has_Pragma_Elaborate_Body); + pragma Inline (Set_Has_Pragma_Inline); + pragma Inline (Set_Has_Pragma_Pack); + pragma Inline (Set_Has_Primitive_Operations); + pragma Inline (Set_Has_Private_Declaration); + pragma Inline (Set_Has_Qualified_Name); + pragma Inline (Set_Has_Record_Rep_Clause); + pragma Inline (Set_Has_Recursive_Call); + pragma Inline (Set_Has_Size_Clause); + pragma Inline (Set_Has_Small_Clause); + pragma Inline (Set_Has_Specified_Layout); + pragma Inline (Set_Has_Storage_Size_Clause); + pragma Inline (Set_Has_Subprogram_Descriptor); + pragma Inline (Set_Has_Task); + pragma Inline (Set_Has_Unchecked_Union); + pragma Inline (Set_Has_Unknown_Discriminants); + pragma Inline (Set_Has_Volatile_Components); + pragma Inline (Set_Hiding_Loop_Variable); + pragma Inline (Set_Homonym); + pragma Inline (Set_In_Package_Body); + pragma Inline (Set_In_Private_Part); + pragma Inline (Set_In_Use); + pragma Inline (Set_Inner_Instances); + pragma Inline (Set_Interface_Name); + pragma Inline (Set_Is_AST_Entry); + pragma Inline (Set_Is_Abstract); + pragma Inline (Set_Is_Access_Constant); + pragma Inline (Set_Is_Aliased); + pragma Inline (Set_Is_Asynchronous); + pragma Inline (Set_Is_Atomic); + pragma Inline (Set_Is_Bit_Packed_Array); + pragma Inline (Set_Is_CPP_Class); + pragma Inline (Set_Is_Called); + pragma Inline (Set_Is_Character_Type); + pragma Inline (Set_Is_Child_Unit); + pragma Inline (Set_Is_Compilation_Unit); + pragma Inline (Set_Is_Completely_Hidden); + pragma Inline (Set_Is_Concurrent_Record_Type); + pragma Inline (Set_Is_Constr_Subt_For_U_Nominal); + pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased); + pragma Inline (Set_Is_Constrained); + pragma Inline (Set_Is_Constructor); + pragma Inline (Set_Is_Controlled); + pragma Inline (Set_Is_Controlling_Formal); + pragma Inline (Set_Is_Destructor); + pragma Inline (Set_Is_Discrim_SO_Function); + pragma Inline (Set_Is_Dispatching_Operation); + pragma Inline (Set_Is_Eliminated); + pragma Inline (Set_Is_Entry_Formal); + pragma Inline (Set_Is_Exported); + pragma Inline (Set_Is_First_Subtype); + pragma Inline (Set_Is_For_Access_Subtype); + pragma Inline (Set_Is_Formal_Subprogram); + pragma Inline (Set_Is_Frozen); + pragma Inline (Set_Is_Generic_Actual_Type); + pragma Inline (Set_Is_Generic_Instance); + pragma Inline (Set_Is_Generic_Type); + pragma Inline (Set_Is_Hidden); + pragma Inline (Set_Is_Hidden_Open_Scope); + pragma Inline (Set_Is_Immediately_Visible); + pragma Inline (Set_Is_Imported); + pragma Inline (Set_Is_Inlined); + pragma Inline (Set_Is_Instantiated); + pragma Inline (Set_Is_Internal); + pragma Inline (Set_Is_Interrupt_Handler); + pragma Inline (Set_Is_Intrinsic_Subprogram); + pragma Inline (Set_Is_Itype); + pragma Inline (Set_Is_Known_Valid); + pragma Inline (Set_Is_Limited_Composite); + pragma Inline (Set_Is_Limited_Record); + pragma Inline (Set_Is_Machine_Code_Subprogram); + pragma Inline (Set_Is_Non_Static_Subtype); + pragma Inline (Set_Is_Null_Init_Proc); + pragma Inline (Set_Is_Optional_Parameter); + pragma Inline (Set_Is_Package_Body_Entity); + pragma Inline (Set_Is_Packed); + pragma Inline (Set_Is_Packed_Array_Type); + pragma Inline (Set_Is_Potentially_Use_Visible); + pragma Inline (Set_Is_Preelaborated); + pragma Inline (Set_Is_Private_Composite); + pragma Inline (Set_Is_Private_Descendant); + pragma Inline (Set_Is_Psected); + pragma Inline (Set_Is_Public); + pragma Inline (Set_Is_Pure); + pragma Inline (Set_Is_Remote_Call_Interface); + pragma Inline (Set_Is_Remote_Types); + pragma Inline (Set_Is_Renaming_Of_Object); + pragma Inline (Set_Is_Shared_Passive); + pragma Inline (Set_Is_Statically_Allocated); + pragma Inline (Set_Is_Tag); + pragma Inline (Set_Is_Tagged_Type); + pragma Inline (Set_Is_True_Constant); + pragma Inline (Set_Is_Unchecked_Union); + pragma Inline (Set_Is_Unsigned_Type); + pragma Inline (Set_Is_VMS_Exception); + pragma Inline (Set_Is_Valued_Procedure); + pragma Inline (Set_Is_Visible_Child_Unit); + pragma Inline (Set_Is_Volatile); + pragma Inline (Set_Last_Entity); + pragma Inline (Set_Lit_Indexes); + pragma Inline (Set_Lit_Strings); + pragma Inline (Set_Machine_Radix_10); + pragma Inline (Set_Master_Id); + pragma Inline (Set_Materialize_Entity); + pragma Inline (Set_Mechanism); + pragma Inline (Set_Modulus); + pragma Inline (Set_Needs_Debug_Info); + pragma Inline (Set_Needs_No_Actuals); + pragma Inline (Set_Next_Inlined_Subprogram); + pragma Inline (Set_No_Pool_Assigned); + pragma Inline (Set_No_Return); + pragma Inline (Set_Non_Binary_Modulus); + pragma Inline (Set_Nonzero_Is_True); + pragma Inline (Set_Normalized_First_Bit); + pragma Inline (Set_Normalized_Position); + pragma Inline (Set_Normalized_Position_Max); + pragma Inline (Set_Not_Source_Assigned); + pragma Inline (Set_Object_Ref); + pragma Inline (Set_Original_Record_Component); + pragma Inline (Set_Packed_Array_Type); + pragma Inline (Set_Parent_Subtype); + pragma Inline (Set_Primitive_Operations); + pragma Inline (Set_Prival); + pragma Inline (Set_Privals_Chain); + pragma Inline (Set_Private_Dependents); + pragma Inline (Set_Private_View); + pragma Inline (Set_Protected_Body_Subprogram); + pragma Inline (Set_Protected_Formal); + pragma Inline (Set_Protected_Operation); + pragma Inline (Set_RM_Size); + pragma Inline (Set_Reachable); + pragma Inline (Set_Referenced); + pragma Inline (Set_Referenced_Object); + pragma Inline (Set_Register_Exception_Call); + pragma Inline (Set_Related_Array_Object); + pragma Inline (Set_Related_Instance); + pragma Inline (Set_Renamed_Entity); + pragma Inline (Set_Renamed_Object); + pragma Inline (Set_Renaming_Map); + pragma Inline (Set_Return_Present); + pragma Inline (Set_Returns_By_Ref); + pragma Inline (Set_Reverse_Bit_Order); + pragma Inline (Set_Scalar_Range); + pragma Inline (Set_Scale_Value); + pragma Inline (Set_Scope_Depth_Value); + pragma Inline (Set_Sec_Stack_Needed_For_Return); + pragma Inline (Set_Shadow_Entities); + pragma Inline (Set_Shared_Var_Assign_Proc); + pragma Inline (Set_Shared_Var_Read_Proc); + pragma Inline (Set_Size_Check_Code); + pragma Inline (Set_Size_Depends_On_Discriminant); + pragma Inline (Set_Size_Known_At_Compile_Time); + pragma Inline (Set_Small_Value); + pragma Inline (Set_Spec_Entity); + pragma Inline (Set_Storage_Size_Variable); + pragma Inline (Set_Strict_Alignment); + pragma Inline (Set_String_Literal_Length); + pragma Inline (Set_String_Literal_Low_Bound); + pragma Inline (Set_Suppress_Access_Checks); + pragma Inline (Set_Suppress_Accessibility_Checks); + pragma Inline (Set_Suppress_Discriminant_Checks); + pragma Inline (Set_Suppress_Division_Checks); + pragma Inline (Set_Suppress_Elaboration_Checks); + pragma Inline (Set_Suppress_Elaboration_Warnings); + pragma Inline (Set_Suppress_Index_Checks); + pragma Inline (Set_Suppress_Init_Proc); + pragma Inline (Set_Suppress_Length_Checks); + pragma Inline (Set_Suppress_Overflow_Checks); + pragma Inline (Set_Suppress_Range_Checks); + pragma Inline (Set_Suppress_Storage_Checks); + pragma Inline (Set_Suppress_Style_Checks); + pragma Inline (Set_Suppress_Tag_Checks); + pragma Inline (Set_Underlying_Full_View); + pragma Inline (Set_Unset_Reference); + pragma Inline (Set_Uses_Sec_Stack); + pragma Inline (Set_Vax_Float); + pragma Inline (Set_Warnings_Off); + + -- END XEINFO INLINES + + -- The following Inline pragmas are *not* read by xeinfo when building + -- the C version of this interface automatically (so the C version will + -- end up making out of line calls). The pragma scan in xeinfo will be + -- terminated on encountering the END XEINFO INLINES line. We inline + -- things here which are small, but not of the canonical attribute + -- access/set format that can be handled by xeinfo. + + pragma Inline (Is_Package); + pragma Inline (Is_Wrapper_Package); + pragma Inline (Known_RM_Size); + pragma Inline (Known_Static_Component_Bit_Offset); + pragma Inline (Known_Static_RM_Size); + pragma Inline (Scope_Depth); + pragma Inline (Scope_Depth_Set); + pragma Inline (Unknown_RM_Size); + +end Einfo; diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb new file mode 100644 index 00000000000..1bfbfd72c33 --- /dev/null +++ b/gcc/ada/elists.adb @@ -0,0 +1,469 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E L I S T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.22 $ +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header a-elists.h. + +with Alloc; +with Debug; use Debug; +with Output; use Output; +with Table; + +package body Elists is + + ------------------------------------- + -- Implementation of Element Lists -- + ------------------------------------- + + -- Element lists are composed of three types of entities. The element + -- list header, which references the first and last elements of the + -- list, the elements themselves which are singly linked and also + -- reference the nodes on the list, and finally the nodes themselves. + -- The following diagram shows how an element list is represented: + + -- +----------------------------------------------------+ + -- | +------------------------------------------+ | + -- | | | | + -- V | V | + -- +-----|--+ +-------+ +-------+ +-------+ | + -- | Elmt | | 1st | | 2nd | | Last | | + -- | List |--->| Elmt |--->| Elmt ---...-->| Elmt ---+ + -- | Header | | | | | | | | | | + -- +--------+ +---|---+ +---|---+ +---|---+ + -- | | | + -- V V V + -- +-------+ +-------+ +-------+ + -- | | | | | | + -- | Node1 | | Node2 | | Node3 | + -- | | | | | | + -- +-------+ +-------+ +-------+ + + -- The list header is an entry in the Elists table. The values used for + -- the type Elist_Id are subscripts into this table. The First_Elmt field + -- (Lfield1) points to the first element on the list, or to No_Elmt in the + -- case of an empty list. Similarly the Last_Elmt field (Lfield2) points to + -- the last element on the list or to No_Elmt in the case of an empty list. + + -- The elements themselves are entries in the Elmts table. The Next field + -- of each entry points to the next element, or to the Elist header if this + -- is the last item in the list. The Node field points to the node which + -- is referenced by the corresponding list entry. + + -------------------------- + -- Element List Tables -- + -------------------------- + + type Elist_Header is record + First : Elmt_Id; + Last : Elmt_Id; + end record; + + package Elists is new Table.Table ( + Table_Component_Type => Elist_Header, + Table_Index_Type => Elist_Id, + Table_Low_Bound => First_Elist_Id, + Table_Initial => Alloc.Elists_Initial, + Table_Increment => Alloc.Elists_Increment, + Table_Name => "Elists"); + + type Elmt_Item is record + Node : Node_Id; + Next : Union_Id; + end record; + + package Elmts is new Table.Table ( + Table_Component_Type => Elmt_Item, + Table_Index_Type => Elmt_Id, + Table_Low_Bound => First_Elmt_Id, + Table_Initial => Alloc.Elmts_Initial, + Table_Increment => Alloc.Elmts_Increment, + Table_Name => "Elmts"); + + ----------------- + -- Append_Elmt -- + ----------------- + + procedure Append_Elmt (Node : Node_Id; To : Elist_Id) is + L : constant Elmt_Id := Elists.Table (To).Last; + + begin + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := Node; + Elmts.Table (Elmts.Last).Next := Union_Id (To); + + if L = No_Elmt then + Elists.Table (To).First := Elmts.Last; + else + Elmts.Table (L).Next := Union_Id (Elmts.Last); + end if; + + Elists.Table (To).Last := Elmts.Last; + + if Debug_Flag_N then + Write_Str ("Append new element Elmt_Id = "); + Write_Int (Int (Elmts.Last)); + Write_Str (" to list Elist_Id = "); + Write_Int (Int (To)); + Write_Str (" referencing Node_Id = "); + Write_Int (Int (Node)); + Write_Eol; + end if; + end Append_Elmt; + + -------------------- + -- Elists_Address -- + -------------------- + + function Elists_Address return System.Address is + begin + return Elists.Table (First_Elist_Id)'Address; + end Elists_Address; + + ------------------- + -- Elmts_Address -- + ------------------- + + function Elmts_Address return System.Address is + begin + return Elmts.Table (First_Elmt_Id)'Address; + end Elmts_Address; + + ---------------- + -- First_Elmt -- + ---------------- + + function First_Elmt (List : Elist_Id) return Elmt_Id is + begin + pragma Assert (List > Elist_Low_Bound); + return Elists.Table (List).First; + end First_Elmt; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Elists.Init; + Elmts.Init; + end Initialize; + + ----------------------- + -- Insert_Elmt_After -- + ----------------------- + + procedure Insert_Elmt_After (Node : Node_Id; Elmt : Elmt_Id) is + N : constant Union_Id := Elmts.Table (Elmt).Next; + + begin + + pragma Assert (Elmt /= No_Elmt); + + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := Node; + Elmts.Table (Elmts.Last).Next := N; + + Elmts.Table (Elmt).Next := Union_Id (Elmts.Last); + + if N in Elist_Range then + Elists.Table (Elist_Id (N)).Last := Elmts.Last; + end if; + end Insert_Elmt_After; + + ------------------------ + -- Is_Empty_Elmt_List -- + ------------------------ + + function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is + begin + return Elists.Table (List).First = No_Elmt; + end Is_Empty_Elmt_List; + + ------------------- + -- Last_Elist_Id -- + ------------------- + + function Last_Elist_Id return Elist_Id is + begin + return Elists.Last; + end Last_Elist_Id; + + --------------- + -- Last_Elmt -- + --------------- + + function Last_Elmt (List : Elist_Id) return Elmt_Id is + begin + return Elists.Table (List).Last; + end Last_Elmt; + + ------------------ + -- Last_Elmt_Id -- + ------------------ + + function Last_Elmt_Id return Elmt_Id is + begin + return Elmts.Last; + end Last_Elmt_Id; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Elists.Locked := True; + Elmts.Locked := True; + Elists.Release; + Elmts.Release; + end Lock; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List return Elist_Id is + begin + Elists.Increment_Last; + Elists.Table (Elists.Last).First := No_Elmt; + Elists.Table (Elists.Last).Last := No_Elmt; + + if Debug_Flag_N then + Write_Str ("Allocate new element list, returned ID = "); + Write_Int (Int (Elists.Last)); + Write_Eol; + end if; + + return Elists.Last; + end New_Elmt_List; + + --------------- + -- Next_Elmt -- + --------------- + + function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is + N : constant Union_Id := Elmts.Table (Elmt).Next; + + begin + if N in Elist_Range then + return No_Elmt; + else + return Elmt_Id (N); + end if; + end Next_Elmt; + + procedure Next_Elmt (Elmt : in out Elmt_Id) is + begin + Elmt := Next_Elmt (Elmt); + end Next_Elmt; + + -------- + -- No -- + -------- + + function No (List : Elist_Id) return Boolean is + begin + return List = No_Elist; + end No; + + function No (Elmt : Elmt_Id) return Boolean is + begin + return Elmt = No_Elmt; + end No; + + ----------- + -- Node -- + ----------- + + function Node (Elmt : Elmt_Id) return Node_Id is + begin + if Elmt = No_Elmt then + return Empty; + else + return Elmts.Table (Elmt).Node; + end if; + end Node; + + ---------------- + -- Num_Elists -- + ---------------- + + function Num_Elists return Nat is + begin + return Int (Elmts.Last) - Int (Elmts.First) + 1; + end Num_Elists; + + ------------------ + -- Prepend_Elmt -- + ------------------ + + procedure Prepend_Elmt (Node : Node_Id; To : Elist_Id) is + F : constant Elmt_Id := Elists.Table (To).First; + + begin + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := Node; + + if F = No_Elmt then + Elists.Table (To).Last := Elmts.Last; + Elmts.Table (Elmts.Last).Next := Union_Id (To); + else + Elmts.Table (Elmts.Last).Next := Union_Id (F); + end if; + + Elists.Table (To).First := Elmts.Last; + + end Prepend_Elmt; + + ------------- + -- Present -- + ------------- + + function Present (List : Elist_Id) return Boolean is + begin + return List /= No_Elist; + end Present; + + function Present (Elmt : Elmt_Id) return Boolean is + begin + return Elmt /= No_Elmt; + end Present; + + ----------------- + -- Remove_Elmt -- + ----------------- + + procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is + Nxt : Elmt_Id; + Prv : Elmt_Id; + + begin + Nxt := Elists.Table (List).First; + + -- Case of removing only element in the list + + if Elmts.Table (Nxt).Next in Elist_Range then + + pragma Assert (Nxt = Elmt); + + Elists.Table (List).First := No_Elmt; + Elists.Table (List).Last := No_Elmt; + + -- Case of removing the first element in the list + + elsif Nxt = Elmt then + Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next); + + -- Case of removing second or later element in the list + + else + loop + Prv := Nxt; + Nxt := Elmt_Id (Elmts.Table (Prv).Next); + exit when Nxt = Elmt + or else Elmts.Table (Nxt).Next in Elist_Range; + end loop; + + pragma Assert (Nxt = Elmt); + + Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; + + if Elmts.Table (Prv).Next in Elist_Range then + Elists.Table (List).Last := Prv; + end if; + end if; + end Remove_Elmt; + + ---------------------- + -- Remove_Last_Elmt -- + ---------------------- + + procedure Remove_Last_Elmt (List : Elist_Id) is + Nxt : Elmt_Id; + Prv : Elmt_Id; + + begin + Nxt := Elists.Table (List).First; + + -- Case of removing only element in the list + + if Elmts.Table (Nxt).Next in Elist_Range then + Elists.Table (List).First := No_Elmt; + Elists.Table (List).Last := No_Elmt; + + -- Case of at least two elements in list + + else + loop + Prv := Nxt; + Nxt := Elmt_Id (Elmts.Table (Prv).Next); + exit when Elmts.Table (Nxt).Next in Elist_Range; + end loop; + + Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; + Elists.Table (List).Last := Prv; + end if; + end Remove_Last_Elmt; + + ------------------ + -- Replace_Elmt -- + ------------------ + + procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Id) is + begin + Elmts.Table (Elmt).Node := New_Node; + end Replace_Elmt; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Elists.Tree_Read; + Elmts.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Elists.Tree_Write; + Elmts.Tree_Write; + end Tree_Write; + +end Elists; diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads new file mode 100644 index 00000000000..0c42196189c --- /dev/null +++ b/gcc/ada/elists.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E L I S T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.14 $ -- +-- -- +-- Copyright (C) 1992-1998 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for manipulating lists of nodes (see +-- package Atree for format and implementation of tree nodes). Separate list +-- elements are allocated to represent elements of these lists, so it is +-- possible for a given node to be on more than one element list at a time. +-- See also package Nlists, which provides another form that is threaded +-- through the nodes themselves (using the Link field), which is more time +-- and space efficient, but a node can be only one such list. + +with Types; use Types; +with System; + +package Elists is + + -- An element list is represented by a header that is allocated in the + -- Elist header table. This header contains pointers to the first and + -- last elements in the list, or to No_Elmt if the list is empty. + + -- The elements in the list each contain a pointer to the next element + -- and a pointer to the referenced node. Putting a node into an element + -- list causes no change at all to the node itself, so a node may be + -- included in multiple element lists, and the nodes thus included may + -- or may not be elements of node lists (see package Nlists). + + procedure Initialize; + -- Initialize allocation of element list tables. Called at the start of + -- compiling each new main source file. Note that Initialize must not be + -- called if Tree_Read is used. + + procedure Lock; + -- Lock tables used for element lists before calling backend + + procedure Tree_Read; + -- Initializes internal tables from current tree file using Tree_Read. + -- Note that Initialize should not be called if Tree_Read is used. + -- Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write + + function Last_Elist_Id return Elist_Id; + -- Returns Id of last allocated element list header + + function Elists_Address return System.Address; + -- Return address of Elists table (used in Back_End for Gigi call) + + function Num_Elists return Nat; + -- Number of currently allocated element lists + + function Last_Elmt_Id return Elmt_Id; + -- Returns Id of last allocated list element + + function Elmts_Address return System.Address; + -- Return address of Elmts table (used in Back_End for Gigi call) + + function Node (Elmt : Elmt_Id) return Node_Id; + pragma Inline (Node); + -- Returns the value of a given list element. Returns Empty if Elmt + -- is set to No_Elmt. + + function New_Elmt_List return Elist_Id; + -- Creates a new empty element list. Typically this is used to initialize + -- a field in some other node which points to an element list where the + -- list is then subsequently filled in using Append calls. + + function First_Elmt (List : Elist_Id) return Elmt_Id; + pragma Inline (First_Elmt); + -- Obtains the first element of the given element list or, if the + -- list has no items, then No_Elmt is returned. + + function Last_Elmt (List : Elist_Id) return Elmt_Id; + pragma Inline (Last_Elmt); + -- Obtains the last element of the given element list or, if the + -- list has no items, then No_Elmt is returned. + + function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id; + pragma Inline (Next_Elmt); + -- This function returns the next element on an element list. The argument + -- must be a list element other than No_Elmt. Returns No_Elmt if the given + -- element is the last element of the list. + + procedure Next_Elmt (Elmt : in out Elmt_Id); + pragma Inline (Next_Elmt); + -- Next_Elmt (Elmt) is equivalent to Elmt := Next_Elmt (Elmt) + + function Is_Empty_Elmt_List (List : Elist_Id) return Boolean; + pragma Inline (Is_Empty_Elmt_List); + -- This function determines if a given tree id references an element list + -- that contains no items. + + procedure Append_Elmt (Node : Node_Id; To : Elist_Id); + -- Appends Node at the end of To, allocating a new element. + + procedure Prepend_Elmt (Node : Node_Id; To : Elist_Id); + -- Appends Node at the beginning of To, allocating a new element. + + procedure Insert_Elmt_After (Node : Node_Id; Elmt : Elmt_Id); + -- Add a new element (Node) right after the pre-existing element Elmt + -- It is invalid to call this subprogram with Elmt = No_Elmt. + + procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Id); + pragma Inline (Replace_Elmt); + -- Causes the given element of the list to refer to New_Node, the node + -- which was previously referred to by Elmt is effectively removed from + -- the list and replaced by New_Node. + + procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id); + -- Removes Elmt from the given list. The node itself is not affected, + -- but the space used by the list element may be (but is not required + -- to be) freed for reuse in a subsequent Append_Elmt call. + + procedure Remove_Last_Elmt (List : Elist_Id); + -- Removes the last element of the given list. The node itself is not + -- affected, but the space used by the list element may be (but is not + -- required to be) freed for reuse in a subsequent Append_Elmt call. + + function No (List : Elist_Id) return Boolean; + pragma Inline (No); + -- Tests given Id for equality with No_Elist. This allows notations like + -- "if No (Statements)" as opposed to "if Statements = No_Elist". + + function Present (List : Elist_Id) return Boolean; + pragma Inline (Present); + -- Tests given Id for inequality with No_Elist. This allows notations like + -- "if Present (Statements)" as opposed to "if Statements /= No_Elist". + + function No (Elmt : Elmt_Id) return Boolean; + pragma Inline (No); + -- Tests given Id for equality with No_Elmt. This allows notations like + -- "if No (Operation)" as opposed to "if Operation = No_Elmt". + + function Present (Elmt : Elmt_Id) return Boolean; + pragma Inline (Present); + -- Tests given Id for inequality with No_Elmt. This allows notations like + -- "if Present (Operation)" as opposed to "if Operation /= No_Elmt". + +end Elists; diff --git a/gcc/ada/elists.h b/gcc/ada/elists.h new file mode 100644 index 00000000000..f9eaea7cabe --- /dev/null +++ b/gcc/ada/elists.h @@ -0,0 +1,107 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * E L I S T S * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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). * + * * + ****************************************************************************/ + +/* This is the C header corresponding to the Ada package specification for + Elists. It also contains the implementations of inlined functions from the + package body for Elists. It was generated manually from elists.ads and + elists.adb and must be kept synchronized with changes in these files. + + Note that only routines for reading the tree are included, since the + tree transformer is not supposed to modify the tree in any way. */ + +/* The following are the structures used to hold element lists */ + +struct Elist_Header +{ + Elmt_Id first; + Elmt_Id last; +}; + +struct Elmt_Item +{ + Node_Id node; + Int next; +}; + +/* The element list headers and element descriptors themselves are stored in + two arrays. The pointers to these arrays are passed as a parameter to the + tree transformer procedure and stored in the global variables Elists_Ptr + and Elmts_Ptr after adjusting them by subtracting Elist_First_Entry and + Elmt_First_Entry, so that Elist_Id and Elmt_Id values can be used as + subscripts into these arrays */ + +extern struct Elist_Header *Elists_Ptr; +extern struct Elmt_Item *Elmts_Ptr; + +/* Element List Access Functions: */ + +static Node_Id Node PARAMS ((Elmt_Id)); +static Elmt_Id First_Elmt PARAMS ((Elist_Id)); +static Elmt_Id Last_Elmt PARAMS ((Elist_Id)); +static Elmt_Id Next_Elmt PARAMS ((Elmt_Id)); +static Boolean Is_Empty_Elmt_List PARAMS ((Elist_Id)); + +INLINE Node_Id +Node (Elmt) + Elmt_Id Elmt; +{ + return Elmts_Ptr [Elmt].node; +} + +INLINE Elmt_Id +First_Elmt (List) + Elist_Id List; +{ + return Elists_Ptr [List].first; +} + +INLINE Elmt_Id +Last_Elmt (List) + Elist_Id List; +{ + return Elists_Ptr [List].last; +} + +INLINE Elmt_Id +Next_Elmt (Node) + Elmt_Id Node; +{ + Int N = Elmts_Ptr [Node].next; + + if (IN (N, Elist_Range)) + return No_Elmt; + else + return N; +} + +INLINE Boolean +Is_Empty_Elmt_List (Id) + Elist_Id Id; +{ + return Elists_Ptr [Id].first == No_Elmt; +} diff --git a/gcc/ada/errno.c b/gcc/ada/errno.c new file mode 100644 index 00000000000..92eb2e3f84c --- /dev/null +++ b/gcc/ada/errno.c @@ -0,0 +1,57 @@ +/**************************************************************************** + * * + * GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS * + * * + * E R R N O * + * * + * C Implementation File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +/* This file provides access to the C-language errno to the Ada interface + for POSIX. It is not possible in general to import errno, even in + Ada compilers that allow (as GNAT does) the importation of variables, + as it may be defined using a macro. +*/ + + +#define _REENTRANT +#define _THREAD_SAFE + +#include <errno.h> +int +__get_errno() +{ + return errno; +} + +void +__set_errno(err) + int err; +{ + errno = err; +} diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb new file mode 100644 index 00000000000..ad64a5fa30a --- /dev/null +++ b/gcc/ada/errout.adb @@ -0,0 +1,3083 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R O U T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.208 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Warning! Error messages can be generated during Gigi processing by direct +-- calls to error message routines, so it is essential that the processing +-- in this body be consistent with the requirements for the Gigi processing +-- environment, and that in particular, no disallowed table expansion is +-- allowed to occur. + +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Fname; use Fname; +with Hostparm; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Scans; use Scans; +with Sinput; use Sinput; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Style; +with Uintp; use Uintp; +with Uname; use Uname; + +package body Errout is + + Class_Flag : Boolean := False; + -- This flag is set True when outputting a reference to a class-wide + -- type, and is used by Add_Class to insert 'Class at the proper point + + Continuation : Boolean; + -- Indicates if current message is a continuation. Intialized from the + -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \ + -- insertion character is encountered. + + Cur_Msg : Error_Msg_Id; + -- Id of most recently posted error message + + Flag_Source : Source_File_Index; + -- Source file index for source file where error is being posted + + Is_Warning_Msg : Boolean; + -- Set by Set_Msg_Text to indicate if current message is warning message + + Is_Unconditional_Msg : Boolean; + -- Set by Set_Msg_Text to indicate if current message is unconditional + + Kill_Message : Boolean; + -- A flag used to kill weird messages (e.g. those containing uninterpreted + -- implicit type references) if we have already seen at least one message + -- already. The idea is that we hope the weird message is a junk cascaded + -- message that should be suppressed. + + Last_Killed : Boolean := False; + -- Set True if the most recently posted non-continuation message was + -- killed. This is used to determine the processing of any continuation + -- messages that follow. + + List_Pragmas_Index : Int; + -- Index into List_Pragmas table + + List_Pragmas_Mode : Boolean; + -- Starts True, gets set False by pragma List (Off), True by List (On) + + Manual_Quote_Mode : Boolean; + -- Set True in manual quotation mode + + Max_Msg_Length : constant := 80 + 2 * Hostparm.Max_Line_Length; + -- Maximum length of error message. The addition of Max_Line_Length + -- ensures that two insertion tokens of maximum length can be accomodated. + + Msg_Buffer : String (1 .. Max_Msg_Length); + -- Buffer used to prepare error messages + + Msglen : Integer; + -- Number of characters currently stored in the message buffer + + Suppress_Message : Boolean; + -- A flag used to suppress certain obviously redundant messages (i.e. + -- those referring to a node whose type is Any_Type). This suppression + -- is effective only if All_Errors_Mode is off. + + Suppress_Instance_Location : Boolean := False; + -- Normally, if a # location in a message references a location within + -- a generic template, then a note is added giving the location of the + -- instantiation. If this variable is set True, then this note is not + -- output. This is used for internal processing for the case of an + -- illegal instantiation. See Error_Msg routine for further details. + + ----------------------------------- + -- Error Message Data Structures -- + ----------------------------------- + + -- The error messages are stored as a linked list of error message objects + -- sorted into ascending order by the source location (Sloc). Each object + -- records the text of the message and its source location. + + -- The following record type and table are used to represent error + -- messages, with one entry in the table being allocated for each message. + + type Error_Msg_Object is record + Text : String_Ptr; + -- Text of error message, fully expanded with all insertions + + Next : Error_Msg_Id; + -- Pointer to next message in error chain + + Sfile : Source_File_Index; + -- Source table index of source file. In the case of an error that + -- refers to a template, always references the original template + -- not an instantiation copy. + + Sptr : Source_Ptr; + -- Flag pointer. In the case of an error that refers to a template, + -- always references the original template, not an instantiation copy. + -- This value is the actual place in the source that the error message + -- will be posted. + + Fptr : Source_Ptr; + -- Flag location used in the call to post the error. This is normally + -- the same as Sptr, except in the case of instantiations, where it + -- is the original flag location value. This may refer to an instance + -- when the actual message (and hence Sptr) references the template. + + Line : Physical_Line_Number; + -- Line number for error message + + Col : Column_Number; + -- Column number for error message + + Warn : Boolean; + -- True if warning message (i.e. insertion character ? appeared) + + Uncond : Boolean; + -- True if unconditional message (i.e. insertion character ! appeared) + + Msg_Cont : Boolean; + -- This is used for logical messages that are composed of multiple + -- individual messages. For messages that are not part of such a + -- group, or that are the first message in such a group. Msg_Cont + -- is set to False. For subsequent messages in a group, Msg_Cont + -- is set to True. This is used to make sure that such a group of + -- messages is either suppressed or retained as a group (e.g. in + -- the circuit that deletes identical messages). + + Deleted : Boolean; + -- If this flag is set, the message is not printed. This is used + -- in the circuit for deleting duplicate/redundant error messages. + end record; + + package Errors is new Table.Table ( + Table_Component_Type => Error_Msg_Object, + Table_Index_Type => Error_Msg_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Error"); + + Error_Msgs : Error_Msg_Id; + -- The list of error messages + + -------------------------- + -- Warning Mode Control -- + -------------------------- + + -- Pragma Warnings allows warnings to be turned off for a specified + -- region of code, and the following tabl is the data structure used + -- to keep track of these regions. + + -- It contains pairs of source locations, the first being the start + -- location for a warnings off region, and the second being the end + -- location. When a pragma Warnings (Off) is encountered, a new entry + -- is established extending from the location of the pragma to the + -- end of the current source file. A subsequent pragma Warnings (On) + -- adjusts the end point of this entry appropriately. + + -- If all warnings are suppressed by comamnd switch, then there is a + -- dummy entry (put there by Errout.Initialize) at the start of the + -- table which covers all possible Source_Ptr values. Note that the + -- source pointer values in this table always reference the original + -- template, not an instantiation copy, in the generic case. + + type Warnings_Entry is record + Start : Source_Ptr; + Stop : Source_Ptr; + end record; + + package Warnings is new Table.Table ( + Table_Component_Type => Warnings_Entry, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Warnings"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Class; + -- Add 'Class to buffer for class wide type case (Class_Flag set) + + function Buffer_Ends_With (S : String) return Boolean; + -- Tests if message buffer ends with given string preceded by a space + + procedure Buffer_Remove (S : String); + -- Removes given string from end of buffer if it is present + -- at end of buffer, and preceded by a space. + + procedure Debug_Output (N : Node_Id); + -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug + -- output giving node number (of node N) if the debug X switch is set. + + procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id); + -- This function is passed the Id values of two error messages. If + -- either M1 or M2 is a continuation message, or is already deleted, + -- the call is ignored. Otherwise a check is made to see if M1 and M2 + -- are duplicated or redundant. If so, the message to be deleted and + -- all its continuations are marked with the Deleted flag set to True. + + procedure Error_Msg_Internal + (Msg : String; + Flag_Location : Source_Ptr; + Msg_Cont : Boolean); + -- This is like Error_Msg, except that Flag_Location is known not to be + -- a location within a instantiation of a generic template. The outer + -- level routine, Error_Msg, takes care of dealing with the generic case. + -- Msg_Cont is set True to indicate that the message is a continuation of + -- a previous message. This means that it must have the same Flag_Location + -- as the previous message. + + procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id); + -- Given a message id, move to next message id, but skip any deleted + -- messages, so that this results in E on output being the first non- + -- deleted message following the input value of E, or No_Error_Msg if + -- the input value of E was either already No_Error_Msg, or was the + -- last non-deleted message. + + function No_Warnings (N : Node_Or_Entity_Id) return Boolean; + -- Determines if warnings should be suppressed for the given node + + function OK_Node (N : Node_Id) return Boolean; + -- Determines if a node is an OK node to place an error message on (return + -- True) or if the error message should be suppressed (return False). A + -- message is suppressed if the node already has an error posted on it, + -- or if it refers to an Etype that has an error posted on it, or if + -- it references an Entity that has an error posted on it. + + procedure Output_Error_Msgs (E : in out Error_Msg_Id); + -- Output source line, error flag, and text of stored error message and + -- all subsequent messages for the same line and unit. On return E is + -- set to be one higher than the last message output. + + procedure Output_Line_Number (L : Logical_Line_Number); + -- Output a line number as six digits (with leading zeroes suppressed), + -- followed by a period and a blank (note that this is 8 characters which + -- means that tabs in the source line will not get messed up). Line numbers + -- that match or are less than the last Source_Reference pragma are listed + -- as all blanks, avoiding output of junk line numbers. + + procedure Output_Msg_Text (E : Error_Msg_Id); + -- Outputs characters of text in the text of the error message E, excluding + -- any final exclamation point. Note that no end of line is output, the + -- caller is responsible for adding the end of line. + + procedure Output_Source_Line + (L : Physical_Line_Number; + Sfile : Source_File_Index; + Errs : Boolean); + -- Outputs text of source line L, in file S, together with preceding line + -- number, as described above for Output_Line_Number. The Errs parameter + -- indicates if there are errors attached to the line, which forces + -- listing on, even in the presence of pragma List (Off). + + function Same_Error (M1, M2 : Error_Msg_Id) return Boolean; + -- See if two messages have the same text. Returns true if the text + -- of the two messages is identical, or if one of them is the same + -- as the other with an appended "instance at xxx" tag. + + procedure Set_Msg_Blank; + -- Sets a single blank in the message if the preceding character is a + -- non-blank character other than a left parenthesis. Has no effect if + -- manual quote mode is turned on. + + procedure Set_Msg_Blank_Conditional; + -- Sets a single blank in the message if the preceding character is a + -- non-blank character other than a left parenthesis or quote. Has no + -- effect if manual quote mode is turned on. + + procedure Set_Msg_Char (C : Character); + -- Add a single character to the current message. This routine does not + -- check for special insertion characters (they are just treated as text + -- characters if they occur). + + procedure Set_Msg_Insertion_Column; + -- Handle column number insertion (@ insertion character) + + procedure Set_Msg_Insertion_Name; + -- Handle name insertion (% insertion character) + + procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr); + -- Handle line number insertion (# insertion character). Loc is the + -- location to be referenced, and Flag is the location at which the + -- flag is posted (used to determine whether to add "in file xxx") + + procedure Set_Msg_Insertion_Node; + -- Handle node (name from node) insertion (& insertion character) + + procedure Set_Msg_Insertion_Reserved_Name; + -- Handle insertion of reserved word name (* insertion character). + + procedure Set_Msg_Insertion_Reserved_Word + (Text : String; + J : in out Integer); + -- Handle reserved word insertion (upper case letters). The Text argument + -- is the current error message input text, and J is an index which on + -- entry points to the first character of the reserved word, and on exit + -- points past the last character of the reserved word. + + procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr); + -- Handle type reference (right brace insertion character). Flag is the + -- location of the flag, which is provided for the internal call to + -- Set_Msg_Insertion_Line_Number, + + procedure Set_Msg_Insertion_Uint; + -- Handle Uint insertion (^ insertion character) + + procedure Set_Msg_Insertion_Unit_Name; + -- Handle unit name insertion ($ insertion character) + + procedure Set_Msg_Insertion_File_Name; + -- Handle file name insertion (left brace insertion character) + + procedure Set_Msg_Int (Line : Int); + -- Set the decimal representation of the argument in the error message + -- buffer with no leading zeroes output. + + procedure Set_Msg_Name_Buffer; + -- Output name from Name_Buffer, with surrounding quotes unless manual + -- quotation mode is in effect. + + procedure Set_Msg_Node (Node : Node_Id); + -- Add the sequence of characters for the name associated with the + -- given node to the current message. + + procedure Set_Msg_Quote; + -- Set quote if in normal quote mode, nothing if in manual quote mode + + procedure Set_Msg_Str (Text : String); + -- Add a sequence of characters to the current message. This routine does + -- not check for special insertion characters (they are just treated as + -- text characters if they occur). + + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); + -- Add a sequence of characters to the current message. The characters may + -- be one of the special insertion characters (see documentation in spec). + -- Flag is the location at which the error is to be posted, which is used + -- to determine whether or not the # insertion needs a file name. The + -- variables Msg_Buffer, Msglen, Is_Warning_Msg, and Is_Unconditional_Msg + -- are set on return. + + procedure Set_Posted (N : Node_Id); + -- Sets the Error_Posted flag on the given node, and all its parents + -- that are subexpressions and then on the parent non-subexpression + -- construct that contains the original expression (this reduces the + -- number of cascaded messages) + + procedure Set_Qualification (N : Nat; E : Entity_Id); + -- Outputs up to N levels of qualification for the given entity. For + -- example, the entity A.B.C.D will output B.C. if N = 2. + + procedure Test_Warning_Msg (Msg : String); + -- Sets Is_Warning_Msg true if Msg is a warning message (contains a + -- question mark character), and False otherwise. + + procedure Unwind_Internal_Type (Ent : in out Entity_Id); + -- This procedure is given an entity id for an internal type, i.e. + -- a type with an internal name. It unwinds the type to try to get + -- to something reasonably printable, generating prefixes like + -- "subtype of", "access to", etc along the way in the buffer. The + -- value in Ent on return is the final name to be printed. Hopefully + -- this is not an internal name, but in some internal name cases, it + -- is an internal name, and has to be printed anyway (although in this + -- case the message has been killed if possible). The global variable + -- Class_Flag is set to True if the resulting entity should have + -- 'Class appended to its name (see Add_Class procedure), and is + -- otherwise unchanged. + + function Warnings_Suppressed (Loc : Source_Ptr) return Boolean; + -- Determines if given location is covered by a warnings off suppression + -- range in the warnings table (or is suppressed by compilation option, + -- which generates a warning range for the whole source file). + + --------------- + -- Add_Class -- + --------------- + + procedure Add_Class is + begin + if Class_Flag then + Class_Flag := False; + Set_Msg_Char ('''); + Get_Name_String (Name_Class); + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Name_Buffer; + end if; + end Add_Class; + + ---------------------- + -- Buffer_Ends_With -- + ---------------------- + + function Buffer_Ends_With (S : String) return Boolean is + Len : constant Natural := S'Length; + + begin + return + Msglen > Len + and then Msg_Buffer (Msglen - Len) = ' ' + and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S; + end Buffer_Ends_With; + + ------------------- + -- Buffer_Remove -- + ------------------- + + procedure Buffer_Remove (S : String) is + begin + if Buffer_Ends_With (S) then + Msglen := Msglen - S'Length; + end if; + end Buffer_Remove; + + ----------------------- + -- Change_Error_Text -- + ----------------------- + + procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is + Save_Next : Error_Msg_Id; + Err_Id : Error_Msg_Id := Error_Id; + + begin + Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr); + Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen)); + + -- If in immediate error message mode, output modified error message now + -- This is just a bit tricky, because we want to output just a single + -- message, and the messages we modified is already linked in. We solve + -- this by temporarily resetting its forward pointer to empty. + + if Debug_Flag_OO then + Save_Next := Errors.Table (Error_Id).Next; + Errors.Table (Error_Id).Next := No_Error_Msg; + Write_Eol; + Output_Source_Line + (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True); + Output_Error_Msgs (Err_Id); + Errors.Table (Error_Id).Next := Save_Next; + end if; + end Change_Error_Text; + + ----------------------------- + -- Check_Duplicate_Message -- + ----------------------------- + + procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is + L1, L2 : Error_Msg_Id; + N1, N2 : Error_Msg_Id; + + procedure Delete_Msg (Delete, Keep : Error_Msg_Id); + -- Called to delete message Delete, keeping message Keep. Marks + -- all messages of Delete with deleted flag set to True, and also + -- makes sure that for the error messages that are retained the + -- preferred message is the one retained (we prefer the shorter + -- one in the case where one has an Instance tag). Note that we + -- always know that Keep has at least as many continuations as + -- Delete (since we always delete the shorter sequence). + + procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is + D, K : Error_Msg_Id; + + begin + D := Delete; + K := Keep; + + loop + Errors.Table (D).Deleted := True; + + -- Adjust error message count + + if Errors.Table (D).Warn then + Warnings_Detected := Warnings_Detected - 1; + else + Errors_Detected := Errors_Detected - 1; + end if; + + -- Substitute shorter of the two error messages + + if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then + Errors.Table (K).Text := Errors.Table (D).Text; + end if; + + D := Errors.Table (D).Next; + K := Errors.Table (K).Next; + + if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then + return; + end if; + end loop; + end Delete_Msg; + + -- Start of processing for Check_Duplicate_Message + + begin + -- Both messages must be non-continuation messages and not deleted + + if Errors.Table (M1).Msg_Cont + or else Errors.Table (M2).Msg_Cont + or else Errors.Table (M1).Deleted + or else Errors.Table (M2).Deleted + then + return; + end if; + + -- Definitely not equal if message text does not match + + if not Same_Error (M1, M2) then + return; + end if; + + -- Same text. See if all continuations are also identical + + L1 := M1; + L2 := M2; + + loop + N1 := Errors.Table (L1).Next; + N2 := Errors.Table (L2).Next; + + -- If M1 continuations have run out, we delete M1, either the + -- messages have the same number of continuations, or M2 has + -- more and we prefer the one with more anyway. + + if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then + Delete_Msg (M1, M2); + return; + + -- If M2 continuatins have run out, we delete M2 + + elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then + Delete_Msg (M2, M1); + return; + + -- Otherwise see if continuations are the same, if not, keep both + -- sequences, a curious case, but better to keep everything! + + elsif not Same_Error (N1, N2) then + return; + + -- If continuations are the same, continue scan + + else + L1 := N1; + L2 := N2; + end if; + end loop; + end Check_Duplicate_Message; + + ------------------------ + -- Compilation_Errors -- + ------------------------ + + function Compilation_Errors return Boolean is + begin + return Errors_Detected /= 0 + or else (Warnings_Detected /= 0 + and then Warning_Mode = Treat_As_Error); + end Compilation_Errors; + + ------------------ + -- Debug_Output -- + ------------------ + + procedure Debug_Output (N : Node_Id) is + begin + if Debug_Flag_1 then + Write_Str ("*** following error message posted on node id = #"); + Write_Int (Int (N)); + Write_Str (" ***"); + Write_Eol; + end if; + end Debug_Output; + + ---------- + -- dmsg -- + ---------- + + procedure dmsg (Id : Error_Msg_Id) is + E : Error_Msg_Object renames Errors.Table (Id); + + begin + w ("Dumping error message, Id = ", Int (Id)); + w (" Text = ", E.Text.all); + w (" Next = ", Int (E.Next)); + w (" Sfile = ", Int (E.Sfile)); + + Write_Str + (" Sptr = "); + Write_Location (E.Sptr); + Write_Eol; + + Write_Str + (" Fptr = "); + Write_Location (E.Fptr); + Write_Eol; + + w (" Line = ", Int (E.Line)); + w (" Col = ", Int (E.Col)); + w (" Warn = ", E.Warn); + w (" Uncond = ", E.Uncond); + w (" Msg_Cont = ", E.Msg_Cont); + w (" Deleted = ", E.Deleted); + + Write_Eol; + end dmsg; + + --------------- + -- Error_Msg -- + --------------- + + -- Error_Msg posts a flag at the given location, except that if the + -- Flag_Location points within a generic template and corresponds + -- to an instantiation of this generic template, then the actual + -- message will be posted on the generic instantiation, along with + -- additional messages referencing the generic declaration. + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is + + Sindex : constant Source_File_Index := + Get_Source_File_Index (Flag_Location); + + Orig_Loc : Source_Ptr; + -- Original location of Flag_Location (i.e. location in original + -- template in instantiation case, otherwise unchanged). + + begin + Test_Warning_Msg (Msg); + + -- It is a fatal error to issue an error message when scanning from + -- the internal source buffer (see Sinput for further documentation) + + pragma Assert (Source /= Internal_Source_Ptr); + + -- Ignore warning message that is suppressed + + Orig_Loc := Original_Location (Flag_Location); + + if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then + return; + end if; + + -- The idea at this stage is that we have two kinds of messages. + + -- First, we have those that are to be placed as requested at + -- Flag_Location. This includes messages that have nothing to + -- do with generics, and also messages placed on generic templates + -- that reflect an error in the template itself. For such messages + -- we simply call Error_Msg_Internal to place the message in the + -- requested location. + + if Instantiation (Sindex) = No_Location then + Error_Msg_Internal (Msg, Flag_Location, False); + return; + end if; + + -- If we are trying to flag an error in an instantiation, we may have + -- a generic contract violation. What we generate in this case is: + + -- instantiation error at ... + -- original error message + + -- or + + -- warning: in instantiation at + -- warning: original warning message + + -- All these messages are posted at the location of the top level + -- instantiation. If there are nested instantiations, then the + -- instantiation error message can be repeated, pointing to each + -- of the relevant instantiations. + + -- However, before we do this, we need to worry about the case where + -- indeed we are in an instantiation, but the message is a warning + -- message. In this case, it almost certainly a warning for the + -- template itself and so it is posted on the template. At least + -- this is the default mode, it can be cancelled (resulting the + -- warning being placed on the instance as in the error case) by + -- setting the global Warn_On_Instance True. + + if (not Warn_On_Instance) and then Is_Warning_Msg then + Error_Msg_Internal (Msg, Flag_Location, False); + return; + end if; + + -- Second, we need to worry about the case where there was a real error + -- in the template, and we are getting a repeat of this error in the + -- instantiation. We don't want to complain about the instantiation + -- in this case, since we have already flagged the template. + + -- To deal with this case, just see if we have posted a message at + -- the template location already. If so, assume that the current + -- message is redundant. There could be cases in which this is not + -- a correct assumption, but it is not terrible to lose a message + -- about an incorrect instantiation given that we have already + -- flagged a message on the template. + + for Err in Errors.First .. Errors.Last loop + if Errors.Table (Err).Sptr = Orig_Loc then + + -- If the current message is a real error, as opposed to a + -- warning, then we don't want to let a warning on the + -- template inhibit a real error on the instantiation. + + if Is_Warning_Msg + or else not Errors.Table (Err).Warn + then + return; + end if; + end if; + end loop; + + -- OK, this is the case where we have an instantiation error, and + -- we need to generate the error on the instantiation, rather than + -- on the template. First, see if we have posted this exact error + -- before, and if so suppress it. It is not so easy to use the main + -- list of errors for this, since they have already been split up + -- according to the processing below. Consequently we use an auxiliary + -- data structure that just records these types of messages (it will + -- never have very many entries). + + declare + Actual_Error_Loc : Source_Ptr; + -- Location of outer level instantiation in instantiation case, or + -- just a copy of Flag_Location in the normal case. This is the + -- location where all error messages will actually be posted. + + Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc; + -- Save possible location set for caller's message. We need to + -- use Error_Msg_Sloc for the location of the instantiation error + -- but we have to preserve a possible original value. + + X : Source_File_Index; + + Msg_Cont_Status : Boolean; + -- Used to label continuation lines in instantiation case with + -- proper Msg_Cont status. + + begin + -- Loop to find highest level instantiation, where all error + -- messages will be placed. + + X := Sindex; + loop + Actual_Error_Loc := Instantiation (X); + X := Get_Source_File_Index (Actual_Error_Loc); + exit when Instantiation (X) = No_Location; + end loop; + + -- Since we are generating the messages at the instantiation + -- point in any case, we do not want the references to the + -- bad lines in the instance to be annotated with the location + -- of the instantiation. + + Suppress_Instance_Location := True; + Msg_Cont_Status := False; + + -- Loop to generate instantiation messages + + Error_Msg_Sloc := Flag_Location; + X := Get_Source_File_Index (Flag_Location); + + while Instantiation (X) /= No_Location loop + + -- Suppress instantiation message on continuation lines + + if Msg (1) /= '\' then + if Is_Warning_Msg then + Error_Msg_Internal + ("?in instantiation #", + Actual_Error_Loc, Msg_Cont_Status); + + else + Error_Msg_Internal + ("instantiation error #", + Actual_Error_Loc, Msg_Cont_Status); + end if; + end if; + + Error_Msg_Sloc := Instantiation (X); + X := Get_Source_File_Index (Error_Msg_Sloc); + Msg_Cont_Status := True; + end loop; + + Suppress_Instance_Location := False; + Error_Msg_Sloc := Save_Error_Msg_Sloc; + + -- Here we output the original message on the outer instantiation + + Error_Msg_Internal (Msg, Actual_Error_Loc, Msg_Cont_Status); + end; + end Error_Msg; + + ------------------ + -- Error_Msg_AP -- + ------------------ + + procedure Error_Msg_AP (Msg : String) is + S1 : Source_Ptr; + C : Character; + + begin + -- If we had saved the Scan_Ptr value after scanning the previous + -- token, then we would have exactly the right place for putting + -- the flag immediately at hand. However, that would add at least + -- two instructions to a Scan call *just* to service the possibility + -- of an Error_Msg_AP call. So instead we reconstruct that value. + + -- We have two possibilities, start with Prev_Token_Ptr and skip over + -- the current token, which is made harder by the possibility that this + -- token may be in error, or start with Token_Ptr and work backwards. + -- We used to take the second approach, but it's hard because of + -- comments, and harder still because things that look like comments + -- can appear inside strings. So now we take the first approach. + + -- Note: in the case where there is no previous token, Prev_Token_Ptr + -- is set to Source_First, which is a reasonable position for the + -- error flag in this situation. + + S1 := Prev_Token_Ptr; + C := Source (S1); + + -- If the previous token is a string literal, we need a special approach + -- since there may be white space inside the literal and we don't want + -- to stop on that white space. + + if Prev_Token = Tok_String_Literal then + loop + S1 := S1 + 1; + + if Source (S1) = C then + S1 := S1 + 1; + exit when Source (S1) /= C; + elsif Source (S1) in Line_Terminator then + exit; + end if; + end loop; + + -- Character literal also needs special handling + + elsif Prev_Token = Tok_Char_Literal then + S1 := S1 + 3; + + -- Otherwise we search forward for the end of the current token, marked + -- by a line terminator, white space, a comment symbol or if we bump + -- into the following token (i.e. the current token) + + else + while Source (S1) not in Line_Terminator + and then Source (S1) /= ' ' + and then Source (S1) /= ASCII.HT + and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-') + and then S1 /= Token_Ptr + loop + S1 := S1 + 1; + end loop; + end if; + + -- S1 is now set to the location for the flag + + Error_Msg (Msg, S1); + + end Error_Msg_AP; + + ------------------ + -- Error_Msg_BC -- + ------------------ + + procedure Error_Msg_BC (Msg : String) is + begin + -- If we are at end of file, post the flag after the previous token + + if Token = Tok_EOF then + Error_Msg_AP (Msg); + + -- If we are at start of file, post the flag at the current token + + elsif Token_Ptr = Source_First (Current_Source_File) then + Error_Msg_SC (Msg); + + -- If the character before the current token is a space or a horizontal + -- tab, then we place the flag on this character (in the case of a tab + -- we would really like to place it in the "last" character of the tab + -- space, but that it too much trouble to worry about). + + elsif Source (Token_Ptr - 1) = ' ' + or else Source (Token_Ptr - 1) = ASCII.HT + then + Error_Msg (Msg, Token_Ptr - 1); + + -- If there is no space or tab before the current token, then there is + -- no room to place the flag before the token, so we place it on the + -- token instead (this happens for example at the start of a line). + + else + Error_Msg (Msg, Token_Ptr); + end if; + end Error_Msg_BC; + + ------------------------ + -- Error_Msg_Internal -- + ------------------------ + + procedure Error_Msg_Internal + (Msg : String; + Flag_Location : Source_Ptr; + Msg_Cont : Boolean) + is + Next_Msg : Error_Msg_Id; + -- Pointer to next message at insertion point + + Prev_Msg : Error_Msg_Id; + -- Pointer to previous message at insertion point + + Temp_Msg : Error_Msg_Id; + + Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location); + + procedure Handle_Fatal_Error; + -- Internal procedure to do all error message handling other than + -- bumping the error count and arranging for the message to be output. + + procedure Handle_Fatal_Error is + begin + -- Turn off code generation if not done already + + if Operating_Mode = Generate_Code then + Operating_Mode := Check_Semantics; + Expander_Active := False; + end if; + + -- Set the fatal error flag in the unit table unless we are + -- in Try_Semantics mode. This stops the semantics from being + -- performed if we find a parser error. This is skipped if we + -- are currently dealing with the configuration pragma file. + + if not Try_Semantics + and then Current_Source_Unit /= No_Unit + then + Set_Fatal_Error (Get_Source_Unit (Orig_Loc)); + end if; + end Handle_Fatal_Error; + + -- Start of processing for Error_Msg_Internal + + begin + if Raise_Exception_On_Error /= 0 then + raise Error_Msg_Exception; + end if; + + Continuation := Msg_Cont; + Suppress_Message := False; + Kill_Message := False; + Set_Msg_Text (Msg, Orig_Loc); + + -- Kill continuation if parent message killed + + if Continuation and Last_Killed then + return; + end if; + + -- Return without doing anything if message is suppressed + + if Suppress_Message + and not All_Errors_Mode + and not (Msg (Msg'Last) = '!') + then + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + + -- Return without doing anything if message is killed and this + -- is not the first error message. The philosophy is that if we + -- get a weird error message and we already have had a message, + -- then we hope the weird message is a junk cascaded message + + if Kill_Message + and then not All_Errors_Mode + and then Errors_Detected /= 0 + then + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + + -- Immediate return if warning message and warnings are suppressed + + if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then + Cur_Msg := No_Error_Msg; + return; + end if; + + -- If message is to be ignored in special ignore message mode, this is + -- where we do this special processing, bypassing message output. + + if Ignore_Errors_Enable > 0 then + Handle_Fatal_Error; + return; + end if; + + -- Otherwise build error message object for new message + + Errors.Increment_Last; + Cur_Msg := Errors.Last; + Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen)); + Errors.Table (Cur_Msg).Next := No_Error_Msg; + Errors.Table (Cur_Msg).Sptr := Orig_Loc; + Errors.Table (Cur_Msg).Fptr := Flag_Location; + Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Orig_Loc); + Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Orig_Loc); + Errors.Table (Cur_Msg).Col := Get_Column_Number (Orig_Loc); + Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; + Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; + Errors.Table (Cur_Msg).Msg_Cont := Continuation; + Errors.Table (Cur_Msg).Deleted := False; + + -- If immediate errors mode set, output error message now. Also output + -- now if the -d1 debug flag is set (so node number message comes out + -- just before actual error message) + + if Debug_Flag_OO or else Debug_Flag_1 then + Write_Eol; + Output_Source_Line (Errors.Table (Cur_Msg).Line, + Errors.Table (Cur_Msg).Sfile, True); + Temp_Msg := Cur_Msg; + Output_Error_Msgs (Temp_Msg); + + -- If not in immediate errors mode, then we insert the message in the + -- error chain for later output by Finalize. The messages are sorted + -- first by unit (main unit comes first), and within a unit by source + -- location (earlier flag location first in the chain). + + else + Prev_Msg := No_Error_Msg; + Next_Msg := Error_Msgs; + + while Next_Msg /= No_Error_Msg loop + exit when + Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; + + if Errors.Table (Cur_Msg).Sfile = + Errors.Table (Next_Msg).Sfile + then + exit when Orig_Loc < Errors.Table (Next_Msg).Sptr; + end if; + + Prev_Msg := Next_Msg; + Next_Msg := Errors.Table (Next_Msg).Next; + end loop; + + -- Now we insert the new message in the error chain. The insertion + -- point for the message is after Prev_Msg and before Next_Msg. + + -- The possible insertion point for the new message is after Prev_Msg + -- and before Next_Msg. However, this is where we do a special check + -- for redundant parsing messages, defined as messages posted on the + -- same line. The idea here is that probably such messages are junk + -- from the parser recovering. In full errors mode, we don't do this + -- deletion, but otherwise such messages are discarded at this stage. + + if Prev_Msg /= No_Error_Msg + and then Errors.Table (Prev_Msg).Line = + Errors.Table (Cur_Msg).Line + and then Errors.Table (Prev_Msg).Sfile = + Errors.Table (Cur_Msg).Sfile + and then Compiler_State = Parsing + and then not All_Errors_Mode + then + -- Don't delete unconditional messages and at this stage, + -- don't delete continuation lines (we attempted to delete + -- those earlier if the parent message was deleted. + + if not Errors.Table (Cur_Msg).Uncond + and then not Continuation + then + + -- Don't delete if prev msg is warning and new msg is + -- an error. This is because we don't want a real error + -- masked by a warning. In all other cases (that is parse + -- errors for the same line that are not unconditional) + -- we do delete the message. This helps to avoid + -- junk extra messages from cascaded parsing errors + + if not Errors.Table (Prev_Msg).Warn + or else Errors.Table (Cur_Msg).Warn + then + -- All tests passed, delete the message by simply + -- returning without any further processing. + + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + end if; + end if; + + -- Come here if message is to be inserted in the error chain + + if not Continuation then + Last_Killed := False; + end if; + + if Prev_Msg = No_Error_Msg then + Error_Msgs := Cur_Msg; + else + Errors.Table (Prev_Msg).Next := Cur_Msg; + end if; + + Errors.Table (Cur_Msg).Next := Next_Msg; + end if; + + -- Bump appropriate statistics count + + if Errors.Table (Cur_Msg).Warn then + Warnings_Detected := Warnings_Detected + 1; + else + Errors_Detected := Errors_Detected + 1; + Handle_Fatal_Error; + end if; + + -- Terminate if max errors reached + + if Errors_Detected + Warnings_Detected = Maximum_Errors then + raise Unrecoverable_Error; + end if; + + end Error_Msg_Internal; + + ----------------- + -- Error_Msg_N -- + ----------------- + + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + begin + if No_Warnings (N) then + Test_Warning_Msg (Msg); + + if Is_Warning_Msg then + return; + end if; + end if; + + if All_Errors_Mode + or else Msg (Msg'Last) = '!' + or else OK_Node (N) + or else (Msg (1) = '\' and not Last_Killed) + then + Debug_Output (N); + Error_Msg_Node_1 := N; + Error_Msg (Msg, Sloc (N)); + + else + Last_Killed := True; + end if; + + if not Is_Warning_Msg then + Set_Posted (N); + end if; + end Error_Msg_N; + + ------------------ + -- Error_Msg_NE -- + ------------------ + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) + is + begin + if No_Warnings (N) or else No_Warnings (E) then + Test_Warning_Msg (Msg); + + if Is_Warning_Msg then + return; + end if; + end if; + + if All_Errors_Mode + or else Msg (Msg'Last) = '!' + or else OK_Node (N) + or else (Msg (1) = '\' and not Last_Killed) + then + Debug_Output (N); + Error_Msg_Node_1 := E; + Error_Msg (Msg, Sloc (N)); + + else + Last_Killed := True; + end if; + + if not Is_Warning_Msg then + Set_Posted (N); + end if; + end Error_Msg_NE; + + ----------------- + -- Error_Msg_S -- + ----------------- + + procedure Error_Msg_S (Msg : String) is + begin + Error_Msg (Msg, Scan_Ptr); + end Error_Msg_S; + + ------------------ + -- Error_Msg_SC -- + ------------------ + + procedure Error_Msg_SC (Msg : String) is + begin + -- If we are at end of file, post the flag after the previous token + + if Token = Tok_EOF then + Error_Msg_AP (Msg); + + -- For all other cases the message is posted at the current token + -- pointer position + + else + Error_Msg (Msg, Token_Ptr); + end if; + end Error_Msg_SC; + + ------------------ + -- Error_Msg_SP -- + ------------------ + + procedure Error_Msg_SP (Msg : String) is + begin + -- Note: in the case where there is no previous token, Prev_Token_Ptr + -- is set to Source_First, which is a reasonable position for the + -- error flag in this situation + + Error_Msg (Msg, Prev_Token_Ptr); + end Error_Msg_SP; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + Cur : Error_Msg_Id; + Nxt : Error_Msg_Id; + E, F : Error_Msg_Id; + Err_Flag : Boolean; + + begin + -- Reset current error source file if the main unit has a pragma + -- Source_Reference. This ensures outputting the proper name of + -- the source file in this situation. + + if Num_SRef_Pragmas (Main_Source_File) /= 0 then + Current_Error_Source_File := No_Source_File; + end if; + + -- Eliminate any duplicated error messages from the list. This is + -- done after the fact to avoid problems with Change_Error_Text. + + Cur := Error_Msgs; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + + F := Nxt; + while F /= No_Error_Msg + and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr + loop + Check_Duplicate_Message (Cur, F); + F := Errors.Table (F).Next; + end loop; + + Cur := Nxt; + end loop; + + -- Brief Error mode + + if Brief_Output or (not Full_List and not Verbose_Mode) then + E := Error_Msgs; + Set_Standard_Error; + + while E /= No_Error_Msg loop + if not Errors.Table (E).Deleted and then not Debug_Flag_KK then + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; + + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); + Output_Msg_Text (E); + Write_Eol; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end if; + + -- Full source listing case + + if Full_List then + List_Pragmas_Index := 1; + List_Pragmas_Mode := True; + E := Error_Msgs; + Write_Eol; + + -- First list initial main source file with its error messages + + for N in 1 .. Last_Source_Line (Main_Source_File) loop + Err_Flag := + E /= No_Error_Msg + and then Errors.Table (E).Line = N + and then Errors.Table (E).Sfile = Main_Source_File; + + Output_Source_Line (N, Main_Source_File, Err_Flag); + + if Err_Flag then + Output_Error_Msgs (E); + + if not Debug_Flag_2 then + Write_Eol; + end if; + end if; + + end loop; + + -- Then output errors, if any, for subsidiary units + + while E /= No_Error_Msg + and then Errors.Table (E).Sfile /= Main_Source_File + loop + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True); + Output_Error_Msgs (E); + end loop; + end if; + + -- Verbose mode (error lines only with error flags) + + if Verbose_Mode and not Full_List then + E := Error_Msgs; + + -- Loop through error lines + + while E /= No_Error_Msg loop + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True); + Output_Error_Msgs (E); + end loop; + end if; + + -- Output error summary if verbose or full list mode + + if Verbose_Mode or else Full_List then + + -- Extra blank line if error messages or source listing were output + + if Errors_Detected + Warnings_Detected > 0 or else Full_List then + Write_Eol; + end if; + + -- Message giving number of lines read and number of errors detected. + -- This normally goes to Standard_Output. The exception is when brief + -- mode is not set, verbose mode (or full list mode) is set, and + -- there are errors. In this case we send the message to standard + -- error to make sure that *something* appears on standard error in + -- an error situation. + + -- Formerly, only the "# errors" suffix was sent to stderr, whereas + -- "# lines:" appeared on stdout. This caused problems on VMS when + -- the stdout buffer was flushed, giving an extra line feed after + -- the prefix. + + if Errors_Detected + Warnings_Detected /= 0 + and then not Brief_Output + and then (Verbose_Mode or Full_List) + then + Set_Standard_Error; + end if; + + -- Message giving total number of lines + + Write_Str (" "); + Write_Int (Num_Source_Lines (Main_Source_File)); + + if Num_Source_Lines (Main_Source_File) = 1 then + Write_Str (" line: "); + else + Write_Str (" lines: "); + end if; + + if Errors_Detected = 0 then + Write_Str ("No errors"); + + elsif Errors_Detected = 1 then + Write_Str ("1 error"); + + else + Write_Int (Errors_Detected); + Write_Str (" errors"); + end if; + + if Warnings_Detected /= 0 then + Write_Str (", "); + Write_Int (Warnings_Detected); + Write_Str (" warning"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + if Warning_Mode = Treat_As_Error then + Write_Str (" (treated as error"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + Write_Char (')'); + end if; + end if; + + Write_Eol; + Set_Standard_Output; + end if; + + if Maximum_Errors /= 0 + and then Errors_Detected + Warnings_Detected = Maximum_Errors + then + Set_Standard_Error; + Write_Str ("fatal error: maximum errors reached"); + Write_Eol; + Set_Standard_Output; + end if; + + if Warning_Mode = Treat_As_Error then + Errors_Detected := Errors_Detected + Warnings_Detected; + Warnings_Detected := 0; + end if; + + end Finalize; + + ------------------ + -- Get_Location -- + ------------------ + + function Get_Location (E : Error_Msg_Id) return Source_Ptr is + begin + return Errors.Table (E).Sptr; + end Get_Location; + + ---------------- + -- Get_Msg_Id -- + ---------------- + + function Get_Msg_Id return Error_Msg_Id is + begin + return Cur_Msg; + end Get_Msg_Id; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Errors.Init; + Error_Msgs := No_Error_Msg; + Errors_Detected := 0; + Warnings_Detected := 0; + Cur_Msg := No_Error_Msg; + List_Pragmas.Init; + + -- Initialize warnings table, if all warnings are suppressed, supply + -- an initial dummy entry covering all possible source locations. + + Warnings.Init; + + if Warning_Mode = Suppress then + Warnings.Increment_Last; + Warnings.Table (Warnings.Last).Start := Source_Ptr'First; + Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last; + end if; + + end Initialize; + + ----------------- + -- No_Warnings -- + ----------------- + + function No_Warnings (N : Node_Or_Entity_Id) return Boolean is + begin + if Error_Posted (N) then + return True; + + elsif Nkind (N) in N_Entity and then Warnings_Off (N) then + return True; + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Warnings_Off (Entity (N)) + then + return True; + + else + return False; + end if; + end No_Warnings; + + ------------- + -- OK_Node -- + ------------- + + function OK_Node (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + + begin + if Error_Posted (N) then + return False; + + elsif K in N_Has_Etype + and then Present (Etype (N)) + and then Error_Posted (Etype (N)) + then + return False; + + elsif (K in N_Op + or else K = N_Attribute_Reference + or else K = N_Character_Literal + or else K = N_Expanded_Name + or else K = N_Identifier + or else K = N_Operator_Symbol) + and then Present (Entity (N)) + and then Error_Posted (Entity (N)) + then + return False; + else + return True; + end if; + end OK_Node; + + ----------------------- + -- Output_Error_Msgs -- + ----------------------- + + procedure Output_Error_Msgs (E : in out Error_Msg_Id) is + P : Source_Ptr; + T : Error_Msg_Id; + S : Error_Msg_Id; + + Flag_Num : Pos; + Mult_Flags : Boolean := False; + + begin + S := E; + + -- Skip deleted messages at start + + if Errors.Table (S).Deleted then + Set_Next_Non_Deleted_Msg (S); + end if; + + -- Figure out if we will place more than one error flag on this line + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + loop + if Errors.Table (T).Sptr > Errors.Table (E).Sptr then + Mult_Flags := True; + end if; + + Set_Next_Non_Deleted_Msg (T); + end loop; + + -- Output the error flags. The circuit here makes sure that the tab + -- characters in the original line are properly accounted for. The + -- eight blanks at the start are to match the line number. + + if not Debug_Flag_2 then + Write_Str (" "); + P := Line_Start (Errors.Table (E).Sptr); + Flag_Num := 1; + + -- Loop through error messages for this line to place flags + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + loop + -- Loop to output blanks till current flag position + + while P < Errors.Table (T).Sptr loop + if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then + Write_Char (ASCII.HT); + else + Write_Char (' '); + end if; + + P := P + 1; + end loop; + + -- Output flag (unless already output, this happens if more + -- than one error message occurs at the same flag position). + + if P = Errors.Table (T).Sptr then + if (Flag_Num = 1 and then not Mult_Flags) + or else Flag_Num > 9 + then + Write_Char ('|'); + else + Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); + end if; + + P := P + 1; + end if; + + Set_Next_Non_Deleted_Msg (T); + Flag_Num := Flag_Num + 1; + end loop; + + Write_Eol; + end if; + + -- Now output the error messages + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + + loop + Write_Str (" >>> "); + Output_Msg_Text (T); + + if Debug_Flag_2 then + while Column < 74 loop + Write_Char (' '); + end loop; + + Write_Str (" <<<"); + end if; + + Write_Eol; + Set_Next_Non_Deleted_Msg (T); + end loop; + + E := T; + end Output_Error_Msgs; + + ------------------------ + -- Output_Line_Number -- + ------------------------ + + procedure Output_Line_Number (L : Logical_Line_Number) is + D : Int; -- next digit + C : Character; -- next character + Z : Boolean; -- flag for zero suppress + N, M : Int; -- temporaries + + begin + if L = No_Line_Number then + Write_Str (" "); + + else + Z := False; + N := Int (L); + + M := 100_000; + while M /= 0 loop + D := Int (N / M); + N := N rem M; + M := M / 10; + + if D = 0 then + if Z then + C := '0'; + else + C := ' '; + end if; + else + Z := True; + C := Character'Val (D + 48); + end if; + + Write_Char (C); + end loop; + + Write_Str (". "); + end if; + end Output_Line_Number; + + --------------------- + -- Output_Msg_Text -- + --------------------- + + procedure Output_Msg_Text (E : Error_Msg_Id) is + begin + if Errors.Table (E).Warn then + if Errors.Table (E).Text'Length > 7 + and then Errors.Table (E).Text (1 .. 7) /= "(style)" + then + Write_Str ("warning: "); + end if; + + elsif Opt.Unique_Error_Tag then + Write_Str ("error: "); + end if; + + Write_Str (Errors.Table (E).Text.all); + end Output_Msg_Text; + + ------------------------ + -- Output_Source_Line -- + ------------------------ + + procedure Output_Source_Line + (L : Physical_Line_Number; + Sfile : Source_File_Index; + Errs : Boolean) + is + S : Source_Ptr; + C : Character; + + Line_Number_Output : Boolean := False; + -- Set True once line number is output + + begin + if Sfile /= Current_Error_Source_File then + Write_Str ("==============Error messages for source file: "); + Write_Name (Full_File_Name (Sfile)); + Write_Eol; + + if Num_SRef_Pragmas (Sfile) > 0 then + Write_Str ("--------------Line numbers from file: "); + Write_Name (Full_Ref_Name (Sfile)); + + -- Write starting line, except do not write it if we had more + -- than one source reference pragma, since in this case there + -- is no very useful number to write. + + Write_Str (" (starting at line "); + Write_Int (Int (First_Mapped_Line (Sfile))); + Write_Char (')'); + Write_Eol; + end if; + + Current_Error_Source_File := Sfile; + end if; + + if Errs or List_Pragmas_Mode then + Output_Line_Number (Physical_To_Logical (L, Sfile)); + Line_Number_Output := True; + end if; + + S := Line_Start (L, Sfile); + + loop + C := Source_Text (Sfile) (S); + exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; + + -- Deal with matching entry in List_Pragmas table + + if Full_List + and then List_Pragmas_Index <= List_Pragmas.Last + and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc + then + case List_Pragmas.Table (List_Pragmas_Index).Ptyp is + when Page => + Write_Char (C); + + -- Ignore if on line with errors so that error flags + -- get properly listed with the error line . + + if not Errs then + Write_Char (ASCII.FF); + end if; + + when List_On => + List_Pragmas_Mode := True; + + if not Line_Number_Output then + Output_Line_Number (Physical_To_Logical (L, Sfile)); + Line_Number_Output := True; + end if; + + Write_Char (C); + + when List_Off => + Write_Char (C); + List_Pragmas_Mode := False; + end case; + + List_Pragmas_Index := List_Pragmas_Index + 1; + + -- Normal case (no matching entry in List_Pragmas table) + + else + if Errs or List_Pragmas_Mode then + Write_Char (C); + end if; + end if; + + S := S + 1; + end loop; + + if Line_Number_Output then + Write_Eol; + end if; + end Output_Source_Line; + + -------------------- + -- Purge_Messages -- + -------------------- + + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is + E : Error_Msg_Id; + + function To_Be_Purged (E : Error_Msg_Id) return Boolean; + -- Returns True for a message that is to be purged. Also adjusts + -- error counts appropriately. + + function To_Be_Purged (E : Error_Msg_Id) return Boolean is + begin + if E /= No_Error_Msg + and then Errors.Table (E).Sptr > From + and then Errors.Table (E).Sptr < To + then + if Errors.Table (E).Warn then + Warnings_Detected := Warnings_Detected - 1; + else + Errors_Detected := Errors_Detected - 1; + end if; + + return True; + + else + return False; + end if; + end To_Be_Purged; + + -- Start of processing for Purge_Messages + + begin + while To_Be_Purged (Error_Msgs) loop + Error_Msgs := Errors.Table (Error_Msgs).Next; + end loop; + + E := Error_Msgs; + while E /= No_Error_Msg loop + while To_Be_Purged (Errors.Table (E).Next) loop + Errors.Table (E).Next := + Errors.Table (Errors.Table (E).Next).Next; + end loop; + + E := Errors.Table (E).Next; + end loop; + end Purge_Messages; + + ----------------------------- + -- Remove_Warning_Messages -- + ----------------------------- + + procedure Remove_Warning_Messages (N : Node_Id) is + + function Check_For_Warning (N : Node_Id) return Traverse_Result; + -- This function checks one node for a possible warning message. + + function Check_All_Warnings is new + Traverse_Func (Check_For_Warning); + -- This defines the traversal operation + + Discard : Traverse_Result; + + ----------------------- + -- Check_For_Warning -- + ----------------------- + + function Check_For_Warning (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + E : Error_Msg_Id; + + function To_Be_Removed (E : Error_Msg_Id) return Boolean; + -- Returns True for a message that is to be removed. Also adjusts + -- warning count appropriately. + + function To_Be_Removed (E : Error_Msg_Id) return Boolean is + begin + if E /= No_Error_Msg + and then Errors.Table (E).Fptr = Loc + and then Errors.Table (E).Warn + then + Warnings_Detected := Warnings_Detected - 1; + return True; + else + return False; + end if; + end To_Be_Removed; + + -- Start of processing for Check_For_Warnings + + begin + while To_Be_Removed (Error_Msgs) loop + Error_Msgs := Errors.Table (Error_Msgs).Next; + end loop; + + E := Error_Msgs; + while E /= No_Error_Msg loop + while To_Be_Removed (Errors.Table (E).Next) loop + Errors.Table (E).Next := + Errors.Table (Errors.Table (E).Next).Next; + end loop; + + E := Errors.Table (E).Next; + end loop; + + return OK; + end Check_For_Warning; + + -- Start of processing for Remove_Warning_Messages + + begin + if Warnings_Detected /= 0 then + Discard := Check_All_Warnings (N); + end if; + end Remove_Warning_Messages; + + ---------------- + -- Same_Error -- + ---------------- + + function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is + Msg1 : constant String_Ptr := Errors.Table (M1).Text; + Msg2 : constant String_Ptr := Errors.Table (M2).Text; + + Msg2_Len : constant Integer := Msg2'Length; + Msg1_Len : constant Integer := Msg1'Length; + + begin + return + Msg1.all = Msg2.all + or else + (Msg1_Len - 10 > Msg2_Len + and then + Msg2.all = Msg1.all (1 .. Msg2_Len) + and then + Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance") + or else + (Msg2_Len - 10 > Msg1_Len + and then + Msg1.all = Msg2.all (1 .. Msg1_Len) + and then + Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance"); + end Same_Error; + + ------------------- + -- Set_Msg_Blank -- + ------------------- + + procedure Set_Msg_Blank is + begin + if Msglen > 0 + and then Msg_Buffer (Msglen) /= ' ' + and then Msg_Buffer (Msglen) /= '(' + and then not Manual_Quote_Mode + then + Set_Msg_Char (' '); + end if; + end Set_Msg_Blank; + + ------------------------------- + -- Set_Msg_Blank_Conditional -- + ------------------------------- + + procedure Set_Msg_Blank_Conditional is + begin + if Msglen > 0 + and then Msg_Buffer (Msglen) /= ' ' + and then Msg_Buffer (Msglen) /= '(' + and then Msg_Buffer (Msglen) /= '"' + and then not Manual_Quote_Mode + then + Set_Msg_Char (' '); + end if; + end Set_Msg_Blank_Conditional; + + ------------------ + -- Set_Msg_Char -- + ------------------ + + procedure Set_Msg_Char (C : Character) is + begin + + -- The check for message buffer overflow is needed to deal with cases + -- where insertions get too long (in particular a child unit name can + -- be very long). + + if Msglen < Max_Msg_Length then + Msglen := Msglen + 1; + Msg_Buffer (Msglen) := C; + end if; + end Set_Msg_Char; + + ------------------------------ + -- Set_Msg_Insertion_Column -- + ------------------------------ + + procedure Set_Msg_Insertion_Column is + begin + if Style.RM_Column_Check then + Set_Msg_Str (" in column "); + Set_Msg_Int (Int (Error_Msg_Col) + 1); + end if; + end Set_Msg_Insertion_Column; + + --------------------------------- + -- Set_Msg_Insertion_File_Name -- + --------------------------------- + + procedure Set_Msg_Insertion_File_Name is + begin + if Error_Msg_Name_1 = No_Name then + null; + + elsif Error_Msg_Name_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + else + Set_Msg_Blank; + Get_Name_String (Error_Msg_Name_1); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + + -- The following assignments ensure that the second and third percent + -- insertion characters will correspond to the Error_Msg_Name_2 and + -- Error_Msg_Name_3 as required. + + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; + + end Set_Msg_Insertion_File_Name; + + ----------------------------------- + -- Set_Msg_Insertion_Line_Number -- + ----------------------------------- + + procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is + Sindex_Loc : Source_File_Index; + Sindex_Flag : Source_File_Index; + + begin + Set_Msg_Blank; + + if Loc = No_Location then + Set_Msg_Str ("at unknown location"); + + elsif Loc <= Standard_Location then + Set_Msg_Str ("in package Standard"); + + if Loc = Standard_ASCII_Location then + Set_Msg_Str (".ASCII"); + end if; + + else + -- Add "at file-name:" if reference is to other than the source + -- file in which the error message is placed. Note that we check + -- full file names, rather than just the source indexes, to + -- deal with generic instantiations from the current file. + + Sindex_Loc := Get_Source_File_Index (Loc); + Sindex_Flag := Get_Source_File_Index (Flag); + + if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then + Set_Msg_Str ("at "); + Get_Name_String + (Reference_Name (Get_Source_File_Index (Loc))); + Set_Msg_Name_Buffer; + Set_Msg_Char (':'); + + -- If in current file, add text "at line " + + else + Set_Msg_Str ("at line "); + end if; + + -- Output line number for reference + + Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); + + -- Deal with the instantiation case. We may have a reference to, + -- e.g. a type, that is declared within a generic template, and + -- what we are really referring to is the occurrence in an instance. + -- In this case, the line number of the instantiation is also of + -- interest, and we add a notation: + + -- , instance at xxx + + -- where xxx is a line number output using this same routine (and + -- the recursion can go further if the instantiation is itself in + -- a generic template). + + -- The flag location passed to us in this situation is indeed the + -- line number within the template, but as described in Sinput.L + -- (file sinput-l.ads, section "Handling Generic Instantiations") + -- we can retrieve the location of the instantiation itself from + -- this flag location value. + + -- Note: this processing is suppressed if Suppress_Instance_Location + -- is set True. This is used to prevent redundant annotations of the + -- location of the instantiation in the case where we are placing + -- the messages on the instantiation in any case. + + if Instantiation (Sindex_Loc) /= No_Location + and then not Suppress_Instance_Location + then + Set_Msg_Str (", instance "); + Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag); + end if; + end if; + end Set_Msg_Insertion_Line_Number; + + ---------------------------- + -- Set_Msg_Insertion_Name -- + ---------------------------- + + procedure Set_Msg_Insertion_Name is + begin + if Error_Msg_Name_1 = No_Name then + null; + + elsif Error_Msg_Name_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + else + Set_Msg_Blank_Conditional; + Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1); + + -- Remove %s or %b at end. These come from unit names. If the + -- caller wanted the (unit) or (body), then they would have used + -- the $ insertion character. Certainly no error message should + -- ever have %b or %s explicitly occurring. + + if Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then (Name_Buffer (Name_Len) = 'b' + or else + Name_Buffer (Name_Len) = 's') + then + Name_Len := Name_Len - 2; + end if; + + -- Remove upper case letter at end, again, we should not be getting + -- such names, and what we hope is that the remainder makes sense. + + if Name_Len > 1 + and then Name_Buffer (Name_Len) in 'A' .. 'Z' + then + Name_Len := Name_Len - 1; + end if; + + -- If operator name or character literal name, just print it as is + -- Also print as is if it ends in a right paren (case of x'val(nnn)) + + if Name_Buffer (1) = '"' + or else Name_Buffer (1) = ''' + or else Name_Buffer (Name_Len) = ')' + then + Set_Msg_Name_Buffer; + + -- Else output with surrounding quotes in proper casing mode + + else + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + end if; + + -- The following assignments ensure that the second and third percent + -- insertion characters will correspond to the Error_Msg_Name_2 and + -- Error_Msg_Name_3 as required. + + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; + + end Set_Msg_Insertion_Name; + + ---------------------------- + -- Set_Msg_Insertion_Node -- + ---------------------------- + + procedure Set_Msg_Insertion_Node is + begin + Suppress_Message := + Error_Msg_Node_1 = Error + or else Error_Msg_Node_1 = Any_Type; + + if Error_Msg_Node_1 = Empty then + Set_Msg_Blank_Conditional; + Set_Msg_Str ("<empty>"); + + elsif Error_Msg_Node_1 = Error then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + elsif Error_Msg_Node_1 = Standard_Void_Type then + Set_Msg_Blank; + Set_Msg_Str ("procedure name"); + + else + Set_Msg_Blank_Conditional; + + -- Skip quotes for operator case + + if Nkind (Error_Msg_Node_1) in N_Op then + Set_Msg_Node (Error_Msg_Node_1); + + else + Set_Msg_Quote; + Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1); + Set_Msg_Node (Error_Msg_Node_1); + Set_Msg_Quote; + end if; + end if; + + -- The following assignment ensures that a second ampersand insertion + -- character will correspond to the Error_Msg_Node_2 parameter. + + Error_Msg_Node_1 := Error_Msg_Node_2; + + end Set_Msg_Insertion_Node; + + ------------------------------------- + -- Set_Msg_Insertion_Reserved_Name -- + ------------------------------------- + + procedure Set_Msg_Insertion_Reserved_Name is + begin + Set_Msg_Blank_Conditional; + Get_Name_String (Error_Msg_Name_1); + Set_Msg_Quote; + Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end Set_Msg_Insertion_Reserved_Name; + + ------------------------------------- + -- Set_Msg_Insertion_Reserved_Word -- + ------------------------------------- + + procedure Set_Msg_Insertion_Reserved_Word + (Text : String; + J : in out Integer) + is + begin + Set_Msg_Blank_Conditional; + Name_Len := 0; + + while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Text (J); + J := J + 1; + end loop; + + Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end Set_Msg_Insertion_Reserved_Word; + + -------------------------------------- + -- Set_Msg_Insertion_Type_Reference -- + -------------------------------------- + + procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is + Ent : Entity_Id; + + begin + Set_Msg_Blank; + + if Error_Msg_Node_1 = Standard_Void_Type then + Set_Msg_Str ("package or procedure name"); + return; + + elsif Error_Msg_Node_1 = Standard_Exception_Type then + Set_Msg_Str ("exception name"); + return; + + elsif Error_Msg_Node_1 = Any_Access + or else Error_Msg_Node_1 = Any_Array + or else Error_Msg_Node_1 = Any_Boolean + or else Error_Msg_Node_1 = Any_Character + or else Error_Msg_Node_1 = Any_Composite + or else Error_Msg_Node_1 = Any_Discrete + or else Error_Msg_Node_1 = Any_Fixed + or else Error_Msg_Node_1 = Any_Integer + or else Error_Msg_Node_1 = Any_Modular + or else Error_Msg_Node_1 = Any_Numeric + or else Error_Msg_Node_1 = Any_Real + or else Error_Msg_Node_1 = Any_Scalar + or else Error_Msg_Node_1 = Any_String + then + Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1)); + Set_Msg_Name_Buffer; + return; + + elsif Error_Msg_Node_1 = Universal_Real then + Set_Msg_Str ("type universal real"); + return; + + elsif Error_Msg_Node_1 = Universal_Integer then + Set_Msg_Str ("type universal integer"); + return; + + elsif Error_Msg_Node_1 = Universal_Fixed then + Set_Msg_Str ("type universal fixed"); + return; + end if; + + -- Special case of anonymous array + + if Nkind (Error_Msg_Node_1) in N_Entity + and then Is_Array_Type (Error_Msg_Node_1) + and then Present (Related_Array_Object (Error_Msg_Node_1)) + then + Set_Msg_Str ("type of "); + Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1)); + Set_Msg_Str (" declared"); + Set_Msg_Insertion_Line_Number + (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag); + return; + end if; + + -- If we fall through, it is not a special case, so first output + -- the name of the type, preceded by private for a private type + + if Is_Private_Type (Error_Msg_Node_1) then + Set_Msg_Str ("private type "); + else + Set_Msg_Str ("type "); + end if; + + Ent := Error_Msg_Node_1; + + if Is_Internal_Name (Chars (Ent)) then + Unwind_Internal_Type (Ent); + end if; + + -- Types in Standard are displayed as "Standard.name" + + if Sloc (Ent) <= Standard_Location then + Set_Msg_Quote; + Set_Msg_Str ("Standard."); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + + -- Types in other language defined units are displayed as + -- "package-name.type-name" + + elsif + Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent))) + then + Get_Unqualified_Decoded_Name_String + (Unit_Name (Get_Source_Unit (Ent))); + Name_Len := Name_Len - 2; + Set_Msg_Quote; + Set_Casing (Mixed_Case); + Set_Msg_Name_Buffer; + Set_Msg_Char ('.'); + Set_Casing (Mixed_Case); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + + -- All other types display as "type name" defined at line xxx + -- possibly qualified if qualification is requested. + + else + Set_Msg_Quote; + Set_Qualification (Error_Msg_Qual_Level, Ent); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + end if; + + -- If the original type did not come from a predefined + -- file, add the location where the type was defined. + + if Sloc (Error_Msg_Node_1) > Standard_Location + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1))) + then + Set_Msg_Str (" defined"); + Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag); + + -- If it did come from a predefined file, deal with the case where + -- this was a file with a generic instantiation from elsewhere. + + else + if Sloc (Error_Msg_Node_1) > Standard_Location then + declare + Iloc : constant Source_Ptr := + Instantiation_Location (Sloc (Error_Msg_Node_1)); + + begin + if Iloc /= No_Location + and then not Suppress_Instance_Location + then + Set_Msg_Str (" from instance"); + Set_Msg_Insertion_Line_Number (Iloc, Flag); + end if; + end; + end if; + end if; + + end Set_Msg_Insertion_Type_Reference; + + ---------------------------- + -- Set_Msg_Insertion_Uint -- + ---------------------------- + + procedure Set_Msg_Insertion_Uint is + begin + Set_Msg_Blank; + UI_Image (Error_Msg_Uint_1); + + for J in 1 .. UI_Image_Length loop + Set_Msg_Char (UI_Image_Buffer (J)); + end loop; + + -- The following assignment ensures that a second carret insertion + -- character will correspond to the Error_Msg_Uint_2 parameter. + + Error_Msg_Uint_1 := Error_Msg_Uint_2; + end Set_Msg_Insertion_Uint; + + --------------------------------- + -- Set_Msg_Insertion_Unit_Name -- + --------------------------------- + + procedure Set_Msg_Insertion_Unit_Name is + begin + if Error_Msg_Unit_1 = No_Name then + null; + + elsif Error_Msg_Unit_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + else + Get_Unit_Name_String (Error_Msg_Unit_1); + Set_Msg_Blank; + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + + -- The following assignment ensures that a second percent insertion + -- character will correspond to the Error_Msg_Unit_2 parameter. + + Error_Msg_Unit_1 := Error_Msg_Unit_2; + + end Set_Msg_Insertion_Unit_Name; + + ----------------- + -- Set_Msg_Int -- + ----------------- + + procedure Set_Msg_Int (Line : Int) is + begin + if Line > 9 then + Set_Msg_Int (Line / 10); + end if; + + Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10))); + end Set_Msg_Int; + + ------------------------- + -- Set_Msg_Name_Buffer -- + ------------------------- + + procedure Set_Msg_Name_Buffer is + begin + for J in 1 .. Name_Len loop + Set_Msg_Char (Name_Buffer (J)); + end loop; + end Set_Msg_Name_Buffer; + + ------------------ + -- Set_Msg_Node -- + ------------------ + + procedure Set_Msg_Node (Node : Node_Id) is + Ent : Entity_Id; + Nam : Name_Id; + + begin + if Nkind (Node) = N_Designator then + Set_Msg_Node (Name (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Identifier (Node)); + return; + + elsif Nkind (Node) = N_Defining_Program_Unit_Name then + Set_Msg_Node (Name (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Defining_Identifier (Node)); + return; + + elsif Nkind (Node) = N_Selected_Component then + Set_Msg_Node (Prefix (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Selector_Name (Node)); + return; + end if; + + -- The only remaining possibilities are identifiers, defining + -- identifiers, pragmas, and pragma argument associations, i.e. + -- nodes that have a Chars field. + + -- Internal names generally represent something gone wrong. An exception + -- is the case of internal type names, where we try to find a reasonable + -- external representation for the external name + + if Is_Internal_Name (Chars (Node)) + and then + ((Is_Entity_Name (Node) + and then Present (Entity (Node)) + and then Is_Type (Entity (Node))) + or else + (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) + then + if Nkind (Node) = N_Identifier then + Ent := Entity (Node); + else + Ent := Node; + end if; + + Unwind_Internal_Type (Ent); + Nam := Chars (Ent); + + else + Nam := Chars (Node); + end if; + + -- At this stage, the name to output is in Nam + + Get_Unqualified_Decoded_Name_String (Nam); + + -- Remove trailing upper case letters from the name (useful for + -- dealing with some cases of internal names. + + while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop + Name_Len := Name_Len - 1; + end loop; + + -- If we have any of the names from standard that start with the + -- characters "any " (e.g. Any_Type), then kill the message since + -- almost certainly it is a junk cascaded message. + + if Name_Len > 4 + and then Name_Buffer (1 .. 4) = "any " + then + Kill_Message := True; + end if; + + -- Now we have to set the proper case. If we have a source location + -- then do a check to see if the name in the source is the same name + -- as the name in the Names table, except for possible differences + -- in case, which is the case when we can copy from the source. + + declare + Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1); + Sbuffer : Source_Buffer_Ptr; + Ref_Ptr : Integer; + Src_Ptr : Source_Ptr; + + begin + Ref_Ptr := 1; + Src_Ptr := Src_Loc; + + -- Determine if the reference we are dealing with corresponds + -- to text at the point of the error reference. This will often + -- be the case for simple identifier references, and is the case + -- where we can copy the spelling from the source. + + if Src_Loc /= No_Location + and then Src_Loc > Standard_Location + then + Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc)); + + while Ref_Ptr <= Name_Len loop + exit when + Fold_Lower (Sbuffer (Src_Ptr)) /= + Fold_Lower (Name_Buffer (Ref_Ptr)); + Ref_Ptr := Ref_Ptr + 1; + Src_Ptr := Src_Ptr + 1; + end loop; + end if; + + -- If we get through the loop without a mismatch, then output + -- the name the way it is spelled in the source program + + if Ref_Ptr > Name_Len then + Src_Ptr := Src_Loc; + + for J in 1 .. Name_Len loop + Name_Buffer (J) := Sbuffer (Src_Ptr); + Src_Ptr := Src_Ptr + 1; + end loop; + + -- Otherwise set the casing using the default identifier casing + + else + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + end if; + end; + + Set_Msg_Name_Buffer; + Add_Class; + + -- Add 'Class if class wide type + + if Class_Flag then + Set_Msg_Char ('''); + Get_Name_String (Name_Class); + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Name_Buffer; + end if; + end Set_Msg_Node; + + ------------------- + -- Set_Msg_Quote -- + ------------------- + + procedure Set_Msg_Quote is + begin + if not Manual_Quote_Mode then + Set_Msg_Char ('"'); + end if; + end Set_Msg_Quote; + + ----------------- + -- Set_Msg_Str -- + ----------------- + + procedure Set_Msg_Str (Text : String) is + begin + for J in Text'Range loop + Set_Msg_Char (Text (J)); + end loop; + end Set_Msg_Str; + + ------------------ + -- Set_Msg_Text -- + ------------------ + + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is + C : Character; -- Current character + P : Natural; -- Current index; + + begin + Manual_Quote_Mode := False; + Is_Unconditional_Msg := False; + Msglen := 0; + Flag_Source := Get_Source_File_Index (Flag); + P := Text'First; + + while P <= Text'Last loop + C := Text (P); + P := P + 1; + + -- Check for insertion character + + if C = '%' then + Set_Msg_Insertion_Name; + + elsif C = '$' then + Set_Msg_Insertion_Unit_Name; + + elsif C = '{' then + Set_Msg_Insertion_File_Name; + + elsif C = '}' then + Set_Msg_Insertion_Type_Reference (Flag); + + elsif C = '*' then + Set_Msg_Insertion_Reserved_Name; + + elsif C = '&' then + Set_Msg_Insertion_Node; + + elsif C = '#' then + Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); + + elsif C = '\' then + Continuation := True; + + elsif C = '@' then + Set_Msg_Insertion_Column; + + elsif C = '^' then + Set_Msg_Insertion_Uint; + + elsif C = '`' then + Manual_Quote_Mode := not Manual_Quote_Mode; + Set_Msg_Char ('"'); + + elsif C = '!' then + Is_Unconditional_Msg := True; + + elsif C = '?' then + null; + + elsif C = ''' then + Set_Msg_Char (Text (P)); + P := P + 1; + + -- Upper case letter (start of reserved word if 2 or more) + + elsif C in 'A' .. 'Z' + and then P <= Text'Last + and then Text (P) in 'A' .. 'Z' + then + P := P - 1; + Set_Msg_Insertion_Reserved_Word (Text, P); + + -- Normal character with no special treatment + + else + Set_Msg_Char (C); + end if; + + end loop; + end Set_Msg_Text; + + ------------------------------ + -- Set_Next_Non_Deleted_Msg -- + ------------------------------ + + procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is + begin + if E = No_Error_Msg then + return; + + else + loop + E := Errors.Table (E).Next; + exit when E = No_Error_Msg or else not Errors.Table (E).Deleted; + end loop; + end if; + end Set_Next_Non_Deleted_Msg; + + ---------------- + -- Set_Posted -- + ---------------- + + procedure Set_Posted (N : Node_Id) is + P : Node_Id; + + begin + -- We always set Error_Posted on the node itself + + Set_Error_Posted (N); + + -- If it is a subexpression, then set Error_Posted on parents + -- up to and including the first non-subexpression construct. This + -- helps avoid cascaded error messages within a single expression. + + P := N; + loop + P := Parent (P); + exit when No (P); + Set_Error_Posted (P); + exit when Nkind (P) not in N_Subexpr; + end loop; + end Set_Posted; + + ----------------------- + -- Set_Qualification -- + ----------------------- + + procedure Set_Qualification (N : Nat; E : Entity_Id) is + begin + if N /= 0 and then Scope (E) /= Standard_Standard then + Set_Qualification (N - 1, Scope (E)); + Set_Msg_Node (Scope (E)); + Set_Msg_Char ('.'); + end if; + end Set_Qualification; + + --------------------------- + -- Set_Warnings_Mode_Off -- + --------------------------- + + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is + begin + -- Don't bother with entries from instantiation copies, since we + -- will already have a copy in the template, which is what matters + + if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then + return; + end if; + + -- If last entry in table already covers us, this is a redundant + -- pragma Warnings (Off) and can be ignored. This also handles the + -- case where all warnings are suppressed by command line switch. + + if Warnings.Last >= Warnings.First + and then Warnings.Table (Warnings.Last).Start <= Loc + and then Loc <= Warnings.Table (Warnings.Last).Stop + then + return; + + -- Otherwise establish a new entry, extending from the location of + -- the pragma to the end of the current source file. This ending + -- point will be adjusted by a subsequent pragma Warnings (On). + + else + Warnings.Increment_Last; + Warnings.Table (Warnings.Last).Start := Loc; + Warnings.Table (Warnings.Last).Stop := + Source_Last (Current_Source_File); + end if; + end Set_Warnings_Mode_Off; + + -------------------------- + -- Set_Warnings_Mode_On -- + -------------------------- + + procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is + begin + -- Don't bother with entries from instantiation copies, since we + -- will already have a copy in the template, which is what matters + + if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then + return; + end if; + + -- Nothing to do unless command line switch to suppress all warnings + -- is off, and the last entry in the warnings table covers this + -- pragma Warnings (On), in which case adjust the end point. + + if (Warnings.Last >= Warnings.First + and then Warnings.Table (Warnings.Last).Start <= Loc + and then Loc <= Warnings.Table (Warnings.Last).Stop) + and then Warning_Mode /= Suppress + then + Warnings.Table (Warnings.Last).Stop := Loc; + end if; + end Set_Warnings_Mode_On; + + ---------------------- + -- Test_Warning_Msg -- + ---------------------- + + procedure Test_Warning_Msg (Msg : String) is + begin + if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then + Is_Warning_Msg := True; + return; + end if; + + for J in Msg'Range loop + if Msg (J) = '?' + and then (J = Msg'First or else Msg (J - 1) /= ''') + then + Is_Warning_Msg := True; + return; + end if; + end loop; + + Is_Warning_Msg := False; + end Test_Warning_Msg; + + -------------------------- + -- Unwind_Internal_Type -- + -------------------------- + + procedure Unwind_Internal_Type (Ent : in out Entity_Id) is + Derived : Boolean := False; + Mchar : Character; + Old_Ent : Entity_Id; + + begin + -- Undo placement of a quote, since we will put it back later + + Mchar := Msg_Buffer (Msglen); + + if Mchar = '"' then + Msglen := Msglen - 1; + end if; + + -- The loop here deals with recursive types, we are trying to + -- find a related entity that is not an implicit type. Note + -- that the check with Old_Ent stops us from getting "stuck". + -- Also, we don't output the "type derived from" message more + -- than once in the case where we climb up multiple levels. + + loop + Old_Ent := Ent; + + -- Implicit access type, use directly designated type + + if Is_Access_Type (Ent) then + Set_Msg_Str ("access to "); + Ent := Directly_Designated_Type (Ent); + + -- Classwide type + + elsif Is_Class_Wide_Type (Ent) then + Class_Flag := True; + Ent := Root_Type (Ent); + + -- Use base type if this is a subtype + + elsif Ent /= Base_Type (Ent) then + Buffer_Remove ("type "); + + -- Avoid duplication "subtype of subtype of", and also replace + -- "derived from subtype of" simply by "derived from" + + if not Buffer_Ends_With ("subtype of ") + and then not Buffer_Ends_With ("derived from ") + then + Set_Msg_Str ("subtype of "); + end if; + + Ent := Base_Type (Ent); + + -- If this is a base type with a first named subtype, use the + -- first named subtype instead. This is not quite accurate in + -- all cases, but it makes too much noise to be accurate and + -- add 'Base in all cases. Note that we only do this is the + -- first named subtype is not itself an internal name. This + -- avoids the obvious loop (subtype->basetype->subtype) which + -- would otherwise occur!) + + elsif Present (Freeze_Node (Ent)) + and then Present (First_Subtype_Link (Freeze_Node (Ent))) + and then + not Is_Internal_Name + (Chars (First_Subtype_Link (Freeze_Node (Ent)))) + then + Ent := First_Subtype_Link (Freeze_Node (Ent)); + + -- Otherwise use root type + + else + if not Derived then + Buffer_Remove ("type "); + + -- Test for "subtype of type derived from" which seems + -- excessive and is replaced by simply "type derived from" + + Buffer_Remove ("subtype of"); + + -- Avoid duplication "type derived from type derived from" + + if not Buffer_Ends_With ("type derived from ") then + Set_Msg_Str ("type derived from "); + end if; + + Derived := True; + end if; + + Ent := Etype (Ent); + end if; + + -- If we are stuck in a loop, get out and settle for the + -- internal name after all. In this case we set to kill the + -- message if it is not the first error message (we really try + -- hard not to show the dirty laundry of the implementation to + -- the poor user!) + + if Ent = Old_Ent then + Kill_Message := True; + exit; + end if; + + -- Get out if we finally found a non-internal name to use + + exit when not Is_Internal_Name (Chars (Ent)); + end loop; + + if Mchar = '"' then + Set_Msg_Char ('"'); + end if; + + end Unwind_Internal_Type; + + ------------------------- + -- Warnings_Suppressed -- + ------------------------- + + function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is + begin + for J in Warnings.First .. Warnings.Last loop + if Warnings.Table (J).Start <= Loc + and then Loc <= Warnings.Table (J).Stop + then + return True; + end if; + end loop; + + return False; + end Warnings_Suppressed; + +end Errout; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads new file mode 100644 index 00000000000..ece8175434c --- /dev/null +++ b/gcc/ada/errout.ads @@ -0,0 +1,504 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R O U T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.70 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines to output error messages. They +-- are basically system independent, however in some environments, e.g. +-- when the parser is embedded into an editor, it may be appropriate +-- to replace the implementation of this package. + +with Table; +with Types; use Types; +with Uintp; use Uintp; + +package Errout is + + Errors_Detected : Nat; + -- Number of errors detected so far + + Warnings_Detected : Nat; + -- Number of warnings detected + + type Compiler_State_Type is (Parsing, Analyzing); + Compiler_State : Compiler_State_Type; + -- Indicates current state of compilation. This is put in the Errout + -- spec because it affects the action of the error message handling. + -- In particular, an attempt is made by Errout to suppress cascaded + -- error messages in Parsing mode, but not in the other modes. + + Current_Error_Source_File : Source_File_Index; + -- Id of current messages. Used to post file name when unit changes. This + -- is initialized to Main_Source_File at the start of a compilation, which + -- means that no file names will be output unless there are errors in units + -- other than the main unit. However, if the main unit has a pragma + -- Source_Reference line, then this is initialized to No_Source_File, + -- to force an initial reference to the real source file name. + + Raise_Exception_On_Error : Nat := 0; + -- If this value is non-zero, then any attempt to generate an error + -- message raises the exception Error_Msg_Exception, and the error + -- message is not output. This is used for defending against junk + -- resulting from illegalities, and also for substitution of more + -- appropriate error messages from higher semantic levels. It is + -- a counter so that the increment/decrement protocol nests neatly. + + Error_Msg_Exception : exception; + -- Exception raised if Raise_Exception_On_Error is true + + ----------------------------------- + -- Suppression of Error Messages -- + ----------------------------------- + + -- In an effort to reduce the impact of redundant error messages, the + -- error output routines in this package normally suppress certain + -- classes of messages as follows: + + -- 1. Identical messages placed at the same point in the text. Such + -- duplicate error message result for example from rescanning + -- sections of the text that contain lexical errors. Only one of + -- such a set of duplicate messages is output, and the rest are + -- suppressed. + + -- 2. If more than one parser message is generated for a single source + -- line, then only the first message is output, the remaining + -- messages on the same line are suppressed. + + -- 3. If a message is posted on a node for which a message has been + -- previously posted, then only the first message is retained. The + -- Error_Posted flag is used to detect such multiple postings. Note + -- that this only applies to semantic messages, since otherwise + -- for parser messages, this would be a special case of case 2. + + -- 4. If a message is posted on a node whose Etype or Entity + -- fields reference entities on which an error message has + -- already been placed, as indicated by the Error_Posted flag + -- being set on these entities, then the message is suppressed. + + -- 5. If a message attempts to insert an Error node, or a direct + -- reference to the Any_Type node, then the message is suppressed. + + -- This normal suppression action may be overridden in cases 2-5 (but not + -- in case 1) by setting All_Errors mode, or by setting the special + -- unconditional message insertion character (!) at the end of the message + -- text as described below. + + --------------------------------------------------------- + -- Error Message Text and Message Insertion Characters -- + --------------------------------------------------------- + + -- Error message text strings are composed of lower case letters, digits + -- and the special characters space, comma, period, colon and semicolon, + -- apostrophe and parentheses. Special insertion characters can also + -- appear which cause the error message circuit to modify the given + -- string as follows: + + -- Insertion character % (Percent: insert name from Names table) + -- The character % is replaced by the text for the name specified by + -- the Name_Id value stored in Error_Msg_Name_1. A blank precedes + -- the name if it is preceded by a non-blank character other than a + -- left parenthesis. The name is enclosed in quotes unless manual + -- quotation mode is set. If the Name_Id is set to No_Name, then + -- no insertion occurs; if the Name_Id is set to Error_Name, then + -- the string <error> is inserted. A second and third % may appear + -- in a single message, similarly replaced by the names which are + -- specified by the Name_Id values stored in Error_Msg_Name_2 and + -- Error_Msg_Name_3. The names are decoded and cased according to + -- the current identifier casing mode. + + -- Insertion character $ (Dollar: insert unit name from Names table) + -- The character $ is treated similarly to %, except that the name + -- is obtained from the Unit_Name_Type value in Error_Msg_Unit_1 + -- and Error_Msg_Unit_2, as provided by Get_Unit_Name_String in + -- package Uname. Note that this name includes the postfix (spec) + -- or (body) strings. If this postfix is not required, use the + -- normal % insertion for the unit name. + + -- Insertion character { (Left brace: insert literally from names table) + -- The character { is treated similarly to %, except that the + -- name is output literally as stored in the names table without + -- adjusting the casing. This can be used for file names and in + -- other situations where the name string is to be output unchanged. + + -- Insertion character * (Asterisk, insert reserved word name) + -- The insertion character * is treated exactly like % except that + -- the resulting name is cased according to the default conventions + -- for reserved words (see package Scans). + + -- Insertion character & (Ampersand: insert name from node) + -- The insertion character & is treated similarly to %, except that + -- the name is taken from the Chars field of the given node, and may + -- refer to a child unit name, or a selected component. The casing + -- is, if possible, taken from the original source reference, which + -- is obtained from the Sloc field of the given node or nodes. If no + -- Sloc is available (happens e.g. for nodes in package Standard), + -- then the default case (see Scans spec) is used. The nodes to be + -- used are stored in Error_Msg_Node_1, Error_Msg_Node_2. No insertion + -- occurs for the Empty node, and the Error node results in the + -- insertion of the characters <error>. In addition, if the special + -- global variable Error_Msg_Qual_Level is non-zero, then the + -- reference will include up to the given number of levels of + -- qualification, using the scope chain. + + -- Insertion character # (Pound: insert line number reference) + -- The character # is replaced by the string indicating the source + -- position stored in Error_Msg_Sloc. There are three cases: + -- + -- for package Standard: in package Standard + -- for locations in current file: at line nnn:ccc + -- for locations in other files: at filename:nnn:ccc + -- + -- By convention, the # insertion character is only used at the end + -- of an error message, so the above strings only appear as the last + -- characters of an error message. + + -- Insertion character } (Right brace: insert type reference) + -- The character } is replaced by a string describing the type + -- referenced by the entity whose Id is stored in Error_Msg_Node_1. + -- the string gives the name or description of the type, and also + -- where appropriate the location of its declaration. Special + -- cases like "some integer type" are handled appropriately. Only + -- one } is allowed in a message, since there is not enough room + -- for two (the insertion can be quite long, including a file name) + -- In addition, if the special global variable Error_Msg_Qual_Level + -- is non-zero, then the reference will include up to the given + -- number of levels of qualification, using the scope chain. + + -- Insertion character @ (At: insert column number reference) + -- The character @ is replaced by null if the RM_Column_Check mode is + -- off (False). If the switch is on (True), then @ is replaced by the + -- text string " in column nnn" where nnn is the decimal representation + -- of the column number stored in Error_Msg_Col plus one (the plus one + -- is because the number is stored 0-origin and displayed 1-origin). + + -- Insertion character ^ (Carret: insert integer value) + -- The character ^ is replaced by the decimal conversion of the Uint + -- value stored in Error_Msg_Uint_1, with a possible leading minus. + -- A second ^ may occur in the message, in which case it is replaced + -- by the decimal conversion of the Uint value in Error_Msg_Uint_2. + + -- Insertion character ! (Exclamation: unconditional message) + -- The character ! appearing as the last character of a message makes + -- the message unconditional which means that it is output even if it + -- would normally be suppressed. See section above for a description + -- of the cases in which messages are normally suppressed. + + -- Insertion character ? (Question: warning message) + -- The character ? appearing anywhere in a message makes the message + -- a warning instead of a normal error message, and the text of the + -- message will be preceded by "Warning:" instead of "Error:" The + -- handling of warnings if further controlled by the Warning_Mode + -- option (-w switch), see package Opt for further details, and + -- also by the current setting from pragma Warnings. This pragma + -- applies only to warnings issued from the semantic phase (not + -- the parser), but currently all relevant warnings are posted + -- by the semantic phase anyway. Messages starting with (style) + -- are also treated as warning messages. + + -- Insertion character A-Z (Upper case letter: Ada reserved word) + -- If two or more upper case letters appear in the message, they are + -- taken as an Ada reserved word, and are converted to the default + -- case for reserved words (see Scans package spec). Surrounding + -- quotes are added unless manual quotation mode is currently set. + + -- Insertion character ` (Backquote: set manual quotation mode) + -- The backquote character always appears in pairs. Each backquote + -- of the pair is replaced by a double quote character. In addition, + -- Any reserved keywords, or name insertions between these backquotes + -- are not surrounded by the usual automatic double quotes. See the + -- section below on manual quotation mode for further details. + + -- Insertion character ' (Quote: literal character) + -- Precedes a character which is placed literally into the message. + -- Used to insert characters into messages that are one of the + -- insertion characters defined here. + + -- Insertion character \ (Backslash: continuation message) + -- Indicates that the message is a continuation of a message + -- previously posted. This is used to ensure that such groups + -- of messages are treated as a unit. The \ character must be + -- the first character of the message text. + + ----------------------------------------------------- + -- Global Values Used for Error Message Insertions -- + ----------------------------------------------------- + + -- The following global variables are essentially additional parameters + -- passed to the error message routine for insertion sequences described + -- above. The reason these are passed globally is that the insertion + -- mechanism is essentially an untyped one in which the appropriate + -- variables are set dependingon the specific insertion characters used. + + Error_Msg_Col : Column_Number; + -- Column for @ insertion character in message + + Error_Msg_Uint_1 : Uint; + Error_Msg_Uint_2 : Uint; + -- Uint values for ^ insertion characters in message + + Error_Msg_Sloc : Source_Ptr; + -- Source location for # insertion character in message + + Error_Msg_Name_1 : Name_Id; + Error_Msg_Name_2 : Name_Id; + Error_Msg_Name_3 : Name_Id; + -- Name_Id values for % insertion characters in message + + Error_Msg_Unit_1 : Name_Id; + Error_Msg_Unit_2 : Name_Id; + -- Name_Id values for $ insertion characters in message + + Error_Msg_Node_1 : Node_Id; + Error_Msg_Node_2 : Node_Id; + -- Node_Id values for & insertion characters in message + + Error_Msg_Qual_Level : Int := 0; + -- Number of levels of qualification required for type name (see the + -- description of the } insertion character. Note that this value does + -- note get reset by any Error_Msg call, so the caller is responsible + -- for resetting it. + + Warn_On_Instance : Boolean := False; + -- Normally if a warning is generated in a generic template from the + -- analysis of the template, then the warning really belongs in the + -- template, and the default value of False for this Boolean achieves + -- that effect. If Warn_On_Instance is set True, then the warnings are + -- generated on the instantiation (referring to the template) rather + -- than on the template itself. + + ----------------------------------------------------- + -- Format of Messages and Manual Quotation Control -- + ----------------------------------------------------- + + -- Messages are generally all in lower case, except for inserted names + -- and appear in one of the following three forms: + + -- error: text + -- warning: text + + -- The prefixes error and warning are supplied automatically (depending + -- on the use of the ? insertion character), and the call to the error + -- message routine supplies the text. The "error: " prefix is omitted + -- in brief error message formats. + + -- Reserved Ada keywords in the message are in the default keyword case + -- (determined from the given source program), surrounded by quotation + -- marks. This is achieved by spelling the reserved word in upper case + -- letters, which is recognized as a request for insertion of quotation + -- marks by the error text processor. Thus for example: + + -- Error_Msg_AP ("IS expected"); + + -- would result in the output of one of the following: + + -- error: "is" expected + -- error: "IS" expected + -- error: "Is" expected + + -- the choice between these being made by looking at the casing convention + -- used for keywords (actually the first compilation unit keyword) in the + -- source file. + + -- In the case of names, the default mode for the error text processor + -- is to surround the name by quotation marks automatically. The case + -- used for the identifier names is taken from the source program where + -- possible, and otherwise is the default casing convention taken from + -- the source file usage. + + -- In some cases, better control over the placement of quote marks is + -- required. This is achieved using manual quotation mode. In this mode, + -- one or more insertion sequences is surrounded by backquote characters. + -- The backquote characters are output as double quote marks, and normal + -- automatic insertion of quotes is suppressed between the double quotes. + -- For example: + + -- Error_Msg_AP ("`END &;` expected"); + + -- generates a message like + + -- error: "end Open_Scope;" expected + + -- where the node specifying the name Open_Scope has been stored in + -- Error_Msg_Node_1 prior to the call. The great majority of error + -- messages operates in normal quotation mode. + + -- Note: the normal automatic insertion of spaces before insertion + -- sequences (such as those that come from & and %) is suppressed in + -- manual quotation mode, so blanks, if needed as in the above example, + -- must be explicitly present. + + ---------------------------- + -- Message ID Definitions -- + ---------------------------- + + type Error_Msg_Id is new Int; + -- A type used to represent specific error messages. Used by the clients + -- of this package only in the context of the Get_Error_Id and + -- Change_Error_Text subprograms. + + No_Error_Msg : constant Error_Msg_Id := 0; + -- A constant which is different from any value returned by Get_Error_Id. + -- Typically used by a client to indicate absense of a saved Id value. + + function Get_Msg_Id return Error_Msg_Id; + -- Returns the Id of the message most recently posted using one of the + -- Error_Msg routines. + + function Get_Location (E : Error_Msg_Id) return Source_Ptr; + -- Returns the flag location of the error message with the given id E. + + ------------------------ + -- List Pragmas Table -- + ------------------------ + + -- When a pragma Page or pragma List is encountered by the parser, an + -- entry is made in the following table. This table is then used to + -- control the full listing if one is being generated. Note that the + -- reason we do the processing in the parser is so that we get proper + -- listing control even in syntax check only mode. + + type List_Pragma_Type is (List_On, List_Off, Page); + + type List_Pragma_Record is record + Ptyp : List_Pragma_Type; + Ploc : Source_Ptr; + end record; + + -- Note: Ploc points to the terminating semicolon in the List_Off and + -- Page cases, and to the pragma keyword for List_On. In the case of + -- a pragma List_Off, a List_On entry is also made in the table, + -- pointing to the pragma keyword. This ensures that, as required, + -- a List (Off) pragma is listed even in list off mode. + + package List_Pragmas is new Table.Table ( + Table_Component_Type => List_Pragma_Record, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "List_Pragmas"); + + --------------------------- + -- Ignore_Errors Feature -- + --------------------------- + + -- In certain cases, notably for optional subunits, the compiler operates + -- in a mode where errors are to be ignored, and the whole unit is to be + -- considered as not present. To implement this we provide the following + -- flag to enable special handling, where error messages are suppressed, + -- but the Fatal_Error flag will still be set in the normal manner. + + Ignore_Errors_Enable : Nat := 0; + -- Triggering switch. If non-zero, then ignore errors mode is activated. + -- This is a counter to allow convenient nesting of enable/disable. + + ------------------------------ + -- Error Output Subprograms -- + ------------------------------ + + procedure Initialize; + -- Initializes for output of error messages. Must be called for each + -- source file before using any of the other routines in the package. + + procedure Finalize; + -- Finalize processing of error messages for one file and output message + -- indicating the number of detected errors. + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + -- Output a message at specified location. Can be called from the parser + -- or the semantic analyzer. + + procedure Error_Msg_S (Msg : String); + -- Output a message at current scan pointer location. This routine can be + -- called only from the parser, since it references Scan_Ptr. + + procedure Error_Msg_AP (Msg : String); + -- Output a message just after the previous token. This routine can be + -- called only from the parser, since it references Prev_Token_Ptr. + + procedure Error_Msg_BC (Msg : String); + -- Output a message just before the current token. Note that the important + -- difference between this and the previous routine is that the BC case + -- posts a flag on the current line, whereas AP can post a flag at the + -- end of the preceding line. This routine can be called only from the + -- parser, since it references Token_Ptr. + + procedure Error_Msg_SC (Msg : String); + -- Output a message at the start of the current token, unless we are at + -- the end of file, in which case we always output the message after the + -- last real token in the file. This routine can be called only from the + -- parser, since it references Token_Ptr. + + procedure Error_Msg_SP (Msg : String); + -- Output a message at the start of the previous token. This routine can + -- be called only from the parser, since it references Prev_Token_Ptr. + + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id); + -- Output a message at the Sloc of the given node. This routine can be + -- called from the parser or the semantic analyzer, although the call + -- from the latter is much more common (and is the most usual way of + -- generating error messages from the analyzer). The message text may + -- contain a single & insertion, which will reference the given node. + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id); + -- Output a message at the Sloc of the given node, with an insertion of + -- the name from the given entity node. This is used by the semantic + -- routines, where this is a common error message situation. The Msg + -- text will contain a & or } as usual to mark the insertion point. + -- This routine can be called from the parser or the analyzer. + + procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String); + -- The error message text of the message identified by Id is replaced by + -- the given text. This text may contain insertion characters in the + -- usual manner, and need not be the same length as the original text. + + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr); + -- All error messages whose location is in the range From .. To (not + -- including the end points) will be deleted from the error listing. + + procedure Remove_Warning_Messages (N : Node_Id); + -- Remove any warning messages corresponding to the Sloc of N or any + -- of its descendent nodes. No effect if no such warnings. + + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr); + -- Called in response to a pragma Warnings (Off) to record the source + -- location from which warnings are to be turned off. + + procedure Set_Warnings_Mode_On (Loc : Source_Ptr); + -- Called in response to a pragma Warnings (On) to record the source + -- location from which warnings are to be turned back on. + + function Compilation_Errors return Boolean; + -- Returns true if errors have been detected, or warnings in -gnatwe + -- (treat warnings as errors) mode. + + procedure dmsg (Id : Error_Msg_Id); + -- Debugging routine to dump an error message + +end Errout; diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb new file mode 100644 index 00000000000..99f5a9f6a19 --- /dev/null +++ b/gcc/ada/eval_fat.adb @@ -0,0 +1,935 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E V A L _ F A T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.33 $ +-- -- +-- Copyright (C) 1992-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 Einfo; use Einfo; +with Sem_Util; use Sem_Util; +with Ttypef; use Ttypef; +with Targparm; use Targparm; + +package body Eval_Fat is + + Radix : constant Int := 2; + -- This code is currently only correct for the radix 2 case. We use + -- the symbolic value Radix where possible to help in the unlikely + -- case of anyone ever having to adjust this code for another value, + -- and for documentation purposes. + + type Radix_Power_Table is array (Int range 1 .. 4) of Int; + + Radix_Powers : constant Radix_Power_Table + := (Radix**1, Radix**2, Radix**3, Radix**4); + + function Float_Radix return T renames Ureal_2; + -- Radix expressed in real form + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Decompose + (RT : R; + X : in T; + Fraction : out T; + Exponent : out UI; + Mode : Rounding_Mode := Round); + -- Decomposes a non-zero floating-point number into fraction and + -- exponent parts. The fraction is in the interval 1.0 / Radix .. + -- T'Pred (1.0) and uses Rbase = Radix. + -- The result is rounded to a nearest machine number. + + procedure Decompose_Int + (RT : R; + X : in T; + Fraction : out UI; + Exponent : out UI; + Mode : Rounding_Mode); + -- This is similar to Decompose, except that the Fraction value returned + -- is an integer representing the value Fraction * Scale, where Scale is + -- the value (Radix ** Machine_Mantissa (RT)). The value is obtained by + -- using biased rounding (halfway cases round away from zero), round to + -- even, a floor operation or a ceiling operation depending on the setting + -- of Mode (see corresponding descriptions in Urealp). + -- In case rounding was specified, Rounding_Was_Biased is set True + -- if the input was indeed halfway between to machine numbers and + -- got rounded away from zero to an odd number. + + function Eps_Model (RT : R) return T; + -- Return the smallest model number of R. + + function Eps_Denorm (RT : R) return T; + -- Return the smallest denormal of type R. + + function Machine_Mantissa (RT : R) return Nat; + -- Get value of machine mantissa + + -------------- + -- Adjacent -- + -------------- + + function Adjacent (RT : R; X, Towards : T) return T is + begin + if Towards = X then + return X; + + elsif Towards > X then + return Succ (RT, X); + + else + return Pred (RT, X); + end if; + end Adjacent; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (RT : R; X : T) return T is + XT : constant T := Truncation (RT, X); + + begin + if UR_Is_Negative (X) then + return XT; + + elsif X = XT then + return X; + + else + return XT + Ureal_1; + end if; + end Ceiling; + + ------------- + -- Compose -- + ------------- + + function Compose (RT : R; Fraction : T; Exponent : UI) return T is + Arg_Frac : T; + Arg_Exp : UI; + + begin + if UR_Is_Zero (Fraction) then + return Fraction; + else + Decompose (RT, Fraction, Arg_Frac, Arg_Exp); + return Scaling (RT, Arg_Frac, Exponent); + end if; + end Compose; + + --------------- + -- Copy_Sign -- + --------------- + + function Copy_Sign (RT : R; Value, Sign : T) return T is + Result : T; + + begin + Result := abs Value; + + if UR_Is_Negative (Sign) then + return -Result; + else + return Result; + end if; + end Copy_Sign; + + --------------- + -- Decompose -- + --------------- + + procedure Decompose + (RT : R; + X : in T; + Fraction : out T; + Exponent : out UI; + Mode : Rounding_Mode := Round) + is + Int_F : UI; + + begin + Decompose_Int (RT, abs X, Int_F, Exponent, Mode); + + Fraction := UR_From_Components + (Num => Int_F, + Den => UI_From_Int (Machine_Mantissa (RT)), + Rbase => Radix, + Negative => False); + + if UR_Is_Negative (X) then + Fraction := -Fraction; + end if; + + return; + end Decompose; + + ------------------- + -- Decompose_Int -- + ------------------- + + -- This procedure should be modified with care, as there + -- are many non-obvious details that may cause problems + -- that are hard to detect. The cases of positive and + -- negative zeroes are also special and should be + -- verified separately. + + procedure Decompose_Int + (RT : R; + X : in T; + Fraction : out UI; + Exponent : out UI; + Mode : Rounding_Mode) + is + Base : Int := Rbase (X); + N : UI := abs Numerator (X); + D : UI := Denominator (X); + + N_Times_Radix : UI; + + Even : Boolean; + -- True iff Fraction is even + + Most_Significant_Digit : constant UI := + Radix ** (Machine_Mantissa (RT) - 1); + + Uintp_Mark : Uintp.Save_Mark; + -- The code is divided into blocks that systematically release + -- intermediate values (this routine generates lots of junk!) + + begin + Calculate_D_And_Exponent_1 : begin + Uintp_Mark := Mark; + Exponent := Uint_0; + + -- In cases where Base > 1, the actual denominator is + -- Base**D. For cases where Base is a power of Radix, use + -- the value 1 for the Denominator and adjust the exponent. + + -- Note: Exponent has different sign from D, because D is a divisor + + for Power in 1 .. Radix_Powers'Last loop + if Base = Radix_Powers (Power) then + Exponent := -D * Power; + Base := 0; + D := Uint_1; + exit; + end if; + end loop; + + Release_And_Save (Uintp_Mark, D, Exponent); + end Calculate_D_And_Exponent_1; + + if Base > 0 then + Calculate_Exponent : begin + Uintp_Mark := Mark; + + -- For bases that are a multiple of the Radix, divide + -- the base by Radix and adjust the Exponent. This will + -- help because D will be much smaller and faster to process. + + -- This occurs for decimal bases on a machine with binary + -- floating-point for example. When calculating 1E40, + -- with Radix = 2, N will be 93 bits instead of 133. + + -- N E + -- ------ * Radix + -- D + -- Base + + -- N E + -- = -------------------------- * Radix + -- D D + -- (Base/Radix) * Radix + + -- N E-D + -- = --------------- * Radix + -- D + -- (Base/Radix) + + -- This code is commented out, because it causes numerous + -- failures in the regression suite. To be studied ??? + + while False and then Base > 0 and then Base mod Radix = 0 loop + Base := Base / Radix; + Exponent := Exponent + D; + end loop; + + Release_And_Save (Uintp_Mark, Exponent); + end Calculate_Exponent; + + -- For remaining bases we must actually compute + -- the exponentiation. + + -- Because the exponentiation can be negative, and D must + -- be integer, the numerator is corrected instead. + + Calculate_N_And_D : begin + Uintp_Mark := Mark; + + if D < 0 then + N := N * Base ** (-D); + D := Uint_1; + else + D := Base ** D; + end if; + + Release_And_Save (Uintp_Mark, N, D); + end Calculate_N_And_D; + + Base := 0; + end if; + + -- Now scale N and D so that N / D is a value in the + -- interval [1.0 / Radix, 1.0) and adjust Exponent accordingly, + -- so the value N / D * Radix ** Exponent remains unchanged. + + -- Step 1 - Adjust N so N / D >= 1 / Radix, or N = 0 + + -- N and D are positive, so N / D >= 1 / Radix implies N * Radix >= D. + -- This scaling is not possible for N is Uint_0 as there + -- is no way to scale Uint_0 so the first digit is non-zero. + + Calculate_N_And_Exponent : begin + Uintp_Mark := Mark; + + N_Times_Radix := N * Radix; + + if N /= Uint_0 then + while not (N_Times_Radix >= D) loop + N := N_Times_Radix; + Exponent := Exponent - 1; + + N_Times_Radix := N * Radix; + end loop; + end if; + + Release_And_Save (Uintp_Mark, N, Exponent); + end Calculate_N_And_Exponent; + + -- Step 2 - Adjust D so N / D < 1 + + -- Scale up D so N / D < 1, so N < D + + Calculate_D_And_Exponent_2 : begin + Uintp_Mark := Mark; + + while not (N < D) loop + + -- As N / D >= 1, N / (D * Radix) will be at least 1 / Radix, + -- so the result of Step 1 stays valid + + D := D * Radix; + Exponent := Exponent + 1; + end loop; + + Release_And_Save (Uintp_Mark, D, Exponent); + end Calculate_D_And_Exponent_2; + + -- Here the value N / D is in the range [1.0 / Radix .. 1.0) + + -- Now find the fraction by doing a very simple-minded + -- division until enough digits have been computed. + + -- This division works for all radices, but is only efficient for + -- a binary radix. It is just like a manual division algorithm, + -- but instead of moving the denominator one digit right, we move + -- the numerator one digit left so the numerator and denominator + -- remain integral. + + Fraction := Uint_0; + Even := True; + + Calculate_Fraction_And_N : begin + Uintp_Mark := Mark; + + loop + while N >= D loop + N := N - D; + Fraction := Fraction + 1; + Even := not Even; + end loop; + + -- Stop when the result is in [1.0 / Radix, 1.0) + + exit when Fraction >= Most_Significant_Digit; + + N := N * Radix; + Fraction := Fraction * Radix; + Even := True; + end loop; + + Release_And_Save (Uintp_Mark, Fraction, N); + end Calculate_Fraction_And_N; + + Calculate_Fraction_And_Exponent : begin + Uintp_Mark := Mark; + + -- Put back sign before applying the rounding. + + if UR_Is_Negative (X) then + Fraction := -Fraction; + end if; + + -- Determine correct rounding based on the remainder + -- which is in N and the divisor D. + + Rounding_Was_Biased := False; -- Until proven otherwise + + case Mode is + when Round_Even => + + -- This rounding mode should not be used for static + -- expressions, but only for compile-time evaluation + -- of non-static expressions. + + if (Even and then N * 2 > D) + or else + (not Even and then N * 2 >= D) + then + Fraction := Fraction + 1; + end if; + + when Round => + + -- Do not round to even as is done with IEEE arithmetic, + -- but instead round away from zero when the result is + -- exactly between two machine numbers. See RM 4.9(38). + + if N * 2 >= D then + Fraction := Fraction + 1; + + Rounding_Was_Biased := Even and then N * 2 = D; + -- Check for the case where the result is actually + -- different from Round_Even. + end if; + + when Ceiling => + if N > Uint_0 then + Fraction := Fraction + 1; + end if; + + when Floor => null; + end case; + + -- The result must be normalized to [1.0/Radix, 1.0), + -- so adjust if the result is 1.0 because of rounding. + + if Fraction = Most_Significant_Digit * Radix then + Fraction := Most_Significant_Digit; + Exponent := Exponent + 1; + end if; + + Release_And_Save (Uintp_Mark, Fraction, Exponent); + end Calculate_Fraction_And_Exponent; + + end Decompose_Int; + + ---------------- + -- Eps_Denorm -- + ---------------- + + function Eps_Denorm (RT : R) return T is + Digs : constant UI := Digits_Value (RT); + Emin : Int; + Mant : Int; + + begin + if Vax_Float (RT) then + if Digs = VAXFF_Digits then + Emin := VAXFF_Machine_Emin; + Mant := VAXFF_Machine_Mantissa; + + elsif Digs = VAXDF_Digits then + Emin := VAXDF_Machine_Emin; + Mant := VAXDF_Machine_Mantissa; + + else + pragma Assert (Digs = VAXGF_Digits); + Emin := VAXGF_Machine_Emin; + Mant := VAXGF_Machine_Mantissa; + end if; + + elsif Is_AAMP_Float (RT) then + if Digs = AAMPS_Digits then + Emin := AAMPS_Machine_Emin; + Mant := AAMPS_Machine_Mantissa; + + else + pragma Assert (Digs = AAMPL_Digits); + Emin := AAMPL_Machine_Emin; + Mant := AAMPL_Machine_Mantissa; + end if; + + else + if Digs = IEEES_Digits then + Emin := IEEES_Machine_Emin; + Mant := IEEES_Machine_Mantissa; + + elsif Digs = IEEEL_Digits then + Emin := IEEEL_Machine_Emin; + Mant := IEEEL_Machine_Mantissa; + + else + pragma Assert (Digs = IEEEX_Digits); + Emin := IEEEX_Machine_Emin; + Mant := IEEEX_Machine_Mantissa; + end if; + end if; + + return Float_Radix ** UI_From_Int (Emin - Mant); + end Eps_Denorm; + + --------------- + -- Eps_Model -- + --------------- + + function Eps_Model (RT : R) return T is + Digs : constant UI := Digits_Value (RT); + Emin : Int; + + begin + if Vax_Float (RT) then + if Digs = VAXFF_Digits then + Emin := VAXFF_Machine_Emin; + + elsif Digs = VAXDF_Digits then + Emin := VAXDF_Machine_Emin; + + else + pragma Assert (Digs = VAXGF_Digits); + Emin := VAXGF_Machine_Emin; + end if; + + elsif Is_AAMP_Float (RT) then + if Digs = AAMPS_Digits then + Emin := AAMPS_Machine_Emin; + + else + pragma Assert (Digs = AAMPL_Digits); + Emin := AAMPL_Machine_Emin; + end if; + + else + if Digs = IEEES_Digits then + Emin := IEEES_Machine_Emin; + + elsif Digs = IEEEL_Digits then + Emin := IEEEL_Machine_Emin; + + else + pragma Assert (Digs = IEEEX_Digits); + Emin := IEEEX_Machine_Emin; + end if; + end if; + + return Float_Radix ** UI_From_Int (Emin); + end Eps_Model; + + -------------- + -- Exponent -- + -------------- + + function Exponent (RT : R; X : T) return UI is + X_Frac : UI; + X_Exp : UI; + + begin + if UR_Is_Zero (X) then + return Uint_0; + else + Decompose_Int (RT, X, X_Frac, X_Exp, Round_Even); + return X_Exp; + end if; + end Exponent; + + ----------- + -- Floor -- + ----------- + + function Floor (RT : R; X : T) return T is + XT : constant T := Truncation (RT, X); + + begin + if UR_Is_Positive (X) then + return XT; + + elsif XT = X then + return X; + + else + return XT - Ureal_1; + end if; + end Floor; + + -------------- + -- Fraction -- + -------------- + + function Fraction (RT : R; X : T) return T is + X_Frac : T; + X_Exp : UI; + + begin + if UR_Is_Zero (X) then + return X; + else + Decompose (RT, X, X_Frac, X_Exp); + return X_Frac; + end if; + end Fraction; + + ------------------ + -- Leading_Part -- + ------------------ + + function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T is + L : UI; + Y, Z : T; + + begin + if Radix_Digits >= Machine_Mantissa (RT) then + return X; + + else + L := Exponent (RT, X) - Radix_Digits; + Y := Truncation (RT, Scaling (RT, X, -L)); + Z := Scaling (RT, Y, L); + return Z; + end if; + + end Leading_Part; + + ------------- + -- Machine -- + ------------- + + function Machine (RT : R; X : T; Mode : Rounding_Mode) return T is + X_Frac : T; + X_Exp : UI; + + begin + if UR_Is_Zero (X) then + return X; + else + Decompose (RT, X, X_Frac, X_Exp, Mode); + return Scaling (RT, X_Frac, X_Exp); + end if; + end Machine; + + ---------------------- + -- Machine_Mantissa -- + ---------------------- + + function Machine_Mantissa (RT : R) return Nat is + Digs : constant UI := Digits_Value (RT); + Mant : Nat; + + begin + if Vax_Float (RT) then + if Digs = VAXFF_Digits then + Mant := VAXFF_Machine_Mantissa; + + elsif Digs = VAXDF_Digits then + Mant := VAXDF_Machine_Mantissa; + + else + pragma Assert (Digs = VAXGF_Digits); + Mant := VAXGF_Machine_Mantissa; + end if; + + elsif Is_AAMP_Float (RT) then + if Digs = AAMPS_Digits then + Mant := AAMPS_Machine_Mantissa; + + else + pragma Assert (Digs = AAMPL_Digits); + Mant := AAMPL_Machine_Mantissa; + end if; + + else + if Digs = IEEES_Digits then + Mant := IEEES_Machine_Mantissa; + + elsif Digs = IEEEL_Digits then + Mant := IEEEL_Machine_Mantissa; + + else + pragma Assert (Digs = IEEEX_Digits); + Mant := IEEEX_Machine_Mantissa; + end if; + end if; + + return Mant; + end Machine_Mantissa; + + ----------- + -- Model -- + ----------- + + function Model (RT : R; X : T) return T is + X_Frac : T; + X_Exp : UI; + + begin + Decompose (RT, X, X_Frac, X_Exp); + return Compose (RT, X_Frac, X_Exp); + end Model; + + ---------- + -- Pred -- + ---------- + + function Pred (RT : R; X : T) return T is + Result_F : UI; + Result_X : UI; + + begin + if abs X < Eps_Model (RT) then + if Denorm_On_Target then + return X - Eps_Denorm (RT); + + elsif X > Ureal_0 then + -- Target does not support denorms, so predecessor is 0.0 + return Ureal_0; + + else + -- Target does not support denorms, and X is 0.0 + -- or at least bigger than -Eps_Model (RT) + + return -Eps_Model (RT); + end if; + + else + Decompose_Int (RT, X, Result_F, Result_X, Ceiling); + return UR_From_Components + (Num => Result_F - 1, + Den => Machine_Mantissa (RT) - Result_X, + Rbase => Radix, + Negative => False); + -- Result_F may be false, but this is OK as UR_From_Components + -- handles that situation. + end if; + end Pred; + + --------------- + -- Remainder -- + --------------- + + function Remainder (RT : R; X, Y : T) return T is + A : T; + B : T; + Arg : T; + P : T; + Arg_Frac : T; + P_Frac : T; + Sign_X : T; + IEEE_Rem : T; + Arg_Exp : UI; + P_Exp : UI; + K : UI; + P_Even : Boolean; + + begin + if UR_Is_Positive (X) then + Sign_X := Ureal_1; + else + Sign_X := -Ureal_1; + end if; + + Arg := abs X; + P := abs Y; + + if Arg < P then + P_Even := True; + IEEE_Rem := Arg; + P_Exp := Exponent (RT, P); + + else + -- ??? what about zero cases? + Decompose (RT, Arg, Arg_Frac, Arg_Exp); + Decompose (RT, P, P_Frac, P_Exp); + + P := Compose (RT, P_Frac, Arg_Exp); + K := Arg_Exp - P_Exp; + P_Even := True; + IEEE_Rem := Arg; + + for Cnt in reverse 0 .. UI_To_Int (K) loop + if IEEE_Rem >= P then + P_Even := False; + IEEE_Rem := IEEE_Rem - P; + else + P_Even := True; + end if; + + P := P * Ureal_Half; + end loop; + end if; + + -- That completes the calculation of modulus remainder. The final step + -- is get the IEEE remainder. Here we compare Rem with (abs Y) / 2. + + if P_Exp >= 0 then + A := IEEE_Rem; + B := abs Y * Ureal_Half; + + else + A := IEEE_Rem * Ureal_2; + B := abs Y; + end if; + + if A > B or else (A = B and then not P_Even) then + IEEE_Rem := IEEE_Rem - abs Y; + end if; + + return Sign_X * IEEE_Rem; + + end Remainder; + + -------------- + -- Rounding -- + -------------- + + function Rounding (RT : R; X : T) return T is + Result : T; + Tail : T; + + begin + Result := Truncation (RT, abs X); + Tail := abs X - Result; + + if Tail >= Ureal_Half then + Result := Result + Ureal_1; + end if; + + if UR_Is_Negative (X) then + return -Result; + else + return Result; + end if; + + end Rounding; + + ------------- + -- Scaling -- + ------------- + + function Scaling (RT : R; X : T; Adjustment : UI) return T is + begin + if Rbase (X) = Radix then + return UR_From_Components + (Num => Numerator (X), + Den => Denominator (X) - Adjustment, + Rbase => Radix, + Negative => UR_Is_Negative (X)); + + elsif Adjustment >= 0 then + return X * Radix ** Adjustment; + else + return X / Radix ** (-Adjustment); + end if; + end Scaling; + + ---------- + -- Succ -- + ---------- + + function Succ (RT : R; X : T) return T is + Result_F : UI; + Result_X : UI; + + begin + if abs X < Eps_Model (RT) then + if Denorm_On_Target then + return X + Eps_Denorm (RT); + + elsif X < Ureal_0 then + -- Target does not support denorms, so successor is 0.0 + return Ureal_0; + + else + -- Target does not support denorms, and X is 0.0 + -- or at least smaller than Eps_Model (RT) + + return Eps_Model (RT); + end if; + + else + Decompose_Int (RT, X, Result_F, Result_X, Floor); + return UR_From_Components + (Num => Result_F + 1, + Den => Machine_Mantissa (RT) - Result_X, + Rbase => Radix, + Negative => False); + -- Result_F may be false, but this is OK as UR_From_Components + -- handles that situation. + end if; + end Succ; + + ---------------- + -- Truncation -- + ---------------- + + function Truncation (RT : R; X : T) return T is + begin + return UR_From_Uint (UR_Trunc (X)); + end Truncation; + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + function Unbiased_Rounding (RT : R; X : T) return T is + Abs_X : constant T := abs X; + Result : T; + Tail : T; + + begin + Result := Truncation (RT, Abs_X); + Tail := Abs_X - Result; + + if Tail > Ureal_Half then + Result := Result + Ureal_1; + + elsif Tail = Ureal_Half then + Result := Ureal_2 * + Truncation (RT, (Result / Ureal_2) + Ureal_Half); + end if; + + if UR_Is_Negative (X) then + return -Result; + elsif UR_Is_Positive (X) then + return Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + + end Unbiased_Rounding; + +end Eval_Fat; diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads new file mode 100644 index 00000000000..b3e398ab208 --- /dev/null +++ b/gcc/ada/eval_fat.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E V A L _ F A T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides for compile-time evaluation of static calls to the +-- floating-point attribute functions. It is the compile-time equivalent of +-- the System.Fat_Gen runtime package. The coding is quite similar, as are +-- the subprogram specs, except that the type is passed as an explicit +-- first parameter (and used via ttypes, to obtain the necessary information +-- about the characteristics of the type for computing the results. + +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Eval_Fat is + + subtype UI is Uint; + -- The compile time representation of universal integer + + subtype T is Ureal; + -- The compile time representation of floating-point values + + subtype R is Entity_Id; + -- The compile time representation of the floating-point root type + + type Rounding_Mode is (Floor, Ceiling, Round, Round_Even); + -- Used to indicate rounding mode for Machine attribute + + Rounding_Was_Biased : Boolean; + -- Set if last use of Machine rounded a halfway case away from zero + + function Adjacent (RT : R; X, Towards : T) return T; + + function Ceiling (RT : R; X : T) return T; + + function Compose (RT : R; Fraction : T; Exponent : UI) return T; + + function Copy_Sign (RT : R; Value, Sign : T) return T; + + function Exponent (RT : R; X : T) return UI; + + function Floor (RT : R; X : T) return T; + + function Fraction (RT : R; X : T) return T; + + function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T; + + function Machine (RT : R; X : T; Mode : Rounding_Mode) return T; + + function Model (RT : R; X : T) return T; + + function Pred (RT : R; X : T) return T; + + function Remainder (RT : R; X, Y : T) return T; + + function Rounding (RT : R; X : T) return T; + + function Scaling (RT : R; X : T; Adjustment : UI) return T; + + function Succ (RT : R; X : T) return T; + + function Truncation (RT : R; X : T) return T; + + function Unbiased_Rounding (RT : R; X : T) return T; + +end Eval_Fat; diff --git a/gcc/ada/exit.c b/gcc/ada/exit.c new file mode 100644 index 00000000000..85bc863fccc --- /dev/null +++ b/gcc/ada/exit.c @@ -0,0 +1,59 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * E X I T * + * * + * C Implementation File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include <sys/stat.h> +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +/* Routine used by Ada.Command_Line.Set_Exit_Status */ + +int gnat_exit_status = 0; + +void +__gnat_set_exit_status (i) + int i; +{ + gnat_exit_status = i; +} diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb new file mode 100644 index 00000000000..92a7396fd63 --- /dev/null +++ b/gcc/ada/exp_aggr.adb @@ -0,0 +1,4016 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A G G R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.170 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Expander; use Expander; +with Exp_Util; use Exp_Util; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch7; use Exp_Ch7; +with Freeze; use Freeze; +with Hostparm; use Hostparm; +with Itypes; use Itypes; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Aggr is + + type Case_Bounds is record + Choice_Lo : Node_Id; + Choice_Hi : Node_Id; + Choice_Node : Node_Id; + end record; + + type Case_Table_Type is array (Nat range <>) of Case_Bounds; + -- Table type used by Check_Case_Choices procedure + + procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); + -- Sort the Case Table using the Lower Bound of each Choice as the key. + -- A simple insertion sort is used since the number of choices in a case + -- statement of variant part will usually be small and probably in near + -- sorted order. + + ------------------------------------------------------ + -- Local subprograms for Record Aggregate Expansion -- + ------------------------------------------------------ + + procedure Expand_Record_Aggregate + (N : Node_Id; + Orig_Tag : Node_Id := Empty; + Parent_Expr : Node_Id := Empty); + -- This is the top level procedure for record aggregate expansion. + -- Expansion for record aggregates needs expand aggregates for tagged + -- record types. Specifically Expand_Record_Aggregate adds the Tag + -- field in front of the Component_Association list that was created + -- during resolution by Resolve_Record_Aggregate. + -- + -- N is the record aggregate node. + -- Orig_Tag is the value of the Tag that has to be provided for this + -- specific aggregate. It carries the tag corresponding to the type + -- of the outermost aggregate during the recursive expansion + -- Parent_Expr is the ancestor part of the original extension + -- aggregate + + procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); + -- N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of + -- the aggregate. Transform the given aggregate into a sequence of + -- assignments component per component. + + function Build_Record_Aggr_Code + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty) + return List_Id; + -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type + -- of the aggregate. Target is an expression containing the + -- location on which the component by component assignments will + -- take place. Returns the list of assignments plus all other + -- adjustments needed for tagged and controlled types. Flist is an + -- expression representing the finalization list on which to + -- attach the controlled components if any. Obj is present in the + -- object declaration and dynamic allocation cases, it contains + -- an entity that allows to know if the value being created needs to be + -- attached to the final list in case of pragma finalize_Storage_Only. + + ----------------------------------------------------- + -- Local subprograms for array aggregate expansion -- + ----------------------------------------------------- + + procedure Expand_Array_Aggregate (N : Node_Id); + -- This is the top-level routine to perform array aggregate expansion. + -- N is the N_Aggregate node to be expanded. + + function Backend_Processing_Possible (N : Node_Id) return Boolean; + -- This function checks if array aggregate N can be processed directly + -- by Gigi. If this is the case True is returned. + + function Build_Array_Aggr_Code + (N : Node_Id; + Index : Node_Id; + Into : Node_Id; + Scalar_Comp : Boolean; + Indices : List_Id := No_List; + Flist : Node_Id := Empty) + return List_Id; + -- This recursive routine returns a list of statements containing the + -- loops and assignments that are needed for the expansion of the array + -- aggregate N. + -- + -- N is the (sub-)aggregate node to be expanded into code. + -- + -- Index is the index node corresponding to the array sub-aggregate N. + -- + -- Into is the target expression into which we are copying the aggregate. + -- + -- Scalar_Comp is True if the component type of the aggregate is scalar. + -- + -- Indices is the current list of expressions used to index the + -- object we are writing into. + -- + -- Flist is an expression representing the finalization list on which + -- to attach the controlled components if any. + + function Number_Of_Choices (N : Node_Id) return Nat; + -- Returns the number of discrete choices (not including the others choice + -- if present) contained in (sub-)aggregate N. + + function Late_Expansion + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty) + return List_Id; + -- N is a nested (record or array) aggregate that has been marked + -- with 'Delay_Expansion'. Typ is the expected type of the + -- aggregate and Target is a (duplicable) expression that will + -- hold the result of the aggregate expansion. Flist is the + -- finalization list to be used to attach controlled + -- components. 'Obj' when non empty, carries the original object + -- being initialized in order to know if it needs to be attached + -- to the previous parameter which may not be the case when + -- Finalize_Storage_Only is set. Basically this procedure is used + -- to implement top-down expansions of nested aggregates. This is + -- necessary for avoiding temporaries at each level as well as for + -- propagating the right internal finalization list. + + function Make_OK_Assignment_Statement + (Sloc : Source_Ptr; + Name : Node_Id; + Expression : Node_Id) + return Node_Id; + -- This is like Make_Assignment_Statement, except that Assignment_OK + -- is set in the left operand. All assignments built by this unit + -- use this routine. This is needed to deal with assignments to + -- initialized constants that are done in place. + + function Safe_Slice_Assignment + (N : Node_Id; + Typ : Entity_Id) + return Boolean; + -- If a slice assignment has an aggregate with a single others_choice, + -- the assignment can be done in place even if bounds are not static, + -- by converting it into a loop over the discrete range of the slice. + + --------------------------------- + -- Backend_Processing_Possible -- + --------------------------------- + + -- Backend processing by Gigi/gcc is possible only if all the following + -- conditions are met: + + -- 1. N is fully positional + + -- 2. N is not a bit-packed array aggregate; + + -- 3. The size of N's array type must be known at compile time. Note + -- that this implies that the component size is also known + + -- 4. The array type of N does not follow the Fortran layout convention + -- or if it does it must be 1 dimensional. + + -- 5. The array component type is tagged, which may necessitate + -- reassignment of proper tags. + + function Backend_Processing_Possible (N : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (N); + -- Typ is the correct constrained array subtype of the aggregate. + + function Static_Check (N : Node_Id; Index : Node_Id) return Boolean; + -- Recursively checks that N is fully positional, returns true if so. + + ------------------ + -- Static_Check -- + ------------------ + + function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is + Expr : Node_Id; + + begin + -- Check for component associations + + if Present (Component_Associations (N)) then + return False; + end if; + + -- Recurse to check subaggregates, which may appear in qualified + -- expressions. If delayed, the front-end will have to expand. + + Expr := First (Expressions (N)); + + while Present (Expr) loop + + if Is_Delayed_Aggregate (Expr) then + return False; + end if; + + if Present (Next_Index (Index)) + and then not Static_Check (Expr, Next_Index (Index)) + then + return False; + end if; + + Next (Expr); + end loop; + + return True; + end Static_Check; + + -- Start of processing for Backend_Processing_Possible + + begin + -- Checks 2 (array must not be bit packed) + + if Is_Bit_Packed_Array (Typ) then + return False; + end if; + + -- Checks 4 (array must not be multi-dimensional Fortran case) + + if Convention (Typ) = Convention_Fortran + and then Number_Dimensions (Typ) > 1 + then + return False; + end if; + + -- Checks 3 (size of array must be known at compile time) + + if not Size_Known_At_Compile_Time (Typ) then + return False; + end if; + + -- Checks 1 (aggregate must be fully positional) + + if not Static_Check (N, First_Index (Typ)) then + return False; + end if; + + -- Checks 5 (if the component type is tagged, then we may need + -- to do tag adjustments; perhaps this should be refined to + -- check for any component associations that actually + -- need tag adjustment, along the lines of the test that's + -- done in Has_Delayed_Nested_Aggregate_Or_Tagged_Comps + -- for record aggregates with tagged components, but not + -- clear whether it's worthwhile ???; in the case of the + -- JVM, object tags are handled implicitly) + + if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then + return False; + end if; + + -- Backend processing is possible + + Set_Compile_Time_Known_Aggregate (N, True); + Set_Size_Known_At_Compile_Time (Etype (N), True); + return True; + end Backend_Processing_Possible; + + --------------------------- + -- Build_Array_Aggr_Code -- + --------------------------- + + -- The code that we generate from a one dimensional aggregate is + + -- 1. If the sub-aggregate contains discrete choices we + + -- (a) Sort the discrete choices + + -- (b) Otherwise for each discrete choice that specifies a range we + -- emit a loop. If a range specifies a maximum of three values, or + -- we are dealing with an expression we emit a sequence of + -- assignments instead of a loop. + + -- (c) Generate the remaining loops to cover the others choice if any. + + -- 2. If the aggregate contains positional elements we + + -- (a) translate the positional elements in a series of assignments. + + -- (b) Generate a final loop to cover the others choice if any. + -- Note that this final loop has to be a while loop since the case + + -- L : Integer := Integer'Last; + -- H : Integer := Integer'Last; + -- A : array (L .. H) := (1, others =>0); + + -- cannot be handled by a for loop. Thus for the following + + -- array (L .. H) := (.. positional elements.., others =>E); + + -- we always generate something like: + + -- I : Index_Type := Index_Of_Last_Positional_Element; + -- while I < H loop + -- I := Index_Base'Succ (I) + -- Tmp (I) := E; + -- end loop; + + function Build_Array_Aggr_Code + (N : Node_Id; + Index : Node_Id; + Into : Node_Id; + Scalar_Comp : Boolean; + Indices : List_Id := No_List; + Flist : Node_Id := Empty) + return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Index_Base : constant Entity_Id := Base_Type (Etype (Index)); + Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); + Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); + + function Add (Val : Int; To : Node_Id) return Node_Id; + -- Returns an expression where Val is added to expression To, + -- unless To+Val is provably out of To's base type range. + -- To must be an already analyzed expression. + + function Empty_Range (L, H : Node_Id) return Boolean; + -- Returns True if the range defined by L .. H is certainly empty. + + function Equal (L, H : Node_Id) return Boolean; + -- Returns True if L = H for sure. + + function Index_Base_Name return Node_Id; + -- Returns a new reference to the index type name. + + function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id; + -- Ind must be a side-effect free expression. + -- If the input aggregate N to Build_Loop contains no sub-aggregates, + -- This routine returns the assignment statement + -- + -- Into (Indices, Ind) := Expr; + -- + -- Otherwise we call Build_Code recursively. + + function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id; + -- Nodes L and H must be side-effect free expressions. + -- If the input aggregate N to Build_Loop contains no sub-aggregates, + -- This routine returns the for loop statement + -- + -- for J in Index_Base'(L) .. Index_Base'(H) loop + -- Into (Indices, J) := Expr; + -- end loop; + -- + -- Otherwise we call Build_Code recursively. + -- As an optimization if the loop covers 3 or less scalar elements we + -- generate a sequence of assignments. + + function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id; + -- Nodes L and H must be side-effect free expressions. + -- If the input aggregate N to Build_Loop contains no sub-aggregates, + -- This routine returns the while loop statement + -- + -- I : Index_Base := L; + -- while I < H loop + -- I := Index_Base'Succ (I); + -- Into (Indices, I) := Expr; + -- end loop; + -- + -- Otherwise we call Build_Code recursively. + + function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean; + function Local_Expr_Value (E : Node_Id) return Uint; + -- These two Local routines are used to replace the corresponding ones + -- in sem_eval because while processing the bounds of an aggregate with + -- discrete choices whose index type is an enumeration, we build static + -- expressions not recognized by Compile_Time_Known_Value as such since + -- they have not yet been analyzed and resolved. All the expressions in + -- question are things like Index_Base_Name'Val (Const) which we can + -- easily recognize as being constant. + + --------- + -- Add -- + --------- + + function Add (Val : Int; To : Node_Id) return Node_Id is + Expr_Pos : Node_Id; + Expr : Node_Id; + To_Pos : Node_Id; + + U_To : Uint; + U_Val : Uint := UI_From_Int (Val); + + begin + -- Note: do not try to optimize the case of Val = 0, because + -- we need to build a new node with the proper Sloc value anyway. + + -- First test if we can do constant folding + + if Local_Compile_Time_Known_Value (To) then + U_To := Local_Expr_Value (To) + Val; + + -- Determine if our constant is outside the range of the index. + -- If so return an Empty node. This empty node will be caught + -- by Empty_Range below. + + if Compile_Time_Known_Value (Index_Base_L) + and then U_To < Expr_Value (Index_Base_L) + then + return Empty; + + elsif Compile_Time_Known_Value (Index_Base_H) + and then U_To > Expr_Value (Index_Base_H) + then + return Empty; + end if; + + Expr_Pos := Make_Integer_Literal (Loc, U_To); + Set_Is_Static_Expression (Expr_Pos); + + if not Is_Enumeration_Type (Index_Base) then + Expr := Expr_Pos; + + -- If we are dealing with enumeration return + -- Index_Base'Val (Expr_Pos) + + else + Expr := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Val, + Expressions => New_List (Expr_Pos)); + end if; + + return Expr; + end if; + + -- If we are here no constant folding possible + + if not Is_Enumeration_Type (Index_Base) then + Expr := + Make_Op_Add (Loc, + Left_Opnd => Duplicate_Subexpr (To), + Right_Opnd => Make_Integer_Literal (Loc, U_Val)); + + -- If we are dealing with enumeration return + -- Index_Base'Val (Index_Base'Pos (To) + Val) + + else + To_Pos := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Pos, + Expressions => New_List (Duplicate_Subexpr (To))); + + Expr_Pos := + Make_Op_Add (Loc, + Left_Opnd => To_Pos, + Right_Opnd => Make_Integer_Literal (Loc, U_Val)); + + Expr := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Val, + Expressions => New_List (Expr_Pos)); + end if; + + return Expr; + end Add; + + ----------------- + -- Empty_Range -- + ----------------- + + function Empty_Range (L, H : Node_Id) return Boolean is + Is_Empty : Boolean := False; + Low : Node_Id; + High : Node_Id; + + begin + -- First check if L or H were already detected as overflowing the + -- index base range type by function Add above. If this is so Add + -- returns the empty node. + + if No (L) or else No (H) then + return True; + end if; + + for J in 1 .. 3 loop + case J is + + -- L > H range is empty + + when 1 => + Low := L; + High := H; + + -- B_L > H range must be empty + + when 2 => + Low := Index_Base_L; + High := H; + + -- L > B_H range must be empty + + when 3 => + Low := L; + High := Index_Base_H; + end case; + + if Local_Compile_Time_Known_Value (Low) + and then Local_Compile_Time_Known_Value (High) + then + Is_Empty := + UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High)); + end if; + + exit when Is_Empty; + end loop; + + return Is_Empty; + end Empty_Range; + + ----------- + -- Equal -- + ----------- + + function Equal (L, H : Node_Id) return Boolean is + begin + if L = H then + return True; + + elsif Local_Compile_Time_Known_Value (L) + and then Local_Compile_Time_Known_Value (H) + then + return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H)); + end if; + + return False; + end Equal; + + ---------------- + -- Gen_Assign -- + ---------------- + + function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is + L : List_Id := New_List; + F : Entity_Id; + A : Node_Id; + + New_Indices : List_Id; + Indexed_Comp : Node_Id; + Expr_Q : Node_Id; + Comp_Type : Entity_Id := Empty; + + function Add_Loop_Actions (Lis : List_Id) return List_Id; + -- Collect insert_actions generated in the construction of a + -- loop, and prepend them to the sequence of assignments to + -- complete the eventual body of the loop. + + ---------------------- + -- Add_Loop_Actions -- + ---------------------- + + function Add_Loop_Actions (Lis : List_Id) return List_Id is + Res : List_Id; + + begin + if Nkind (Parent (Expr)) = N_Component_Association + and then Present (Loop_Actions (Parent (Expr))) + then + Append_List (Lis, Loop_Actions (Parent (Expr))); + Res := Loop_Actions (Parent (Expr)); + Set_Loop_Actions (Parent (Expr), No_List); + return Res; + + else + return Lis; + end if; + end Add_Loop_Actions; + + -- Start of processing for Gen_Assign + + begin + if No (Indices) then + New_Indices := New_List; + else + New_Indices := New_Copy_List_Tree (Indices); + end if; + + Append_To (New_Indices, Ind); + + if Present (Flist) then + F := New_Copy_Tree (Flist); + + elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then + if Is_Entity_Name (Into) + and then Present (Scope (Entity (Into))) + then + F := Find_Final_List (Scope (Entity (Into))); + + else + F := Find_Final_List (Current_Scope); + end if; + else + F := 0; + end if; + + if Present (Next_Index (Index)) then + return + Add_Loop_Actions ( + Build_Array_Aggr_Code + (Expr, Next_Index (Index), + Into, Scalar_Comp, New_Indices, F)); + end if; + + -- If we get here then we are at a bottom-level (sub-)aggregate + + Indexed_Comp := Checks_Off ( + Make_Indexed_Component (Loc, + Prefix => New_Copy_Tree (Into), + Expressions => New_Indices)); + + Set_Assignment_OK (Indexed_Comp); + + if Nkind (Expr) = N_Qualified_Expression then + Expr_Q := Expression (Expr); + else + Expr_Q := Expr; + end if; + + if Present (Etype (N)) + and then Etype (N) /= Any_Composite + then + Comp_Type := Component_Type (Etype (N)); + + elsif Present (Next (First (New_Indices))) then + + -- this is a multidimensional array. Recover the component + -- type from the outermost aggregate, because subaggregates + -- do not have an assigned type. + + declare + P : Node_Id := Parent (Expr); + + begin + while Present (P) loop + + if Nkind (P) = N_Aggregate + and then Present (Etype (P)) + then + Comp_Type := Component_Type (Etype (P)); + exit; + + else + P := Parent (P); + end if; + end loop; + end; + end if; + + if (Nkind (Expr_Q) = N_Aggregate + or else Nkind (Expr_Q) = N_Extension_Aggregate) + then + + -- At this stage the Expression may not have been + -- analyzed yet because the array aggregate code has not + -- been updated to use the Expansion_Delayed flag and + -- avoid analysis altogether to solve the same problem + -- (see Resolve_Aggr_Expr) so let's do the analysis of + -- non-array aggregates now in order to get the value of + -- Expansion_Delayed flag for the inner aggregate ??? + + if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then + Analyze_And_Resolve (Expr_Q, Comp_Type); + end if; + + if Is_Delayed_Aggregate (Expr_Q) then + return + Add_Loop_Actions ( + Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp, F)); + end if; + end if; + + -- Now generate the assignment with no associated controlled + -- actions since the target of the assignment may not have + -- been initialized, it is not possible to Finalize it as + -- expected by normal controlled assignment. The rest of the + -- controlled actions are done manually with the proper + -- finalization list coming from the context. + + A := + Make_OK_Assignment_Statement (Loc, + Name => Indexed_Comp, + Expression => New_Copy_Tree (Expr)); + + if Present (Comp_Type) and then Controlled_Type (Comp_Type) then + Set_No_Ctrl_Actions (A); + end if; + + Append_To (L, A); + + -- Adjust the tag if tagged (because of possible view + -- conversions), unless compiling for the Java VM + -- where tags are implicit. + + if Present (Comp_Type) + and then Is_Tagged_Type (Comp_Type) + and then not Java_VM + then + A := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Indexed_Comp), + Selector_Name => + New_Reference_To (Tag_Component (Comp_Type), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To ( + Access_Disp_Table (Comp_Type), Loc))); + + Append_To (L, A); + end if; + + -- Adjust and Attach the component to the proper final list + -- which can be the controller of the outer record object or + -- the final list associated with the scope + + if Present (Comp_Type) and then Controlled_Type (Comp_Type) then + Append_List_To (L, + Make_Adjust_Call ( + Ref => New_Copy_Tree (Indexed_Comp), + Typ => Comp_Type, + Flist_Ref => F, + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + + return Add_Loop_Actions (L); + end Gen_Assign; + + -------------- + -- Gen_Loop -- + -------------- + + function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is + L_I : Node_Id; + + L_Range : Node_Id; + -- Index_Base'(L) .. Index_Base'(H) + + L_Iteration_Scheme : Node_Id; + -- L_I in Index_Base'(L) .. Index_Base'(H) + + L_Body : List_Id; + -- The statements to execute in the loop + + S : List_Id := New_List; + -- list of statement + + Tcopy : Node_Id; + -- Copy of expression tree, used for checking purposes + + begin + -- If loop bounds define an empty range return the null statement + + if Empty_Range (L, H) then + Append_To (S, Make_Null_Statement (Loc)); + + -- The expression must be type-checked even though no component + -- of the aggregate will have this value. This is done only for + -- actual components of the array, not for subaggregates. Do the + -- check on a copy, because the expression may be shared among + -- several choices, some of which might be non-null. + + if Present (Etype (N)) + and then Is_Array_Type (Etype (N)) + and then No (Next_Index (Index)) + then + Expander_Mode_Save_And_Set (False); + Tcopy := New_Copy_Tree (Expr); + Set_Parent (Tcopy, N); + Analyze_And_Resolve (Tcopy, Component_Type (Etype (N))); + Expander_Mode_Restore; + end if; + + return S; + + -- If loop bounds are the same then generate an assignment + + elsif Equal (L, H) then + return Gen_Assign (New_Copy_Tree (L), Expr); + + -- If H - L <= 2 then generate a sequence of assignments + -- when we are processing the bottom most aggregate and it contains + -- scalar components. + + elsif No (Next_Index (Index)) + and then Scalar_Comp + and then Local_Compile_Time_Known_Value (L) + and then Local_Compile_Time_Known_Value (H) + and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2 + then + Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr)); + Append_List_To (S, Gen_Assign (Add (1, To => L), Expr)); + + if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then + Append_List_To (S, Gen_Assign (Add (2, To => L), Expr)); + end if; + + return S; + end if; + + -- Otherwise construct the loop, starting with the loop index L_I + + L_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + -- Construct "L .. H" + + L_Range := + Make_Range + (Loc, + Low_Bound => Make_Qualified_Expression + (Loc, + Subtype_Mark => Index_Base_Name, + Expression => L), + High_Bound => Make_Qualified_Expression + (Loc, + Subtype_Mark => Index_Base_Name, + Expression => H)); + + -- Construct "for L_I in Index_Base range L .. H" + + L_Iteration_Scheme := + Make_Iteration_Scheme + (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification + (Loc, + Defining_Identifier => L_I, + Discrete_Subtype_Definition => L_Range)); + + -- Construct the statements to execute in the loop body + + L_Body := Gen_Assign (New_Reference_To (L_I, Loc), Expr); + + -- Construct the final loop + + Append_To (S, Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => L_Iteration_Scheme, + Statements => L_Body)); + + return S; + end Gen_Loop; + + --------------- + -- Gen_While -- + --------------- + + -- The code built is + + -- W_I : Index_Base := L; + -- while W_I < H loop + -- W_I := Index_Base'Succ (W); + -- L_Body; + -- end loop; + + function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is + + W_I : Node_Id; + + W_Decl : Node_Id; + -- W_I : Base_Type := L; + + W_Iteration_Scheme : Node_Id; + -- while W_I < H + + W_Index_Succ : Node_Id; + -- Index_Base'Succ (I) + + W_Increment : Node_Id; + -- W_I := Index_Base'Succ (W) + + W_Body : List_Id := New_List; + -- The statements to execute in the loop + + S : List_Id := New_List; + -- list of statement + + begin + -- If loop bounds define an empty range or are equal return null + + if Empty_Range (L, H) or else Equal (L, H) then + Append_To (S, Make_Null_Statement (Loc)); + return S; + end if; + + -- Build the decl of W_I + + W_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + W_Decl := + Make_Object_Declaration + (Loc, + Defining_Identifier => W_I, + Object_Definition => Index_Base_Name, + Expression => L); + + -- Theoretically we should do a New_Copy_Tree (L) here, but we know + -- that in this particular case L is a fresh Expr generated by + -- Add which we are the only ones to use. + + Append_To (S, W_Decl); + + -- construct " while W_I < H" + + W_Iteration_Scheme := + Make_Iteration_Scheme + (Loc, + Condition => Make_Op_Lt + (Loc, + Left_Opnd => New_Reference_To (W_I, Loc), + Right_Opnd => New_Copy_Tree (H))); + + -- Construct the statements to execute in the loop body + + W_Index_Succ := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Succ, + Expressions => New_List (New_Reference_To (W_I, Loc))); + + W_Increment := + Make_OK_Assignment_Statement + (Loc, + Name => New_Reference_To (W_I, Loc), + Expression => W_Index_Succ); + + Append_To (W_Body, W_Increment); + Append_List_To (W_Body, + Gen_Assign (New_Reference_To (W_I, Loc), Expr)); + + -- Construct the final loop + + Append_To (S, Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => W_Iteration_Scheme, + Statements => W_Body)); + + return S; + end Gen_While; + + --------------------- + -- Index_Base_Name -- + --------------------- + + function Index_Base_Name return Node_Id is + begin + return New_Reference_To (Index_Base, Sloc (N)); + end Index_Base_Name; + + ------------------------------------ + -- Local_Compile_Time_Known_Value -- + ------------------------------------ + + function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is + begin + return Compile_Time_Known_Value (E) + or else + (Nkind (E) = N_Attribute_Reference + and then Attribute_Name (E) = Name_Val + and then Compile_Time_Known_Value (First (Expressions (E)))); + end Local_Compile_Time_Known_Value; + + ---------------------- + -- Local_Expr_Value -- + ---------------------- + + function Local_Expr_Value (E : Node_Id) return Uint is + begin + if Compile_Time_Known_Value (E) then + return Expr_Value (E); + else + return Expr_Value (First (Expressions (E))); + end if; + end Local_Expr_Value; + + -- Build_Array_Aggr_Code Variables + + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + + Others_Expr : Node_Id := Empty; + + Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); + Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); + -- The aggregate bounds of this specific sub-aggregate. Note that if + -- the code generated by Build_Array_Aggr_Code is executed then these + -- bounds are OK. Otherwise a Constraint_Error would have been raised. + + Aggr_Low : constant Node_Id := Duplicate_Subexpr (Aggr_L); + Aggr_High : constant Node_Id := Duplicate_Subexpr (Aggr_H); + -- After Duplicate_Subexpr these are side-effect free. + + Low : Node_Id; + High : Node_Id; + + Nb_Choices : Nat := 0; + Table : Case_Table_Type (1 .. Number_Of_Choices (N)); + -- Used to sort all the different choice values + + Nb_Elements : Int; + -- Number of elements in the positional aggregate + + New_Code : List_Id := New_List; + + -- Start of processing for Build_Array_Aggr_Code + + begin + -- STEP 1: Process component associations + + if No (Expressions (N)) then + + -- STEP 1 (a): Sort the discrete choices + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + + Choice := First (Choices (Assoc)); + while Present (Choice) loop + + if Nkind (Choice) = N_Others_Choice then + Others_Expr := Expression (Assoc); + exit; + end if; + + Get_Index_Bounds (Choice, Low, High); + + Nb_Choices := Nb_Choices + 1; + Table (Nb_Choices) := (Choice_Lo => Low, + Choice_Hi => High, + Choice_Node => Expression (Assoc)); + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + -- If there is more than one set of choices these must be static + -- and we can therefore sort them. Remember that Nb_Choices does not + -- account for an others choice. + + if Nb_Choices > 1 then + Sort_Case_Table (Table); + end if; + + -- STEP 1 (b): take care of the whole set of discrete choices. + + for J in 1 .. Nb_Choices loop + Low := Table (J).Choice_Lo; + High := Table (J).Choice_Hi; + Expr := Table (J).Choice_Node; + + Append_List (Gen_Loop (Low, High, Expr), To => New_Code); + end loop; + + -- STEP 1 (c): generate the remaining loops to cover others choice + -- We don't need to generate loops over empty gaps, but if there is + -- a single empty range we must analyze the expression for semantics + + if Present (Others_Expr) then + declare + First : Boolean := True; + + begin + for J in 0 .. Nb_Choices loop + + if J = 0 then + Low := Aggr_Low; + else + Low := Add (1, To => Table (J).Choice_Hi); + end if; + + if J = Nb_Choices then + High := Aggr_High; + else + High := Add (-1, To => Table (J + 1).Choice_Lo); + end if; + + if First + or else not Empty_Range (Low, High) + then + First := False; + Append_List + (Gen_Loop (Low, High, Others_Expr), To => New_Code); + end if; + end loop; + end; + end if; + + -- STEP 2: Process positional components + + else + -- STEP 2 (a): Generate the assignments for each positional element + -- Note that here we have to use Aggr_L rather than Aggr_Low because + -- Aggr_L is analyzed and Add wants an analyzed expression. + + Expr := First (Expressions (N)); + Nb_Elements := -1; + + while Present (Expr) loop + Nb_Elements := Nb_Elements + 1; + Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr), + To => New_Code); + Next (Expr); + end loop; + + -- STEP 2 (b): Generate final loop if an others choice is present + -- Here Nb_Elements gives the offset of the last positional element. + + if Present (Component_Associations (N)) then + Assoc := Last (Component_Associations (N)); + Expr := Expression (Assoc); + + Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), + Aggr_High, + Expr), + To => New_Code); + end if; + end if; + + return New_Code; + end Build_Array_Aggr_Code; + + ---------------------------- + -- Build_Record_Aggr_Code -- + ---------------------------- + + function Build_Record_Aggr_Code + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty) + return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + L : constant List_Id := New_List; + Start_L : constant List_Id := New_List; + N_Typ : constant Entity_Id := Etype (N); + + Comp : Node_Id; + Instr : Node_Id; + Ref : Node_Id; + F : Node_Id; + Comp_Type : Entity_Id; + Selector : Entity_Id; + Comp_Expr : Node_Id; + Comp_Kind : Node_Kind; + Expr_Q : Node_Id; + + Internal_Final_List : Node_Id; + + -- If this is an internal aggregate, the External_Final_List is an + -- expression for the controller record of the enclosing type. + -- If the current aggregate has several controlled components, this + -- expression will appear in several calls to attach to the finali- + -- zation list, and it must not be shared. + + External_Final_List : Node_Id; + Ancestor_Is_Expression : Boolean := False; + Ancestor_Is_Subtype_Mark : Boolean := False; + + Init_Typ : Entity_Id := Empty; + Attach : Node_Id; + + function Get_Constraint_Association (T : Entity_Id) return Node_Id; + -- Returns the first discriminant association in the constraint + -- associated with T, if any, otherwise returns Empty. + + function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; + -- Returns the value that the given discriminant of an ancestor + -- type should receive (in the absence of a conflict with the + -- value provided by an ancestor part of an extension aggregate). + + procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id); + -- Check that each of the discriminant values defined by the + -- ancestor part of an extension aggregate match the corresponding + -- values provided by either an association of the aggregate or + -- by the constraint imposed by a parent type (RM95-4.3.2(8)). + + function Init_Controller + (Target : Node_Id; + Typ : Entity_Id; + F : Node_Id; + Attach : Node_Id; + Init_Pr : Boolean) + return List_Id; + -- returns the list of statements necessary to initialize the internal + -- controller of the (possible) ancestor typ into target and attach + -- it to finalization list F. Init_Pr conditions the call to the + -- init_proc since it may already be done due to ancestor initialization + + --------------------------------- + -- Ancestor_Discriminant_Value -- + --------------------------------- + + function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is + Assoc : Node_Id; + Assoc_Elmt : Elmt_Id; + Aggr_Comp : Entity_Id; + Corresp_Disc : Entity_Id; + Current_Typ : Entity_Id := Base_Type (Typ); + Parent_Typ : Entity_Id; + Parent_Disc : Entity_Id; + Save_Assoc : Node_Id := Empty; + + begin + -- First check any discriminant associations to see if + -- any of them provide a value for the discriminant. + + if Present (Discriminant_Specifications (Parent (Current_Typ))) then + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Aggr_Comp := Entity (First (Choices (Assoc))); + + if Ekind (Aggr_Comp) = E_Discriminant then + Save_Assoc := Expression (Assoc); + + Corresp_Disc := Corresponding_Discriminant (Aggr_Comp); + while Present (Corresp_Disc) loop + -- If found a corresponding discriminant then return + -- the value given in the aggregate. (Note: this is + -- not correct in the presence of side effects. ???) + + if Disc = Corresp_Disc then + return Duplicate_Subexpr (Expression (Assoc)); + end if; + Corresp_Disc := + Corresponding_Discriminant (Corresp_Disc); + end loop; + end if; + + Next (Assoc); + end loop; + end if; + + -- No match found in aggregate, so chain up parent types to find + -- a constraint that defines the value of the discriminant. + + Parent_Typ := Etype (Current_Typ); + while Current_Typ /= Parent_Typ loop + if Has_Discriminants (Parent_Typ) then + Parent_Disc := First_Discriminant (Parent_Typ); + + -- We either get the association from the subtype indication + -- of the type definition itself, or from the discriminant + -- constraint associated with the type entity (which is + -- preferable, but it's not always present ???) + + if Is_Empty_Elmt_List ( + Discriminant_Constraint (Current_Typ)) + then + Assoc := Get_Constraint_Association (Current_Typ); + Assoc_Elmt := No_Elmt; + else + Assoc_Elmt := + First_Elmt (Discriminant_Constraint (Current_Typ)); + Assoc := Node (Assoc_Elmt); + end if; + + -- Traverse the discriminants of the parent type looking + -- for one that corresponds. + + while Present (Parent_Disc) and then Present (Assoc) loop + Corresp_Disc := Parent_Disc; + while Present (Corresp_Disc) + and then Disc /= Corresp_Disc + loop + Corresp_Disc := + Corresponding_Discriminant (Corresp_Disc); + end loop; + + if Disc = Corresp_Disc then + if Nkind (Assoc) = N_Discriminant_Association then + Assoc := Expression (Assoc); + end if; + + -- If the located association directly denotes + -- a discriminant, then use the value of a saved + -- association of the aggregate. This is a kludge + -- to handle certain cases involving multiple + -- discriminants mapped to a single discriminant + -- of a descendant. It's not clear how to locate the + -- appropriate discriminant value for such cases. ??? + + if Is_Entity_Name (Assoc) + and then Ekind (Entity (Assoc)) = E_Discriminant + then + Assoc := Save_Assoc; + end if; + + return Duplicate_Subexpr (Assoc); + end if; + + Next_Discriminant (Parent_Disc); + + if No (Assoc_Elmt) then + Next (Assoc); + else + Next_Elmt (Assoc_Elmt); + if Present (Assoc_Elmt) then + Assoc := Node (Assoc_Elmt); + else + Assoc := Empty; + end if; + end if; + end loop; + end if; + + Current_Typ := Parent_Typ; + Parent_Typ := Etype (Current_Typ); + end loop; + + -- In some cases there's no ancestor value to locate (such as + -- when an ancestor part given by an expression defines the + -- discriminant value). + + return Empty; + end Ancestor_Discriminant_Value; + + ---------------------------------- + -- Check_Ancestor_Discriminants -- + ---------------------------------- + + procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is + Discr : Entity_Id := First_Discriminant (Base_Type (Anc_Typ)); + Disc_Value : Node_Id; + Cond : Node_Id; + + begin + while Present (Discr) loop + Disc_Value := Ancestor_Discriminant_Value (Discr); + + if Present (Disc_Value) then + Cond := Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Discr, Loc)), + Right_Opnd => Disc_Value); + + Append_To (L, Make_Raise_Constraint_Error (Loc, + Condition => Cond)); + end if; + + Next_Discriminant (Discr); + end loop; + end Check_Ancestor_Discriminants; + + -------------------------------- + -- Get_Constraint_Association -- + -------------------------------- + + function Get_Constraint_Association (T : Entity_Id) return Node_Id is + Typ_Def : constant Node_Id := Type_Definition (Parent (T)); + Indic : constant Node_Id := Subtype_Indication (Typ_Def); + + begin + -- ??? Also need to cover case of a type mark denoting a subtype + -- with constraint. + + if Nkind (Indic) = N_Subtype_Indication + and then Present (Constraint (Indic)) + then + return First (Constraints (Constraint (Indic))); + end if; + + return Empty; + end Get_Constraint_Association; + + --------------------- + -- Init_controller -- + --------------------- + + function Init_Controller + (Target : Node_Id; + Typ : Entity_Id; + F : Node_Id; + Attach : Node_Id; + Init_Pr : Boolean) + return List_Id + is + Ref : Node_Id; + L : List_Id := New_List; + + begin + -- _init_proc (target._controller); + -- initialize (target._controller); + -- Attach_to_Final_List (target._controller, F); + + Ref := Make_Selected_Component (Loc, + Prefix => Convert_To (Typ, New_Copy_Tree (Target)), + Selector_Name => Make_Identifier (Loc, Name_uController)); + Set_Assignment_OK (Ref); + + if Init_Pr then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => RTE (RE_Record_Controller), + In_Init_Proc => Within_Init_Proc)); + end if; + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller), + Name_Initialize), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + + Append_To (L, + Make_Attach_Call ( + Obj_Ref => New_Copy_Tree (Ref), + Flist_Ref => F, + With_Attach => Attach)); + return L; + end Init_Controller; + + -- Start of processing for Build_Record_Aggr_Code + + begin + + -- Deal with the ancestor part of extension aggregates + -- or with the discriminants of the root type + + if Nkind (N) = N_Extension_Aggregate then + declare + A : constant Node_Id := Ancestor_Part (N); + + begin + + -- If the ancestor part is a subtype mark "T", we generate + -- _init_proc (T(tmp)); if T is constrained and + -- _init_proc (S(tmp)); where S applies an appropriate + -- constraint if T is unconstrained + + if Is_Entity_Name (A) and then Is_Type (Entity (A)) then + + Ancestor_Is_Subtype_Mark := True; + + if Is_Constrained (Entity (A)) then + Init_Typ := Entity (A); + + -- For an ancestor part given by an unconstrained type + -- mark, create a subtype constrained by appropriate + -- corresponding discriminant values coming from either + -- associations of the aggregate or a constraint on + -- a parent type. The subtype will be used to generate + -- the correct default value for the ancestor part. + + elsif Has_Discriminants (Entity (A)) then + declare + Anc_Typ : Entity_Id := Entity (A); + Discrim : Entity_Id := First_Discriminant (Anc_Typ); + Anc_Constr : List_Id := New_List; + Disc_Value : Node_Id; + New_Indic : Node_Id; + Subt_Decl : Node_Id; + begin + while Present (Discrim) loop + Disc_Value := Ancestor_Discriminant_Value (Discrim); + Append_To (Anc_Constr, Disc_Value); + Next_Discriminant (Discrim); + end loop; + + New_Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Anc_Constr)); + + Init_Typ := Create_Itype (Ekind (Anc_Typ), N); + + Subt_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Init_Typ, + Subtype_Indication => New_Indic); + + -- Itypes must be analyzed with checks off + + Analyze (Subt_Decl, Suppress => All_Checks); + end; + end if; + + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + + Append_List_To (Start_L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => Init_Typ, + In_Init_Proc => Within_Init_Proc)); + + if Is_Constrained (Entity (A)) + and then Has_Discriminants (Entity (A)) + then + Check_Ancestor_Discriminants (Entity (A)); + end if; + + -- If the ancestor part is an expression "E", we generate + -- T(tmp) := E; + + else + Ancestor_Is_Expression := True; + Init_Typ := Etype (A); + + -- Assign the tag before doing the assignment to make sure + -- that the dispatching call in the subsequent deep_adjust + -- works properly (unless Java_VM, where tags are implicit). + + if not Java_VM then + Instr := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To ( + Tag_Component (Base_Type (Typ)), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To ( + Access_Disp_Table (Base_Type (Typ)), Loc))); + + Set_Assignment_OK (Name (Instr)); + Append_To (L, Instr); + end if; + + -- If the ancestor part is an aggregate, force its full + -- expansion, which was delayed. + + if Nkind (A) = N_Qualified_Expression + and then (Nkind (Expression (A)) = N_Aggregate + or else + Nkind (Expression (A)) = N_Extension_Aggregate) + then + Set_Analyzed (A, False); + Set_Analyzed (Expression (A), False); + end if; + + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + Append_To (L, + Make_Unsuppress_Block (Loc, + Name_Discriminant_Check, + New_List ( + Make_OK_Assignment_Statement (Loc, + Name => Ref, + Expression => A)))); + + if Has_Discriminants (Init_Typ) then + Check_Ancestor_Discriminants (Init_Typ); + end if; + end if; + end; + + else + -- Generate the discriminant expressions, component by component. + -- If the base type is an unchecked union, the discriminants are + -- unknown to the back-end and absent from a value of the type, so + -- assignments for them are not emitted. + + if Has_Discriminants (Typ) + and then not Is_Unchecked_Union (Base_Type (Typ)) + then + + -- ??? The discriminants of the object not inherited in the type + -- of the object should be initialized here + + null; + + -- Generate discriminant init values + + declare + Discriminant : Entity_Id; + Discriminant_Value : Node_Id; + + begin + Discriminant := First_Girder_Discriminant (Typ); + + while Present (Discriminant) loop + + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Discriminant, Loc)); + + Discriminant_Value := + Get_Discriminant_Value ( + Discriminant, + N_Typ, + Discriminant_Constraint (N_Typ)); + + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => New_Copy_Tree (Discriminant_Value)); + + Set_No_Ctrl_Actions (Instr); + Append_To (L, Instr); + + Next_Girder_Discriminant (Discriminant); + end loop; + end; + end if; + end if; + + -- Generate the assignments, component by component + + -- tmp.comp1 := Expr1_From_Aggr; + -- tmp.comp2 := Expr2_From_Aggr; + -- .... + + Comp := First (Component_Associations (N)); + while Present (Comp) loop + Selector := Entity (First (Choices (Comp))); + + if Ekind (Selector) /= E_Discriminant + or else Nkind (N) = N_Extension_Aggregate + then + Comp_Type := Etype (Selector); + Comp_Kind := Nkind (Expression (Comp)); + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Selector, Loc)); + + if Nkind (Expression (Comp)) = N_Qualified_Expression then + Expr_Q := Expression (Expression (Comp)); + else + Expr_Q := Expression (Comp); + end if; + + -- The controller is the one of the parent type defining + -- the component (in case of inherited components). + + if Controlled_Type (Comp_Type) then + Internal_Final_List := + Make_Selected_Component (Loc, + Prefix => Convert_To ( + Scope (Original_Record_Component (Selector)), + New_Copy_Tree (Target)), + Selector_Name => + Make_Identifier (Loc, Name_uController)); + Internal_Final_List := + Make_Selected_Component (Loc, + Prefix => Internal_Final_List, + Selector_Name => Make_Identifier (Loc, Name_F)); + + -- The internal final list can be part of a constant object + + Set_Assignment_OK (Internal_Final_List); + else + Internal_Final_List := Empty; + end if; + + if Is_Delayed_Aggregate (Expr_Q) then + Append_List_To (L, + Late_Expansion (Expr_Q, Comp_Type, Comp_Expr, + Internal_Final_List)); + else + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => Expression (Comp)); + + Set_No_Ctrl_Actions (Instr); + Append_To (L, Instr); + + -- Adjust the tag if tagged (because of possible view + -- conversions), unless compiling for the Java VM + -- where tags are implicit. + + -- tmp.comp._tag := comp_typ'tag; + + if Is_Tagged_Type (Comp_Type) and then not Java_VM then + Instr := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Comp_Expr), + Selector_Name => + New_Reference_To (Tag_Component (Comp_Type), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To ( + Access_Disp_Table (Comp_Type), Loc))); + + Append_To (L, Instr); + end if; + + -- Adjust and Attach the component to the proper controller + -- Adjust (tmp.comp); + -- Attach_To_Final_List (tmp.comp, + -- comp_typ (tmp)._record_controller.f) + + if Controlled_Type (Comp_Type) then + Append_List_To (L, + Make_Adjust_Call ( + Ref => New_Copy_Tree (Comp_Expr), + Typ => Comp_Type, + Flist_Ref => Internal_Final_List, + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + end if; + end if; + + Next (Comp); + end loop; + + -- If the type is tagged, the tag needs to be initialized (unless + -- compiling for the Java VM where tags are implicit). It is done + -- late in the initialization process because in some cases, we call + -- the init_proc of an ancestor which will not leave out the right tag + + if Ancestor_Is_Expression then + null; + + elsif Is_Tagged_Type (Typ) and then not Java_VM then + Instr := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc))); + + Append_To (L, Instr); + end if; + + -- Now deal with the various controlled type data structure + -- initializations + + if Present (Obj) + and then Finalize_Storage_Only (Typ) + and then (Is_Library_Level_Entity (Obj) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) + = Standard_True) + then + Attach := Make_Integer_Literal (Loc, 0); + + elsif Nkind (Parent (N)) = N_Qualified_Expression + and then Nkind (Parent (Parent (N))) = N_Allocator + then + Attach := Make_Integer_Literal (Loc, 2); + + else + Attach := Make_Integer_Literal (Loc, 1); + end if; + + -- Determine the external finalization list. It is either the + -- finalization list of the outer-scope or the one coming from + -- an outer aggregate. When the target is not a temporary, the + -- proper scope is the scope of the target rather than the + -- potentially transient current scope. + + if Controlled_Type (Typ) then + if Present (Flist) then + External_Final_List := New_Copy_Tree (Flist); + + elsif Is_Entity_Name (Target) + and then Present (Scope (Entity (Target))) + then + External_Final_List := Find_Final_List (Scope (Entity (Target))); + + else + External_Final_List := Find_Final_List (Current_Scope); + end if; + + else + External_Final_List := Empty; + end if; + + -- initialize and attach the outer object in the is_controlled + -- case + + if Is_Controlled (Typ) then + if Ancestor_Is_Subtype_Mark then + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Init_Typ, Name_Initialize), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + end if; + + -- ??? when the ancestor part is an expression, the global + -- object is already attached at the wrong level. It should + -- be detached and re-attached. We have a design problem here. + + if Ancestor_Is_Expression + and then Has_Controlled_Component (Init_Typ) + then + null; + + elsif Has_Controlled_Component (Typ) then + F := Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => Make_Identifier (Loc, Name_uController)); + F := Make_Selected_Component (Loc, + Prefix => F, + Selector_Name => Make_Identifier (Loc, Name_F)); + + Ref := New_Copy_Tree (Target); + Set_Assignment_OK (Ref); + + Append_To (L, + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => F, + With_Attach => Make_Integer_Literal (Loc, 1))); + + else -- is_Controlled (Typ) and not Has_Controlled_Component (Typ) + Ref := New_Copy_Tree (Target); + Set_Assignment_OK (Ref); + Append_To (Start_L, + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => New_Copy_Tree (External_Final_List), + With_Attach => Attach)); + end if; + end if; + + -- in the Has_Controlled component case, all the intermediate + -- controllers must be initialized + + if Has_Controlled_Component (Typ) then + declare + Inner_Typ : Entity_Id; + Outer_Typ : Entity_Id; + At_Root : Boolean; + + begin + + Outer_Typ := Base_Type (Typ); + + -- find outer type with a controller + + while Outer_Typ /= Init_Typ + and then not Has_New_Controlled_Component (Outer_Typ) + loop + Outer_Typ := Etype (Outer_Typ); + end loop; + + -- attach it to the outer record controller to the + -- external final list + + if Outer_Typ = Init_Typ then + Append_List_To (Start_L, + Init_Controller ( + Target => Target, + Typ => Outer_Typ, + F => External_Final_List, + Attach => Attach, + Init_Pr => Ancestor_Is_Expression)); + At_Root := True; + Inner_Typ := Init_Typ; + + else + Append_List_To (Start_L, + Init_Controller ( + Target => Target, + Typ => Outer_Typ, + F => External_Final_List, + Attach => Attach, + Init_Pr => True)); + + Inner_Typ := Etype (Outer_Typ); + At_Root := + not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ; + end if; + + -- Initialize the internal controllers for tagged types with + -- more than one controller. + + while not At_Root and then Inner_Typ /= Init_Typ loop + if Has_New_Controlled_Component (Inner_Typ) then + F := + Make_Selected_Component (Loc, + Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)), + Selector_Name => + Make_Identifier (Loc, Name_uController)); + F := Make_Selected_Component (Loc, + Prefix => F, + Selector_Name => Make_Identifier (Loc, Name_F)); + Append_List_To (Start_L, + Init_Controller ( + Target => Target, + Typ => Inner_Typ, + F => F, + Attach => Make_Integer_Literal (Loc, 1), + Init_Pr => True)); + Outer_Typ := Inner_Typ; + end if; + + -- Stop at the root + + At_Root := Inner_Typ = Etype (Inner_Typ); + Inner_Typ := Etype (Inner_Typ); + end loop; + + -- if not done yet attach the controller of the ancestor part + + if Outer_Typ /= Init_Typ + and then Inner_Typ = Init_Typ + and then Has_Controlled_Component (Init_Typ) + then + F := + Make_Selected_Component (Loc, + Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)), + Selector_Name => Make_Identifier (Loc, Name_uController)); + F := Make_Selected_Component (Loc, + Prefix => F, + Selector_Name => Make_Identifier (Loc, Name_F)); + + Attach := Make_Integer_Literal (Loc, 1); + Append_List_To (Start_L, + Init_Controller ( + Target => Target, + Typ => Init_Typ, + F => F, + Attach => Attach, + Init_Pr => Ancestor_Is_Expression)); + end if; + end; + end if; + + Append_List_To (Start_L, L); + return Start_L; + end Build_Record_Aggr_Code; + + ------------------------------- + -- Convert_Aggr_In_Allocator -- + ------------------------------- + + procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id) is + Loc : constant Source_Ptr := Sloc (Aggr); + Typ : constant Entity_Id := Etype (Aggr); + Temp : constant Entity_Id := Defining_Identifier (Decl); + Occ : constant Node_Id := Unchecked_Convert_To (Typ, + Make_Explicit_Dereference (Loc, New_Reference_To (Temp, Loc))); + + Access_Type : constant Entity_Id := Etype (Temp); + + begin + Insert_Actions_After (Decl, + Late_Expansion (Aggr, Typ, Occ, + Find_Final_List (Access_Type), + Associated_Final_Chain (Base_Type (Access_Type)))); + end Convert_Aggr_In_Allocator; + + -------------------------------- + -- Convert_Aggr_In_Assignment -- + -------------------------------- + + procedure Convert_Aggr_In_Assignment (N : Node_Id) is + Aggr : Node_Id := Expression (N); + Typ : constant Entity_Id := Etype (Aggr); + Occ : constant Node_Id := New_Copy_Tree (Name (N)); + + begin + if Nkind (Aggr) = N_Qualified_Expression then + Aggr := Expression (Aggr); + end if; + + Insert_Actions_After (N, + Late_Expansion (Aggr, Typ, Occ, + Find_Final_List (Typ, New_Copy_Tree (Occ)))); + end Convert_Aggr_In_Assignment; + + --------------------------------- + -- Convert_Aggr_In_Object_Decl -- + --------------------------------- + + procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is + Obj : constant Entity_Id := Defining_Identifier (N); + Aggr : Node_Id := Expression (N); + Loc : constant Source_Ptr := Sloc (Aggr); + Typ : constant Entity_Id := Etype (Aggr); + Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); + + begin + Set_Assignment_OK (Occ); + + if Nkind (Aggr) = N_Qualified_Expression then + Aggr := Expression (Aggr); + end if; + + Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); + Set_No_Initialization (N); + end Convert_Aggr_In_Object_Decl; + + ---------------------------- + -- Convert_To_Assignments -- + ---------------------------- + + procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Temp : Entity_Id; + + Instr : Node_Id; + Target_Expr : Node_Id; + Parent_Kind : Node_Kind; + Unc_Decl : Boolean := False; + Parent_Node : Node_Id; + + begin + + Parent_Node := Parent (N); + Parent_Kind := Nkind (Parent_Node); + + if Parent_Kind = N_Qualified_Expression then + + -- Check if we are in a unconstrained declaration because in this + -- case the current delayed expansion mechanism doesn't work when + -- the declared object size depend on the initializing expr. + + begin + Parent_Node := Parent (Parent_Node); + Parent_Kind := Nkind (Parent_Node); + if Parent_Kind = N_Object_Declaration then + Unc_Decl := + not Is_Entity_Name (Object_Definition (Parent_Node)) + or else Has_Discriminants ( + Entity (Object_Definition (Parent_Node))) + or else Is_Class_Wide_Type ( + Entity (Object_Definition (Parent_Node))); + end if; + end; + end if; + + -- Just set the Delay flag in the following cases where the + -- transformation will be done top down from above + -- - internal aggregate (transformed when expanding the parent) + -- - allocators (see Convert_Aggr_In_Allocator) + -- - object decl (see Convert_Aggr_In_Object_Decl) + -- - safe assignments (see Convert_Aggr_Assignments) + -- so far only the assignments in the init_procs are taken + -- into account + + if Parent_Kind = N_Aggregate + or else Parent_Kind = N_Extension_Aggregate + or else Parent_Kind = N_Component_Association + or else Parent_Kind = N_Allocator + or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl) + or else (Parent_Kind = N_Assignment_Statement + and then Inside_Init_Proc) + then + Set_Expansion_Delayed (N); + return; + end if; + + if Requires_Transient_Scope (Typ) then + Establish_Transient_Scope (N, Sec_Stack => + Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); + end if; + + -- Create the temporary + + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Instr := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Set_No_Initialization (Instr); + Insert_Action (N, Instr); + Target_Expr := New_Occurrence_Of (Temp, Loc); + + Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr)); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Analyze_And_Resolve (N, Typ); + end Convert_To_Assignments; + + ---------------------------- + -- Expand_Array_Aggregate -- + ---------------------------- + + -- Array aggregate expansion proceeds as follows: + + -- 1. If requested we generate code to perform all the array aggregate + -- bound checks, specifically + + -- (a) Check that the index range defined by aggregate bounds is + -- compatible with corresponding index subtype. + + -- (b) If an others choice is present check that no aggregate + -- index is outside the bounds of the index constraint. + + -- (c) For multidimensional arrays make sure that all subaggregates + -- corresponding to the same dimension have the same bounds. + + -- 2. Check if the aggregate can be statically processed. If this is the + -- case pass it as is to Gigi. Note that a necessary condition for + -- static processing is that the aggregate be fully positional. + + -- 3. If in place aggregate expansion is possible (i.e. no need to create + -- a temporary) then mark the aggregate as such and return. Otherwise + -- create a new temporary and generate the appropriate initialization + -- code. + + procedure Expand_Array_Aggregate (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Typ : constant Entity_Id := Etype (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + -- Typ is the correct constrained array subtype of the aggregate and + -- Ctyp is the corresponding component type. + + Aggr_Dimension : constant Pos := Number_Dimensions (Typ); + -- Number of aggregate index dimensions. + + Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id; + Aggr_High : array (1 .. Aggr_Dimension) of Node_Id; + -- Low and High bounds of the constraint for each aggregate index. + + Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; + -- The type of each index. + + Maybe_In_Place_OK : Boolean; + -- If the type is neither controlled nor packed and the aggregate + -- is the expression in an assignment, assignment in place may be + -- possible, provided other conditions are met on the LHS. + + Others_Present : array (1 .. Aggr_Dimension) of Boolean + := (others => False); + -- If Others_Present (I) is True, then there is an others choice + -- in one of the sub-aggregates of N at dimension I. + + procedure Build_Constrained_Type (Positional : Boolean); + -- If the subtype is not static or unconstrained, build a constrained + -- type using the computable sizes of the aggregate and its sub- + -- aggregates. + + procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id); + -- Checks that the bounds of Aggr_Bounds are within the bounds defined + -- by Index_Bounds. + + procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos); + -- Checks that in a multi-dimensional array aggregate all subaggregates + -- corresponding to the same dimension have the same bounds. + -- Sub_Aggr is an array sub-aggregate. Dim is the dimension + -- corresponding to the sub-aggregate. + + procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos); + -- Computes the values of array Others_Present. Sub_Aggr is the + -- array sub-aggregate we start the computation from. Dim is the + -- dimension corresponding to the sub-aggregate. + + procedure Convert_To_Positional (N : Node_Id); + -- If possible, convert named notation to positional notation. This + -- conversion is possible only in some static cases. If the conversion + -- is possible, then N is rewritten with the analyzed converted + -- aggregate. + + function Has_Address_Clause (D : Node_Id) return Boolean; + -- If the aggregate is the expression in an object declaration, it + -- cannot be expanded in place. This function does a lookahead in the + -- current declarative part to find an address clause for the object + -- being declared. + + function In_Place_Assign_OK return Boolean; + -- Simple predicate to determine whether an aggregate assignment can + -- be done in place, because none of the new values can depend on the + -- components of the target of the assignment. + + procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos); + -- Checks that if an others choice is present in any sub-aggregate no + -- aggregate index is outside the bounds of the index constraint. + -- Sub_Aggr is an array sub-aggregate. Dim is the dimension + -- corresponding to the sub-aggregate. + + ---------------------------- + -- Build_Constrained_Type -- + ---------------------------- + + procedure Build_Constrained_Type (Positional : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Agg_Type : Entity_Id; + Comp : Node_Id; + Decl : Node_Id; + Typ : constant Entity_Id := Etype (N); + Indices : List_Id := New_List; + Num : Int; + Sub_Agg : Node_Id; + + begin + Agg_Type := + Make_Defining_Identifier ( + Loc, New_Internal_Name ('A')); + + -- If the aggregate is purely positional, all its subaggregates + -- have the same size. We collect the dimensions from the first + -- subaggregate at each level. + + if Positional then + Sub_Agg := N; + + for D in 1 .. Number_Dimensions (Typ) loop + Comp := First (Expressions (Sub_Agg)); + + Sub_Agg := Comp; + Num := 0; + + while Present (Comp) loop + Num := Num + 1; + Next (Comp); + end loop; + + Append ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Integer_Literal (Loc, Num)), + Indices); + end loop; + + else + + -- We know the aggregate type is unconstrained and the + -- aggregate is not processable by the back end, therefore + -- not necessarily positional. Retrieve the bounds of each + -- dimension as computed earlier. + + for D in 1 .. Number_Dimensions (Typ) loop + Append ( + Make_Range (Loc, + Low_Bound => Aggr_Low (D), + High_Bound => Aggr_High (D)), + Indices); + end loop; + end if; + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Agg_Type, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => Indices, + Subtype_Indication => + New_Occurrence_Of (Component_Type (Typ), Loc))); + + Insert_Action (N, Decl); + Analyze (Decl); + Set_Etype (N, Agg_Type); + Set_Is_Itype (Agg_Type); + Freeze_Itype (Agg_Type, N); + end Build_Constrained_Type; + + ------------------ + -- Check_Bounds -- + ------------------ + + procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is + Aggr_Lo : Node_Id; + Aggr_Hi : Node_Id; + + Ind_Lo : Node_Id; + Ind_Hi : Node_Id; + + Cond : Node_Id := Empty; + + begin + Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi); + Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi); + + -- Generate the following test: + -- + -- [constraint_error when + -- Aggr_Lo <= Aggr_Hi and then + -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] + -- + -- As an optimization try to see if some tests are trivially vacuos + -- because we are comparing an expression against itself. + + if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then + Cond := Empty; + + elsif Aggr_Hi = Ind_Hi then + Cond := + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr (Ind_Lo)); + + elsif Aggr_Lo = Ind_Lo then + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr (Ind_Hi)); + + else + Cond := + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr (Ind_Lo)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr (Ind_Hi))); + end if; + + if Present (Cond) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Le (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr (Aggr_Hi)), + + Right_Opnd => Cond); + + Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); + Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, Condition => Cond)); + end if; + end Check_Bounds; + + ---------------------------- + -- Check_Same_Aggr_Bounds -- + ---------------------------- + + procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is + Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr)); + Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr)); + -- The bounds of this specific sub-aggregate. + + Aggr_Lo : constant Node_Id := Aggr_Low (Dim); + Aggr_Hi : constant Node_Id := Aggr_High (Dim); + -- The bounds of the aggregate for this dimension + + Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); + -- The index type for this dimension. + + Cond : Node_Id := Empty; + + Assoc : Node_Id; + Expr : Node_Id; + + begin + -- If index checks are on generate the test + -- + -- [constraint_error when + -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi] + -- + -- As an optimization try to see if some tests are trivially vacuos + -- because we are comparing an expression against itself. Also for + -- the first dimension the test is trivially vacuous because there + -- is just one aggregate for dimension 1. + + if Index_Checks_Suppressed (Ind_Typ) then + Cond := Empty; + + elsif Dim = 1 + or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) + then + Cond := Empty; + + elsif Aggr_Hi = Sub_Hi then + Cond := + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr (Sub_Lo)); + + elsif Aggr_Lo = Sub_Lo then + Cond := + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr (Sub_Hi)); + + else + Cond := + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr (Sub_Lo)), + + Right_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr (Sub_Hi))); + end if; + + if Present (Cond) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, Condition => Cond)); + end if; + + -- Now look inside the sub-aggregate to see if there is more work + + if Dim < Aggr_Dimension then + + -- Process positional components + + if Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + while Present (Expr) loop + Check_Same_Aggr_Bounds (Expr, Dim + 1); + Next (Expr); + end loop; + end if; + + -- Process component associations + + if Present (Component_Associations (Sub_Aggr)) then + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Check_Same_Aggr_Bounds (Expr, Dim + 1); + Next (Assoc); + end loop; + end if; + end if; + end Check_Same_Aggr_Bounds; + + ---------------------------- + -- Compute_Others_Present -- + ---------------------------- + + procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is + Assoc : Node_Id; + Expr : Node_Id; + + begin + if Present (Component_Associations (Sub_Aggr)) then + Assoc := Last (Component_Associations (Sub_Aggr)); + if Nkind (First (Choices (Assoc))) = N_Others_Choice then + Others_Present (Dim) := True; + end if; + end if; + + -- Now look inside the sub-aggregate to see if there is more work + + if Dim < Aggr_Dimension then + + -- Process positional components + + if Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + while Present (Expr) loop + Compute_Others_Present (Expr, Dim + 1); + Next (Expr); + end loop; + end if; + + -- Process component associations + + if Present (Component_Associations (Sub_Aggr)) then + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Compute_Others_Present (Expr, Dim + 1); + Next (Assoc); + end loop; + end if; + end if; + end Compute_Others_Present; + + --------------------------- + -- Convert_To_Positional -- + --------------------------- + + procedure Convert_To_Positional (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Ndim : constant Pos := Number_Dimensions (Typ); + Xtyp : constant Entity_Id := Etype (First_Index (Typ)); + Blo : constant Node_Id := + Type_Low_Bound (Etype (First_Index (Base_Type (Typ)))); + Lo : constant Node_Id := Type_Low_Bound (Xtyp); + Hi : constant Node_Id := Type_High_Bound (Xtyp); + Lov : Uint; + Hiv : Uint; + + Max_Aggr_Size : constant := 500; + -- Maximum size of aggregate produced by converting positional to + -- named notation. This avoids running away with attempts to + -- convert huge aggregates. + + Max_Others_Replicate : constant := 5; + -- This constant defines the maximum expansion of an others clause + -- into a list of values. This applies when converting a named + -- aggregate to positional form for processing by the back end. + -- If a given others clause generates more than five values, the + -- aggregate is retained as named, since the loop is more compact. + -- However, this constant is completely overridden if restriction + -- No_Elaboration_Code is active, since in this case, the loop + -- would not be allowed anyway. Similarly No_Implicit_Loops causes + -- this parameter to be ignored. + + begin + -- For now, we only handle the one dimensional case and aggregates + -- that are not part of a component_association + + if Ndim > 1 or else Nkind (Parent (N)) = N_Aggregate + or else Nkind (Parent (N)) = N_Component_Association + then + return; + end if; + + -- If already positional, nothing to do! + + if No (Component_Associations (N)) then + return; + end if; + + -- Bounds need to be known at compile time + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return; + end if; + + -- Do not attempt to convert bit packed arrays, since they cannot + -- be handled by the backend in any case. + + if Is_Bit_Packed_Array (Typ) then + return; + end if; + + -- Do not convert to positional if controlled components are + -- involved since these require special processing + + if Has_Controlled_Component (Typ) then + return; + end if; + + -- Get bounds and check reasonable size (positive, not too large) + -- Also only handle bounds starting at the base type low bound for + -- now since the compiler isn't able to handle different low bounds + -- yet + + Lov := Expr_Value (Lo); + Hiv := Expr_Value (Hi); + + if Hiv < Lov + or else (Hiv - Lov > Max_Aggr_Size) + or else not Compile_Time_Known_Value (Blo) + or else (Lov /= Expr_Value (Blo)) + then + return; + end if; + + -- Bounds must be in integer range (for array Vals below) + + if not UI_Is_In_Int_Range (Lov) + or else + not UI_Is_In_Int_Range (Hiv) + then + return; + end if; + + -- Determine if set of alternatives is suitable for conversion + -- and build an array containing the values in sequence. + + declare + Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) + of Node_Id := (others => Empty); + -- The values in the aggregate sorted appropriately + + Vlist : List_Id; + -- Same data as Vals in list form + + Rep_Count : Nat; + -- Used to validate Max_Others_Replicate limit + + Elmt : Node_Id; + Num : Int := UI_To_Int (Lov); + Choice : Node_Id; + Lo, Hi : Node_Id; + + begin + if Present (Expressions (N)) then + Elmt := First (Expressions (N)); + while Present (Elmt) loop + Vals (Num) := Relocate_Node (Elmt); + Num := Num + 1; + Next (Elmt); + end loop; + end if; + + Elmt := First (Component_Associations (N)); + Component_Loop : while Present (Elmt) loop + + Choice := First (Choices (Elmt)); + Choice_Loop : while Present (Choice) loop + + -- If we have an others choice, fill in the missing elements + -- subject to the limit established by Max_Others_Replicate. + + if Nkind (Choice) = N_Others_Choice then + Rep_Count := 0; + + for J in Vals'Range loop + if No (Vals (J)) then + Vals (J) := New_Copy_Tree (Expression (Elmt)); + Rep_Count := Rep_Count + 1; + + if Rep_Count > Max_Others_Replicate + and then not Restrictions (No_Elaboration_Code) + and then not Restrictions (No_Implicit_Loops) + then + return; + end if; + end if; + end loop; + + exit Component_Loop; + + -- Case of a subtype mark + + elsif (Nkind (Choice) = N_Identifier + and then Is_Type (Entity (Choice))) + then + Lo := Type_Low_Bound (Etype (Choice)); + Hi := Type_High_Bound (Etype (Choice)); + + -- Case of subtype indication + + elsif Nkind (Choice) = N_Subtype_Indication then + Lo := Low_Bound (Range_Expression (Constraint (Choice))); + Hi := High_Bound (Range_Expression (Constraint (Choice))); + + -- Case of a range + + elsif Nkind (Choice) = N_Range then + Lo := Low_Bound (Choice); + Hi := High_Bound (Choice); + + -- Normal subexpression case + + else pragma Assert (Nkind (Choice) in N_Subexpr); + if not Compile_Time_Known_Value (Choice) then + return; + + else + Vals (UI_To_Int (Expr_Value (Choice))) := + New_Copy_Tree (Expression (Elmt)); + goto Continue; + end if; + end if; + + -- Range cases merge with Lo,Hi said + + if not Compile_Time_Known_Value (Lo) + or else + not Compile_Time_Known_Value (Hi) + then + return; + else + for J in UI_To_Int (Expr_Value (Lo)) .. + UI_To_Int (Expr_Value (Hi)) + loop + Vals (J) := New_Copy_Tree (Expression (Elmt)); + end loop; + end if; + + <<Continue>> + Next (Choice); + end loop Choice_Loop; + + Next (Elmt); + end loop Component_Loop; + + -- If we get here the conversion is possible + + Vlist := New_List; + for J in Vals'Range loop + Append (Vals (J), Vlist); + end loop; + + Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); + Analyze_And_Resolve (N, Typ); + end; + end Convert_To_Positional; + + ------------------------- + -- Has_Address_Clause -- + ------------------------- + + function Has_Address_Clause (D : Node_Id) return Boolean is + Id : Entity_Id := Defining_Identifier (D); + Decl : Node_Id := Next (D); + + begin + while Present (Decl) loop + + if Nkind (Decl) = N_At_Clause + and then Chars (Identifier (Decl)) = Chars (Id) + then + return True; + + elsif Nkind (Decl) = N_Attribute_Definition_Clause + and then Chars (Decl) = Name_Address + and then Chars (Name (Decl)) = Chars (Id) + then + return True; + end if; + + Next (Decl); + end loop; + + return False; + end Has_Address_Clause; + + ------------------------ + -- In_Place_Assign_OK -- + ------------------------ + + function In_Place_Assign_OK return Boolean is + Aggr_In : Node_Id; + Aggr_Lo : Node_Id; + Aggr_Hi : Node_Id; + Obj_In : Node_Id; + Obj_Lo : Node_Id; + Obj_Hi : Node_Id; + + function Safe_Aggregate (Aggr : Node_Id) return Boolean; + -- Check recursively that each component of a (sub)aggregate does + -- not depend on the variable being assigned to. + + function Safe_Component (Expr : Node_Id) return Boolean; + -- Verify that an expression cannot depend on the variable being + -- assigned to. Room for improvement here (but less than before). + + -------------------- + -- Safe_Aggregate -- + -------------------- + + function Safe_Aggregate (Aggr : Node_Id) return Boolean is + Expr : Node_Id; + + begin + if Present (Expressions (Aggr)) then + Expr := First (Expressions (Aggr)); + + while Present (Expr) loop + if Nkind (Expr) = N_Aggregate then + if not Safe_Aggregate (Expr) then + return False; + end if; + + elsif not Safe_Component (Expr) then + return False; + end if; + + Next (Expr); + end loop; + end if; + + if Present (Component_Associations (Aggr)) then + Expr := First (Component_Associations (Aggr)); + + while Present (Expr) loop + if Nkind (Expression (Expr)) = N_Aggregate then + if not Safe_Aggregate (Expression (Expr)) then + return False; + end if; + + elsif not Safe_Component (Expression (Expr)) then + return False; + end if; + + Next (Expr); + end loop; + end if; + + return True; + end Safe_Aggregate; + + -------------------- + -- Safe_Component -- + -------------------- + + function Safe_Component (Expr : Node_Id) return Boolean is + Comp : Node_Id := Expr; + + function Check_Component (Comp : Node_Id) return Boolean; + -- Do the recursive traversal, after copy. + + function Check_Component (Comp : Node_Id) return Boolean is + begin + if Is_Overloaded (Comp) then + return False; + end if; + + return Compile_Time_Known_Value (Comp) + + or else (Is_Entity_Name (Comp) + and then Present (Entity (Comp)) + and then No (Renamed_Object (Entity (Comp)))) + + or else (Nkind (Comp) = N_Attribute_Reference + and then Check_Component (Prefix (Comp))) + + or else (Nkind (Comp) in N_Binary_Op + and then Check_Component (Left_Opnd (Comp)) + and then Check_Component (Right_Opnd (Comp))) + + or else (Nkind (Comp) in N_Unary_Op + and then Check_Component (Right_Opnd (Comp))) + + or else (Nkind (Comp) = N_Selected_Component + and then Check_Component (Prefix (Comp))); + end Check_Component; + + -- Start of processing for Safe_Component + + begin + -- If the component appears in an association that may + -- correspond to more than one element, it is not analyzed + -- before the expansion into assignments, to avoid side effects. + -- We analyze, but do not resolve the copy, to obtain sufficient + -- entity information for the checks that follow. If component is + -- overloaded we assume an unsafe function call. + + if not Analyzed (Comp) then + if Is_Overloaded (Expr) then + return False; + end if; + + Comp := New_Copy_Tree (Expr); + Analyze (Comp); + end if; + + return Check_Component (Comp); + end Safe_Component; + + -- Start of processing for In_Place_Assign_OK + + begin + if Present (Component_Associations (N)) then + + -- On assignment, sliding can take place, so we cannot do the + -- assignment in place unless the bounds of the aggregate are + -- statically equal to those of the target. + + -- If the aggregate is given by an others choice, the bounds + -- are derived from the left-hand side, and the assignment is + -- safe if the expression is. + + if No (Expressions (N)) + and then Nkind + (First (Choices (First (Component_Associations (N))))) + = N_Others_Choice + then + return + Safe_Component + (Expression (First (Component_Associations (N)))); + end if; + + Aggr_In := First_Index (Etype (N)); + Obj_In := First_Index (Etype (Name (Parent (N)))); + + while Present (Aggr_In) loop + Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi); + Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi); + + if not Compile_Time_Known_Value (Aggr_Lo) + or else not Compile_Time_Known_Value (Aggr_Hi) + or else not Compile_Time_Known_Value (Obj_Lo) + or else not Compile_Time_Known_Value (Obj_Hi) + or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo) + or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) + then + return False; + end if; + + Next_Index (Aggr_In); + Next_Index (Obj_In); + end loop; + end if; + + -- Now check the component values themselves. + + return Safe_Aggregate (N); + end In_Place_Assign_OK; + + ------------------ + -- Others_Check -- + ------------------ + + procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is + Aggr_Lo : constant Node_Id := Aggr_Low (Dim); + Aggr_Hi : constant Node_Id := Aggr_High (Dim); + -- The bounds of the aggregate for this dimension. + + Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); + -- The index type for this dimension. + + Need_To_Check : Boolean := False; + + Choices_Lo : Node_Id := Empty; + Choices_Hi : Node_Id := Empty; + -- The lowest and highest discrete choices for a named sub-aggregate + + Nb_Choices : Int := -1; + -- The number of discrete non-others choices in this sub-aggregate + + Nb_Elements : Uint := Uint_0; + -- The number of elements in a positional aggregate + + Cond : Node_Id := Empty; + + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + + begin + -- Check if we have an others choice. If we do make sure that this + -- sub-aggregate contains at least one element in addition to the + -- others choice. + + if Range_Checks_Suppressed (Ind_Typ) then + Need_To_Check := False; + + elsif Present (Expressions (Sub_Aggr)) + and then Present (Component_Associations (Sub_Aggr)) + then + Need_To_Check := True; + + elsif Present (Component_Associations (Sub_Aggr)) then + Assoc := Last (Component_Associations (Sub_Aggr)); + + if Nkind (First (Choices (Assoc))) /= N_Others_Choice then + Need_To_Check := False; + + else + -- Count the number of discrete choices. Start with -1 + -- because the others choice does not count. + + Nb_Choices := -1; + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + Nb_Choices := Nb_Choices + 1; + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + -- If there is only an others choice nothing to do + + Need_To_Check := (Nb_Choices > 0); + end if; + + else + Need_To_Check := False; + end if; + + -- If we are dealing with a positional sub-aggregate with an + -- others choice, compute the number or positional elements. + + if Need_To_Check and then Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + Nb_Elements := Uint_0; + while Present (Expr) loop + Nb_Elements := Nb_Elements + 1; + Next (Expr); + end loop; + + -- If the aggregate contains discrete choices and an others choice + -- compute the smallest and largest discrete choice values. + + elsif Need_To_Check then + Compute_Choices_Lo_And_Choices_Hi : declare + Table : Case_Table_Type (1 .. Nb_Choices); + -- Used to sort all the different choice values + + I : Pos := 1; + Low : Node_Id; + High : Node_Id; + + begin + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + exit; + end if; + + Get_Index_Bounds (Choice, Low, High); + Table (I).Choice_Lo := Low; + Table (I).Choice_Hi := High; + + I := I + 1; + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + -- Sort the discrete choices + + Sort_Case_Table (Table); + + Choices_Lo := Table (1).Choice_Lo; + Choices_Hi := Table (Nb_Choices).Choice_Hi; + end Compute_Choices_Lo_And_Choices_Hi; + end if; + + -- If no others choice in this sub-aggregate, or the aggregate + -- comprises only an others choice, nothing to do. + + if not Need_To_Check then + Cond := Empty; + + -- If we are dealing with an aggregate containing an others + -- choice and positional components, we generate the following test: + -- + -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) > + -- Ind_Typ'Pos (Aggr_Hi) + -- then + -- raise Constraint_Error; + -- end if; + + elsif Nb_Elements > Uint_0 then + Cond := + Make_Op_Gt (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => + New_List (Duplicate_Subexpr (Aggr_Lo))), + Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Duplicate_Subexpr (Aggr_Hi)))); + + -- If we are dealing with an aggregate containing an others + -- choice and discrete choices we generate the following test: + -- + -- [constraint_error when + -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi]; + + else + Cond := + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr (Choices_Lo), + Right_Opnd => Duplicate_Subexpr (Aggr_Lo)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr (Choices_Hi), + Right_Opnd => Duplicate_Subexpr (Aggr_Hi))); + end if; + + if Present (Cond) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, Condition => Cond)); + end if; + + -- Now look inside the sub-aggregate to see if there is more work + + if Dim < Aggr_Dimension then + + -- Process positional components + + if Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + while Present (Expr) loop + Others_Check (Expr, Dim + 1); + Next (Expr); + end loop; + end if; + + -- Process component associations + + if Present (Component_Associations (Sub_Aggr)) then + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Others_Check (Expr, Dim + 1); + Next (Assoc); + end loop; + end if; + end if; + end Others_Check; + + -- Remaining Expand_Array_Aggregate variables + + Tmp : Entity_Id; + -- Holds the temporary aggregate value. + + Tmp_Decl : Node_Id; + -- Holds the declaration of Tmp. + + Aggr_Code : List_Id; + Parent_Node : Node_Id; + Parent_Kind : Node_Kind; + + -- Start of processing for Expand_Array_Aggregate + + begin + -- Do not touch the special aggregates of attributes used for Asm calls + + if Is_RTE (Ctyp, RE_Asm_Input_Operand) + or else Is_RTE (Ctyp, RE_Asm_Output_Operand) + then + return; + end if; + + -- If during semantic analysis it has been determined that aggregate N + -- will raise Constraint_Error at run-time, then the aggregate node + -- has been replaced with an N_Raise_Constraint_Error node and we + -- should never get here. + + pragma Assert (not Raises_Constraint_Error (N)); + + -- STEP 1: Check (a) + + Index_Compatibility_Check : declare + Aggr_Index_Range : Node_Id := First_Index (Typ); + -- The current aggregate index range + + Index_Constraint : Node_Id := First_Index (Etype (Typ)); + -- The corresponding index constraint against which we have to + -- check the above aggregate index range. + + begin + Compute_Others_Present (N, 1); + + for J in 1 .. Aggr_Dimension loop + -- There is no need to emit a check if an others choice is + -- present for this array aggregate dimension since in this + -- case one of N's sub-aggregates has taken its bounds from the + -- context and these bounds must have been checked already. In + -- addition all sub-aggregates corresponding to the same + -- dimension must all have the same bounds (checked in (c) below). + + if not Range_Checks_Suppressed (Etype (Index_Constraint)) + and then not Others_Present (J) + then + -- We don't use Checks.Apply_Range_Check here because it + -- emits a spurious check. Namely it checks that the range + -- defined by the aggregate bounds is non empty. But we know + -- this already if we get here. + + Check_Bounds (Aggr_Index_Range, Index_Constraint); + end if; + + -- Save the low and high bounds of the aggregate index as well + -- as the index type for later use in checks (b) and (c) below. + + Aggr_Low (J) := Low_Bound (Aggr_Index_Range); + Aggr_High (J) := High_Bound (Aggr_Index_Range); + + Aggr_Index_Typ (J) := Etype (Index_Constraint); + + Next_Index (Aggr_Index_Range); + Next_Index (Index_Constraint); + end loop; + end Index_Compatibility_Check; + + -- STEP 1: Check (b) + + Others_Check (N, 1); + + -- STEP 1: Check (c) + + if Aggr_Dimension > 1 then + Check_Same_Aggr_Bounds (N, 1); + end if; + + -- STEP 2. + + -- First try to convert to positional form. If the result is not + -- an aggregate any more, then we are done with the analysis (it + -- it could be a string literal or an identifier for a temporary + -- variable following this call). If result is an analyzed aggregate + -- the transformation was also successful and we are done as well. + + Convert_To_Positional (N); + + if Nkind (N) /= N_Aggregate then + return; + + elsif Analyzed (N) + and then N /= Original_Node (N) + then + return; + end if; + + if Backend_Processing_Possible (N) then + + -- If the aggregate is static but the constraints are not, build + -- a static subtype for the aggregate, so that Gigi can place it + -- in static memory. Perform an unchecked_conversion to the non- + -- static type imposed by the context. + + declare + Itype : constant Entity_Id := Etype (N); + Index : Node_Id; + Needs_Type : Boolean := False; + + begin + Index := First_Index (Itype); + + while Present (Index) loop + if not Is_Static_Subtype (Etype (Index)) then + Needs_Type := True; + exit; + else + Next_Index (Index); + end if; + end loop; + + if Needs_Type then + Build_Constrained_Type (Positional => True); + Rewrite (N, Unchecked_Convert_To (Itype, N)); + Analyze (N); + end if; + end; + + return; + end if; + + -- Delay expansion for nested aggregates it will be taken care of + -- when the parent aggregate is expanded + + Parent_Node := Parent (N); + Parent_Kind := Nkind (Parent_Node); + + if Parent_Kind = N_Qualified_Expression then + Parent_Node := Parent (Parent_Node); + Parent_Kind := Nkind (Parent_Node); + end if; + + if Parent_Kind = N_Aggregate + or else Parent_Kind = N_Extension_Aggregate + or else Parent_Kind = N_Component_Association + or else (Parent_Kind = N_Object_Declaration + and then Controlled_Type (Typ)) + or else (Parent_Kind = N_Assignment_Statement + and then Inside_Init_Proc) + then + Set_Expansion_Delayed (N); + return; + end if; + + -- STEP 3. + + -- Look if in place aggregate expansion is possible + + -- For object declarations we build the aggregate in place, unless + -- the array is bit-packed or the component is controlled. + + -- For assignments we do the assignment in place if all the component + -- associations have compile-time known values. For other cases we + -- create a temporary. The analysis for safety of on-line assignment + -- is delicate, i.e. we don't know how to do it fully yet ??? + + if Requires_Transient_Scope (Typ) then + Establish_Transient_Scope + (N, Sec_Stack => Has_Controlled_Component (Typ)); + end if; + + Maybe_In_Place_OK := + Comes_From_Source (N) + and then Nkind (Parent (N)) = N_Assignment_Statement + and then not Is_Bit_Packed_Array (Typ) + and then not Has_Controlled_Component (Typ) + and then In_Place_Assign_OK; + + if Comes_From_Source (Parent (N)) + and then Nkind (Parent (N)) = N_Object_Declaration + and then N = Expression (Parent (N)) + and then not Is_Bit_Packed_Array (Typ) + and then not Has_Controlled_Component (Typ) + and then not Has_Address_Clause (Parent (N)) + then + + Tmp := Defining_Identifier (Parent (N)); + Set_No_Initialization (Parent (N)); + Set_Expression (Parent (N), Empty); + + -- Set the type of the entity, for use in the analysis of the + -- subsequent indexed assignments. If the nominal type is not + -- constrained, build a subtype from the known bounds of the + -- aggregate. If the declaration has a subtype mark, use it, + -- otherwise use the itype of the aggregate. + + if not Is_Constrained (Typ) then + Build_Constrained_Type (Positional => False); + elsif Is_Entity_Name (Object_Definition (Parent (N))) + and then Is_Constrained (Entity (Object_Definition (Parent (N)))) + then + Set_Etype (Tmp, Entity (Object_Definition (Parent (N)))); + else + Set_Size_Known_At_Compile_Time (Typ, False); + Set_Etype (Tmp, Typ); + end if; + + elsif Maybe_In_Place_OK + and then Is_Entity_Name (Name (Parent (N))) + then + Tmp := Entity (Name (Parent (N))); + + if Etype (Tmp) /= Etype (N) then + Apply_Length_Check (N, Etype (Tmp)); + end if; + + elsif Maybe_In_Place_OK + and then Nkind (Name (Parent (N))) = N_Slice + and then Safe_Slice_Assignment (N, Typ) + then + -- Safe_Slice_Assignment rewrites assignment as a loop. + + return; + + else + Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Tmp_Decl := + Make_Object_Declaration + (Loc, + Defining_Identifier => Tmp, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + Set_No_Initialization (Tmp_Decl, True); + + -- If we are within a loop, the temporary will be pushed on the + -- stack at each iteration. If the aggregate is the expression for + -- an allocator, it will be immediately copied to the heap and can + -- be reclaimed at once. We create a transient scope around the + -- aggregate for this purpose. + + if Ekind (Current_Scope) = E_Loop + and then Nkind (Parent (Parent (N))) = N_Allocator + then + Establish_Transient_Scope (N, False); + end if; + + Insert_Action (N, Tmp_Decl); + end if; + + -- Construct and insert the aggregate code. We can safely suppress + -- index checks because this code is guaranteed not to raise CE + -- on index checks. However we should *not* suppress all checks. + + Aggr_Code := + Build_Array_Aggr_Code (N, + Index => First_Index (Typ), + Into => New_Reference_To (Tmp, Loc), + Scalar_Comp => Is_Scalar_Type (Ctyp)); + + if Comes_From_Source (Tmp) then + Insert_Actions_After (Parent (N), Aggr_Code); + + else + Insert_Actions (N, Aggr_Code); + end if; + + if Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (N))) + and then Tmp = Entity (Name (Parent (N))) + then + Rewrite (Parent (N), Make_Null_Statement (Loc)); + Analyze (N); + + elsif Nkind (Parent (N)) /= N_Object_Declaration + or else Tmp /= Defining_Identifier (Parent (N)) + then + Rewrite (N, New_Occurrence_Of (Tmp, Loc)); + Analyze_And_Resolve (N, Typ); + end if; + end Expand_Array_Aggregate; + + ------------------------ + -- Expand_N_Aggregate -- + ------------------------ + + procedure Expand_N_Aggregate (N : Node_Id) is + begin + if Is_Record_Type (Etype (N)) then + Expand_Record_Aggregate (N); + else + Expand_Array_Aggregate (N); + end if; + end Expand_N_Aggregate; + + ---------------------------------- + -- Expand_N_Extension_Aggregate -- + ---------------------------------- + + -- If the ancestor part is an expression, add a component association for + -- the parent field. If the type of the ancestor part is not the direct + -- parent of the expected type, build recursively the needed ancestors. + -- If the ancestor part is a subtype_mark, replace aggregate with a decla- + -- ration for a temporary of the expected type, followed by individual + -- assignments to the given components. + + procedure Expand_N_Extension_Aggregate (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + A : constant Node_Id := Ancestor_Part (N); + Typ : constant Entity_Id := Etype (N); + + begin + -- If the ancestor is a subtype mark, an init_proc must be called + -- on the resulting object which thus has to be materialized in + -- the front-end + + if Is_Entity_Name (A) and then Is_Type (Entity (A)) then + Convert_To_Assignments (N, Typ); + + -- The extension aggregate is transformed into a record aggregate + -- of the following form (c1 and c2 are inherited components) + + -- (Exp with c3 => a, c4 => b) + -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b) + + else + Set_Etype (N, Typ); + + -- No tag is needed in the case of Java_VM + + if Java_VM then + Expand_Record_Aggregate (N, + Parent_Expr => A); + else + Expand_Record_Aggregate (N, + Orig_Tag => New_Occurrence_Of (Access_Disp_Table (Typ), Loc), + Parent_Expr => A); + end if; + end if; + end Expand_N_Extension_Aggregate; + + ----------------------------- + -- Expand_Record_Aggregate -- + ----------------------------- + + procedure Expand_Record_Aggregate + (N : Node_Id; + Orig_Tag : Node_Id := Empty; + Parent_Expr : Node_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (N); + Comps : constant List_Id := Component_Associations (N); + Typ : constant Entity_Id := Etype (N); + Base_Typ : constant Entity_Id := Base_Type (Typ); + + function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean; + -- Checks the presence of a nested aggregate which needs Late_Expansion + -- or the presence of tagged components which may need tag adjustment. + + -------------------------------------------------- + -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps -- + -------------------------------------------------- + + function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is + C : Node_Id; + Expr_Q : Node_Id; + + begin + if No (Comps) then + return False; + end if; + + C := First (Comps); + while Present (C) loop + + if Nkind (Expression (C)) = N_Qualified_Expression then + Expr_Q := Expression (Expression (C)); + else + Expr_Q := Expression (C); + end if; + + -- Return true if the aggregate has any associations for + -- tagged components that may require tag adjustment. + -- These are cases where the source expression may have + -- a tag that could differ from the component tag (e.g., + -- can occur for type conversions and formal parameters). + -- (Tag adjustment is not needed if Java_VM because object + -- tags are implicit in the JVM.) + + if Is_Tagged_Type (Etype (Expr_Q)) + and then (Nkind (Expr_Q) = N_Type_Conversion + or else (Is_Entity_Name (Expr_Q) + and then Ekind (Entity (Expr_Q)) in Formal_Kind)) + and then not Java_VM + then + return True; + end if; + + if Is_Delayed_Aggregate (Expr_Q) then + return True; + end if; + + Next (C); + end loop; + + return False; + end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps; + + -- Remaining Expand_Record_Aggregate variables + + Tag_Value : Node_Id; + Comp : Entity_Id; + New_Comp : Node_Id; + + -- Start of processing for Expand_Record_Aggregate + + begin + -- Gigi doesn't handle properly temporaries of variable size + -- so we generate it in the front-end + + if not Size_Known_At_Compile_Time (Typ) then + Convert_To_Assignments (N, Typ); + + -- Temporaries for controlled aggregates need to be attached to a + -- final chain in order to be properly finalized, so it has to + -- be created in the front-end + + elsif Is_Controlled (Typ) + or else Has_Controlled_Component (Base_Type (Typ)) + then + Convert_To_Assignments (N, Typ); + + elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then + Convert_To_Assignments (N, Typ); + + -- If an ancestor is private, some components are not inherited and + -- we cannot expand into a record aggregate + + elsif Has_Private_Ancestor (Typ) then + Convert_To_Assignments (N, Typ); + + -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi + -- is not able to handle the aggregate for Late_Request. + + elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then + Convert_To_Assignments (N, Typ); + + -- In all other cases we generate a proper aggregate that + -- can be handled by gigi. + + else + if not Has_Discriminants (Typ) then + + -- This bizarre if/elsif is to avoid a compiler crash ??? + + null; + + elsif Is_Derived_Type (Typ) then + + -- Non-girder discriminants are replaced with girder discriminants + + declare + First_Comp : Node_Id; + Discriminant : Entity_Id; + + begin + -- Remove all the discriminants + + First_Comp := First (Component_Associations (N)); + + while Present (First_Comp) loop + Comp := First_Comp; + Next (First_Comp); + + if Ekind (Entity (First (Choices (Comp)))) = + E_Discriminant + then + Remove (Comp); + end if; + end loop; + + -- Insert girder discriminant associations + -- in the correct order + + First_Comp := Empty; + Discriminant := First_Girder_Discriminant (Typ); + while Present (Discriminant) loop + New_Comp := + Make_Component_Association (Loc, + Choices => + New_List (New_Occurrence_Of (Discriminant, Loc)), + + Expression => + New_Copy_Tree ( + Get_Discriminant_Value ( + Discriminant, + Typ, + Discriminant_Constraint (Typ)))); + + if No (First_Comp) then + Prepend_To (Component_Associations (N), New_Comp); + else + Insert_After (First_Comp, New_Comp); + end if; + + First_Comp := New_Comp; + Next_Girder_Discriminant (Discriminant); + end loop; + end; + end if; + + if Is_Tagged_Type (Typ) then + + -- The tagged case, _parent and _tag component must be created. + + -- Reset null_present unconditionally. tagged records always have + -- at least one field (the tag or the parent) + + Set_Null_Record_Present (N, False); + + -- When the current aggregate comes from the expansion of an + -- extension aggregate, the parent expr is replaced by an + -- aggregate formed by selected components of this expr + + if Present (Parent_Expr) + and then Is_Empty_List (Comps) + then + Comp := First_Entity (Typ); + while Present (Comp) loop + + -- Skip all entities that aren't discriminants or components + + if Ekind (Comp) /= E_Discriminant + and then Ekind (Comp) /= E_Component + then + null; + + -- Skip all expander-generated components + + elsif + not Comes_From_Source (Original_Record_Component (Comp)) + then + null; + + else + New_Comp := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + Duplicate_Subexpr (Parent_Expr, True)), + + Selector_Name => New_Occurrence_Of (Comp, Loc)); + + Append_To (Comps, + Make_Component_Association (Loc, + Choices => + New_List (New_Occurrence_Of (Comp, Loc)), + Expression => + New_Comp)); + + Analyze_And_Resolve (New_Comp, Etype (Comp)); + end if; + + Next_Entity (Comp); + end loop; + end if; + + -- Compute the value for the Tag now, if the type is a root it + -- will be included in the aggregate right away, otherwise it will + -- be propagated to the parent aggregate + + if Present (Orig_Tag) then + Tag_Value := Orig_Tag; + elsif Java_VM then + Tag_Value := Empty; + else + Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc); + end if; + + -- For a derived type, an aggregate for the parent is formed with + -- all the inherited components. + + if Is_Derived_Type (Typ) then + + declare + First_Comp : Node_Id; + Parent_Comps : List_Id; + Parent_Aggr : Node_Id; + Parent_Name : Node_Id; + + begin + -- Remove the inherited component association from the + -- aggregate and store them in the parent aggregate + + First_Comp := First (Component_Associations (N)); + Parent_Comps := New_List; + + while Present (First_Comp) + and then Scope (Original_Record_Component ( + Entity (First (Choices (First_Comp))))) /= Base_Typ + loop + Comp := First_Comp; + Next (First_Comp); + Remove (Comp); + Append (Comp, Parent_Comps); + end loop; + + Parent_Aggr := Make_Aggregate (Loc, + Component_Associations => Parent_Comps); + Set_Etype (Parent_Aggr, Etype (Base_Type (Typ))); + + -- Find the _parent component + + Comp := First_Component (Typ); + while Chars (Comp) /= Name_uParent loop + Comp := Next_Component (Comp); + end loop; + + Parent_Name := New_Occurrence_Of (Comp, Loc); + + -- Insert the parent aggregate + + Prepend_To (Component_Associations (N), + Make_Component_Association (Loc, + Choices => New_List (Parent_Name), + Expression => Parent_Aggr)); + + -- Expand recursively the parent propagating the right Tag + + Expand_Record_Aggregate ( + Parent_Aggr, Tag_Value, Parent_Expr); + end; + + -- For a root type, the tag component is added (unless compiling + -- for the Java VM, where tags are implicit). + + elsif not Java_VM then + declare + Tag_Name : constant Node_Id := + New_Occurrence_Of (Tag_Component (Typ), Loc); + Typ_Tag : constant Entity_Id := RTE (RE_Tag); + Conv_Node : constant Node_Id := + Unchecked_Convert_To (Typ_Tag, Tag_Value); + + begin + Set_Etype (Conv_Node, Typ_Tag); + Prepend_To (Component_Associations (N), + Make_Component_Association (Loc, + Choices => New_List (Tag_Name), + Expression => Conv_Node)); + end; + end if; + end if; + end if; + end Expand_Record_Aggregate; + + -------------------------- + -- Is_Delayed_Aggregate -- + -------------------------- + + function Is_Delayed_Aggregate (N : Node_Id) return Boolean is + Node : Node_Id := N; + Kind : Node_Kind := Nkind (Node); + begin + if Kind = N_Qualified_Expression then + Node := Expression (Node); + Kind := Nkind (Node); + end if; + + if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then + return False; + else + return Expansion_Delayed (Node); + end if; + end Is_Delayed_Aggregate; + + -------------------- + -- Late_Expansion -- + -------------------- + + function Late_Expansion + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty) + + return List_Id is + + begin + if Is_Record_Type (Etype (N)) then + return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj); + else + return + Build_Array_Aggr_Code + (N, + First_Index (Typ), + Target, + Is_Scalar_Type (Component_Type (Typ)), + No_List, + Flist); + end if; + end Late_Expansion; + + ---------------------------------- + -- Make_OK_Assignment_Statement -- + ---------------------------------- + + function Make_OK_Assignment_Statement + (Sloc : Source_Ptr; + Name : Node_Id; + Expression : Node_Id) + return Node_Id + is + begin + Set_Assignment_OK (Name); + return Make_Assignment_Statement (Sloc, Name, Expression); + end Make_OK_Assignment_Statement; + + ----------------------- + -- Number_Of_Choices -- + ----------------------- + + function Number_Of_Choices (N : Node_Id) return Nat is + Assoc : Node_Id; + Choice : Node_Id; + + Nb_Choices : Nat := 0; + + begin + if Present (Expressions (N)) then + return 0; + end if; + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + + Choice := First (Choices (Assoc)); + while Present (Choice) loop + + if Nkind (Choice) /= N_Others_Choice then + Nb_Choices := Nb_Choices + 1; + end if; + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + return Nb_Choices; + end Number_Of_Choices; + + --------------------------- + -- Safe_Slice_Assignment -- + --------------------------- + + function Safe_Slice_Assignment + (N : Node_Id; + Typ : Entity_Id) + return Boolean + is + Loc : constant Source_Ptr := Sloc (Parent (N)); + Pref : constant Node_Id := Prefix (Name (Parent (N))); + Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); + Expr : Node_Id; + L_I : Entity_Id; + L_Iter : Node_Id; + L_Body : Node_Id; + Stat : Node_Id; + + begin + -- Generate: For J in Range loop Pref (I) := Expr; end loop; + + if Comes_From_Source (N) + and then No (Expressions (N)) + and then Nkind (First (Choices (First (Component_Associations (N))))) + = N_Others_Choice + then + Expr := + Expression (First (Component_Associations (N))); + L_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + L_Iter := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification + (Loc, + Defining_Identifier => L_I, + Discrete_Subtype_Definition => Relocate_Node (Range_Node))); + + L_Body := + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Pref), + Expressions => New_List (New_Occurrence_Of (L_I, Loc))), + Expression => Relocate_Node (Expr)); + + -- Construct the final loop + + Stat := + Make_Implicit_Loop_Statement + (Node => Parent (N), + Identifier => Empty, + Iteration_Scheme => L_Iter, + Statements => New_List (L_Body)); + + Rewrite (Parent (N), Stat); + Analyze (Parent (N)); + return True; + + else + return False; + end if; + end Safe_Slice_Assignment; + + --------------------- + -- Sort_Case_Table -- + --------------------- + + procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is + L : Int := Case_Table'First; + U : Int := Case_Table'Last; + K : Int; + J : Int; + T : Case_Bounds; + + begin + K := L; + + while K /= U loop + T := Case_Table (K + 1); + J := K + 1; + + while J /= L + and then Expr_Value (Case_Table (J - 1).Choice_Lo) > + Expr_Value (T.Choice_Lo) + loop + Case_Table (J) := Case_Table (J - 1); + J := J - 1; + end loop; + + Case_Table (J) := T; + K := K + 1; + end loop; + end Sort_Case_Table; + +end Exp_Aggr; diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads new file mode 100644 index 00000000000..2e435defa32 --- /dev/null +++ b/gcc/ada/exp_aggr.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A G G R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1992-2000 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 Types; use Types; + +package Exp_Aggr is + + procedure Expand_N_Aggregate (N : Node_Id); + procedure Expand_N_Extension_Aggregate (N : Node_Id); + + function Is_Delayed_Aggregate (N : Node_Id) return Boolean; + -- returns True if N is a delayed aggregate of some kind + + procedure Convert_Aggr_In_Object_Decl (N : Node_Id); + -- N is a N_Object_Declaration with an expression which must be + -- an N_Aggregate or N_Extension_Aggregate with Expansion_Delayed + -- This procedure performs in-place aggregate assignment. + + procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id); + -- Decl is an access N_Object_Declaration (produced during + -- allocator expansion), Aggr is the initial expression aggregate + -- of an allocator. This procedure perform in-place aggregate + -- assignent in the newly allocated object. + + procedure Convert_Aggr_In_Assignment (N : Node_Id); + -- Decl is an access N_Object_Declaration (produced during + -- allocator expansion), Aggr is the initial expression aggregate + -- of an allocator. This procedure perform in-place aggregate + -- assignent in the newly allocated object. + + +end Exp_Aggr; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb new file mode 100644 index 00000000000..2fada3e36a5 --- /dev/null +++ b/gcc/ada/exp_attr.adb @@ -0,0 +1,3924 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T T R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.304 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch9; use Exp_Ch9; +with Exp_Imgv; use Exp_Imgv; +with Exp_Pakd; use Exp_Pakd; +with Exp_Strm; use Exp_Strm; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Gnatvsn; use Gnatvsn; +with Hostparm; use Hostparm; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Uname; use Uname; +with Validsw; use Validsw; + +package body Exp_Attr is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Compile_Stream_Body_In_Scope + (N : Node_Id; + Decl : Node_Id; + Arr : Entity_Id; + Check : Boolean); + -- The body for a stream subprogram may be generated outside of the scope + -- of the type. If the type is fully private, it may depend on the full + -- view of other types (e.g. indices) that are currently private as well. + -- We install the declarations of the package in which the type is declared + -- before compiling the body in what is its proper environment. The Check + -- parameter indicates if checks are to be suppressed for the stream body. + -- We suppress checks for array/record reads, since the rule is that these + -- are like assignments, out of range values due to uninitialized storage, + -- or other invalid values do NOT cause a Constraint_Error to be raised. + + procedure Expand_Fpt_Attribute + (N : Node_Id; + Rtp : Entity_Id; + Args : List_Id); + -- This procedure expands a call to a floating-point attribute function. + -- N is the attribute reference node, and Args is a list of arguments to + -- be passed to the function call. Rtp is the root type of the floating + -- point type involved (used to select the proper generic instantiation + -- of the package containing the attribute routines). + + procedure Expand_Fpt_Attribute_R (N : Node_Id); + -- This procedure expands a call to a floating-point attribute function + -- that takes a single floating-point argument. + + procedure Expand_Fpt_Attribute_RI (N : Node_Id); + -- This procedure expands a call to a floating-point attribute function + -- that takes one floating-point argument and one integer argument. + + procedure Expand_Fpt_Attribute_RR (N : Node_Id); + -- This procedure expands a call to a floating-point attribute function + -- that takes two floating-point arguments. + + procedure Expand_Pred_Succ (N : Node_Id); + -- Handles expansion of Pred or Succ attributes for case of non-real + -- operand with overflow checking required. + + function Get_Index_Subtype (N : Node_Id) return Entity_Id; + -- Used for Last, Last, and Length, when the prefix is an array type, + -- Obtains the corresponding index subtype. + + procedure Expand_Access_To_Type (N : Node_Id); + -- A reference to a type within its own scope is resolved to a reference + -- to the current instance of the type in its initialization procedure. + + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + + function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean; + -- Utility for array attributes, returns true on packed constrained + -- arrays, and on access to same. + + ---------------------------------- + -- Compile_Stream_Body_In_Scope -- + ---------------------------------- + + procedure Compile_Stream_Body_In_Scope + (N : Node_Id; + Decl : Node_Id; + Arr : Entity_Id; + Check : Boolean) + is + Installed : Boolean := False; + Scop : constant Entity_Id := Scope (Arr); + Curr : constant Entity_Id := Current_Scope; + + begin + if Is_Hidden (Arr) + and then not In_Open_Scopes (Scop) + and then Ekind (Scop) = E_Package + then + New_Scope (Scop); + Install_Visible_Declarations (Scop); + Install_Private_Declarations (Scop); + Installed := True; + + -- The entities in the package are now visible, but the generated + -- stream entity must appear in the current scope (usually an + -- enclosing stream function) so that itypes all have their proper + -- scopes. + + New_Scope (Curr); + end if; + + if Check then + Insert_Action (N, Decl); + else + Insert_Action (N, Decl, All_Checks); + end if; + + if Installed then + + -- Remove extra copy of current scope, and package itself + + Pop_Scope; + End_Package_Scope (Scop); + end if; + end Compile_Stream_Body_In_Scope; + + --------------------------- + -- Expand_Access_To_Type -- + --------------------------- + + procedure Expand_Access_To_Type (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pref : constant Node_Id := Prefix (N); + Par : Node_Id; + Formal : Entity_Id; + + begin + if Is_Entity_Name (Pref) + and then Is_Type (Entity (Pref)) + then + -- If the current instance name denotes a task type, + -- then the access attribute is rewritten to be the + -- name of the "_task" parameter associated with the + -- task type's task body procedure. An unchecked + -- conversion is applied to ensure a type match in + -- cases of expander-generated calls (e.g., init procs). + + if Is_Task_Type (Entity (Pref)) then + Formal := + First_Entity (Get_Task_Body_Procedure (Entity (Pref))); + + while Present (Formal) loop + exit when Chars (Formal) = Name_uTask; + Next_Entity (Formal); + end loop; + + pragma Assert (Present (Formal)); + + Rewrite (N, + Unchecked_Convert_To (Typ, New_Occurrence_Of (Formal, Loc))); + Set_Etype (N, Typ); + + -- The expression must appear in a default expression, + -- (which in the initialization procedure is the rhs of + -- an assignment), and not in a discriminant constraint. + + else + Par := Parent (N); + + while Present (Par) loop + exit when Nkind (Par) = N_Assignment_Statement; + + if Nkind (Par) = N_Component_Declaration then + return; + end if; + + Par := Parent (Par); + end loop; + + if Present (Par) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Attribute_Name (N))); + + Analyze_And_Resolve (N, Typ); + end if; + end if; + end if; + end Expand_Access_To_Type; + + -------------------------- + -- Expand_Fpt_Attribute -- + -------------------------- + + procedure Expand_Fpt_Attribute + (N : Node_Id; + Rtp : Entity_Id; + Args : List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pkg : RE_Id; + Fnm : Node_Id; + + begin + -- The function name is the selected component Fat_xxx.yyy where xxx + -- is the floating-point root type, and yyy is the attribute name + + -- Note: it would be more usual to have separate RE entries for each + -- of the entities in the Fat packages, but first they have identical + -- names (so we would have to have lots of renaming declarations to + -- meet the normal RE rule of separate names for all runtime entities), + -- and second there would be an awful lot of them! + + if Rtp = Standard_Short_Float then + Pkg := RE_Fat_Short_Float; + elsif Rtp = Standard_Float then + Pkg := RE_Fat_Float; + elsif Rtp = Standard_Long_Float then + Pkg := RE_Fat_Long_Float; + else + Pkg := RE_Fat_Long_Long_Float; + end if; + + Fnm := + Make_Selected_Component (Loc, + Prefix => New_Reference_To (RTE (Pkg), Loc), + Selector_Name => Make_Identifier (Loc, Attribute_Name (N))); + + -- The generated call is given the provided set of parameters, and then + -- wrapped in a conversion which converts the result to the target type + + Rewrite (N, + Unchecked_Convert_To (Etype (N), + Make_Function_Call (Loc, + Name => Fnm, + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ); + + end Expand_Fpt_Attribute; + + ---------------------------- + -- Expand_Fpt_Attribute_R -- + ---------------------------- + + -- The single argument is converted to its root type to call the + -- appropriate runtime function, with the actual call being built + -- by Expand_Fpt_Attribute + + procedure Expand_Fpt_Attribute_R (N : Node_Id) is + E1 : constant Node_Id := First (Expressions (N)); + Rtp : constant Entity_Id := Root_Type (Etype (E1)); + + begin + Expand_Fpt_Attribute (N, Rtp, New_List ( + Unchecked_Convert_To (Rtp, Relocate_Node (E1)))); + end Expand_Fpt_Attribute_R; + + ----------------------------- + -- Expand_Fpt_Attribute_RI -- + ----------------------------- + + -- The first argument is converted to its root type and the second + -- argument is converted to standard long long integer to call the + -- appropriate runtime function, with the actual call being built + -- by Expand_Fpt_Attribute + + procedure Expand_Fpt_Attribute_RI (N : Node_Id) is + E1 : constant Node_Id := First (Expressions (N)); + Rtp : constant Entity_Id := Root_Type (Etype (E1)); + E2 : constant Node_Id := Next (E1); + + begin + Expand_Fpt_Attribute (N, Rtp, New_List ( + Unchecked_Convert_To (Rtp, Relocate_Node (E1)), + Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2)))); + end Expand_Fpt_Attribute_RI; + + ----------------------------- + -- Expand_Fpt_Attribute_RR -- + ----------------------------- + + -- The two arguments is converted to their root types to call the + -- appropriate runtime function, with the actual call being built + -- by Expand_Fpt_Attribute + + procedure Expand_Fpt_Attribute_RR (N : Node_Id) is + E1 : constant Node_Id := First (Expressions (N)); + Rtp : constant Entity_Id := Root_Type (Etype (E1)); + E2 : constant Node_Id := Next (E1); + + begin + Expand_Fpt_Attribute (N, Rtp, New_List ( + Unchecked_Convert_To (Rtp, Relocate_Node (E1)), + Unchecked_Convert_To (Rtp, Relocate_Node (E2)))); + end Expand_Fpt_Attribute_RR; + + ---------------------------------- + -- Expand_N_Attribute_Reference -- + ---------------------------------- + + procedure Expand_N_Attribute_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Pref : constant Node_Id := Prefix (N); + Exprs : constant List_Id := Expressions (N); + Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); + + procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id); + -- Rewrites a stream attribute for Read, Write or Output with the + -- procedure call. Pname is the entity for the procedure to call. + + ------------------------------ + -- Rewrite_Stream_Proc_Call -- + ------------------------------ + + procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is + Item : constant Node_Id := Next (First (Exprs)); + Formal_Typ : constant Entity_Id := + Etype (Next_Formal (First_Formal (Pname))); + + begin + -- We have to worry about the type of the second argument + + -- For the class-wide dispatching cases, and for cases in which + -- the base type of the second argument matches the base type of + -- the corresponding formal parameter, we are all set, and can use + -- the argument unchanged. + + -- For all other cases we do an unchecked conversion of the second + -- parameter to the type of the formal of the procedure we are + -- calling. This deals with the private type cases, and with going + -- to the root type as required in elementary type case. + + if not Is_Class_Wide_Type (Entity (Pref)) + and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ) + then + Rewrite (Item, + Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item))); + + -- For untagged derived types set Assignment_OK, to prevent + -- copies from being created when the unchecked conversion + -- is expanded (which would happen in Remove_Side_Effects + -- if Expand_N_Unchecked_Conversion were allowed to call + -- Force_Evaluation). The copy could violate Ada semantics + -- in cases such as an actual that is an out parameter. + -- Note that this approach is also used in exp_ch7 for calls + -- to controlled type operations to prevent problems with + -- actuals wrapped in unchecked conversions. + + if Is_Untagged_Derivation (Etype (Expression (Item))) then + Set_Assignment_OK (Item); + end if; + end if; + + -- And now rewrite the call + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Pname, Loc), + Parameter_Associations => Exprs)); + + Analyze (N); + end Rewrite_Stream_Proc_Call; + + -- Start of processing for Expand_N_Attribute_Reference + + begin + -- Do required validity checking + + if Validity_Checks_On and Validity_Check_Operands then + declare + Expr : Node_Id; + + begin + Expr := First (Expressions (N)); + while Present (Expr) loop + Ensure_Valid (Expr); + Next (Expr); + end loop; + end; + end if; + + -- Remaining processing depends on specific attribute + + case Id is + + ------------ + -- Access -- + ------------ + + when Attribute_Access => + + if Ekind (Btyp) = E_Access_Protected_Subprogram_Type then + + -- The value of the attribute_reference is a record containing + -- two fields: an access to the protected object, and an access + -- to the subprogram itself. The prefix is a selected component. + + declare + Agg : Node_Id; + Sub : Entity_Id; + E_T : constant Entity_Id := Equivalent_Type (Typ); + Acc : constant Entity_Id := + Etype (Next_Component (First_Component (E_T))); + Obj_Ref : Node_Id; + Curr : Entity_Id; + + begin + -- Within the body of the protected type, the prefix + -- designates a local operation, and the object is the first + -- parameter of the corresponding protected body of the + -- current enclosing operation. + + if Is_Entity_Name (Pref) then + pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); + Sub := + New_Occurrence_Of + (Protected_Body_Subprogram (Entity (Pref)), Loc); + Curr := Current_Scope; + + while Scope (Curr) /= Scope (Entity (Pref)) loop + Curr := Scope (Curr); + end loop; + + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (First_Formal + (Protected_Body_Subprogram (Curr)), Loc), + Attribute_Name => Name_Address); + + -- Case where the prefix is not an entity name. Find the + -- version of the protected operation to be called from + -- outside the protected object. + + else + Sub := + New_Occurrence_Of + (External_Subprogram + (Entity (Selector_Name (Pref))), Loc); + + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (Pref)), + Attribute_Name => Name_Address); + end if; + + Agg := + Make_Aggregate (Loc, + Expressions => + New_List ( + Obj_Ref, + Unchecked_Convert_To (Acc, + Make_Attribute_Reference (Loc, + Prefix => Sub, + Attribute_Name => Name_Address)))); + + Rewrite (N, Agg); + + Analyze_And_Resolve (N, Equivalent_Type (Typ)); + + -- For subsequent analysis, the node must retain its type. + -- The backend will replace it with the equivalent type where + -- needed. + + Set_Etype (N, Typ); + end; + + elsif Ekind (Btyp) = E_General_Access_Type then + declare + Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); + Parm_Ent : Entity_Id; + Conversion : Node_Id; + + begin + -- If the prefix of an Access attribute is a dereference of an + -- access parameter (or a renaming of such a dereference) and + -- the context is a general access type (but not an anonymous + -- access type), then rewrite the attribute as a conversion of + -- the access parameter to the context access type. This will + -- result in an accessibility check being performed, if needed. + + -- (X.all'Access => Acc_Type (X)) + + if Nkind (Ref_Object) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Ref_Object)) + then + Parm_Ent := Entity (Prefix (Ref_Object)); + + if Ekind (Parm_Ent) in Formal_Kind + and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type + and then Present (Extra_Accessibility (Parm_Ent)) + then + Conversion := + Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))); + + Rewrite (N, Conversion); + Analyze_And_Resolve (N, Typ); + end if; + end if; + end; + + -- If the prefix is a type name, this is a reference to the current + -- instance of the type, within its initialization procedure. + + else + Expand_Access_To_Type (N); + end if; + + -------------- + -- Adjacent -- + -------------- + + -- Transforms 'Adjacent into a call to the floating-point attribute + -- function Adjacent in Fat_xxx (where xxx is the root type) + + when Attribute_Adjacent => + Expand_Fpt_Attribute_RR (N); + + ------------- + -- Address -- + ------------- + + when Attribute_Address => Address : declare + Task_Proc : Entity_Id; + + begin + -- If the prefix is a task or a task type, the useful address + -- is that of the procedure for the task body, i.e. the actual + -- program unit. We replace the original entity with that of + -- the procedure. + + if Is_Entity_Name (Pref) + and then Is_Task_Type (Entity (Pref)) + then + Task_Proc := Next_Entity (Root_Type (Etype (Pref))); + + while Present (Task_Proc) loop + exit when Ekind (Task_Proc) = E_Procedure + and then Etype (First_Formal (Task_Proc)) = + Corresponding_Record_Type (Etype (Pref)); + Next_Entity (Task_Proc); + end loop; + + if Present (Task_Proc) then + Set_Entity (Pref, Task_Proc); + Set_Etype (Pref, Etype (Task_Proc)); + end if; + + -- Similarly, the address of a protected operation is the address + -- of the corresponding protected body, regardless of the protected + -- object from which it is selected. + + elsif Nkind (Pref) = N_Selected_Component + and then Is_Subprogram (Entity (Selector_Name (Pref))) + and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref)))) + then + Rewrite (Pref, + New_Occurrence_Of ( + External_Subprogram (Entity (Selector_Name (Pref))), Loc)); + + elsif Nkind (Pref) = N_Explicit_Dereference + and then Ekind (Etype (Pref)) = E_Subprogram_Type + and then Convention (Etype (Pref)) = Convention_Protected + then + -- The prefix is be a dereference of an access_to_protected_ + -- subprogram. The desired address is the second component of + -- the record that represents the access. + + declare + Addr : constant Entity_Id := Etype (N); + Ptr : constant Node_Id := Prefix (Pref); + T : constant Entity_Id := + Equivalent_Type (Base_Type (Etype (Ptr))); + + begin + Rewrite (N, + Unchecked_Convert_To (Addr, + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => New_Occurrence_Of ( + Next_Entity (First_Entity (T)), Loc)))); + + Analyze_And_Resolve (N, Addr); + end; + end if; + + -- Deal with packed array reference, other cases are handled by gigi + + if Involves_Packed_Array_Reference (Pref) then + Expand_Packed_Address_Reference (N); + end if; + end Address; + + --------------- + -- AST_Entry -- + --------------- + + when Attribute_AST_Entry => AST_Entry : declare + Ttyp : Entity_Id; + T_Id : Node_Id; + Eent : Entity_Id; + + Entry_Ref : Node_Id; + -- The reference to the entry or entry family + + Index : Node_Id; + -- The index expression for an entry family reference, or + -- the Empty if Entry_Ref references a simple entry. + + begin + if Nkind (Pref) = N_Indexed_Component then + Entry_Ref := Prefix (Pref); + Index := First (Expressions (Pref)); + else + Entry_Ref := Pref; + Index := Empty; + end if; + + -- Get expression for Task_Id and the entry entity + + if Nkind (Entry_Ref) = N_Selected_Component then + T_Id := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Identity, + Prefix => Prefix (Entry_Ref)); + + Ttyp := Etype (Prefix (Entry_Ref)); + Eent := Entity (Selector_Name (Entry_Ref)); + + else + T_Id := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc)); + + Eent := Entity (Entry_Ref); + + -- We have to find the enclosing task to get the task type + -- There must be one, since we already validated this earlier + + Ttyp := Current_Scope; + while not Is_Task_Type (Ttyp) loop + Ttyp := Scope (Ttyp); + end loop; + end if; + + -- Now rewrite the attribute with a call to Create_AST_Handler + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc), + Parameter_Associations => New_List ( + T_Id, + Entry_Index_Expression (Loc, Eent, Index, Ttyp)))); + + Analyze_And_Resolve (N, RTE (RE_AST_Handler)); + end AST_Entry; + + ------------------ + -- Bit_Position -- + ------------------ + + -- We compute this if a component clause was present, otherwise + -- we leave the computation up to Gigi, since we don't know what + -- layout will be chosen. + + -- Note that the attribute can apply to a naked record component + -- in generated code (i.e. the prefix is an identifier that + -- references the component or discriminant entity). + + when Attribute_Bit_Position => Bit_Position : + declare + CE : Entity_Id; + + begin + if Nkind (Pref) = N_Identifier then + CE := Entity (Pref); + else + CE := Entity (Selector_Name (Pref)); + end if; + + if Known_Static_Component_Bit_Offset (CE) then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Component_Bit_Offset (CE))); + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Bit_Position; + + ------------------ + -- Body_Version -- + ------------------ + + -- A reference to P'Body_Version or P'Version is expanded to + + -- Vnn : Unsigned; + -- pragma Import (C, Vnn, "uuuuT"; + -- ... + -- Get_Version_String (Vnn) + + -- where uuuu is the unit name (dots replaced by double underscore) + -- and T is B for the cases of Body_Version, or Version applied to a + -- subprogram acting as its own spec, and S for Version applied to a + -- subprogram spec or package. This sequence of code references the + -- the unsigned constant created in the main program by the binder. + + -- A special exception occurs for Standard, where the string + -- returned is a copy of the library string in gnatvsn.ads. + + when Attribute_Body_Version | Attribute_Version => Version : declare + E : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + Pent : Entity_Id := Entity (Pref); + S : String_Id; + + begin + -- If not library unit, get to containing library unit + + while Pent /= Standard_Standard + and then Scope (Pent) /= Standard_Standard + loop + Pent := Scope (Pent); + end loop; + + -- Special case Standard + + if Pent = Standard_Standard + or else Pent = Standard_ASCII + then + Name_Buffer (1 .. Library_Version'Length) := Library_Version; + Name_Len := Library_Version'Length; + Rewrite (N, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- All other cases + + else + -- Build required string constant + + Get_Name_String (Get_Unit_Name (Pent)); + + Start_String; + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) = '.' then + Store_String_Chars ("__"); + else + Store_String_Char (Get_Char_Code (Name_Buffer (J))); + end if; + end loop; + + -- Case of subprogram acting as its own spec, always use body + + if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification + and then Nkind (Parent (Declaration_Node (Pent))) = + N_Subprogram_Body + and then Acts_As_Spec (Parent (Declaration_Node (Pent))) + then + Store_String_Chars ("B"); + + -- Case of no body present, always use spec + + elsif not Unit_Requires_Body (Pent) then + Store_String_Chars ("S"); + + -- Otherwise use B for Body_Version, S for spec + + elsif Id = Attribute_Body_Version then + Store_String_Chars ("B"); + else + Store_String_Chars ("S"); + end if; + + S := End_String; + Lib.Version_Referenced (S); + + -- Insert the object declaration + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned), Loc)))); + + -- Set entity as imported with correct external name + + Set_Is_Imported (E); + Set_Interface_Name (E, Make_String_Literal (Loc, S)); + + -- And now rewrite original reference + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Version_String), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (E, Loc)))); + end if; + + Analyze_And_Resolve (N, RTE (RE_Version_String)); + end Version; + + ------------- + -- Ceiling -- + ------------- + + -- Transforms 'Ceiling into a call to the floating-point attribute + -- function Ceiling in Fat_xxx (where xxx is the root type) + + when Attribute_Ceiling => + Expand_Fpt_Attribute_R (N); + + -------------- + -- Callable -- + -------------- + + -- Transforms 'Callable attribute into a call to the Callable function. + + when Attribute_Callable => Callable : + begin + Rewrite (N, + Build_Call_With_Task (Pref, RTE (RE_Callable))); + Analyze_And_Resolve (N, Standard_Boolean); + end Callable; + + ------------ + -- Caller -- + ------------ + + -- Transforms 'Caller attribute into a call to either the + -- Task_Entry_Caller or the Protected_Entry_Caller function. + + when Attribute_Caller => Caller : declare + Id_Kind : Entity_Id := RTE (RO_AT_Task_ID); + Ent : Entity_Id := Entity (Pref); + Conctype : Entity_Id := Scope (Ent); + Nest_Depth : Integer := 0; + Name : Node_Id; + S : Entity_Id; + + begin + -- Protected case + + if Is_Protected_Type (Conctype) then + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Conctype) > 1 + then + Name := + New_Reference_To + (RTE (RE_Protected_Entry_Caller), Loc); + else + Name := + New_Reference_To + (RTE (RE_Protected_Single_Entry_Caller), Loc); + end if; + + Rewrite (N, + Unchecked_Convert_To (Id_Kind, + Make_Function_Call (Loc, + Name => Name, + Parameter_Associations => New_List + (New_Reference_To ( + Object_Ref + (Corresponding_Body (Parent (Conctype))), Loc))))); + + -- Task case + + else + -- Determine the nesting depth of the E'Caller attribute, that + -- is, how many accept statements are nested within the accept + -- statement for E at the point of E'Caller. The runtime uses + -- this depth to find the specified entry call. + + for J in reverse 0 .. Scope_Stack.Last loop + S := Scope_Stack.Table (J).Entity; + + -- We should not reach the scope of the entry, as it should + -- already have been checked in Sem_Attr that this attribute + -- reference is within a matching accept statement. + + pragma Assert (S /= Conctype); + + if S = Ent then + exit; + + elsif Is_Entry (S) then + Nest_Depth := Nest_Depth + 1; + end if; + end loop; + + Rewrite (N, + Unchecked_Convert_To (Id_Kind, + Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Task_Entry_Caller), Loc), + Parameter_Associations => New_List ( + Make_Integer_Literal (Loc, + Intval => Int (Nest_Depth)))))); + end if; + + Analyze_And_Resolve (N, Id_Kind); + end Caller; + + ------------- + -- Compose -- + ------------- + + -- Transforms 'Compose into a call to the floating-point attribute + -- function Compose in Fat_xxx (where xxx is the root type) + + -- Note: we strictly should have special code here to deal with the + -- case of absurdly negative arguments (less than Integer'First) + -- which will return a (signed) zero value, but it hardly seems + -- worth the effort. Absurdly large positive arguments will raise + -- constraint error which is fine. + + when Attribute_Compose => + Expand_Fpt_Attribute_RI (N); + + ----------------- + -- Constrained -- + ----------------- + + when Attribute_Constrained => Constrained : declare + Formal_Ent : constant Entity_Id := Param_Entity (Pref); + + begin + -- Reference to a parameter where the value is passed as an extra + -- actual, corresponding to the extra formal referenced by the + -- Extra_Constrained field of the corresponding formal. + + if Present (Formal_Ent) + and then Present (Extra_Constrained (Formal_Ent)) + then + Rewrite (N, + New_Occurrence_Of + (Extra_Constrained (Formal_Ent), Sloc (N))); + + -- For variables with a Extra_Constrained field, we use the + -- corresponding entity. + + elsif Nkind (Pref) = N_Identifier + and then Ekind (Entity (Pref)) = E_Variable + and then Present (Extra_Constrained (Entity (Pref))) + then + Rewrite (N, + New_Occurrence_Of + (Extra_Constrained (Entity (Pref)), Sloc (N))); + + -- For all other entity names, we can tell at compile time + + elsif Is_Entity_Name (Pref) then + declare + Ent : constant Entity_Id := Entity (Pref); + Res : Boolean; + + begin + -- (RM J.4) obsolescent cases + + if Is_Type (Ent) then + + -- Private type + + if Is_Private_Type (Ent) then + Res := not Has_Discriminants (Ent) + or else Is_Constrained (Ent); + + -- It not a private type, must be a generic actual type + -- that corresponded to a private type. We know that this + -- correspondence holds, since otherwise the reference + -- within the generic template would have been illegal. + + else + declare + UT : Entity_Id := Underlying_Type (Ent); + + begin + if Is_Composite_Type (UT) then + Res := Is_Constrained (Ent); + else + Res := True; + end if; + end; + end if; + + -- If the prefix is not a variable or is aliased, then + -- definitely true; if it's a formal parameter without + -- an associated extra formal, then treat it as constrained. + + elsif not Is_Variable (Pref) + or else Present (Formal_Ent) + or else Is_Aliased_View (Pref) + then + Res := True; + + -- Variable case, just look at type to see if it is + -- constrained. Note that the one case where this is + -- not accurate (the procedure formal case), has been + -- handled above. + + else + Res := Is_Constrained (Etype (Ent)); + end if; + + if Res then + Rewrite (N, + New_Reference_To (Standard_True, Loc)); + else + Rewrite (N, + New_Reference_To (Standard_False, Loc)); + end if; + end; + + -- Prefix is not an entity name. These are also cases where + -- we can always tell at compile time by looking at the form + -- and type of the prefix. + + else + if not Is_Variable (Pref) + or else Nkind (Pref) = N_Explicit_Dereference + or else Is_Constrained (Etype (Pref)) + then + Rewrite (N, + New_Reference_To (Standard_True, Loc)); + else + Rewrite (N, + New_Reference_To (Standard_False, Loc)); + end if; + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + end Constrained; + + --------------- + -- Copy_Sign -- + --------------- + + -- Transforms 'Copy_Sign into a call to the floating-point attribute + -- function Copy_Sign in Fat_xxx (where xxx is the root type) + + when Attribute_Copy_Sign => + Expand_Fpt_Attribute_RR (N); + + ----------- + -- Count -- + ----------- + + -- Transforms 'Count attribute into a call to the Count function + + when Attribute_Count => Count : + declare + Entnam : Node_Id; + Index : Node_Id; + Name : Node_Id; + Call : Node_Id; + Conctyp : Entity_Id; + + begin + -- If the prefix is a member of an entry family, retrieve both + -- entry name and index. For a simple entry there is no index. + + if Nkind (Pref) = N_Indexed_Component then + Entnam := Prefix (Pref); + Index := First (Expressions (Pref)); + else + Entnam := Pref; + Index := Empty; + end if; + + -- Find the concurrent type in which this attribute is referenced + -- (there had better be one). + + Conctyp := Current_Scope; + while not Is_Concurrent_Type (Conctyp) loop + Conctyp := Scope (Conctyp); + end loop; + + -- Protected case + + if Is_Protected_Type (Conctyp) then + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Conctyp) > 1 + then + Name := New_Reference_To (RTE (RE_Protected_Count), Loc); + + Call := + Make_Function_Call (Loc, + Name => Name, + Parameter_Associations => New_List ( + New_Reference_To ( + Object_Ref ( + Corresponding_Body (Parent (Conctyp))), Loc), + Entry_Index_Expression ( + Loc, Entity (Entnam), Index, Scope (Entity (Entnam))))); + else + Name := New_Reference_To (RTE (RE_Protected_Count_Entry), Loc); + + Call := Make_Function_Call (Loc, + Name => Name, + Parameter_Associations => New_List ( + New_Reference_To ( + Object_Ref ( + Corresponding_Body (Parent (Conctyp))), Loc))); + end if; + + -- Task case + + else + Call := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Task_Count), Loc), + Parameter_Associations => New_List ( + Entry_Index_Expression + (Loc, Entity (Entnam), Index, Scope (Entity (Entnam))))); + end if; + + -- The call returns type Natural but the context is universal integer + -- so any integer type is allowed. The attribute was already resolved + -- so its Etype is the required result type. If the base type of the + -- context type is other than Standard.Integer we put in a conversion + -- to the required type. This can be a normal typed conversion since + -- both input and output types of the conversion are integer types + + if Base_Type (Typ) /= Base_Type (Standard_Integer) then + Rewrite (N, Convert_To (Typ, Call)); + else + Rewrite (N, Call); + end if; + + Analyze_And_Resolve (N, Typ); + end Count; + + --------------- + -- Elab_Body -- + --------------- + + -- This processing is shared by Elab_Spec + + -- What we do is to insert the following declarations + + -- procedure tnn; + -- pragma Import (C, enn, "name___elabb/s"); + + -- and then the Elab_Body/Spec attribute is replaced by a reference + -- to this defining identifier. + + when Attribute_Elab_Body | + Attribute_Elab_Spec => + + Elab_Body : declare + Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('E')); + Str : String_Id; + Lang : Node_Id; + + procedure Make_Elab_String (Nod : Node_Id); + -- Given Nod, an identifier, or a selected component, put the + -- image into the current string literal, with double underline + -- between components. + + procedure Make_Elab_String (Nod : Node_Id) is + begin + if Nkind (Nod) = N_Selected_Component then + Make_Elab_String (Prefix (Nod)); + if Java_VM then + Store_String_Char ('$'); + else + Store_String_Char ('_'); + Store_String_Char ('_'); + end if; + + Get_Name_String (Chars (Selector_Name (Nod))); + + else + pragma Assert (Nkind (Nod) = N_Identifier); + Get_Name_String (Chars (Nod)); + end if; + + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + end Make_Elab_String; + + -- Start of processing for Elab_Body/Elab_Spec + + begin + -- First we need to prepare the string literal for the name of + -- the elaboration routine to be referenced. + + Start_String; + Make_Elab_String (Pref); + + if Java_VM then + Store_String_Chars ("._elab"); + Lang := Make_Identifier (Loc, Name_Ada); + else + Store_String_Chars ("___elab"); + Lang := Make_Identifier (Loc, Name_C); + end if; + + if Id = Attribute_Elab_Body then + Store_String_Char ('b'); + else + Store_String_Char ('s'); + end if; + + Str := End_String; + + Insert_Actions (N, New_List ( + Make_Subprogram_Declaration (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Ent)), + + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Lang), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, Chars (Ent))), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_String_Literal (Loc, Str)))))); + + Set_Entity (N, Ent); + Rewrite (N, New_Occurrence_Of (Ent, Loc)); + end Elab_Body; + + ---------------- + -- Elaborated -- + ---------------- + + -- Elaborated is always True for preelaborated units, predefined + -- units, pure units and units which have Elaborate_Body pragmas. + -- These units have no elaboration entity. + + -- Note: The Elaborated attribute is never passed through to Gigi + + when Attribute_Elaborated => Elaborated : declare + Ent : constant Entity_Id := Entity (Pref); + + begin + if Present (Elaboration_Entity (Ent)) then + Rewrite (N, + New_Occurrence_Of (Elaboration_Entity (Ent), Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + end if; + end Elaborated; + + -------------- + -- Enum_Rep -- + -------------- + + when Attribute_Enum_Rep => Enum_Rep : + begin + -- X'Enum_Rep (Y) expands to + + -- target-type (Y) + + -- This is simply a direct conversion from the enumeration type + -- to the target integer type, which is treated by Gigi as a normal + -- integer conversion, treating the enumeration type as an integer, + -- which is exactly what we want! We set Conversion_OK to make sure + -- that the analyzer does not complain about what otherwise might + -- be an illegal conversion. + + if Is_Non_Empty_List (Exprs) then + Rewrite (N, + OK_Convert_To (Typ, Relocate_Node (First (Exprs)))); + + -- X'Enum_Rep where X is an enumeration literal is replaced by + -- the literal value. + + elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then + Rewrite (N, + Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref)))); + + -- X'Enum_Rep where X is an object does a direct unchecked conversion + -- of the object value, as described for the type case above. + + else + Rewrite (N, + OK_Convert_To (Typ, Relocate_Node (Pref))); + end if; + + Set_Etype (N, Typ); + Analyze_And_Resolve (N, Typ); + + end Enum_Rep; + + -------------- + -- Exponent -- + -------------- + + -- Transforms 'Exponent into a call to the floating-point attribute + -- function Exponent in Fat_xxx (where xxx is the root type) + + when Attribute_Exponent => + Expand_Fpt_Attribute_R (N); + + ------------------ + -- External_Tag -- + ------------------ + + -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag) + + when Attribute_External_Tag => External_Tag : + begin + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => Prefix (N))))); + + Analyze_And_Resolve (N, Standard_String); + end External_Tag; + + ----------- + -- First -- + ----------- + + when Attribute_First => declare + Ptyp : constant Entity_Id := Etype (Pref); + + begin + -- If the prefix type is a constrained packed array type which + -- already has a Packed_Array_Type representation defined, then + -- replace this attribute with a direct reference to 'First of the + -- appropriate index subtype (since otherwise Gigi will try to give + -- us the value of 'First for this implementation type). + + if Is_Constrained_Packed_Array (Ptyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Reference_To (Get_Index_Subtype (N), Loc))); + Analyze_And_Resolve (N, Typ); + + elsif Is_Access_Type (Ptyp) then + Apply_Access_Check (N); + end if; + end; + + --------------- + -- First_Bit -- + --------------- + + -- We compute this if a component clause was present, otherwise + -- we leave the computation up to Gigi, since we don't know what + -- layout will be chosen. + + when Attribute_First_Bit => First_Bit : + declare + CE : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Known_Static_Component_Bit_Offset (CE) then + Rewrite (N, + Make_Integer_Literal (Loc, + Component_Bit_Offset (CE) mod System_Storage_Unit)); + + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end First_Bit; + + ----------------- + -- Fixed_Value -- + ----------------- + + -- We transform: + + -- fixtype'Fixed_Value (integer-value) + + -- into + + -- fixtype(integer-value) + + -- we do all the required analysis of the conversion here, because + -- we do not want this to go through the fixed-point conversion + -- circuits. Note that gigi always treats fixed-point as equivalent + -- to the corresponding integer type anyway. + + when Attribute_Fixed_Value => Fixed_Value : + begin + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), + Expression => Relocate_Node (First (Exprs)))); + Set_Etype (N, Entity (Pref)); + Set_Analyzed (N); + Apply_Type_Conversion_Checks (N); + end Fixed_Value; + + ----------- + -- Floor -- + ----------- + + -- Transforms 'Floor into a call to the floating-point attribute + -- function Floor in Fat_xxx (where xxx is the root type) + + when Attribute_Floor => + Expand_Fpt_Attribute_R (N); + + ---------- + -- Fore -- + ---------- + + -- For the fixed-point type Typ: + + -- Typ'Fore + + -- expands into + + -- Result_Type (System.Fore (Long_Long_Float (Type'First)), + -- Long_Long_Float (Type'Last)) + + -- Note that we know that the type is a non-static subtype, or Fore + -- would have itself been computed dynamically in Eval_Attribute. + + when Attribute_Fore => Fore : + declare + Ptyp : constant Entity_Id := Etype (Pref); + + begin + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Fore), Loc), + + Parameter_Associations => New_List ( + Convert_To (Standard_Long_Long_Float, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First)), + + Convert_To (Standard_Long_Long_Float, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last)))))); + + Analyze_And_Resolve (N, Typ); + end Fore; + + -------------- + -- Fraction -- + -------------- + + -- Transforms 'Fraction into a call to the floating-point attribute + -- function Fraction in Fat_xxx (where xxx is the root type) + + when Attribute_Fraction => + Expand_Fpt_Attribute_R (N); + + -------------- + -- Identity -- + -------------- + + -- For an exception returns a reference to the exception data: + -- Exception_Id!(Prefix'Reference) + + -- For a task it returns a reference to the _task_id component of + -- corresponding record: + + -- taskV!(Prefix)._Task_Id, converted to the type Task_ID defined + + -- in Ada.Task_Identification. + + when Attribute_Identity => Identity : declare + Id_Kind : Entity_Id; + + begin + if Etype (Pref) = Standard_Exception_Type then + Id_Kind := RTE (RE_Exception_Id); + + if Present (Renamed_Object (Entity (Pref))) then + Set_Entity (Pref, Renamed_Object (Entity (Pref))); + end if; + + Rewrite (N, + Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref))); + else + Id_Kind := RTE (RO_AT_Task_ID); + + Rewrite (N, + Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref))); + end if; + + Analyze_And_Resolve (N, Id_Kind); + end Identity; + + ----------- + -- Image -- + ----------- + + -- Image attribute is handled in separate unit Exp_Imgv + + when Attribute_Image => + Exp_Imgv.Expand_Image_Attribute (N); + + --------- + -- Img -- + --------- + + -- X'Img is expanded to typ'Image (X), where typ is the type of X + + when Attribute_Img => Img : + begin + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Etype (Pref), Loc), + Attribute_Name => Name_Image, + Expressions => New_List (Relocate_Node (Pref)))); + + Analyze_And_Resolve (N, Standard_String); + end Img; + + ----------- + -- Input -- + ----------- + + when Attribute_Input => Input : declare + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Strm : constant Node_Id := First (Exprs); + Fname : Entity_Id; + Decl : Node_Id; + Call : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; + + Cntrl : Node_Id := Empty; + -- Value for controlling argument in call. Always Empty except in + -- the dispatching (class-wide type) case, where it is a reference + -- to the dummy object initialized to the right internal tag. + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- If there is a TSS for Input, just call it + + Fname := Find_Inherited_TSS (P_Type, Name_uInput); + + if Present (Fname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Input (stream) + + -- as + + -- sourcetyp (streamread (strmtyp'Input (stream))); + + -- where stmrearead is the given Read function that converts + -- an argument of type strmtyp to type sourcetyp or a type + -- from which it is derived. The extra conversion is required + -- for the derived case. + + Prag := + Get_Rep_Pragma + (Implementation_Base_Type (P_Type), Name_Stream_Convert); + + if Present (Prag) then + Arg2 := Next (First (Pragma_Argument_Associations (Prag))); + Rfunc := Entity (Expression (Arg2)); + + Rewrite (N, + Convert_To (B_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Rfunc, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Formal (Rfunc)), Loc), + Attribute_Name => Name_Input, + Expressions => Exprs))))); + + Analyze_And_Resolve (N, B_Type); + return; + + -- Elementary types + + elsif Is_Elementary_Type (U_Type) then + + -- A special case arises if we have a defined _Read routine, + -- since in this case we are required to call this routine. + + if Present (TSS (B_Type, Name_uRead)) then + Build_Record_Or_Elementary_Input_Function + (Loc, U_Type, Decl, Fname); + Insert_Action (N, Decl); + + -- For normal cases, we call the I_xxx routine directly + + else + Rewrite (N, Build_Elementary_Input_Call (N)); + Analyze_And_Resolve (N, P_Type); + return; + end if; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Input_Function (Loc, U_Type, Decl, Fname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Dispatching case with class-wide type + + elsif Is_Class_Wide_Type (P_Type) then + + declare + Rtyp : constant Entity_Id := Root_Type (P_Type); + Dnn : Entity_Id; + Decl : Node_Id; + + begin + -- Read the internal tag (RM 13.13.2(34)) and use it to + -- initialize a dummy tag object: + + -- Dnn : Ada.Tags.Tag + -- := Internal_Tag (String'Input (Strm)); + + -- This dummy object is used only to provide a controlling + -- argument for the eventual _Input call. + + Dnn := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('D')); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => + New_Occurrence_Of (RTE (RE_Tag), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Internal_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node + (Duplicate_Subexpr (Strm))))))); + + Insert_Action (N, Decl); + + -- Now we need to get the entity for the call, and construct + -- a function call node, where we preset a reference to Dnn + -- as the controlling argument (doing an unchecked + -- conversion to the tagged type to make it look like + -- a real tagged object). + + Fname := Find_Prim_Op (Rtyp, Name_uInput); + Cntrl := Unchecked_Convert_To (Rtyp, + New_Occurrence_Of (Dnn, Loc)); + Set_Etype (Cntrl, Rtyp); + Set_Parent (Cntrl, N); + end; + + -- For tagged types, use the primitive Input function + + elsif Is_Tagged_Type (U_Type) then + Fname := Find_Prim_Op (U_Type, Name_uInput); + + -- All other record type cases, including protected records. + -- The latter only arise for expander generated code for + -- handling shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + Build_Record_Or_Elementary_Input_Function + (Loc, Base_Type (U_Type), Decl, Fname); + Insert_Action (N, Decl); + end if; + end if; + + -- If we fall through, Fname is the function to be called. The + -- result is obtained by calling the appropriate function, then + -- converting the result. The conversion does a subtype check. + + Call := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fname, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm))); + + Set_Controlling_Argument (Call, Cntrl); + Rewrite (N, Unchecked_Convert_To (P_Type, Call)); + Analyze_And_Resolve (N, P_Type); + end Input; + + ------------------- + -- Integer_Value -- + ------------------- + + -- We transform + + -- inttype'Fixed_Value (fixed-value) + + -- into + + -- inttype(integer-value)) + + -- we do all the required analysis of the conversion here, because + -- we do not want this to go through the fixed-point conversion + -- circuits. Note that gigi always treats fixed-point as equivalent + -- to the corresponding integer type anyway. + + when Attribute_Integer_Value => Integer_Value : + begin + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), + Expression => Relocate_Node (First (Exprs)))); + Set_Etype (N, Entity (Pref)); + Set_Analyzed (N); + Apply_Type_Conversion_Checks (N); + end Integer_Value; + + ---------- + -- Last -- + ---------- + + when Attribute_Last => declare + Ptyp : constant Entity_Id := Etype (Pref); + + begin + -- If the prefix type is a constrained packed array type which + -- already has a Packed_Array_Type representation defined, then + -- replace this attribute with a direct reference to 'Last of the + -- appropriate index subtype (since otherwise Gigi will try to give + -- us the value of 'Last for this implementation type). + + if Is_Constrained_Packed_Array (Ptyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Reference_To (Get_Index_Subtype (N), Loc))); + Analyze_And_Resolve (N, Typ); + + elsif Is_Access_Type (Ptyp) then + Apply_Access_Check (N); + end if; + end; + + -------------- + -- Last_Bit -- + -------------- + + -- We compute this if a component clause was present, otherwise + -- we leave the computation up to Gigi, since we don't know what + -- layout will be chosen. + + when Attribute_Last_Bit => Last_Bit : + declare + CE : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Known_Static_Component_Bit_Offset (CE) + and then Known_Static_Esize (CE) + then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit) + + Esize (CE) - 1)); + + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Last_Bit; + + ------------------ + -- Leading_Part -- + ------------------ + + -- Transforms 'Leading_Part into a call to the floating-point attribute + -- function Leading_Part in Fat_xxx (where xxx is the root type) + + -- Note: strictly, we should have special case code to deal with + -- absurdly large positive arguments (greater than Integer'Last), + -- which result in returning the first argument unchanged, but it + -- hardly seems worth the effort. We raise constraint error for + -- absurdly negative arguments which is fine. + + when Attribute_Leading_Part => + Expand_Fpt_Attribute_RI (N); + + ------------ + -- Length -- + ------------ + + when Attribute_Length => declare + Ptyp : constant Entity_Id := Etype (Pref); + Ityp : Entity_Id; + Xnum : Uint; + + begin + -- Processing for packed array types + + if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then + Ityp := Get_Index_Subtype (N); + + -- If the index type, Ityp, is an enumeration type with + -- holes, then we calculate X'Length explicitly using + + -- Typ'Max + -- (0, Ityp'Pos (X'Last (N)) - + -- Ityp'Pos (X'First (N)) + 1); + + -- Since the bounds in the template are the representation + -- values and gigi would get the wrong value. + + if Is_Enumeration_Type (Ityp) + and then Present (Enum_Pos_To_Rep (Base_Type (Ityp))) + then + if No (Exprs) then + Xnum := Uint_1; + else + Xnum := Expr_Value (First (Expressions (N))); + end if; + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Max, + Expressions => New_List + (Make_Integer_Literal (Loc, 0), + + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Pref), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, Xnum))))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Pref), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, Xnum)))))), + + Right_Opnd => Make_Integer_Literal (Loc, 1))))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + return; + + -- If the prefix type is a constrained packed array type which + -- already has a Packed_Array_Type representation defined, then + -- replace this attribute with a direct reference to 'Range_Length + -- of the appropriate index subtype (since otherwise Gigi will try + -- to give us the value of 'Length for this implementation type). + + elsif Is_Constrained (Ptyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Range_Length, + Prefix => New_Reference_To (Ityp, Loc))); + Analyze_And_Resolve (N, Typ); + end if; + + -- If we have a packed array that is not bit packed, which was + + -- Access type case + + elsif Is_Access_Type (Ptyp) then + Apply_Access_Check (N); + + -- If the designated type is a packed array type, then we + -- convert the reference to: + + -- typ'Max (0, 1 + + -- xtyp'Pos (Pref'Last (Expr)) - + -- xtyp'Pos (Pref'First (Expr))); + + -- This is a bit complex, but it is the easiest thing to do + -- that works in all cases including enum types with holes + -- xtyp here is the appropriate index type. + + declare + Dtyp : constant Entity_Id := Designated_Type (Ptyp); + Xtyp : Entity_Id; + + begin + if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then + Xtyp := Get_Index_Subtype (N); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + + Make_Op_Add (Loc, + Make_Integer_Literal (Loc, 1), + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Xtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Pref), + Attribute_Name => Name_Last, + Expressions => + New_Copy_List (Exprs)))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Xtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Pref), + Attribute_Name => Name_First, + Expressions => + New_Copy_List (Exprs))))))))); + + Analyze_And_Resolve (N, Typ); + end if; + end; + + -- Otherwise leave it to gigi + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end; + + ------------- + -- Machine -- + ------------- + + -- Transforms 'Machine into a call to the floating-point attribute + -- function Machine in Fat_xxx (where xxx is the root type) + + when Attribute_Machine => + Expand_Fpt_Attribute_R (N); + + ------------------ + -- Machine_Size -- + ------------------ + + -- Machine_Size is equivalent to Object_Size, so transform it into + -- Object_Size and that way Gigi never sees Machine_Size. + + when Attribute_Machine_Size => + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Prefix (N), + Attribute_Name => Name_Object_Size)); + + Analyze_And_Resolve (N, Typ); + + -------------- + -- Mantissa -- + -------------- + + -- The only case that can get this far is the dynamic case of the + -- old Ada 83 Mantissa attribute for the fixed-point case. For this + -- case, we expand: + + -- typ'Mantissa + + -- into + + -- ityp (System.Mantissa.Mantissa_Value + -- (Integer'Integer_Value (typ'First), + -- Integer'Integer_Value (typ'Last))); + + when Attribute_Mantissa => Mantissa : declare + Ptyp : constant Entity_Id := Etype (Pref); + + begin + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc), + + Parameter_Associations => New_List ( + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Integer, Loc), + Attribute_Name => Name_Integer_Value, + Expressions => New_List ( + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_First))), + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Integer, Loc), + Attribute_Name => Name_Integer_Value, + Expressions => New_List ( + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last))))))); + + Analyze_And_Resolve (N, Typ); + end Mantissa; + + ----------- + -- Model -- + ----------- + + -- Transforms 'Model into a call to the floating-point attribute + -- function Model in Fat_xxx (where xxx is the root type) + + when Attribute_Model => + Expand_Fpt_Attribute_R (N); + + ----------------- + -- Object_Size -- + ----------------- + + -- The processing for Object_Size shares the processing for Size + + ------------ + -- Output -- + ------------ + + when Attribute_Output => Output : declare + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- If TSS for Output is present, just call it + + Pname := Find_Inherited_TSS (P_Type, Name_uOutput); + + if Present (Pname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Output (stream, Item) + + -- as + + -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); + + -- where strmwrite is the given Write function that converts + -- an argument of type sourcetyp or a type acctyp, from which + -- it is derived to type strmtyp. The conversion to acttyp is + -- required for the derived case. + + Prag := + Get_Rep_Pragma + (Implementation_Base_Type (P_Type), Name_Stream_Convert); + + if Present (Prag) then + Arg3 := + Next (Next (First (Pragma_Argument_Associations (Prag)))); + Wfunc := Entity (Expression (Arg3)); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (First (Exprs)), + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Wfunc, Loc), + Parameter_Associations => New_List ( + Convert_To (Etype (First_Formal (Wfunc)), + Relocate_Node (Next (First (Exprs))))))))); + + Analyze (N); + return; + + -- For elementary types, we call the W_xxx routine directly. + -- Note that the effect of Write and Output is identical for + -- the case of an elementary type, since there are no + -- discriminants or bounds. + + elsif Is_Elementary_Type (U_Type) then + + -- A special case arises if we have a defined _Write routine, + -- since in this case we are required to call this routine. + + if Present (TSS (B_Type, Name_uWrite)) then + Build_Record_Or_Elementary_Output_Procedure + (Loc, U_Type, Decl, Pname); + Insert_Action (N, Decl); + + -- For normal cases, we call the W_xxx routine directly + + else + Rewrite (N, Build_Elementary_Write_Call (N)); + Analyze (N); + return; + end if; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Class-wide case, first output external tag, then dispatch + -- to the appropriate primitive Output function (RM 13.13.2(31)). + + elsif Is_Class_Wide_Type (P_Type) then + Tag_Write : declare + Strm : constant Node_Id := First (Exprs); + Item : constant Node_Id := Next (Strm); + + begin + -- The code is: + -- String'Output (Strm, External_Tag (Item'Tag)) + + Insert_Action (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node + (Duplicate_Subexpr (Item, Name_Req => True)), + Attribute_Name => Name_Tag)))))); + end Tag_Write; + + Pname := Find_Prim_Op (U_Type, Name_uOutput); + + -- Tagged type case, use the primitive Output function + + elsif Is_Tagged_Type (U_Type) then + Pname := Find_Prim_Op (U_Type, Name_uOutput); + + -- All other record type cases, including protected records. + -- The latter only arise for expander generated code for + -- handling shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + Build_Record_Or_Elementary_Output_Procedure + (Loc, Base_Type (U_Type), Decl, Pname); + Insert_Action (N, Decl); + end if; + end if; + + -- If we fall through, Pname is the name of the procedure to call + + Rewrite_Stream_Proc_Call (Pname); + end Output; + + --------- + -- Pos -- + --------- + + -- For enumeration types with a standard representation, Pos is + -- handled by Gigi. + + -- For enumeration types, with a non-standard representation we + -- generate a call to the _Rep_To_Pos function created when the + -- type was frozen. The call has the form + + -- _rep_to_pos (expr, True) + + -- The parameter True causes Program_Error to be raised if the + -- expression has an invalid representation. + + -- For integer types, Pos is equivalent to a simple integer + -- conversion and we rewrite it as such + + when Attribute_Pos => Pos : + declare + Etyp : Entity_Id := Base_Type (Entity (Pref)); + + begin + -- Deal with zero/non-zero boolean values + + if Is_Boolean_Type (Etyp) then + Adjust_Condition (First (Exprs)); + Etyp := Standard_Boolean; + Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc)); + end if; + + -- Case of enumeration type + + if Is_Enumeration_Type (Etyp) then + + -- Non-standard enumeration type (generate call) + + if Present (Enum_Pos_To_Rep (Etyp)) then + Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc)); + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Reference_To (TSS (Etyp, Name_uRep_To_Pos), Loc), + Parameter_Associations => Exprs))); + + Analyze_And_Resolve (N, Typ); + + -- Standard enumeration type (do universal integer check) + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + + -- Deal with integer types (replace by conversion) + + elsif Is_Integer_Type (Etyp) then + Rewrite (N, Convert_To (Typ, First (Exprs))); + Analyze_And_Resolve (N, Typ); + end if; + + end Pos; + + -------------- + -- Position -- + -------------- + + -- We compute this if a component clause was present, otherwise + -- we leave the computation up to Gigi, since we don't know what + -- layout will be chosen. + + when Attribute_Position => Position : + declare + CE : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Present (Component_Clause (CE)) then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Component_Bit_Offset (CE) / System_Storage_Unit)); + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Position; + + ---------- + -- Pred -- + ---------- + + -- 1. Deal with enumeration types with holes + -- 2. For floating-point, generate call to attribute function + -- 3. For other cases, deal with constraint checking + + when Attribute_Pred => Pred : + declare + Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); + + begin + -- For enumeration types with non-standard representations, we + -- expand typ'Pred (x) into + + -- Pos_To_Rep (Rep_To_Pos (x) - 1) + + if Is_Enumeration_Type (Ptyp) + and then Present (Enum_Pos_To_Rep (Ptyp)) + then + -- Add Boolean parameter True, to request program errror if + -- we have a bad representation on our hands. + + Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc)); + + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), + Expressions => New_List ( + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc), + Parameter_Associations => Exprs), + Right_Opnd => Make_Integer_Literal (Loc, 1))))); + + Analyze_And_Resolve (N, Typ); + + -- For floating-point, we transform 'Pred into a call to the Pred + -- floating-point attribute function in Fat_xxx (xxx is root type) + + elsif Is_Floating_Point_Type (Ptyp) then + Expand_Fpt_Attribute_R (N); + Analyze_And_Resolve (N, Typ); + + -- For modular types, nothing to do (no overflow, since wraps) + + elsif Is_Modular_Integer_Type (Ptyp) then + null; + + -- For other types, if range checking is enabled, we must generate + -- a check if overflow checking is enabled. + + elsif not Overflow_Checks_Suppressed (Ptyp) then + Expand_Pred_Succ (N); + end if; + + end Pred; + + ------------------ + -- Range_Length -- + ------------------ + + when Attribute_Range_Length => Range_Length : declare + P_Type : constant Entity_Id := Etype (Pref); + + begin + -- The only special processing required is for the case where + -- Range_Length is applied to an enumeration type with holes. + -- In this case we transform + + -- X'Range_Length + + -- to + + -- X'Pos (X'Last) - X'Pos (X'First) + 1 + + -- So that the result reflects the proper Pos values instead + -- of the underlying representations. + + if Is_Enumeration_Type (P_Type) + and then Has_Non_Standard_Rep (P_Type) + then + Rewrite (N, + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (P_Type, Loc), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Occurrence_Of (P_Type, Loc)))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (P_Type, Loc), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (P_Type, Loc))))), + + Right_Opnd => + Make_Integer_Literal (Loc, 1))); + + Analyze_And_Resolve (N, Typ); + + -- For all other cases, attribute is handled by Gigi, but we need + -- to deal with the case of the range check on a universal integer. + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + + end Range_Length; + + ---------- + -- Read -- + ---------- + + when Attribute_Read => Read : declare + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- The simple case, if there is a TSS for Read, just call it + + Pname := Find_Inherited_TSS (P_Type, Name_uRead); + + if Present (Pname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Read (stream, Item) + + -- as + + -- Item := sourcetyp (strmread (strmtyp'Input (Stream))); + + -- where strmread is the given Read function that converts + -- an argument of type strmtyp to type sourcetyp or a type + -- from which it is derived. The conversion to sourcetyp + -- is required in the latter case. + + -- A special case arises if Item is a type conversion in which + -- case, we have to expand to: + + -- Itemx := typex (strmread (strmtyp'Input (Stream))); + + -- where Itemx is the expression of the type conversion (i.e. + -- the actual object), and typex is the type of Itemx. + + Prag := + Get_Rep_Pragma + (Implementation_Base_Type (P_Type), Name_Stream_Convert); + + if Present (Prag) then + Arg2 := Next (First (Pragma_Argument_Associations (Prag))); + Rfunc := Entity (Expression (Arg2)); + Lhs := Relocate_Node (Next (First (Exprs))); + Rhs := + Convert_To (B_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Rfunc, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Formal (Rfunc)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (First (Exprs))))))); + + if Nkind (Lhs) = N_Type_Conversion then + Lhs := Expression (Lhs); + Rhs := Convert_To (Etype (Lhs), Rhs); + end if; + + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Rhs)); + Set_Assignment_OK (Lhs); + Analyze (N); + return; + + -- For elementary types, we call the I_xxx routine using the first + -- parameter and then assign the result into the second parameter. + -- We set Assignment_OK to deal with the conversion case. + + elsif Is_Elementary_Type (U_Type) then + declare + Lhs : Node_Id; + Rhs : Node_Id; + + begin + Lhs := Relocate_Node (Next (First (Exprs))); + Rhs := Build_Elementary_Input_Call (N); + + if Nkind (Lhs) = N_Type_Conversion then + Lhs := Expression (Lhs); + Rhs := Convert_To (Etype (Lhs), Rhs); + end if; + + Set_Assignment_OK (Lhs); + + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Rhs)); + + Analyze (N); + return; + end; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Read_Procedure (N, U_Type, Decl, Pname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Tagged type case, use the primitive Read function. Note that + -- this will dispatch in the class-wide case which is what we want + + elsif Is_Tagged_Type (U_Type) then + Pname := Find_Prim_Op (U_Type, Name_uRead); + + -- All other record type cases, including protected records. + -- The latter only arise for expander generated code for + -- handling shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + if Has_Discriminants (U_Type) + and then Present + (Discriminant_Default_Value (First_Discriminant (U_Type))) + then + Build_Mutable_Record_Read_Procedure + (Loc, Base_Type (U_Type), Decl, Pname); + + else + Build_Record_Read_Procedure + (Loc, Base_Type (U_Type), Decl, Pname); + end if; + + -- Suppress checks, uninitialized or otherwise invalid + -- data does not cause constraint errors to be raised for + -- a complete record read. + + Insert_Action (N, Decl, All_Checks); + end if; + end if; + + Rewrite_Stream_Proc_Call (Pname); + end Read; + + --------------- + -- Remainder -- + --------------- + + -- Transforms 'Remainder into a call to the floating-point attribute + -- function Remainder in Fat_xxx (where xxx is the root type) + + when Attribute_Remainder => + Expand_Fpt_Attribute_RR (N); + + ----------- + -- Round -- + ----------- + + -- The handling of the Round attribute is quite delicate. The + -- processing in Sem_Attr introduced a conversion to universal + -- real, reflecting the semantics of Round, but we do not want + -- anything to do with universal real at runtime, since this + -- corresponds to using floating-point arithmetic. + + -- What we have now is that the Etype of the Round attribute + -- correctly indicates the final result type. The operand of + -- the Round is the conversion to universal real, described + -- above, and the operand of this conversion is the actual + -- operand of Round, which may be the special case of a fixed + -- point multiplication or division (Etype = universal fixed) + + -- The exapander will expand first the operand of the conversion, + -- then the conversion, and finally the round attribute itself, + -- since we always work inside out. But we cannot simply process + -- naively in this order. In the semantic world where universal + -- fixed and real really exist and have infinite precision, there + -- is no problem, but in the implementation world, where universal + -- real is a floating-point type, we would get the wrong result. + + -- So the approach is as follows. First, when expanding a multiply + -- or divide whose type is universal fixed, we do nothing at all, + -- instead deferring the operation till later. + + -- The actual processing is done in Expand_N_Type_Conversion which + -- handles the special case of Round by looking at its parent to + -- see if it is a Round attribute, and if it is, handling the + -- conversion (or its fixed multiply/divide child) in an appropriate + -- manner. + + -- This means that by the time we get to expanding the Round attribute + -- itself, the Round is nothing more than a type conversion (and will + -- often be a null type conversion), so we just replace it with the + -- appropriate conversion operation. + + when Attribute_Round => + Rewrite (N, + Convert_To (Etype (N), Relocate_Node (First (Exprs)))); + Analyze_And_Resolve (N); + + -------------- + -- Rounding -- + -------------- + + -- Transforms 'Rounding into a call to the floating-point attribute + -- function Rounding in Fat_xxx (where xxx is the root type) + + when Attribute_Rounding => + Expand_Fpt_Attribute_R (N); + + ------------- + -- Scaling -- + ------------- + + -- Transforms 'Scaling into a call to the floating-point attribute + -- function Scaling in Fat_xxx (where xxx is the root type) + + when Attribute_Scaling => + Expand_Fpt_Attribute_RI (N); + + ---------- + -- Size -- + ---------- + + when Attribute_Size | + Attribute_Object_Size | + Attribute_Value_Size | + Attribute_VADS_Size => Size : + + declare + Ptyp : constant Entity_Id := Etype (Pref); + New_Node : Node_Id; + Siz : Uint; + + begin + -- Processing for VADS_Size case. Note that this processing removes + -- all traces of VADS_Size from the tree, and completes all required + -- processing for VADS_Size by translating the attribute reference + -- to an appropriate Size or Object_Size reference. + + if Id = Attribute_VADS_Size + or else (Use_VADS_Size and then Id = Attribute_Size) + then + -- If the size is specified, then we simply use the specified + -- size. This applies to both types and objects. The size of an + -- object can be specified in the following ways: + + -- An explicit size object is given for an object + -- A component size is specified for an indexed component + -- A component clause is specified for a selected component + -- The object is a component of a packed composite object + + -- If the size is specified, then VADS_Size of an object + + if (Is_Entity_Name (Pref) + and then Present (Size_Clause (Entity (Pref)))) + or else + (Nkind (Pref) = N_Component_Clause + and then (Present (Component_Clause + (Entity (Selector_Name (Pref)))) + or else Is_Packed (Etype (Prefix (Pref))))) + or else + (Nkind (Pref) = N_Indexed_Component + and then (Component_Size (Etype (Prefix (Pref))) /= 0 + or else Is_Packed (Etype (Prefix (Pref))))) + then + Set_Attribute_Name (N, Name_Size); + + -- Otherwise if we have an object rather than a type, then the + -- VADS_Size attribute applies to the type of the object, rather + -- than the object itself. This is one of the respects in which + -- VADS_Size differs from Size. + + else + if (not Is_Entity_Name (Pref) + or else not Is_Type (Entity (Pref))) + and then (Is_Scalar_Type (Etype (Pref)) + or else Is_Constrained (Etype (Pref))) + then + Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc)); + end if; + + -- For a scalar type for which no size was + -- explicitly given, VADS_Size means Object_Size. This is the + -- other respect in which VADS_Size differs from Size. + + if Is_Scalar_Type (Etype (Pref)) + and then No (Size_Clause (Etype (Pref))) + then + Set_Attribute_Name (N, Name_Object_Size); + + -- In all other cases, Size and VADS_Size are the sane + + else + Set_Attribute_Name (N, Name_Size); + end if; + end if; + end if; + + -- For class-wide types, transform X'Size into a call to + -- the primitive operation _Size + + if Is_Class_Wide_Type (Ptyp) then + New_Node := + Make_Function_Call (Loc, + Name => New_Reference_To + (Find_Prim_Op (Ptyp, Name_uSize), Loc), + Parameter_Associations => New_List (Pref)); + + if Typ /= Standard_Long_Long_Integer then + + -- The context is a specific integer type with which the + -- original attribute was compatible. The function has a + -- specific type as well, so to preserve the compatibility + -- we must convert explicitly. + + New_Node := Convert_To (Typ, New_Node); + end if; + + Rewrite (N, New_Node); + Analyze_And_Resolve (N, Typ); + return; + + -- For an array component, we can do Size in the front end + -- if the component_size of the array is set. + + elsif Nkind (Pref) = N_Indexed_Component then + Siz := Component_Size (Etype (Prefix (Pref))); + + -- For a record component, we can do Size in the front end + -- if there is a component clause, or if the record is packed + -- and the component's size is known at compile time. + + elsif Nkind (Pref) = N_Selected_Component then + declare + Rec : constant Entity_Id := Etype (Prefix (Pref)); + Comp : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Present (Component_Clause (Comp)) then + Siz := Esize (Comp); + + elsif Is_Packed (Rec) then + Siz := RM_Size (Ptyp); + + else + Apply_Universal_Integer_Attribute_Checks (N); + return; + end if; + end; + + -- All other cases are handled by Gigi + + else + Apply_Universal_Integer_Attribute_Checks (N); + + -- If we have Size applied to a formal parameter, that is a + -- packed array subtype, then apply size to the actual subtype. + + if Is_Entity_Name (Pref) + and then Is_Formal (Entity (Pref)) + and then Is_Array_Type (Etype (Pref)) + and then Is_Packed (Etype (Pref)) + then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc), + Attribute_Name => Name_Size)); + Analyze_And_Resolve (N, Typ); + end if; + + return; + end if; + + -- Common processing for record and array component case + + if Siz /= 0 then + Rewrite (N, + Make_Integer_Literal (Loc, Siz)); + + Analyze_And_Resolve (N, Typ); + + -- The result is not a static expression + + Set_Is_Static_Expression (N, False); + end if; + end Size; + + ------------------ + -- Storage_Pool -- + ------------------ + + when Attribute_Storage_Pool => + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Etype (N), Loc), + Expression => New_Reference_To (Entity (N), Loc))); + Analyze_And_Resolve (N, Typ); + + ------------------ + -- Storage_Size -- + ------------------ + + when Attribute_Storage_Size => Storage_Size : + declare + Ptyp : constant Entity_Id := Etype (Pref); + + begin + -- Access type case, always go to the root type + + -- The case of access types results in a value of zero for the case + -- where no storage size attribute clause has been given. If a + -- storage size has been given, then the attribute is converted + -- to a reference to the variable used to hold this value. + + if Is_Access_Type (Ptyp) then + if Present (Storage_Size_Variable (Root_Type (Ptyp))) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + Convert_To (Typ, + New_Reference_To + (Storage_Size_Variable (Root_Type (Ptyp)), Loc))))); + + elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then + Rewrite (N, + OK_Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (Find_Prim_Op (Etype ( + Associated_Storage_Pool (Root_Type (Ptyp))), + Attribute_Name (N)), Loc), + + Parameter_Associations => New_List (New_Reference_To ( + Associated_Storage_Pool (Root_Type (Ptyp)), Loc))))); + else + Rewrite (N, Make_Integer_Literal (Loc, 0)); + end if; + + Analyze_And_Resolve (N, Typ); + + -- The case of a task type (an obsolescent feature) is handled the + -- same way, seems as reasonable as anything, and it is what the + -- ACVC tests (e.g. CD1009K) seem to expect. + + -- If there is no Storage_Size variable, then we return the default + -- task stack size, otherwise, expand a Storage_Size attribute as + -- follows: + + -- Typ (Adjust_Storage_Size (taskZ)) + + -- except for the case of a task object which has a Storage_Size + -- pragma: + + -- Typ (Adjust_Storage_Size (taskV!(name)._Size)) + + else + if not Present (Storage_Size_Variable (Ptyp)) then + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc)))); + + else + if not (Is_Entity_Name (Pref) and then + Is_Task_Type (Entity (Pref))) and then + Chars (Last_Entity (Corresponding_Record_Type (Ptyp))) = + Name_uSize + then + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Adjust_Storage_Size), Loc), + Parameter_Associations => + New_List ( + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + Corresponding_Record_Type (Ptyp), + New_Copy_Tree (Pref)), + Selector_Name => + Make_Identifier (Loc, Name_uSize)))))); + + -- Task not having Storage_Size pragma + + else + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Adjust_Storage_Size), Loc), + Parameter_Associations => + New_List ( + New_Reference_To ( + Storage_Size_Variable (Ptyp), Loc))))); + end if; + + Analyze_And_Resolve (N, Typ); + end if; + end if; + end Storage_Size; + + ---------- + -- Succ -- + ---------- + + -- 1. Deal with enumeration types with holes + -- 2. For floating-point, generate call to attribute function + -- 3. For other cases, deal with constraint checking + + when Attribute_Succ => Succ : + declare + Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); + + begin + -- For enumeration types with non-standard representations, we + -- expand typ'Succ (x) into + + -- Pos_To_Rep (Rep_To_Pos (x) + 1) + + if Is_Enumeration_Type (Ptyp) + and then Present (Enum_Pos_To_Rep (Ptyp)) + then + -- Add Boolean parameter True, to request program errror if + -- we have a bad representation on our hands. + + Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc)); + + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc), + Parameter_Associations => Exprs), + Right_Opnd => Make_Integer_Literal (Loc, 1))))); + + Analyze_And_Resolve (N, Typ); + + -- For floating-point, we transform 'Succ into a call to the Succ + -- floating-point attribute function in Fat_xxx (xxx is root type) + + elsif Is_Floating_Point_Type (Ptyp) then + Expand_Fpt_Attribute_R (N); + Analyze_And_Resolve (N, Typ); + + -- For modular types, nothing to do (no overflow, since wraps) + + elsif Is_Modular_Integer_Type (Ptyp) then + null; + + -- For other types, if range checking is enabled, we must generate + -- a check if overflow checking is enabled. + + elsif not Overflow_Checks_Suppressed (Ptyp) then + Expand_Pred_Succ (N); + end if; + end Succ; + + --------- + -- Tag -- + --------- + + -- Transforms X'Tag into a direct reference to the tag of X + + when Attribute_Tag => Tag : + declare + Ttyp : Entity_Id; + Prefix_Is_Type : Boolean; + + begin + if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then + Ttyp := Entity (Pref); + Prefix_Is_Type := True; + else + Ttyp := Etype (Pref); + Prefix_Is_Type := False; + end if; + + if Is_Class_Wide_Type (Ttyp) then + Ttyp := Root_Type (Ttyp); + end if; + + Ttyp := Underlying_Type (Ttyp); + + if Prefix_Is_Type then + Rewrite (N, + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Access_Disp_Table (Ttyp), Loc))); + + else + Rewrite (N, + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Pref), + Selector_Name => + New_Reference_To (Tag_Component (Ttyp), Loc))); + end if; + + Analyze_And_Resolve (N, RTE (RE_Tag)); + end Tag; + + ---------------- + -- Terminated -- + ---------------- + + -- Transforms 'Terminated attribute into a call to Terminated function. + + when Attribute_Terminated => Terminated : + begin + if Restricted_Profile then + Rewrite (N, + Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated))); + + else + Rewrite (N, + Build_Call_With_Task (Pref, RTE (RE_Terminated))); + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + end Terminated; + + ---------------- + -- To_Address -- + ---------------- + + -- Transforms System'To_Address (X) into unchecked conversion + -- from (integral) type of X to type address. + + when Attribute_To_Address => + Rewrite (N, + Unchecked_Convert_To (RTE (RE_Address), + Relocate_Node (First (Exprs)))); + Analyze_And_Resolve (N, RTE (RE_Address)); + + ---------------- + -- Truncation -- + ---------------- + + -- Transforms 'Truncation into a call to the floating-point attribute + -- function Truncation in Fat_xxx (where xxx is the root type) + + when Attribute_Truncation => + Expand_Fpt_Attribute_R (N); + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + -- Transforms 'Unbiased_Rounding into a call to the floating-point + -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the + -- root type) + + when Attribute_Unbiased_Rounding => + Expand_Fpt_Attribute_R (N); + + ---------------------- + -- Unchecked_Access -- + ---------------------- + + when Attribute_Unchecked_Access => + Expand_Access_To_Type (N); + + ----------------- + -- UET_Address -- + ----------------- + + when Attribute_UET_Address => UET_Address : declare + Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + begin + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + -- Construct name __gnat_xxx__SDP, where xxx is the unit name + -- in normal external form. + + Get_External_Unit_Name_String (Get_Unit_Name (Pref)); + Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); + Name_Len := Name_Len + 7; + Name_Buffer (1 .. 7) := "__gnat_"; + Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP"; + Name_Len := Name_Len + 5; + + Set_Is_Imported (Ent); + Set_Interface_Name (Ent, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Attribute_Name => Name_Address)); + + Analyze_And_Resolve (N, Typ); + end UET_Address; + + ------------------------- + -- Unrestricted_Access -- + ------------------------- + + when Attribute_Unrestricted_Access => + Expand_Access_To_Type (N); + + --------------- + -- VADS_Size -- + --------------- + + -- The processing for VADS_Size is shared with Size + + --------- + -- Val -- + --------- + + -- For enumeration types with a standard representation, and for all + -- other types, Val is handled by Gigi. For enumeration types with + -- a non-standard representation we use the _Pos_To_Rep array that + -- was created when the type was frozen. + + when Attribute_Val => Val : + declare + Etyp : constant Entity_Id := Base_Type (Entity (Pref)); + + begin + if Is_Enumeration_Type (Etyp) + and then Present (Enum_Pos_To_Rep (Etyp)) + then + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Relocate_Node (First (Exprs)))))); + + Analyze_And_Resolve (N, Typ); + end if; + end Val; + + ----------- + -- Valid -- + ----------- + + -- The code for valid is dependent on the particular types involved. + -- See separate sections below for the generated code in each case. + + when Attribute_Valid => Valid : + declare + Ptyp : constant Entity_Id := Etype (Pref); + Btyp : Entity_Id := Base_Type (Ptyp); + Tst : Node_Id; + + function Make_Range_Test return Node_Id; + -- Build the code for a range test of the form + -- Btyp!(Pref) >= Btyp!(Ptyp'First) + -- and then + -- Btyp!(Pref) <= Btyp!(Ptyp'Last) + + function Make_Range_Test return Node_Id is + begin + return + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ge (Loc, + Left_Opnd => + Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)), + + Right_Opnd => + Unchecked_Convert_To (Btyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_First))), + + Right_Opnd => + Make_Op_Le (Loc, + Left_Opnd => + Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)), + + Right_Opnd => + Unchecked_Convert_To (Btyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last)))); + end Make_Range_Test; + + -- Start of processing for Attribute_Valid + + begin + -- Floating-point case. This case is handled by the Valid attribute + -- code in the floating-point attribute run-time library. + + if Is_Floating_Point_Type (Ptyp) then + declare + Rtp : constant Entity_Id := Root_Type (Etype (Pref)); + + begin + Expand_Fpt_Attribute (N, Rtp, New_List ( + Make_Attribute_Reference (Loc, + Prefix => Unchecked_Convert_To (Rtp, Pref), + Attribute_Name => Name_Unrestricted_Access))); + + -- One more task, we still need a range check. Required + -- only if we have a constraint, since the Valid routine + -- catches infinities properly (infinities are never valid). + + -- The way we do the range check is simply to create the + -- expression: Valid (N) and then Base_Type(Pref) in Typ. + + if not Subtypes_Statically_Match (Ptyp, Btyp) then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => + Make_In (Loc, + Left_Opnd => Convert_To (Btyp, Pref), + Right_Opnd => New_Occurrence_Of (Ptyp, Loc)))); + end if; + end; + + -- Enumeration type with holes + + -- For enumeration types with holes, the Pos value constructed by + -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a + -- second argument of False returns minus one for an invalid value, + -- and the non-negative pos value for a valid value, so the + -- expansion of X'Valid is simply: + + -- type(X)'Pos (X) >= 0 + + -- We can't quite generate it that way because of the requirement + -- for the non-standard second argument of False, so we have to + -- explicitly create: + + -- _rep_to_pos (X, False) >= 0 + + -- If we have an enumeration subtype, we also check that the + -- value is in range: + + -- _rep_to_pos (X, False) >= 0 + -- and then + -- (X >= type(X)'First and then type(X)'Last <= X) + + elsif Is_Enumeration_Type (Ptyp) + and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp))) + then + Tst := + Make_Op_Ge (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (TSS (Base_Type (Ptyp), Name_uRep_To_Pos), Loc), + Parameter_Associations => New_List ( + Pref, + New_Occurrence_Of (Standard_False, Loc))), + Right_Opnd => Make_Integer_Literal (Loc, 0)); + + if Ptyp /= Btyp + and then + (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp) + or else + Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp)) + then + -- The call to Make_Range_Test will create declarations + -- that need a proper insertion point, but Pref is now + -- attached to a node with no ancestor. Attach to tree + -- even if it is to be rewritten below. + + Set_Parent (Tst, Parent (N)); + + Tst := + Make_And_Then (Loc, + Left_Opnd => Make_Range_Test, + Right_Opnd => Tst); + end if; + + Rewrite (N, Tst); + + -- Fortran convention booleans + + -- For the very special case of Fortran convention booleans, the + -- value is always valid, since it is an integer with the semantics + -- that non-zero is true, and any value is permissible. + + elsif Is_Boolean_Type (Ptyp) + and then Convention (Ptyp) = Convention_Fortran + then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + + -- For biased representations, we will be doing an unchecked + -- conversion without unbiasing the result. That means that + -- the range test has to take this into account, and the + -- proper form of the test is: + + -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length) + + elsif Has_Biased_Representation (Ptyp) then + Btyp := RTE (RE_Unsigned_32); + Rewrite (N, + Make_Op_Lt (Loc, + Left_Opnd => + Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)), + Right_Opnd => + Unchecked_Convert_To (Btyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Range_Length)))); + + -- For all other scalar types, what we want logically is a + -- range test: + + -- X in type(X)'First .. type(X)'Last + + -- But that's precisely what won't work because of possible + -- unwanted optimization (and indeed the basic motivation for + -- the Valid attribute -is exactly that this test does not work. + -- What will work is: + + -- Btyp!(X) >= Btyp!(type(X)'First) + -- and then + -- Btyp!(X) <= Btyp!(type(X)'Last) + + -- where Btyp is an integer type large enough to cover the full + -- range of possible stored values (i.e. it is chosen on the basis + -- of the size of the type, not the range of the values). We write + -- this as two tests, rather than a range check, so that static + -- evaluation will easily remove either or both of the checks if + -- they can be -statically determined to be true (this happens + -- when the type of X is static and the range extends to the full + -- range of stored values). + + -- Unsigned types. Note: it is safe to consider only whether the + -- subtype is unsigned, since we will in that case be doing all + -- unsigned comparisons based on the subtype range. Since we use + -- the actual subtype object size, this is appropriate. + + -- For example, if we have + + -- subtype x is integer range 1 .. 200; + -- for x'Object_Size use 8; + + -- Now the base type is signed, but objects of this type are 8 + -- bits unsigned, and doing an unsigned test of the range 1 to + -- 200 is correct, even though a value greater than 127 looks + -- signed to a signed comparison. + + elsif Is_Unsigned_Type (Ptyp) then + if Esize (Ptyp) <= 32 then + Btyp := RTE (RE_Unsigned_32); + else + Btyp := RTE (RE_Unsigned_64); + end if; + + Rewrite (N, Make_Range_Test); + + -- Signed types + + else + if Esize (Ptyp) <= Esize (Standard_Integer) then + Btyp := Standard_Integer; + else + Btyp := Universal_Integer; + end if; + + Rewrite (N, Make_Range_Test); + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + end Valid; + + ----------- + -- Value -- + ----------- + + -- Value attribute is handled in separate unti Exp_Imgv + + when Attribute_Value => + Exp_Imgv.Expand_Value_Attribute (N); + + ----------------- + -- Value_Size -- + ----------------- + + -- The processing for Value_Size shares the processing for Size + + ------------- + -- Version -- + ------------- + + -- The processing for Version shares the processing for Body_Version + + ---------------- + -- Wide_Image -- + ---------------- + + -- We expand typ'Wide_Image (X) into + + -- String_To_Wide_String + -- (typ'Image (X), Wide_Character_Encoding_Method) + + -- This works in all cases because String_To_Wide_String converts any + -- wide character escape sequences resulting from the Image call to the + -- proper Wide_Character equivalent + + -- not quite right for typ = Wide_Character ??? + + when Attribute_Wide_Image => Wide_Image : + begin + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_String_To_Wide_String), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Image, + Expressions => Exprs), + + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))); + + Analyze_And_Resolve (N, Standard_Wide_String); + end Wide_Image; + + ---------------- + -- Wide_Value -- + ---------------- + + -- We expand typ'Wide_Value (X) into + + -- typ'Value + -- (Wide_String_To_String (X, Wide_Character_Encoding_Method)) + + -- Wide_String_To_String is a runtime function that converts its wide + -- string argument to String, converting any non-translatable characters + -- into appropriate escape sequences. This preserves the required + -- semantics of Wide_Value in all cases, and results in a very simple + -- implementation approach. + + -- It's not quite right where typ = Wide_Character, because the encoding + -- method may not cover the whole character type ??? + + when Attribute_Wide_Value => Wide_Value : + begin + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Value, + + Expressions => New_List ( + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Wide_String_To_String), Loc), + + Parameter_Associations => New_List ( + Relocate_Node (First (Exprs)), + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))))); + + Analyze_And_Resolve (N, Typ); + end Wide_Value; + + ---------------- + -- Wide_Width -- + ---------------- + + -- Wide_Width attribute is handled in separate unit Exp_Imgv + + when Attribute_Wide_Width => + Exp_Imgv.Expand_Width_Attribute (N, Wide => True); + + ----------- + -- Width -- + ----------- + + -- Width attribute is handled in separate unit Exp_Imgv + + when Attribute_Width => + Exp_Imgv.Expand_Width_Attribute (N, Wide => False); + + ----------- + -- Write -- + ----------- + + when Attribute_Write => Write : declare + P_Type : constant Entity_Id := Entity (Pref); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- The simple case, if there is a TSS for Write, just call it + + Pname := Find_Inherited_TSS (P_Type, Name_uWrite); + + if Present (Pname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Output (stream, Item) + + -- as + + -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); + + -- where strmwrite is the given Write function that converts + -- an argument of type sourcetyp or a type acctyp, from which + -- it is derived to type strmtyp. The conversion to acttyp is + -- required for the derived case. + + Prag := + Get_Rep_Pragma + (Implementation_Base_Type (P_Type), Name_Stream_Convert); + + if Present (Prag) then + Arg3 := + Next (Next (First (Pragma_Argument_Associations (Prag)))); + Wfunc := Entity (Expression (Arg3)); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (First (Exprs)), + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Wfunc, Loc), + Parameter_Associations => New_List ( + Convert_To (Etype (First_Formal (Wfunc)), + Relocate_Node (Next (First (Exprs))))))))); + + Analyze (N); + return; + + -- For elementary types, we call the W_xxx routine directly + + elsif Is_Elementary_Type (U_Type) then + Rewrite (N, Build_Elementary_Write_Call (N)); + Analyze (N); + return; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Write_Procedure (N, U_Type, Decl, Pname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Tagged type case, use the primitive Write function. Note that + -- this will dispatch in the class-wide case which is what we want + + elsif Is_Tagged_Type (U_Type) then + Pname := Find_Prim_Op (U_Type, Name_uWrite); + + -- All other record type cases, including protected records. + -- The latter only arise for expander generated code for + -- handling shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + if Has_Discriminants (U_Type) + and then Present + (Discriminant_Default_Value (First_Discriminant (U_Type))) + then + Build_Mutable_Record_Write_Procedure + (Loc, Base_Type (U_Type), Decl, Pname); + + else + Build_Record_Write_Procedure + (Loc, Base_Type (U_Type), Decl, Pname); + end if; + + Insert_Action (N, Decl); + end if; + end if; + + -- If we fall through, Pname is the procedure to be called + + Rewrite_Stream_Proc_Call (Pname); + end Write; + + -- Component_Size is handled by Gigi, unless the component size is + -- known at compile time, which is always true in the packed array + -- case. It is important that the packed array case is handled in + -- the front end (see Eval_Attribute) since Gigi would otherwise + -- get confused by the equivalent packed array type. + + when Attribute_Component_Size => + null; + + -- The following attributes are handled by Gigi (except that static + -- cases have already been evaluated by the semantics, but in any + -- case Gigi should not count on that). + + -- In addition Gigi handles the non-floating-point cases of Pred + -- and Succ (including the fixed-point cases, which can just be + -- treated as integer increment/decrement operations) + + -- Gigi also handles the non-class-wide cases of Size + + when Attribute_Bit_Order | + Attribute_Code_Address | + Attribute_Definite | + Attribute_Max | + Attribute_Mechanism_Code | + Attribute_Min | + Attribute_Null_Parameter | + Attribute_Passed_By_Reference => + null; + + -- The following attributes are also handled by Gigi, but return a + -- universal integer result, so may need a conversion for checking + -- that the result is in range. + + when Attribute_Aft | + Attribute_Alignment | + Attribute_Bit | + Attribute_Max_Size_In_Storage_Elements + => + Apply_Universal_Integer_Attribute_Checks (N); + + -- The following attributes should not appear at this stage, since they + -- have already been handled by the analyzer (and properly rewritten + -- with corresponding values or entities to represent the right values) + + when Attribute_Abort_Signal | + Attribute_Address_Size | + Attribute_Base | + Attribute_Class | + Attribute_Default_Bit_Order | + Attribute_Delta | + Attribute_Denorm | + Attribute_Digits | + Attribute_Emax | + Attribute_Epsilon | + Attribute_Has_Discriminants | + Attribute_Large | + Attribute_Machine_Emax | + Attribute_Machine_Emin | + Attribute_Machine_Mantissa | + Attribute_Machine_Overflows | + Attribute_Machine_Radix | + Attribute_Machine_Rounds | + Attribute_Max_Interrupt_Priority | + Attribute_Max_Priority | + Attribute_Maximum_Alignment | + Attribute_Model_Emin | + Attribute_Model_Epsilon | + Attribute_Model_Mantissa | + Attribute_Model_Small | + Attribute_Modulus | + Attribute_Partition_ID | + Attribute_Range | + Attribute_Safe_Emax | + Attribute_Safe_First | + Attribute_Safe_Large | + Attribute_Safe_Last | + Attribute_Safe_Small | + Attribute_Scale | + Attribute_Signed_Zeros | + Attribute_Small | + Attribute_Storage_Unit | + Attribute_Tick | + Attribute_Type_Class | + Attribute_Universal_Literal_String | + Attribute_Wchar_T_Size | + Attribute_Word_Size => + + raise Program_Error; + + -- The Asm_Input and Asm_Output attributes are not expanded at this + -- stage, but will be eliminated in the expansion of the Asm call, + -- see Exp_Intr for details. So Gigi will never see these either. + + when Attribute_Asm_Input | + Attribute_Asm_Output => + + null; + + end case; + + end Expand_N_Attribute_Reference; + + ---------------------- + -- Expand_Pred_Succ -- + ---------------------- + + -- For typ'Pred (exp), we generate the check + + -- [constraint_error when exp = typ'Base'First] + + -- Similarly, for typ'Succ (exp), we generate the check + + -- [constraint_error when exp = typ'Base'Last] + + -- These checks are not generated for modular types, since the proper + -- semantics for Succ and Pred on modular types is to wrap, not raise CE. + + procedure Expand_Pred_Succ (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Cnam : Name_Id; + + begin + if Attribute_Name (N) = Name_Pred then + Cnam := Name_First; + else + Cnam := Name_Last; + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (First (Expressions (N))), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Base_Type (Etype (Prefix (N))), Loc), + Attribute_Name => Cnam)))); + + end Expand_Pred_Succ; + + ------------------------ + -- Find_Inherited_TSS -- + ------------------------ + + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + P_Type : Entity_Id := Typ; + Proc : Entity_Id; + + begin + Proc := TSS (Base_Type (Typ), Nam); + + -- Check first if there is a TSS given for the type itself. + + if Present (Proc) then + return Proc; + end if; + + -- If Typ is a derived type, it may inherit attributes from some + -- ancestor which is not the ultimate underlying one. + + if Is_Derived_Type (P_Type) then + + while Is_Derived_Type (P_Type) loop + Proc := TSS (Base_Type (Etype (Typ)), Nam); + + if Present (Proc) then + return Proc; + else + P_Type := Base_Type (Etype (P_Type)); + end if; + end loop; + end if; + + -- If nothing else, use the TSS of the root type. + + return TSS (Base_Type (Underlying_Type (Typ)), Nam); + end Find_Inherited_TSS; + + ----------------------- + -- Get_Index_Subtype -- + ----------------------- + + function Get_Index_Subtype (N : Node_Id) return Node_Id is + P_Type : Entity_Id := Etype (Prefix (N)); + Indx : Node_Id; + J : Int; + + begin + if Is_Access_Type (P_Type) then + P_Type := Designated_Type (P_Type); + end if; + + if No (Expressions (N)) then + J := 1; + else + J := UI_To_Int (Expr_Value (First (Expressions (N)))); + end if; + + Indx := First_Index (P_Type); + while J > 1 loop + Next_Index (Indx); + J := J - 1; + end loop; + + return Etype (Indx); + end Get_Index_Subtype; + + --------------------------------- + -- Is_Constrained_Packed_Array -- + --------------------------------- + + function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is + Arr : Entity_Id := Typ; + + begin + if Is_Access_Type (Arr) then + Arr := Designated_Type (Arr); + end if; + + return Is_Array_Type (Arr) + and then Is_Constrained (Arr) + and then Present (Packed_Array_Type (Arr)); + end Is_Constrained_Packed_Array; + +end Exp_Attr; diff --git a/gcc/ada/exp_attr.ads b/gcc/ada/exp_attr.ads new file mode 100644 index 00000000000..1665bc74c14 --- /dev/null +++ b/gcc/ada/exp_attr.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T T R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for attribute references + +with Types; use Types; + +package Exp_Attr is + procedure Expand_N_Attribute_Reference (N : Node_Id); +end Exp_Attr; diff --git a/gcc/ada/exp_ch10.ads b/gcc/ada/exp_ch10.ads new file mode 100644 index 00000000000..d98350cd85f --- /dev/null +++ b/gcc/ada/exp_ch10.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 0 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 10 constructs + +package Exp_Ch10 is +end Exp_Ch10; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb new file mode 100644 index 00000000000..62a4f6fd3e6 --- /dev/null +++ b/gcc/ada/exp_ch11.adb @@ -0,0 +1,1824 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 1 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.117 $ +-- -- +-- Copyright (C) 1992-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 Casing; use Casing; +with Debug; use Debug; +with Einfo; use Einfo; +with Exp_Ch7; use Exp_Ch7; +with Exp_Util; use Exp_Util; +with Hostparm; use Hostparm; +with Inline; use Inline; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Restrict; use Restrict; +with Sem; use Sem; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Uname; use Uname; + +package body Exp_Ch11 is + + SD_List : List_Id; + -- This list gathers the values SDn'Unrestricted_Access used to + -- construct the unit exception table. It is set to Empty_List if + -- there are no subprogram descriptors. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Exception_Handler_Tables (HSS : Node_Id); + -- Subsidiary procedure called by Expand_Exception_Handlers if zero + -- cost exception handling is installed for this target. Replaces the + -- exception handler structure with appropriate labeled code and tables + -- that allow the zero cost exception handling circuits to find the + -- correct handler (see unit Ada.Exceptions for details). + + procedure Generate_Subprogram_Descriptor + (N : Node_Id; + Loc : Source_Ptr; + Spec : Entity_Id; + Slist : List_Id); + -- Procedure called to generate a subprogram descriptor. N is the + -- subprogram body node or, in the case of an imported subprogram, is + -- Empty, and Spec is the entity of the sunprogram. For details of the + -- required structure, see package System.Exceptions. The generated + -- subprogram descriptor is appended to Slist. Loc provides the + -- source location to be used for the generated descriptor. + + --------------------------- + -- Expand_At_End_Handler -- + --------------------------- + + -- For a handled statement sequence that has a cleanup (At_End_Proc + -- field set), an exception handler of the following form is required: + + -- exception + -- when all others => + -- cleanup call + -- raise; + + -- Note: this exception handler is treated rather specially by + -- subsequent expansion in two respects: + + -- The normal call to Undefer_Abort is omitted + -- The raise call does not do Defer_Abort + + -- This is because the current tasking code seems to assume that + -- the call to the cleanup routine that is made from an exception + -- handler for the abort signal is called with aborts deferred. + + procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is + Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); + Loc : constant Source_Ptr := Sloc (Clean); + Ohandle : Node_Id; + Stmnts : List_Id; + + begin + pragma Assert (Present (Clean)); + pragma Assert (No (Exception_Handlers (HSS))); + + if Restrictions (No_Exception_Handlers) then + return; + end if; + + if Present (Block) then + New_Scope (Block); + end if; + + Ohandle := + Make_Others_Choice (Loc); + Set_All_Others (Ohandle); + + Stmnts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Clean, Loc)), + Make_Raise_Statement (Loc)); + + Set_Exception_Handlers (HSS, New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List (Ohandle), + Statements => Stmnts))); + + Analyze_List (Stmnts, Suppress => All_Checks); + Expand_Exception_Handlers (HSS); + + if Present (Block) then + Pop_Scope; + end if; + end Expand_At_End_Handler; + + ------------------------------------- + -- Expand_Exception_Handler_Tables -- + ------------------------------------- + + -- See Ada.Exceptions specification for full details of the data + -- structures that we need to construct here. As an example of the + -- transformation that is required, given the structure: + + -- declare + -- {declarations} + -- .. + -- begin + -- {statements-1} + -- ... + -- exception + -- when a | b => + -- {statements-2} + -- ... + -- when others => + -- {statements-3} + -- ... + -- end; + + -- We transform this into: + + -- declare + -- {declarations} + -- ... + -- L1 : label; + -- L2 : label; + -- L3 : label; + -- L4 : Label; + -- L5 : label; + + -- begin + -- <<L1>> + -- {statements-1} + -- <<L2>> + + -- exception + + -- when a | b => + -- <<L3>> + -- {statements-2} + + -- HR2 : constant Handler_Record := ( + -- Lo => L1'Address, + -- Hi => L2'Address, + -- Id => a'Identity, + -- Handler => L5'Address); + + -- HR3 : constant Handler_Record := ( + -- Lo => L1'Address, + -- Hi => L2'Address, + -- Id => b'Identity, + -- Handler => L4'Address); + + -- when others => + -- <<L4>> + -- {statements-3} + + -- HR1 : constant Handler_Record := ( + -- Lo => L1'Address, + -- Hi => L2'Address, + -- Id => Others_Id, + -- Handler => L4'Address); + -- end; + + -- The exception handlers in the transformed version are marked with the + -- Zero_Cost_Handling flag set, and all gigi does in this case is simply + -- to put the handler code somewhere. It can optionally be put inline + -- between the goto L3 and the label <<L3>> (which is why we generate + -- that goto in the first place). + + procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is + Loc : constant Source_Ptr := Sloc (HSS); + Handlrs : constant List_Id := Exception_Handlers (HSS); + Stms : constant List_Id := Statements (HSS); + Handler : Node_Id; + + Hlist : List_Id; + -- This is the list to which handlers are to be appended. It is + -- either the list for the enclosing subprogram, or the enclosing + -- selective accept statement (which will turn into a subprogram + -- during expansion later on). + + L1 : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + L2 : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Lnn : Entity_Id; + Choice : Node_Id; + E_Id : Node_Id; + HR_Ent : Node_Id; + HL_Ref : Node_Id; + Item : Node_Id; + + Subp_Entity : Entity_Id; + -- This is the entity for the subprogram (or library level package) + -- to which the handler record is to be attached for later reference + -- in a subprogram descriptor for this entity. + + procedure Append_To_Stms (N : Node_Id); + -- Append given statement to the end of the statements of the + -- handled sequence of statements and analyze it in place. + + function Inside_Selective_Accept return Boolean; + -- This function is called if we are inside the scope of an entry + -- or task. It checks if the handler is appearing in the context + -- of a selective accept statement. If so, Hlist is set to + -- temporarily park the handlers in the N_Accept_Alternative. + -- node. They will subsequently be moved to the procedure entity + -- for the procedure built for this alternative. The statements that + -- follow the Accept within the alternative are not inside the Accept + -- for purposes of this test, and handlers that may appear within + -- them belong in the enclosing task procedure. + + procedure Set_Hlist; + -- Sets the handler list corresponding to Subp_Entity + + -------------------- + -- Append_To_Stms -- + -------------------- + + procedure Append_To_Stms (N : Node_Id) is + begin + Insert_After_And_Analyze (Last (Stms), N); + Set_Exception_Junk (N); + end Append_To_Stms; + + ----------------------------- + -- Inside_Selective_Accept -- + ----------------------------- + + function Inside_Selective_Accept return Boolean is + Parnt : Node_Id; + Curr : Node_Id := HSS; + + begin + Parnt := Parent (HSS); + while Nkind (Parnt) /= N_Compilation_Unit loop + if Nkind (Parnt) = N_Accept_Alternative + and then Curr = Accept_Statement (Parnt) + then + if Present (Accept_Handler_Records (Parnt)) then + Hlist := Accept_Handler_Records (Parnt); + else + Hlist := New_List; + Set_Accept_Handler_Records (Parnt, Hlist); + end if; + + return True; + else + Curr := Parnt; + Parnt := Parent (Parnt); + end if; + end loop; + + return False; + end Inside_Selective_Accept; + + --------------- + -- Set_Hlist -- + --------------- + + procedure Set_Hlist is + begin + -- Never try to inline a subprogram with exception handlers + + Set_Is_Inlined (Subp_Entity, False); + + if Present (Subp_Entity) + and then Present (Handler_Records (Subp_Entity)) + then + Hlist := Handler_Records (Subp_Entity); + else + Hlist := New_List; + Set_Handler_Records (Subp_Entity, Hlist); + end if; + end Set_Hlist; + + -- Start of processing for Expand_Exception_Handler_Tables + + begin + -- Nothing to do if this handler has already been processed + + if Zero_Cost_Handling (HSS) then + return; + end if; + + Set_Zero_Cost_Handling (HSS); + + -- Find the parent subprogram or package scope containing this + -- exception frame. This should always find a real package or + -- subprogram. If it does not it will stop at Standard, but + -- this cannot legitimately occur. + + -- We only stop at library level packages, for inner packages + -- we always attach handlers to the containing procedure. + + Subp_Entity := Current_Scope; + Scope_Loop : loop + + -- Never need tables expanded inside a generic template + + if Is_Generic_Unit (Subp_Entity) then + return; + + -- Stop if we reached containing subprogram. Go to protected + -- subprogram if there is one defined. + + elsif Ekind (Subp_Entity) = E_Function + or else Ekind (Subp_Entity) = E_Procedure + then + if Present (Protected_Body_Subprogram (Subp_Entity)) then + Subp_Entity := Protected_Body_Subprogram (Subp_Entity); + end if; + + Set_Hlist; + exit Scope_Loop; + + -- Case of within an entry + + elsif Is_Entry (Subp_Entity) then + + -- Protected entry, use corresponding body subprogram + + if Present (Protected_Body_Subprogram (Subp_Entity)) then + Subp_Entity := Protected_Body_Subprogram (Subp_Entity); + Set_Hlist; + exit Scope_Loop; + + -- Check if we are within a selective accept alternative + + elsif Inside_Selective_Accept then + + -- As a side effect, Inside_Selective_Accept set Hlist, + -- in much the same manner as Set_Hlist, except that + -- the list involved was the one for the selective accept. + + exit Scope_Loop; + end if; + + -- Case of within library level package + + elsif Ekind (Subp_Entity) = E_Package + and then Is_Compilation_Unit (Subp_Entity) + then + if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then + Subp_Entity := Body_Entity (Subp_Entity); + end if; + + Set_Hlist; + exit Scope_Loop; + + -- Task type case + + elsif Ekind (Subp_Entity) = E_Task_Type then + + -- Check if we are within a selective accept alternative + + if Inside_Selective_Accept then + + -- As a side effect, Inside_Selective_Accept set Hlist, + -- in much the same manner as Set_Hlist, except that the + -- list involved was the one for the selective accept. + + exit Scope_Loop; + + -- Stop if we reached task type with task body procedure, + -- use the task body procedure. + + elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then + Subp_Entity := Get_Task_Body_Procedure (Subp_Entity); + Set_Hlist; + exit Scope_Loop; + end if; + end if; + + -- If we fall through, keep looking + + Subp_Entity := Scope (Subp_Entity); + end loop Scope_Loop; + + pragma Assert (Subp_Entity /= Standard_Standard); + + -- Analyze standard labels + + Analyze_Label_Entity (L1); + Analyze_Label_Entity (L2); + + Insert_Before_And_Analyze (First (Stms), + Make_Label (Loc, + Identifier => New_Occurrence_Of (L1, Loc))); + Set_Exception_Junk (First (Stms)); + + Append_To_Stms ( + Make_Label (Loc, + Identifier => New_Occurrence_Of (L2, Loc))); + + -- Loop through exception handlers + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + Set_Zero_Cost_Handling (Handler); + + -- Add label at start of handler, and goto at the end + + Lnn := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Analyze_Label_Entity (Lnn); + + Item := + Make_Label (Loc, + Identifier => New_Occurrence_Of (Lnn, Loc)); + Set_Exception_Junk (Item); + Insert_Before_And_Analyze (First (Statements (Handler)), Item); + + -- Loop through choices + + Choice := First (Exception_Choices (Handler)); + while Present (Choice) loop + + -- Others (or all others) choice + + if Nkind (Choice) = N_Others_Choice then + if All_Others (Choice) then + E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc); + else + E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc); + end if; + + -- Special case of VMS_Exception. Not clear what we will do + -- eventually here if and when we implement zero cost exceptions + -- on VMS. But at least for now, don't blow up trying to take + -- a garbage code address for such an exception. + + elsif Is_VMS_Exception (Entity (Choice)) then + E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc); + + -- Normal case of specific exception choice + + else + E_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Entity (Choice), Loc), + Attribute_Name => Name_Identity); + end if; + + HR_Ent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('H')); + + HL_Ref := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (HR_Ent, Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- Now we need to add the entry for the new handler record to + -- the list of handler records for the current subprogram. + + -- Normally we end up generating the handler records in exactly + -- the right order. Here right order means innermost first, + -- since the table will be searched sequentially. Since we + -- generally expand from outside to inside, the order is just + -- what we want, and we need to append the new entry to the + -- end of the list. + + -- However, there are exceptions, notably in the case where + -- a generic body is inserted later on. See for example the + -- case of ACVC test C37213J, which has the following form: + + -- generic package x ... end x; + -- package body x is + -- begin + -- ... + -- exception (1) + -- ... + -- end x; + + -- ... + + -- declare + -- package q is new x; + -- begin + -- ... + -- exception (2) + -- ... + -- end; + + -- In this case, we will expand exception handler (2) first, + -- since the expansion of (1) is delayed till later when the + -- generic body is inserted. But (1) belongs before (2) in + -- the chain. + + -- Note that scopes are not totally ordered, because two + -- scopes can be in parallel blocks, so that it does not + -- matter what order these entries appear in. An ordering + -- relation exists if one scope is inside another, and what + -- we really want is some partial ordering. + + -- A simple, not very efficient, but adequate algorithm to + -- achieve this partial ordering is to search the list for + -- the first entry containing the given scope, and put the + -- new entry just before it. + + declare + New_Scop : constant Entity_Id := Current_Scope; + Ent : Node_Id; + + begin + Ent := First (Hlist); + loop + -- If all searched, then we can just put the new + -- entry at the end of the list (it actually does + -- not matter where we put it in this case). + + if No (Ent) then + Append_To (Hlist, HL_Ref); + exit; + + -- If the current scope is within the scope of the + -- entry then insert the entry before to retain the + -- proper order as per above discussion. + + -- Note that for equal entries, we just keep going, + -- which is fine, the entry will end up at the end + -- of the list where it belongs. + + elsif Scope_Within + (New_Scop, Scope (Entity (Prefix (Ent)))) + then + Insert_Before (Ent, HL_Ref); + exit; + + -- Otherwise keep looking + + else + Next (Ent); + end if; + end loop; + end; + + Item := + Make_Object_Declaration (Loc, + Defining_Identifier => HR_Ent, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Handler_Record), Loc), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, -- Lo + Prefix => New_Occurrence_Of (L1, Loc), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, -- Hi + Prefix => New_Occurrence_Of (L2, Loc), + Attribute_Name => Name_Address), + + E_Id, -- Id + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lnn, Loc), -- Handler + Attribute_Name => Name_Address)))); + + Set_Handler_List_Entry (Item, HL_Ref); + Set_Exception_Junk (Item); + Insert_After_And_Analyze (Last (Statements (Handler)), Item); + Set_Is_Statically_Allocated (HR_Ent); + + -- If this is a late insertion (from body instance) it is being + -- inserted in the component list of an already analyzed aggre- + -- gate, and must be analyzed explicitly. + + Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr)); + + Next (Choice); + end loop; + + Next_Non_Pragma (Handler); + end loop; + end Expand_Exception_Handler_Tables; + + ------------------------------- + -- Expand_Exception_Handlers -- + ------------------------------- + + procedure Expand_Exception_Handlers (HSS : Node_Id) is + Handlrs : constant List_Id := Exception_Handlers (HSS); + Loc : Source_Ptr; + Handler : Node_Id; + Others_Choice : Boolean; + Obj_Decl : Node_Id; + + procedure Prepend_Call_To_Handler + (Proc : RE_Id; + Args : List_Id := No_List); + -- Routine to prepend a call to the procedure referenced by Proc at + -- the start of the handler code for the current Handler. + + procedure Prepend_Call_To_Handler + (Proc : RE_Id; + Args : List_Id := No_List) + is + Call : constant Node_Id := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (Proc), Loc), + Parameter_Associations => Args); + + begin + Prepend_To (Statements (Handler), Call); + Analyze (Call, Suppress => All_Checks); + end Prepend_Call_To_Handler; + + -- Start of processing for Expand_Exception_Handlers + + begin + -- Loop through handlers + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + Loc := Sloc (Handler); + + -- If an exception occurrence is present, then we must declare it + -- and initialize it from the value stored in the TSD + + -- declare + -- name : Exception_Occurrence; + -- + -- begin + -- Save_Occurrence (name, Get_Current_Excep.all) + -- ... + -- end; + + if Present (Choice_Parameter (Handler)) then + declare + Cparm : constant Entity_Id := Choice_Parameter (Handler); + Clc : constant Source_Ptr := Sloc (Cparm); + Save : Node_Id; + + begin + Save := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Cparm, Clc), + Make_Explicit_Dereference (Loc, + Make_Function_Call (Loc, + Name => Make_Explicit_Dereference (Loc, + New_Occurrence_Of + (RTE (RE_Get_Current_Excep), Loc)))))); + + Mark_Rewrite_Insertion (Save); + Prepend (Save, Statements (Handler)); + + Obj_Decl := + Make_Object_Declaration (Clc, + Defining_Identifier => Cparm, + Object_Definition => + New_Occurrence_Of + (RTE (RE_Exception_Occurrence), Clc)); + Set_No_Initialization (Obj_Decl, True); + + Rewrite (Handler, + Make_Exception_Handler (Loc, + Exception_Choices => Exception_Choices (Handler), + + Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => New_List (Obj_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements (Handler)))))); + + Analyze_List (Statements (Handler), Suppress => All_Checks); + end; + end if; + + -- The processing at this point is rather different for the + -- JVM case, so we completely separate the processing. + + -- For the JVM case, we unconditionally call Update_Exception, + -- passing a call to the intrinsic function Current_Target_Exception + -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details). + + if Hostparm.Java_VM then + declare + Arg : Node_Id + := Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Current_Target_Exception), Loc)); + begin + Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg)); + end; + + -- For the normal case, we have to worry about the state of abort + -- deferral. Generally, we defer abort during runtime handling of + -- exceptions. When control is passed to the handler, then in the + -- normal case we undefer aborts. In any case this entire handling + -- is relevant only if aborts are allowed! + + elsif Abort_Allowed then + + -- There are some special cases in which we do not do the + -- undefer. In particular a finalization (AT END) handler + -- wants to operate with aborts still deferred. + + -- We also suppress the call if this is the special handler + -- for Abort_Signal, since if we are aborting, we want to keep + -- aborts deferred (one abort is enough thank you very much :-) + + -- If abort really needs to be deferred the expander must add + -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select. + + Others_Choice := + Nkind (First (Exception_Choices (Handler))) = N_Others_Choice; + + if (Others_Choice + or else Entity (First (Exception_Choices (Handler))) /= + Stand.Abort_Signal) + and then not + (Others_Choice + and then All_Others (First (Exception_Choices (Handler)))) + and then Abort_Allowed + then + Prepend_Call_To_Handler (RE_Abort_Undefer); + end if; + end if; + + Next_Non_Pragma (Handler); + end loop; + + -- The last step for expanding exception handlers is to expand the + -- exception tables if zero cost exception handling is active. + + if Exception_Mechanism = Front_End_ZCX then + Expand_Exception_Handler_Tables (HSS); + end if; + end Expand_Exception_Handlers; + + ------------------------------------ + -- Expand_N_Exception_Declaration -- + ------------------------------------ + + -- Generates: + -- exceptE : constant String := "A.B.EXCEP"; -- static data + -- except : exception_data := ( + -- Handled_By_Other => False, + -- Lang => 'A', + -- Name_Length => exceptE'Length + -- Full_Name => exceptE'Address + -- HTable_Ptr => null); + + -- (protecting test only needed if not at library level) + -- + -- exceptF : Boolean := True -- static data + -- if exceptF then + -- exceptF := False; + -- Register_Exception (except'Unchecked_Access); + -- end if; + + procedure Expand_N_Exception_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + L : List_Id := New_List; + Flag_Id : Entity_Id; + + Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E'); + Exname : constant Node_Id := + Make_Defining_Identifier (Loc, Name_Exname); + + begin + -- There is no expansion needed when compiling for the JVM since the + -- JVM has a built-in exception mechanism. See 4jexcept.ads for details. + + if Hostparm.Java_VM then + return; + end if; + + -- Definition of the external name: nam : constant String := "A.B.NAME"; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id)))); + + Set_Is_Statically_Allocated (Exname); + + -- Create the aggregate list for type Standard.Exception_Type: + -- Handled_By_Other component: False + + Append_To (L, New_Occurrence_Of (Standard_False, Loc)); + + -- Lang component: 'A' + + Append_To (L, + Make_Character_Literal (Loc, Name_uA, Get_Char_Code ('A'))); + + -- Name_Length component: Nam'Length + + Append_To (L, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Exname, Loc), + Attribute_Name => Name_Length)); + + -- Full_Name component: Standard.A_Char!(Nam'Address) + + Append_To (L, Unchecked_Convert_To (Standard_A_Char, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Exname, Loc), + Attribute_Name => Name_Address))); + + -- HTable_Ptr component: null + + Append_To (L, Make_Null (Loc)); + + -- Import_Code component: 0 + + Append_To (L, Make_Integer_Literal (Loc, 0)); + + Set_Expression (N, Make_Aggregate (Loc, Expressions => L)); + Analyze_And_Resolve (Expression (N), Etype (Id)); + + -- Register_Exception (except'Unchecked_Access); + + if not Restrictions (No_Exception_Handlers) then + L := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Id, Loc), + Attribute_Name => Name_Unrestricted_Access))))); + + Set_Register_Exception_Call (Id, First (L)); + + if not Is_Library_Level_Entity (Id) then + Flag_Id := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Id), 'F')); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Standard_True, Loc))); + + Set_Is_Statically_Allocated (Flag_Id); + + Append_To (L, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Flag_Id, Loc), + Expression => New_Occurrence_Of (Standard_False, Loc))); + + Insert_After_And_Analyze (N, + Make_Implicit_If_Statement (N, + Condition => New_Occurrence_Of (Flag_Id, Loc), + Then_Statements => L)); + + else + Insert_List_After_And_Analyze (N, L); + end if; + end if; + + end Expand_N_Exception_Declaration; + + --------------------------------------------- + -- Expand_N_Handled_Sequence_Of_Statements -- + --------------------------------------------- + + procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is + begin + if Present (Exception_Handlers (N)) then + Expand_Exception_Handlers (N); + end if; + + -- The following code needs comments ??? + + if Nkind (Parent (N)) /= N_Package_Body + and then Nkind (Parent (N)) /= N_Accept_Statement + and then not Delay_Cleanups (Current_Scope) + then + Expand_Cleanup_Actions (Parent (N)); + else + Set_First_Real_Statement (N, First (Statements (N))); + end if; + + end Expand_N_Handled_Sequence_Of_Statements; + + ------------------------------------- + -- Expand_N_Raise_Constraint_Error -- + ------------------------------------- + + -- The only processing required is to adjust the condition to deal + -- with the C/Fortran boolean case. This may well not be necessary, + -- as all such conditions are generated by the expander and probably + -- are all standard boolean, but who knows what strange optimization + -- in future may require this adjustment! + + procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is + begin + Adjust_Condition (Condition (N)); + end Expand_N_Raise_Constraint_Error; + + ---------------------------------- + -- Expand_N_Raise_Program_Error -- + ---------------------------------- + + -- The only processing required is to adjust the condition to deal + -- with the C/Fortran boolean case. This may well not be necessary, + -- as all such conditions are generated by the expander and probably + -- are all standard boolean, but who knows what strange optimization + -- in future may require this adjustment! + + procedure Expand_N_Raise_Program_Error (N : Node_Id) is + begin + Adjust_Condition (Condition (N)); + end Expand_N_Raise_Program_Error; + + ------------------------------ + -- Expand_N_Raise_Statement -- + ------------------------------ + + procedure Expand_N_Raise_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ehand : Node_Id; + E : Entity_Id; + Str : String_Id; + + begin + -- There is no expansion needed for statement "raise <exception>;" when + -- compiling for the JVM since the JVM has a built-in exception + -- mechanism. However we need the keep the expansion for "raise;" + -- statements. See 4jexcept.ads for details. + + if Present (Name (N)) and then Hostparm.Java_VM then + return; + end if; + + -- Convert explicit raise of Program_Error, Constraint_Error, and + -- Storage_Error into the corresponding raise node (in No_Run_Time + -- mode all other raises will get normal expansion and be disallowed, + -- but this is also faster in all modes). + + if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then + if Entity (Name (N)) = Standard_Program_Error then + Rewrite (N, Make_Raise_Program_Error (Loc)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Constraint_Error then + Rewrite (N, Make_Raise_Constraint_Error (Loc)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Storage_Error then + Rewrite (N, Make_Raise_Storage_Error (Loc)); + Analyze (N); + return; + end if; + end if; + + -- Case of name present, in this case we expand raise name to + + -- Raise_Exception (name'Identity, location_string); + + -- where location_string identifies the file/line of the raise + + if Present (Name (N)) then + declare + Id : Entity_Id := Entity (Name (N)); + + begin + Build_Location_String (Loc); + + -- Build a C compatible string in case of no exception handlers, + -- since this is what the last chance handler is expecting. + + if Restrictions (No_Exception_Handlers) then + -- Generate a C null message when Global_Discard_Names is True + -- or when Debug_Flag_NN is set. + + if Global_Discard_Names or else Debug_Flag_NN then + Name_Buffer (1) := ASCII.NUL; + Name_Len := 1; + else + Name_Len := Name_Len + 1; + end if; + + -- Do not generate the message when Global_Discard_Names is True + -- or when Debug_Flag_NN is set. + + elsif Global_Discard_Names or else Debug_Flag_NN then + Name_Len := 0; + end if; + + Str := String_From_Name_Buffer; + + -- For VMS exceptions, convert the raise into a call to + -- lib$stop so it will be handled by __gnat_error_handler. + + if Is_VMS_Exception (Id) then + declare + Excep_Image : String_Id; + Cond : Node_Id; + + begin + if Present (Interface_Name (Id)) then + Excep_Image := Strval (Interface_Name (Id)); + else + Get_Name_String (Chars (Id)); + Set_All_Upper_Case; + Excep_Image := String_From_Name_Buffer; + end if; + + if Exception_Code (Id) /= No_Uint then + Cond := + Make_Integer_Literal (Loc, Exception_Code (Id)); + else + Cond := + Unchecked_Convert_To (Standard_Integer, + Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Import_Value), Loc), + Parameter_Associations => New_List + (Make_String_Literal (Loc, + Strval => Excep_Image)))); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Lib_Stop), Loc), + Parameter_Associations => New_List (Cond))); + Analyze_And_Resolve (Cond, Standard_Integer); + end; + + -- Not VMS exception case, convert raise to call to the + -- Raise_Exception routine. + + else + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Name (N), + Attribute_Name => Name_Identity), + Make_String_Literal (Loc, + Strval => Str)))); + end if; + end; + + -- Case of no name present (reraise). We rewrite the raise to: + + -- Reraise_Occurrence_Always (EO); + + -- where EO is the current exception occurrence. If the current handler + -- does not have a choice parameter specification, then we provide one. + + else + -- Find innermost enclosing exception handler (there must be one, + -- since the semantics has already verified that this raise statement + -- is valid, and a raise with no arguments is only permitted in the + -- context of an exception handler. + + Ehand := Parent (N); + while Nkind (Ehand) /= N_Exception_Handler loop + Ehand := Parent (Ehand); + end loop; + + -- Make exception choice parameter if none present. Note that we do + -- not need to put the entity on the entity chain, since no one will + -- be referencing this entity by normal visibility methods. + + if No (Choice_Parameter (Ehand)) then + E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Set_Choice_Parameter (Ehand, E); + Set_Ekind (E, E_Variable); + Set_Etype (E, RTE (RE_Exception_Occurrence)); + Set_Scope (E, Current_Scope); + end if; + + -- Now rewrite the raise as a call to Reraise. A special case arises + -- if this raise statement occurs in the context of a handler for + -- all others (i.e. an at end handler). in this case we avoid + -- the call to defer abort, cleanup routines are expected to be + -- called in this case with aborts deferred. + + declare + Ech : constant Node_Id := First (Exception_Choices (Ehand)); + Ent : Entity_Id; + + begin + if Nkind (Ech) = N_Others_Choice + and then All_Others (Ech) + then + Ent := RTE (RE_Reraise_Occurrence_No_Defer); + else + Ent := RTE (RE_Reraise_Occurrence_Always); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Choice_Parameter (Ehand), Loc)))); + end; + end if; + + Analyze (N); + end Expand_N_Raise_Statement; + + ---------------------------------- + -- Expand_N_Raise_Storage_Error -- + ---------------------------------- + + -- The only processing required is to adjust the condition to deal + -- with the C/Fortran boolean case. This may well not be necessary, + -- as all such conditions are generated by the expander and probably + -- are all standard boolean, but who knows what strange optimization + -- in future may require this adjustment! + + procedure Expand_N_Raise_Storage_Error (N : Node_Id) is + begin + Adjust_Condition (Condition (N)); + end Expand_N_Raise_Storage_Error; + + ------------------------------ + -- Expand_N_Subprogram_Info -- + ------------------------------ + + procedure Expand_N_Subprogram_Info (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + -- For now, we replace an Expand_N_Subprogram_Info node with an + -- attribute reference that gives the address of the procedure. + -- This is because gigi does not yet recognize this node, and + -- for the initial targets, this is the right value anyway. + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Identifier (N), + Attribute_Name => Name_Code_Address)); + + Analyze_And_Resolve (N, RTE (RE_Code_Loc)); + end Expand_N_Subprogram_Info; + + ------------------------------------ + -- Generate_Subprogram_Descriptor -- + ------------------------------------ + + procedure Generate_Subprogram_Descriptor + (N : Node_Id; + Loc : Source_Ptr; + Spec : Entity_Id; + Slist : List_Id) + is + Code : Node_Id; + Ent : Entity_Id; + Decl : Node_Id; + Dtyp : Entity_Id; + Numh : Nat; + Sdes : Node_Id; + Hrc : List_Id; + + begin + if Exception_Mechanism /= Front_End_ZCX then + return; + end if; + + -- Suppress descriptor if we are not generating code. This happens + -- in the case of a -gnatc -gnatt compilation where we force generics + -- to be generated, but we still don't want exception tables. + + if Operating_Mode /= Generate_Code then + return; + end if; + + -- Suppress descriptor if we are in No_Exceptions restrictions mode, + -- since we can never propagate exceptions in any case in this mode. + -- The same consideration applies for No_Exception_Handlers (which + -- is also set in No_Run_Time mode). + + if Restrictions (No_Exceptions) + or Restrictions (No_Exception_Handlers) + then + return; + end if; + + -- Suppress descriptor if we are inside a generic. There are two + -- ways that we can tell that, depending on what is going on. If + -- we are actually inside the processing for a generic right now, + -- then Expander_Active will be reset. If we are outside the + -- generic, then we will see the generic entity. + + if not Expander_Active then + return; + end if; + + -- Suppress descriptor is subprogram is marked as eliminated, for + -- example if this is a subprogram created to analyze a default + -- expression with potential side effects. Ditto if it is nested + -- within an eliminated subprogram, for example a cleanup action. + + declare + Scop : Entity_Id; + + begin + Scop := Spec; + while Scop /= Standard_Standard loop + if Ekind (Scop) = E_Generic_Procedure + or else + Ekind (Scop) = E_Generic_Function + or else + Ekind (Scop) = E_Generic_Package + or else + Is_Eliminated (Scop) + then + return; + end if; + + Scop := Scope (Scop); + end loop; + end; + + -- Suppress descriptor for original protected subprogram (we will + -- be called again later to generate the descriptor for the actual + -- protected body subprogram.) This does not apply to barrier + -- functions which are there own protected subprogram. + + if Is_Subprogram (Spec) + and then Present (Protected_Body_Subprogram (Spec)) + and then Protected_Body_Subprogram (Spec) /= Spec + then + return; + end if; + + -- Suppress descriptors for packages unless they have at least one + -- handler. The binder will generate the dummy (no handler) descriptors + -- for elaboration procedures. We can't do it here, because we don't + -- know if an elaboration routine does in fact exist. + + -- If there is at least one handler for the package spec or body + -- then most certainly an elaboration routine must exist, so we + -- can safely reference it. + + if (Nkind (N) = N_Package_Declaration + or else + Nkind (N) = N_Package_Body) + and then No (Handler_Records (Spec)) + then + return; + end if; + + -- Suppress all subprogram descriptors for the file System.Exceptions. + -- We similarly suppress subprogram descriptors for Ada.Exceptions. + -- These are all init_proc's for types which cannot raise exceptions. + -- The reason this is done is that otherwise we get embarassing + -- elaboration dependencies. + + Get_Name_String (Unit_File_Name (Current_Sem_Unit)); + + if Name_Buffer (1 .. 12) = "s-except.ads" + or else + Name_Buffer (1 .. 12) = "a-except.ads" + then + return; + end if; + + -- Similarly, we need to suppress entries for System.Standard_Library, + -- since otherwise we get elaboration circularities. Again, this would + -- better be done with a Suppress_Initialization pragma :-) + + if Name_Buffer (1 .. 11) = "s-stalib.ad" then + return; + end if; + + -- For now, also suppress entries for s-stoele because we have + -- some kind of unexplained error there ??? + + if Name_Buffer (1 .. 11) = "s-stoele.ad" then + return; + end if; + + -- And also for g-htable, because it cannot raise exceptions, + -- and generates some kind of elaboration order problem. + + if Name_Buffer (1 .. 11) = "g-htable.ad" then + return; + end if; + + -- Suppress subprogram descriptor if already generated. This happens + -- in the case of late generation from Delay_Subprogram_Descriptors + -- beging set (where there is more than one instantiation in the list) + + if Has_Subprogram_Descriptor (Spec) then + return; + else + Set_Has_Subprogram_Descriptor (Spec); + end if; + + -- Never generate descriptors for inlined bodies + + if Analyzing_Inlined_Bodies then + return; + end if; + + -- Here we definitely are going to generate a subprogram descriptor + + declare + Hnum : Nat := Homonym_Number (Spec); + + begin + if Hnum = 1 then + Hnum := 0; + end if; + + Ent := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Spec), "SD", Hnum)); + end; + + if No (Handler_Records (Spec)) then + Hrc := Empty_List; + Numh := 0; + else + Hrc := Handler_Records (Spec); + Numh := List_Length (Hrc); + end if; + + New_Scope (Spec); + + -- We need a static subtype for the declaration of the subprogram + -- descriptor. For the case of 0-3 handlers we can use one of the + -- predefined subtypes in System.Exceptions. For more handlers, + -- we build our own subtype here. + + case Numh is + when 0 => + Dtyp := RTE (RE_Subprogram_Descriptor_0); + + when 1 => + Dtyp := RTE (RE_Subprogram_Descriptor_1); + + when 2 => + Dtyp := RTE (RE_Subprogram_Descriptor_2); + + when 3 => + Dtyp := RTE (RE_Subprogram_Descriptor_3); + + when others => + Dtyp := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + -- Set the constructed type as global, since we wil be + -- referencing the object that is of this type globally + + Set_Is_Statically_Allocated (Dtyp); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Dtyp, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Numh))))); + + Append (Decl, Slist); + + -- We analyze the descriptor for the subprogram and package + -- case, but not for the imported subprogram case (it will + -- be analyzed when the freeze entity actions are analyzed. + + if Present (N) then + Analyze (Decl); + end if; + + Set_Exception_Junk (Decl); + end case; + + -- Prepare the code address entry for the table entry. For the normal + -- case of being within a procedure, this is simply: + + -- P'Code_Address + + -- where P is the procedure, but for the package case, it is + + -- P'Elab_Body'Code_Address + -- P'Elab_Spec'Code_Address + + -- for the body and spec respectively. Note that we do our own + -- analysis of these attribute references, because we know in this + -- case that the prefix of ELab_Body/Spec is a visible package, + -- which can be referenced directly instead of using the general + -- case expansion for these attributes. + + if Ekind (Spec) = E_Package then + Code := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Spec, Loc), + Attribute_Name => Name_Elab_Spec); + Set_Etype (Code, Standard_Void_Type); + Set_Analyzed (Code); + + elsif Ekind (Spec) = E_Package_Body then + Code := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc), + Attribute_Name => Name_Elab_Body); + Set_Etype (Code, Standard_Void_Type); + Set_Analyzed (Code); + + else + Code := New_Occurrence_Of (Spec, Loc); + end if; + + Code := + Make_Attribute_Reference (Loc, + Prefix => Code, + Attribute_Name => Name_Code_Address); + + Set_Etype (Code, RTE (RE_Address)); + Set_Analyzed (Code); + + -- Now we can build the subprogram descriptor + + Sdes := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Dtyp, Loc), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Integer_Literal (Loc, Numh), -- Num_Handlers + + Code, -- Code + +-- temp code ??? + +-- Make_Subprogram_Info (Loc, -- Subprogram_Info +-- Identifier => +-- New_Occurrence_Of (Spec, Loc)), + + New_Copy_Tree (Code), + + Make_Aggregate (Loc, -- Handler_Records + Expressions => Hrc)))); + + Set_Exception_Junk (Sdes); + Set_Is_Subprogram_Descriptor (Sdes); + + Append (Sdes, Slist); + + -- We analyze the descriptor for the subprogram and package case, + -- but not for the imported subprogram case (it will be analyzed + -- when the freeze entity actions are analyzed. + + if Present (N) then + Analyze (Sdes); + end if; + + -- We can now pop the scope used for analyzing the descriptor + + Pop_Scope; + + -- We need to set the descriptor as statically allocated, since + -- it will be referenced from the unit exception table. + + Set_Is_Statically_Allocated (Ent); + + -- Append the resulting descriptor to the list. We do this only + -- if we are in the main unit. You might think that we could + -- simply skip generating the descriptors completely if we are + -- not in the main unit, but in fact this is not the case, since + -- we have problems with inconsistent serial numbers for internal + -- names if we do this. + + if In_Extended_Main_Code_Unit (Spec) then + Append_To (SD_List, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + Unit_Exception_Table_Present := True; + end if; + + end Generate_Subprogram_Descriptor; + + ------------------------------------------------------------ + -- Generate_Subprogram_Descriptor_For_Imported_Subprogram -- + ------------------------------------------------------------ + + procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram + (Spec : Entity_Id; + Slist : List_Id) + is + begin + Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist); + end Generate_Subprogram_Descriptor_For_Imported_Subprogram; + + ------------------------------------------------ + -- Generate_Subprogram_Descriptor_For_Package -- + ------------------------------------------------ + + procedure Generate_Subprogram_Descriptor_For_Package + (N : Node_Id; + Spec : Entity_Id) + is + Adecl : Node_Id; + + begin + Adecl := Aux_Decls_Node (Parent (N)); + + if No (Actions (Adecl)) then + Set_Actions (Adecl, New_List); + end if; + + Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl)); + end Generate_Subprogram_Descriptor_For_Package; + + --------------------------------------------------- + -- Generate_Subprogram_Descriptor_For_Subprogram -- + --------------------------------------------------- + + procedure Generate_Subprogram_Descriptor_For_Subprogram + (N : Node_Id; + Spec : Entity_Id) + is + HSS : constant Node_Id := Handled_Statement_Sequence (N); + + begin + if No (Exception_Handlers (HSS)) then + Generate_Subprogram_Descriptor + (N, Sloc (N), Spec, Statements (HSS)); + else + Generate_Subprogram_Descriptor + (N, Sloc (N), Spec, Statements (Last (Exception_Handlers (HSS)))); + end if; + end Generate_Subprogram_Descriptor_For_Subprogram; + + ----------------------------------- + -- Generate_Unit_Exception_Table -- + ----------------------------------- + + -- The only remaining thing to generate here is to generate the + -- reference to the subprogram descriptor chain. See Ada.Exceptions + -- for details of required data structures. + + procedure Generate_Unit_Exception_Table is + Loc : constant Source_Ptr := No_Location; + Num : Nat; + Decl : Node_Id; + Ent : Entity_Id; + Next_Ent : Entity_Id; + Stent : Entity_Id; + + begin + -- Nothing to be done if zero length exceptions not active + + if Exception_Mechanism /= Front_End_ZCX then + return; + end if; + + -- Remove any entries from SD_List that correspond to eliminated + -- subprograms. + + Ent := First (SD_List); + while Present (Ent) loop + Next_Ent := Next (Ent); + if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then + Remove (Ent); -- After this, there is no Next (Ent) anymore + end if; + + Ent := Next_Ent; + end loop; + + -- Nothing to do if no unit exception table present. + -- An empty table can result from subprogram elimination, + -- in such a case, eliminate the exception table itself. + + if Is_Empty_List (SD_List) then + Unit_Exception_Table_Present := False; + return; + end if; + + -- Do not generate table in a generic + + if Inside_A_Generic then + return; + end if; + + -- Generate the unit exception table + + -- subtype Tnn is Subprogram_Descriptors_Record (Num); + -- __gnat_unitname__SDP : aliased constant Tnn := + -- Num, + -- (sub1'unrestricted_access, + -- sub2'unrestricted_access, + -- ... + -- subNum'unrestricted_access)); + + Num := List_Length (SD_List); + + Stent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + Insert_Library_Level_Action ( + Make_Subtype_Declaration (Loc, + Defining_Identifier => Stent, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Subprogram_Descriptors_Record), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Num)))))); + + Set_Is_Statically_Allocated (Stent); + + Get_External_Unit_Name_String (Unit_Name (Main_Unit)); + Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. 7) := "__gnat_"; + Name_Len := Name_Len + 7; + Add_Str_To_Name_Buffer ("__SDP"); + + Ent := + Make_Defining_Identifier (Loc, + Chars => Name_Find); + + Get_Name_String (Chars (Ent)); + Set_Interface_Name (Ent, + Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => New_Occurrence_Of (Stent, Loc), + Constant_Present => True, + Aliased_Present => True, + Expression => + Make_Aggregate (Loc, + New_List ( + Make_Integer_Literal (Loc, List_Length (SD_List)), + + Make_Aggregate (Loc, + Expressions => SD_List)))); + + Insert_Library_Level_Action (Decl); + + Set_Is_Exported (Ent, True); + Set_Is_Public (Ent, True); + Set_Is_Statically_Allocated (Ent, True); + + Get_Name_String (Chars (Ent)); + Set_Interface_Name (Ent, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + end Generate_Unit_Exception_Table; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SD_List := Empty_List; + end Initialize; + + ---------------------- + -- Is_Non_Ada_Error -- + ---------------------- + + function Is_Non_Ada_Error (E : Entity_Id) return Boolean is + begin + if not OpenVMS_On_Target then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- Note: it is a little irregular for the body of exp_ch11 to know + -- the details of the encoding scheme for names, but on the other + -- hand, gigi knows them, and this is for gigi's benefit anyway! + + if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then + return False; + end if; + + return True; + end Is_Non_Ada_Error; + + ---------------------------- + -- Remove_Handler_Entries -- + ---------------------------- + + procedure Remove_Handler_Entries (N : Node_Id) is + function Check_Handler_Entry (N : Node_Id) return Traverse_Result; + -- This function checks one node for a possible reference to a + -- handler entry that must be deleted. it always returns OK. + + function Remove_All_Handler_Entries is new + Traverse_Func (Check_Handler_Entry); + -- This defines the traversal operation + + Discard : Traverse_Result; + + function Check_Handler_Entry (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Object_Declaration then + + if Present (Handler_List_Entry (N)) then + Remove (Handler_List_Entry (N)); + Delete_Tree (Handler_List_Entry (N)); + Set_Handler_List_Entry (N, Empty); + + elsif Is_Subprogram_Descriptor (N) then + declare + SDN : Node_Id; + + begin + SDN := First (SD_List); + while Present (SDN) loop + if Defining_Identifier (N) = Entity (Prefix (SDN)) then + Remove (SDN); + Delete_Tree (SDN); + exit; + end if; + + Next (SDN); + end loop; + end; + end if; + end if; + + return OK; + end Check_Handler_Entry; + + -- Start of processing for Remove_Handler_Entries + + begin + if Exception_Mechanism = Front_End_ZCX then + Discard := Remove_All_Handler_Entries (N); + end if; + end Remove_Handler_Entries; + +end Exp_Ch11; diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads new file mode 100644 index 00000000000..56af9a49e42 --- /dev/null +++ b/gcc/ada/exp_ch11.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 1 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.25 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 11 constructs + +with Types; use Types; + +package Exp_Ch11 is + procedure Expand_N_Exception_Declaration (N : Node_Id); + procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id); + procedure Expand_N_Raise_Constraint_Error (N : Node_Id); + procedure Expand_N_Raise_Program_Error (N : Node_Id); + procedure Expand_N_Raise_Statement (N : Node_Id); + procedure Expand_N_Raise_Storage_Error (N : Node_Id); + procedure Expand_N_Subprogram_Info (N : Node_Id); + + -- Data structures for gathering information to build exception tables + -- See runtime routine Ada.Exceptions for full details on the format and + -- content of these tables. + + procedure Initialize; + -- Initializes these data structures for a new main unit file + + procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id); + -- Given a handled statement sequence, HSS, for which the At_End_Proc + -- field is set, and which currently has no exception handlers, this + -- procedure expands the special exception handler required. + -- This procedure also create a new scope for the given Block, if + -- Block is not Empty. + + procedure Expand_Exception_Handlers (HSS : Node_Id); + -- This procedure expands exception handlers, and is called as part + -- of the processing for Expand_N_Handled_Sequence_Of_Statements and + -- is also called from Expand_At_End_Handler. N is the handled sequence + -- of statements that has the exception handler(s) to be expanded. This + -- is also called to expand the special exception handler built for + -- accept bodies (see Exp_Ch9.Build_Accept_Body). + + procedure Generate_Unit_Exception_Table; + -- Procedure called by main driver to generate unit exception table if + -- zero cost exceptions are enabled. See System.Exceptions for details. + + function Is_Non_Ada_Error (E : Entity_Id) return Boolean; + -- This function is provided for Gigi use. It returns True if operating on + -- VMS, and the argument E is the entity for System.Aux_Dec.Non_Ada_Error. + -- This is used to generate the special matching code for this exception. + + procedure Remove_Handler_Entries (N : Node_Id); + -- This procedure is called when optimization circuits determine that + -- an entire subtree can be removed. If the subtree contains handler + -- entries in zero cost exception mode, then such removal can lead to + -- dangling references to non-existent handlers in the handler table. + -- This procedure removes such references. + + -------------------------------------- + -- Subprogram_Descriptor Generation -- + -------------------------------------- + + -- Subprogram descriptors are required for all subprograms, including + -- explicit subprograms defined in the program, subprograms that are + -- imported via pragma Import, and also for the implicit elaboration + -- subprograms used to elaborate package specs and bodies. + + procedure Generate_Subprogram_Descriptor_For_Package + (N : Node_Id; + Spec : Entity_Id); + -- This is used to create a descriptor for the implicit elaboration + -- procedure for a package spec of body. The compiler only generates + -- such descriptors if the package spec or body contains exception + -- handlers (either explicitly in the case of a body, or from generic + -- package instantiations). N is the node for the package body or + -- spec, and Spec is the package body or package entity respectively. + -- N must be a compilation unit, and the descriptor is placed at + -- the end of the actions for the auxiliary compilation unit node. + + procedure Generate_Subprogram_Descriptor_For_Subprogram + (N : Node_Id; + Spec : Entity_Id); + -- This is used to create a desriptor for a subprogram, both those + -- present in the source, and those implicitly generated by code + -- expansion. N is the subprogram body node, and Spec is the entity + -- for the subprogram. The descriptor is placed at the end of the + -- Last exception handler, or, if there are no handlers, at the end + -- of the statement sequence. + + procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram + (Spec : Entity_Id; + Slist : List_Id); + -- This is used to create a descriptor for an imported subprogram. + -- Such descriptors are needed for propagation of exceptions through + -- such subprograms. The descriptor never references any handlers, + -- and is appended to the given Slist. + +end Exp_Ch11; diff --git a/gcc/ada/exp_ch12.adb b/gcc/ada/exp_ch12.adb new file mode 100644 index 00000000000..fe1416f6761 --- /dev/null +++ b/gcc/ada/exp_ch12.adb @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 2 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1997-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 Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Nmake; use Nmake; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Ch12 is + + ------------------------------------ + -- Expand_N_Generic_Instantiation -- + ------------------------------------ + + -- If elaboration entity is defined and this is not an outer level entity, + -- we need to generate a check for it here. + + procedure Expand_N_Generic_Instantiation (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Entity (Name (N)); + + begin + if Etype (Name (N)) = Any_Type then + return; + end if; + + if Present (Elaboration_Entity (Ent)) + and then not Is_Compilation_Unit (Ent) + and then not Elaboration_Checks_Suppressed (Ent) + then + Insert_Action (Instance_Spec (N), + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Occurrence_Of (Elaboration_Entity (Ent), Loc)))); + end if; + end Expand_N_Generic_Instantiation; + +end Exp_Ch12; diff --git a/gcc/ada/exp_ch12.ads b/gcc/ada/exp_ch12.ads new file mode 100644 index 00000000000..2cbc4e71b0c --- /dev/null +++ b/gcc/ada/exp_ch12.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 2 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992-1997 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 12 constructs + +with Types; use Types; + +package Exp_Ch12 is + procedure Expand_N_Generic_Instantiation (N : Node_Id); +end Exp_Ch12; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb new file mode 100644 index 00000000000..6e57f3beb77 --- /dev/null +++ b/gcc/ada/exp_ch13.adb @@ -0,0 +1,425 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.76 $ +-- -- +-- Copyright (C) 1992-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 Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; +with Exp_Imgv; use Exp_Imgv; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Ch13 is + + ------------------------------------------ + -- Expand_N_Attribute_Definition_Clause -- + ------------------------------------------ + + -- Expansion action depends on attribute involved + + procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Exp : constant Node_Id := Expression (N); + Ent : Entity_Id; + V : Node_Id; + + begin + Ent := Entity (Name (N)); + + if Is_Type (Ent) then + Ent := Underlying_Type (Ent); + end if; + + case Get_Attribute_Id (Chars (N)) is + + ------------- + -- Address -- + ------------- + + when Attribute_Address => + + -- If there is an initialization which did not come from + -- the source program, then it is an artifact of our + -- expansion, and we suppress it. The case we are most + -- concerned about here is the initialization of a packed + -- array to all false, which seems inappropriate for a + -- variable to which an address clause is applied. The + -- expression may itself have been rewritten if the type is a + -- packed array, so we need to examine whether the original + -- node is in the source. + + declare + Decl : constant Node_Id := Declaration_Node (Ent); + + begin + if Nkind (Decl) = N_Object_Declaration + and then Present (Expression (Decl)) + and then + not Comes_From_Source (Original_Node (Expression (Decl))) + then + Set_Expression (Decl, Empty); + end if; + end; + + --------------- + -- Alignment -- + --------------- + + when Attribute_Alignment => + + -- As required by Gigi, we guarantee that the operand is an + -- integer literal (this simplifies things in Gigi). + + if Nkind (Exp) /= N_Integer_Literal then + Rewrite + (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp))); + end if; + + ------------------ + -- External_Tag -- + ------------------ + + -- For the rep clause "for x'external_tag use y" generate: + + -- xV : constant string := y; + -- Set_External_Tag (x'tag, xV'Address); + -- Register_Tag (x'tag); + + -- note that register_tag has been delayed up to now because + -- the external_tag must be set before resistering. + + when Attribute_External_Tag => External_Tag : declare + E : Entity_Id; + Old_Val : String_Id := Strval (Expr_Value_S (Exp)); + New_Val : String_Id; + + begin + -- Create a new nul terminated string if it is not already + + if String_Length (Old_Val) > 0 + and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 + then + New_Val := Old_Val; + else + Start_String (Old_Val); + Store_String_Char (Get_Char_Code (ASCII.NUL)); + New_Val := End_String; + end if; + + E := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Ent), 'A')); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Strval => New_Val))); + + Insert_Actions (N, New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => New_Occurrence_Of (Ent, Loc)), + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Occurrence_Of (E, Loc)))), + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => New_Occurrence_Of (Ent, Loc)))))); + end External_Tag; + + ------------------ + -- Storage_Size -- + ------------------ + + when Attribute_Storage_Size => + + -- If the type is a task type, then assign the value of the + -- storage size to the Size variable associated with the task. + -- task_typeZ := expression + + if Ekind (Ent) = E_Task_Type then + Insert_Action (N, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Storage_Size_Variable (Ent), Loc), + Expression => + Convert_To (RTE (RE_Size_Type), Expression (N)))); + + -- For Storage_Size for an access type, create a variable to hold + -- the value of the specified size with name typeV and expand an + -- assignment statement to initialze this value. + + elsif Is_Access_Type (Ent) then + + V := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Ent), 'V')); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => V, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Convert_To (RTE (RE_Storage_Offset), Expression (N)))); + + Set_Storage_Size_Variable (Ent, Entity_Id (V)); + end if; + + -- Other attributes require no expansion + + when others => + null; + + end case; + + end Expand_N_Attribute_Definition_Clause; + + ---------------------------- + -- Expand_N_Freeze_Entity -- + ---------------------------- + + procedure Expand_N_Freeze_Entity (N : Node_Id) is + E : constant Entity_Id := Entity (N); + E_Scope : Entity_Id; + S : Entity_Id; + In_Other_Scope : Boolean; + In_Outer_Scope : Boolean; + Decl : Node_Id; + + begin + if not Is_Type (E) and then not Is_Subprogram (E) then + return; + end if; + + E_Scope := Scope (E); + + -- If we are freezing entities defined in protected types, they + -- belong in the enclosing scope, given that the original type + -- has been expanded away. The same is true for entities in task types, + -- in particular the parameter records of entries (Entities in bodies + -- are all frozen within the body). If we are in the task body, this + -- is a proper scope. + + if Ekind (E_Scope) = E_Protected_Type + or else (Ekind (E_Scope) = E_Task_Type + and then not Has_Completion (E_Scope)) + then + E_Scope := Scope (E_Scope); + end if; + + S := Current_Scope; + while S /= Standard_Standard and then S /= E_Scope loop + S := Scope (S); + end loop; + + In_Other_Scope := not (S = E_Scope); + In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope); + + -- If the entity being frozen is defined in a scope that is not + -- currently on the scope stack, we must establish the proper + -- visibility before freezing the entity and related subprograms. + + if In_Other_Scope then + New_Scope (E_Scope); + Install_Visible_Declarations (E_Scope); + + if Ekind (E_Scope) = E_Package or else + Ekind (E_Scope) = E_Generic_Package or else + Is_Protected_Type (E_Scope) or else + Is_Task_Type (E_Scope) + then + Install_Private_Declarations (E_Scope); + end if; + + -- If the entity is in an outer scope, then that scope needs to + -- temporarily become the current scope so that operations created + -- during type freezing will be declared in the right scope and + -- can properly override any corresponding inherited operations. + + elsif In_Outer_Scope then + New_Scope (E_Scope); + end if; + + -- If type, freeze the type + + if Is_Type (E) then + Freeze_Type (N); + + -- And for enumeration type, build the enumeration tables + + if Is_Enumeration_Type (E) then + Build_Enumeration_Image_Tables (E, N); + end if; + + -- If subprogram, freeze the subprogram + + elsif Is_Subprogram (E) then + Freeze_Subprogram (N); + + -- No other entities require any front end freeze actions + + else + null; + end if; + + -- Analyze actions generated by freezing. The init_proc contains + -- source expressions that may raise constraint_error, and the + -- assignment procedure for complex types needs checks on individual + -- component assignments, but all other freezing actions should be + -- compiled with all checks off. + + if Present (Actions (N)) then + Decl := First (Actions (N)); + + while Present (Decl) loop + + if Nkind (Decl) = N_Subprogram_Body + and then (Chars (Defining_Entity (Decl)) = Name_uInit_Proc + or else Chars (Defining_Entity (Decl)) = Name_uAssign) + then + Analyze (Decl); + + -- A subprogram body created for a renaming_as_body completes + -- a previous declaration, which may be in a different scope. + -- Establish the proper scope before analysis. + + elsif Nkind (Decl) = N_Subprogram_Body + and then Present (Corresponding_Spec (Decl)) + and then Scope (Corresponding_Spec (Decl)) /= Current_Scope + then + New_Scope (Scope (Corresponding_Spec (Decl))); + Analyze (Decl, Suppress => All_Checks); + Pop_Scope; + + else + Analyze (Decl, Suppress => All_Checks); + end if; + + Next (Decl); + end loop; + end if; + + if In_Other_Scope then + if Ekind (Current_Scope) = E_Package then + End_Package_Scope (E_Scope); + else + End_Scope; + end if; + + elsif In_Outer_Scope then + Pop_Scope; + end if; + end Expand_N_Freeze_Entity; + + ------------------------------------------- + -- Expand_N_Record_Representation_Clause -- + ------------------------------------------- + + -- The only expansion required is for the case of a mod clause present, + -- which is removed, and translated into an alignment representation + -- clause inserted immediately after the record rep clause with any + -- initial pragmas inserted at the start of the component clause list. + + procedure Expand_N_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rectype : constant Entity_Id := Entity (Identifier (N)); + Mod_Val : Uint; + Citems : List_Id; + Repitem : Node_Id; + AtM_Nod : Node_Id; + + begin + if Present (Mod_Clause (N)) then + Mod_Val := Expr_Value (Expression (Mod_Clause (N))); + Citems := Pragmas_Before (Mod_Clause (N)); + + if Present (Citems) then + Append_List_To (Citems, Component_Clauses (N)); + Set_Component_Clauses (N, Citems); + end if; + + AtM_Nod := + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Base_Type (Rectype), Loc), + Chars => Name_Alignment, + Expression => Make_Integer_Literal (Loc, Mod_Val)); + + Set_From_At_Mod (AtM_Nod); + Insert_After (N, AtM_Nod); + Set_Mod_Clause (N, Empty); + end if; + + -- If the record representation clause has no components, then + -- completely remove it. Note that we also have to remove + -- ourself from the Rep Item list. + + if Is_Empty_List (Component_Clauses (N)) then + if First_Rep_Item (Rectype) = N then + Set_First_Rep_Item (Rectype, Next_Rep_Item (N)); + else + Repitem := First_Rep_Item (Rectype); + while Present (Next_Rep_Item (Repitem)) loop + if Next_Rep_Item (Repitem) = N then + Set_Next_Rep_Item (Repitem, Next_Rep_Item (N)); + exit; + end if; + + Next_Rep_Item (Repitem); + end loop; + end if; + + Rewrite (N, + Make_Null_Statement (Loc)); + end if; + end Expand_N_Record_Representation_Clause; + +end Exp_Ch13; diff --git a/gcc/ada/exp_ch13.ads b/gcc/ada/exp_ch13.ads new file mode 100644 index 00000000000..b68d197601f --- /dev/null +++ b/gcc/ada/exp_ch13.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 3 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 13 constructs + +with Types; use Types; + +package Exp_Ch13 is + + procedure Expand_N_Attribute_Definition_Clause (N : Node_Id); + procedure Expand_N_Freeze_Entity (N : Node_Id); + procedure Expand_N_Record_Representation_Clause (N : Node_Id); + +end Exp_Ch13; diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb new file mode 100644 index 00000000000..1a0c903f892 --- /dev/null +++ b/gcc/ada/exp_ch2.adb @@ -0,0 +1,487 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 2 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.64 $ +-- -- +-- Copyright (C) 1992-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 Elists; use Elists; +with Exp_Smem; use Exp_Smem; +with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; +with Nmake; use Nmake; +with Sem; use Sem; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Tbuild; use Tbuild; +with Snames; use Snames; + +package body Exp_Ch2 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Discriminant (N : Node_Id); + -- An occurence of a discriminant within a discriminated type is replaced + -- with the corresponding discriminal, that is to say the formal parameter + -- of the initialization procedure for the type that is associated with + -- that particular discriminant. This replacement is not performed for + -- discriminants of records that appear in constraints of component of the + -- record, because Gigi uses the discriminant name to retrieve its value. + -- In the other hand, it has to be performed for default expressions of + -- components because they are used in the record init procedure. See + -- Einfo for more details, and Exp_Ch3, Exp_Ch9 for examples of use. + -- For discriminants of tasks and protected types, the transformation is + -- more complex when it occurs within a default expression for an entry + -- or protected operation. The corresponding default_expression_function + -- has an additional parameter which is the target of an entry call, and + -- the discriminant of the task must be replaced with a reference to the + -- discriminant of that formal parameter. + + procedure Expand_Entity_Reference (N : Node_Id); + -- Common processing for expansion of identifiers and expanded names + + procedure Expand_Entry_Index_Parameter (N : Node_Id); + -- A reference to the identifier in the entry index specification + -- of a protected entry body is modified to a reference to a constant + -- definintion equal to the index of the entry family member being + -- called. This constant is calculated as part of the elaboration + -- of the expanded code for the body, and is calculated from the + -- object-wide entry index returned by Next_Entry_Call. + + procedure Expand_Entry_Parameter (N : Node_Id); + -- A reference to an entry parameter is modified to be a reference to + -- the corresponding component of the entry parameter record that is + -- passed by the runtime to the accept body procedure + + procedure Expand_Formal (N : Node_Id); + -- A reference to a formal parameter of a protected subprogram is + -- expanded to the corresponding formal of the unprotected procedure + -- used to represent the protected subprogram within the protected object. + + procedure Expand_Protected_Private (N : Node_Id); + -- A reference to a private object of a protected type is expanded + -- to a component selected from the record used to implement + -- the protected object. Such a record is passed to all operations + -- on a protected object in a parameter named _object. Such an object + -- is a constant within a function, and a variable otherwise. + + procedure Expand_Renaming (N : Node_Id); + -- For renamings, just replace the identifier by the corresponding + -- name expression. Note that this has been evaluated (see routine + -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives + -- the correct renaming semantics. + + ------------------------- + -- Expand_Discriminant -- + ------------------------- + + procedure Expand_Discriminant (N : Node_Id) is + Scop : constant Entity_Id := Scope (Entity (N)); + P : Node_Id := N; + Parent_P : Node_Id := Parent (P); + In_Entry : Boolean := False; + + begin + -- The Incomplete_Or_Private_Kind happens while resolving the + -- discriminant constraint involved in a derived full type, + -- such as: + + -- type D is private; + -- type D(C : ...) is new T(C); + + if Ekind (Scop) = E_Record_Type + or Ekind (Scop) in Incomplete_Or_Private_Kind + then + + -- Find the origin by walking up the tree till the component + -- declaration + + while Present (Parent_P) + and then Nkind (Parent_P) /= N_Component_Declaration + loop + P := Parent_P; + Parent_P := Parent (P); + end loop; + + -- If the discriminant reference was part of the default expression + -- it has to be "discriminalized" + + if Present (Parent_P) and then P = Expression (Parent_P) then + Set_Entity (N, Discriminal (Entity (N))); + end if; + + elsif Is_Concurrent_Type (Scop) then + while Present (Parent_P) + and then Nkind (Parent_P) /= N_Subprogram_Body + loop + P := Parent_P; + + if Nkind (P) = N_Entry_Declaration then + In_Entry := True; + end if; + + Parent_P := Parent (Parent_P); + end loop; + + -- If the discriminant occurs within the default expression for + -- a formal of an entry or protected operation, create a default + -- function for it, and replace the discriminant with a reference + -- to the discriminant of the formal of the default function. + -- The discriminant entity is the one defined in the corresponding + -- record. + + if Present (Parent_P) + and then Present (Corresponding_Spec (Parent_P)) + then + + declare + Loc : constant Source_Ptr := Sloc (N); + D_Fun : Entity_Id := Corresponding_Spec (Parent_P); + Formal : Entity_Id := First_Formal (D_Fun); + New_N : Node_Id; + Disc : Entity_Id; + + begin + -- Verify that we are within a default function: the type of + -- its formal parameter is the same task or protected type. + + if Present (Formal) + and then Etype (Formal) = Scope (Entity (N)) + then + Disc := CR_Discriminant (Entity (N)); + + New_N := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Formal, Loc), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Set_Etype (New_N, Etype (N)); + Rewrite (N, New_N); + + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + end; + + elsif Nkind (Parent (N)) = N_Range + and then In_Entry + then + Set_Entity (N, CR_Discriminant (Entity (N))); + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + end Expand_Discriminant; + + ----------------------------- + -- Expand_Entity_Reference -- + ----------------------------- + + procedure Expand_Entity_Reference (N : Node_Id) is + E : constant Entity_Id := Entity (N); + + begin + if Ekind (E) = E_Discriminant then + Expand_Discriminant (N); + + elsif Is_Entry_Formal (E) then + Expand_Entry_Parameter (N); + + elsif Ekind (E) = E_Component + and then Is_Protected_Private (E) + then + Expand_Protected_Private (N); + + elsif Ekind (E) = E_Entry_Index_Parameter then + Expand_Entry_Index_Parameter (N); + + elsif Is_Formal (E) then + Expand_Formal (N); + + elsif Is_Renaming_Of_Object (E) then + Expand_Renaming (N); + + elsif Ekind (E) = E_Variable + and then Is_Shared_Passive (E) + then + Expand_Shared_Passive_Variable (N); + end if; + end Expand_Entity_Reference; + + ---------------------------------- + -- Expand_Entry_Index_Parameter -- + ---------------------------------- + + procedure Expand_Entry_Index_Parameter (N : Node_Id) is + begin + Set_Entity (N, Entry_Index_Constant (Entity (N))); + end Expand_Entry_Index_Parameter; + + ---------------------------- + -- Expand_Entry_Parameter -- + ---------------------------- + + procedure Expand_Entry_Parameter (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent_Formal : constant Entity_Id := Entity (N); + Ent_Spec : constant Entity_Id := Scope (Ent_Formal); + Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec); + Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec); + Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack)); + P_Comp_Ref : Entity_Id; + + begin + -- What we need is a reference to the corresponding component of the + -- parameter record object. The Accept_Address field of the entry + -- entity references the address variable that contains the address + -- of the accept parameters record. We first have to do an unchecked + -- conversion to turn this into a pointer to the parameter record and + -- then we select the required parameter field. + + P_Comp_Ref := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Parm_Type, + New_Reference_To (Addr_Ent, Loc)), + Selector_Name => + New_Reference_To (Entry_Component (Ent_Formal), Loc)); + + -- For all types of parameters, the constructed parameter record + -- object contains a pointer to the parameter. Thus we must + -- dereference them to access them (this will often be redundant, + -- since the needed deference is implicit, but no harm is done by + -- making it explicit). + + Rewrite (N, + Make_Explicit_Dereference (Loc, P_Comp_Ref)); + + Analyze (N); + end Expand_Entry_Parameter; + + ------------------- + -- Expand_Formal -- + ------------------- + + procedure Expand_Formal (N : Node_Id) is + E : constant Entity_Id := Entity (N); + Subp : constant Entity_Id := Scope (E); + + begin + if Is_Protected_Type (Scope (Subp)) + and then Chars (Subp) /= Name_uInit_Proc + and then Present (Protected_Formal (E)) + then + Set_Entity (N, Protected_Formal (E)); + end if; + end Expand_Formal; + + ---------------------------- + -- Expand_N_Expanded_Name -- + ---------------------------- + + procedure Expand_N_Expanded_Name (N : Node_Id) is + begin + Expand_Entity_Reference (N); + end Expand_N_Expanded_Name; + + ------------------------- + -- Expand_N_Identifier -- + ------------------------- + + procedure Expand_N_Identifier (N : Node_Id) is + begin + Expand_Entity_Reference (N); + end Expand_N_Identifier; + + --------------------------- + -- Expand_N_Real_Literal -- + --------------------------- + + procedure Expand_N_Real_Literal (N : Node_Id) is + begin + if Vax_Float (Etype (N)) then + Expand_Vax_Real_Literal (N); + end if; + end Expand_N_Real_Literal; + + ------------------------------ + -- Expand_Protected_Private -- + ------------------------------ + + procedure Expand_Protected_Private (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := Entity (N); + Op : constant Node_Id := Protected_Operation (E); + Scop : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + D_Range : Node_Id; + + begin + if Nkind (Op) /= N_Subprogram_Body + or else Nkind (Specification (Op)) /= N_Function_Specification + then + Set_Ekind (Prival (E), E_Variable); + else + Set_Ekind (Prival (E), E_Constant); + end if; + + -- If the private component appears in an assignment (either lhs or + -- rhs) and is a one-dimensional array constrained by a discriminant, + -- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal + -- is directly visible. This solves delicate visibility problems. + + if Comes_From_Source (N) + and then Is_Array_Type (Etype (E)) + and then Number_Dimensions (Etype (E)) = 1 + and then not Within_Init_Proc + then + Lo := Type_Low_Bound (Etype (First_Index (Etype (E)))); + Hi := Type_High_Bound (Etype (First_Index (Etype (E)))); + + if Nkind (Parent (N)) = N_Assignment_Statement + and then ((Is_Entity_Name (Lo) + and then Ekind (Entity (Lo)) = E_In_Parameter) + or else (Is_Entity_Name (Hi) + and then + Ekind (Entity (Hi)) = E_In_Parameter)) + then + D_Range := New_Node (N_Range, Loc); + + if Is_Entity_Name (Lo) + and then Ekind (Entity (Lo)) = E_In_Parameter + then + Set_Low_Bound (D_Range, + Make_Identifier (Loc, Chars (Entity (Lo)))); + else + Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo)); + end if; + + if Is_Entity_Name (Hi) + and then Ekind (Entity (Hi)) = E_In_Parameter + then + Set_High_Bound (D_Range, + Make_Identifier (Loc, Chars (Entity (Hi)))); + else + Set_High_Bound (D_Range, Duplicate_Subexpr (Hi)); + end if; + + Rewrite (N, + Make_Slice (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Discrete_Range => D_Range)); + + Analyze_And_Resolve (N, Etype (E)); + return; + end if; + end if; + + -- The type of the reference is the type of the prival, which may + -- differ from that of the original component if it is an itype. + + Set_Entity (N, Prival (E)); + Set_Etype (N, Etype (Prival (E))); + Scop := Current_Scope; + + -- Find entity for protected operation, which must be on scope stack. + + while not Is_Protected_Type (Scope (Scop)) loop + Scop := Scope (Scop); + end loop; + + Append_Elmt (N, Privals_Chain (Scop)); + end Expand_Protected_Private; + + --------------------- + -- Expand_Renaming -- + --------------------- + + procedure Expand_Renaming (N : Node_Id) is + E : constant Entity_Id := Entity (N); + T : constant Entity_Id := Etype (N); + + begin + Rewrite (N, New_Copy_Tree (Renamed_Object (E))); + + -- We mark the copy as unanalyzed, so that it is sure to be + -- reanalyzed at the top level. This is needed in the packed + -- case since we specifically avoided expanding packed array + -- references when the renaming declaration was analyzed. + + Reset_Analyzed_Flags (N); + Analyze_And_Resolve (N, T); + end Expand_Renaming; + + ------------------ + -- Param_Entity -- + ------------------ + + -- This would be trivial, simply a test for an identifier that was a + -- reference to a formal, if it were not for the fact that a previous + -- call to Expand_Entry_Parameter will have modified the reference + -- to the identifier to be of the form + + -- typ!(recobj).rec.all'Constrained + + -- where rec is a selector whose Entry_Formal link points to the formal + + function Param_Entity (N : Node_Id) return Entity_Id is + begin + -- Simple reference case + + if Nkind (N) = N_Identifier then + if Is_Formal (Entity (N)) then + return Entity (N); + end if; + + else + if Nkind (N) = N_Explicit_Dereference then + declare + P : constant Node_Id := Prefix (N); + S : Node_Id; + + begin + if Nkind (P) = N_Selected_Component then + S := Selector_Name (P); + + if Present (Entry_Formal (Entity (S))) then + return Entry_Formal (Entity (S)); + end if; + end if; + end; + end if; + end if; + + return (Empty); + end Param_Entity; + +end Exp_Ch2; diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads new file mode 100644 index 00000000000..f5f105e4064 --- /dev/null +++ b/gcc/ada/exp_ch2.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 2 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- Copyright (C) 1992-1997 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 2 constructs + +with Types; use Types; +package Exp_Ch2 is + + procedure Expand_N_Expanded_Name (N : Node_Id); + procedure Expand_N_Identifier (N : Node_Id); + procedure Expand_N_Real_Literal (N : Node_Id); + + function Param_Entity (N : Node_Id) return Entity_Id; + -- Given an expression N, determines if the expression is a reference + -- to a formal (of a subprogram or entry), and if so returns the Id + -- of the corresponding formal entity, otherwise returns Empty. The + -- reason that this is in Exp_Ch2 is that it has to deal with the + -- case where the reference is to an entry formal, and has been + -- expanded already. Since Exp_Ch2 is in charge of the expansion, it + -- is best suited to knowing how to detect this case. + +end Exp_Ch2; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb new file mode 100644 index 00000000000..76520cfdb9a --- /dev/null +++ b/gcc/ada/exp_ch3.adb @@ -0,0 +1,5200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.481 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Aggr; use Exp_Aggr; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Smem; use Exp_Smem; +with Exp_Strm; use Exp_Strm; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Hostparm; use Hostparm; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Snames; use Snames; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Ch3 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Adjust_Discriminants (Rtype : Entity_Id); + -- This is used when freezing a record type. It attempts to construct + -- more restrictive subtypes for discriminants so that the max size of + -- the record can be calculated more accurately. See the body of this + -- procedure for details. + + procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); + -- Build initialization procedure for given array type. Nod is a node + -- used for attachment of any actions required in its construction. + -- It also supplies the source location used for the procedure. + + procedure Build_Class_Wide_Master (T : Entity_Id); + -- for access to class-wide limited types we must build a task master + -- because some subsequent extension may add a task component. To avoid + -- bringing in the tasking run-time whenever an access-to-class-wide + -- limited type is used, we use the soft-link mechanism and add a level + -- of indirection to calls to routines that manipulate Master_Ids. + + function Build_Discriminant_Formals + (Rec_Id : Entity_Id; + Use_Dl : Boolean) + return List_Id; + -- This function uses the discriminants of a type to build a list of + -- formal parameters, used in the following function. If the flag Use_Dl + -- is set, the list is built using the already defined discriminals + -- of the type. Otherwise new identifiers are created, with the source + -- names of the discriminants. + + procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); + -- If the designated type of an access type is a task type or contains + -- tasks, we make sure that a _Master variable is declared in the current + -- scope, and then declare a renaming for it: + -- + -- atypeM : Master_Id renames _Master; + -- + -- where atyp is the name of the access type. This declaration is + -- used when an allocator for the access type is expanded. The node N + -- is the full declaration of the designated type that contains tasks. + -- The renaming declaration is inserted before N, and after the Master + -- declaration. + + procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); + -- Build record initialization procedure. N is the type declaration + -- node, and Pe is the corresponding entity for the record type. + + procedure Build_Variant_Record_Equality (Typ : Entity_Id); + -- Create An Equality function for the non-tagged variant record 'Typ' + -- and attach it to the TSS list + + procedure Expand_Tagged_Root (T : Entity_Id); + -- Add a field _Tag at the beginning of the record. This field carries + -- the value of the access to the Dispatch table. This procedure is only + -- called on root (non CPP_Class) types, the _Tag field being inherited + -- by the descendants. + + procedure Expand_Record_Controller (T : Entity_Id); + -- T must be a record type that Has_Controlled_Component. Add a field _C + -- of type Record_Controller or Limited_Record_Controller in the record T. + + procedure Freeze_Array_Type (N : Node_Id); + -- Freeze an array type. Deals with building the initialization procedure, + -- creating the packed array type for a packed array and also with the + -- creation of the controlling procedures for the controlled case. The + -- argument N is the N_Freeze_Entity node for the type. + + procedure Freeze_Enumeration_Type (N : Node_Id); + -- Freeze enumeration type with non-standard representation. Builds the + -- array and function needed to convert between enumeration pos and + -- enumeration representation values. N is the N_Freeze_Entity node + -- for the type. + + procedure Freeze_Record_Type (N : Node_Id); + -- Freeze record type. Builds all necessary discriminant checking + -- and other ancillary functions, and builds dispatch tables where + -- needed. The argument N is the N_Freeze_Entity node. This processing + -- applies only to E_Record_Type entities, not to class wide types, + -- record subtypes, or private types. + + function Init_Formals (Typ : Entity_Id) return List_Id; + -- This function builds the list of formals for an initialization routine. + -- The first formal is always _Init with the given type. For task value + -- record types and types containing tasks, three additional formals are + -- added: + -- + -- _Master : Master_Id + -- _Chain : in out Activation_Chain + -- _Task_Id : Task_Image_Type + -- + -- The caller must append additional entries for discriminants if required. + + function In_Runtime (E : Entity_Id) return Boolean; + -- Check if E is defined in the RTL (in a child of Ada or System). Used + -- to avoid to bring in the overhead of _Input, _Output for tagged types. + + function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id; + -- Building block for variant record equality. Defined to share the + -- code between the tagged and non-tagged case. Given a Component_List + -- node CL, it generates an 'if' followed by a 'case' statement that + -- compares all components of local temporaries named X and Y (that + -- are declared as formals at some upper level). Node provides the + -- Sloc to be used for the generated code. + + function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id; + -- Building block for variant record equality. Defined to share the + -- code between the tagged and non-tagged case. Given the list of + -- components (or discriminants) L, it generates a return statement + -- that compares all components of local temporaries named X and Y + -- (that are declared as formals at some upper level). Node provides + -- the Sloc to be used for the generated code. + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Node_Id); + -- Create a list with the specs of the predefined primitive operations. + -- This list contains _Size, _Read, _Write, _Input and _Output for + -- every tagged types, plus _equality, _assign, _deep_finalize and + -- _deep_adjust for non limited tagged types. _Size, _Read, _Write, + -- _Input and _Output implement the corresponding attributes that need + -- to be dispatching when their arguments are classwide. _equality and + -- _assign, implement equality and assignment that also must be + -- dispatching. _Deep_Finalize and _Deep_Adjust are empty procedures + -- unless the type contains some controlled components that require + -- finalization actions. The list is returned in Predef_List. The + -- parameter Renamed_Eq either returns the value Empty, or else the + -- defining unit name for the predefined equality function in the + -- case where the type has a primitive operation that is a renaming + -- of predefined equality (but only if there is also an overriding + -- user-defined equality function). The returned Renamed_Eq will be + -- passed to the corresponding parameter of Predefined_Primitive_Bodies. + + function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; + -- returns True if there are representation clauses for type T that + -- are not inherited. If the result is false, the init_proc and the + -- discriminant_checking functions of the parent can be reused by + -- a derived type. + + function Predef_Spec_Or_Body + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + Profile : List_Id; + Ret_Type : Entity_Id := Empty; + For_Body : Boolean := False) + return Node_Id; + -- This function generates the appropriate expansion for a predefined + -- primitive operation specified by its name, parameter profile and + -- return type (Empty means this is a procedure). If For_Body is false, + -- then the returned node is a subprogram declaration. If For_Body is + -- true, then the returned node is a empty subprogram body containing + -- no declarations and no statements. + + function Predef_Stream_Attr_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + For_Body : Boolean := False) + return Node_Id; + -- Specialized version of Predef_Spec_Or_Body that apply to _read, _write, + -- _input and _output whose specs are constructed in Exp_Strm. + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + For_Body : Boolean := False) + return Node_Id; + -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust + -- and _deep_finalize + + function Predefined_Primitive_Bodies + (Tag_Typ : Entity_Id; + Renamed_Eq : Node_Id) + return List_Id; + -- Create the bodies of the predefined primitives that are described in + -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote + -- the defining unit name of the type's predefined equality as returned + -- by Make_Predefined_Primitive_Specs. + + function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; + -- Freeze entities of all predefined primitive operations. This is needed + -- because the bodies of these operations do not normally do any freezeing. + + -------------------------- + -- Adjust_Discriminants -- + -------------------------- + + -- This procedure attempts to define subtypes for discriminants that + -- are more restrictive than those declared. Such a replacement is + -- possible if we can demonstrate that values outside the restricted + -- range would cause constraint errors in any case. The advantage of + -- restricting the discriminant types in this way is tha the maximum + -- size of the variant record can be calculated more conservatively. + + -- An example of a situation in which we can perform this type of + -- restriction is the following: + + -- subtype B is range 1 .. 10; + -- type Q is array (B range <>) of Integer; + + -- type V (N : Natural) is record + -- C : Q (1 .. N); + -- end record; + + -- In this situation, we can restrict the upper bound of N to 10, since + -- any larger value would cause a constraint error in any case. + + -- There are many situations in which such restriction is possible, but + -- for now, we just look for cases like the above, where the component + -- in question is a one dimensional array whose upper bound is one of + -- the record discriminants. Also the component must not be part of + -- any variant part, since then the component does not always exist. + + procedure Adjust_Discriminants (Rtype : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Rtype); + Comp : Entity_Id; + Ctyp : Entity_Id; + Ityp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + P : Node_Id; + Loval : Uint; + Discr : Entity_Id; + Dtyp : Entity_Id; + Dhi : Node_Id; + Dhiv : Uint; + Ahi : Node_Id; + Ahiv : Uint; + Tnn : Entity_Id; + + begin + Comp := First_Component (Rtype); + while Present (Comp) loop + + -- If our parent is a variant, quit, we do not look at components + -- that are in variant parts, because they may not always exist. + + P := Parent (Comp); -- component declaration + P := Parent (P); -- component list + + exit when Nkind (Parent (P)) = N_Variant; + + -- We are looking for a one dimensional array type + + Ctyp := Etype (Comp); + + if not Is_Array_Type (Ctyp) + or else Number_Dimensions (Ctyp) > 1 + then + goto Continue; + end if; + + -- The lower bound must be constant, and the upper bound is a + -- discriminant (which is a discriminant of the current record). + + Ityp := Etype (First_Index (Ctyp)); + Lo := Type_Low_Bound (Ityp); + Hi := Type_High_Bound (Ityp); + + if not Compile_Time_Known_Value (Lo) + or else Nkind (Hi) /= N_Identifier + or else No (Entity (Hi)) + or else Ekind (Entity (Hi)) /= E_Discriminant + then + goto Continue; + end if; + + -- We have an array with appropriate bounds + + Loval := Expr_Value (Lo); + Discr := Entity (Hi); + Dtyp := Etype (Discr); + + -- See if the discriminant has a known upper bound + + Dhi := Type_High_Bound (Dtyp); + + if not Compile_Time_Known_Value (Dhi) then + goto Continue; + end if; + + Dhiv := Expr_Value (Dhi); + + -- See if base type of component array has known upper bound + + Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); + + if not Compile_Time_Known_Value (Ahi) then + goto Continue; + end if; + + Ahiv := Expr_Value (Ahi); + + -- The condition for doing the restriction is that the high bound + -- of the discriminant is greater than the low bound of the array, + -- and is also greater than the high bound of the base type index. + + if Dhiv > Loval and then Dhiv > Ahiv then + + -- We can reset the upper bound of the discriminant type to + -- whichever is larger, the low bound of the component, or + -- the high bound of the base type array index. + + -- We build a subtype that is declared as + + -- subtype Tnn is discr_type range discr_type'First .. max; + + -- And insert this declaration into the tree. The type of the + -- discriminant is then reset to this more restricted subtype. + + Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + Insert_Action (Declaration_Node (Rtype), + Make_Subtype_Declaration (Loc, + Defining_Identifier => Tnn, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (Dtyp, Loc)), + High_Bound => + Make_Integer_Literal (Loc, + Intval => UI_Max (Loval, Ahiv))))))); + + Set_Etype (Discr, Tnn); + end if; + + <<Continue>> + Next_Component (Comp); + end loop; + + end Adjust_Discriminants; + + --------------------------- + -- Build_Array_Init_Proc -- + --------------------------- + + procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Index_List : List_Id; + Proc_Id : Entity_Id; + Proc_Body : Node_Id; + Body_Stmts : List_Id; + + function Init_Component return List_Id; + -- Create one statement to initialize one array component, designated + -- by a full set of indices. + + function Init_One_Dimension (N : Int) return List_Id; + -- Create loop to initialize one dimension of the array. The single + -- statement in the loop body initializes the inner dimensions if any, + -- or else the single component. Note that this procedure is called + -- recursively, with N being the dimension to be initialized. A call + -- with N greater than the number of dimensions simply generates the + -- component initialization, terminating the recursion. + + -------------------- + -- Init_Component -- + -------------------- + + function Init_Component return List_Id is + Comp : Node_Id; + + begin + Comp := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Expressions => Index_List); + + if Needs_Simple_Initialization (Comp_Type) then + Set_Assignment_OK (Comp); + return New_List ( + Make_Assignment_Statement (Loc, + Name => Comp, + Expression => Get_Simple_Init_Val (Comp_Type, Loc))); + + else + return + Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type); + end if; + end Init_Component; + + ------------------------ + -- Init_One_Dimension -- + ------------------------ + + function Init_One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + -- If the component does not need initializing, then there is nothing + -- to do here, so we return a null body. This occurs when generating + -- the dummy Init_Proc needed for Initialize_Scalars processing. + + if not Has_Non_Null_Base_Init_Proc (Comp_Type) + and then not Needs_Simple_Initialization (Comp_Type) + and then not Has_Task (Comp_Type) + then + return New_List (Make_Null_Statement (Loc)); + + -- If all dimensions dealt with, we simply initialize the component + + elsif N > Number_Dimensions (A_Type) then + return Init_Component; + + -- Here we generate the required loop + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))))), + Statements => Init_One_Dimension (N + 1))); + end if; + end Init_One_Dimension; + + -- Start of processing for Build_Array_Init_Proc + + begin + if Suppress_Init_Proc (A_Type) then + return; + end if; + + Index_List := New_List; + + -- We need an initialization procedure if any of the following is true: + + -- 1. The component type has an initialization procedure + -- 2. The component type needs simple initialization + -- 3. Tasks are present + -- 4. The type is marked as a publc entity + + -- The reason for the public entity test is to deal properly with the + -- Initialize_Scalars pragma. This pragma can be set in the client and + -- not in the declaring package, this means the client will make a call + -- to the initialization procedure (because one of conditions 1-3 must + -- apply in this case), and we must generate a procedure (even if it is + -- null) to satisfy the call in this case. + + -- Exception: do not build an array init_proc for a type whose root type + -- is Standard.String or Standard.Wide_String, since there is no place + -- to put the code, and in any case we handle initialization of such + -- types (in the Initialize_Scalars case, that's the only time the issue + -- arises) in a special manner anyway which does not need an init_proc. + + if Has_Non_Null_Base_Init_Proc (Comp_Type) + or else Needs_Simple_Initialization (Comp_Type) + or else Has_Task (Comp_Type) + or else (Is_Public (A_Type) + and then Root_Type (A_Type) /= Standard_String + and then Root_Type (A_Type) /= Standard_Wide_String) + then + Proc_Id := + Make_Defining_Identifier (Loc, Name_uInit_Proc); + + Body_Stmts := Init_One_Dimension (1); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Init_Formals (A_Type)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts)); + + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Public (Proc_Id, Is_Public (A_Type)); + Set_Is_Inlined (Proc_Id); + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Associate Init_Proc with type, and determine if the procedure + -- is null (happens because of the Initialize_Scalars pragma case, + -- where we have to generate a null procedure in case it is called + -- by a client with Initialize_Scalars set). Such procedures have + -- to be generated, but do not have to be called, so we mark them + -- as null to suppress the call. + + Set_Init_Proc (A_Type, Proc_Id); + + if List_Length (Body_Stmts) = 1 + and then Nkind (First (Body_Stmts)) = N_Null_Statement + then + Set_Is_Null_Init_Proc (Proc_Id); + end if; + end if; + + end Build_Array_Init_Proc; + + ----------------------------- + -- Build_Class_Wide_Master -- + ----------------------------- + + procedure Build_Class_Wide_Master (T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (T); + M_Id : Entity_Id; + Decl : Node_Id; + P : Node_Id; + + begin + -- Nothing to do if there is no task hierarchy. + + if Restrictions (No_Task_Hierarchy) then + return; + end if; + + -- Nothing to do if we already built a master entity for this scope + + if not Has_Master_Entity (Scope (T)) then + -- first build the master entity + -- _Master : constant Master_Id := Current_Master.all; + -- and insert it just before the current declaration + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); + + P := Parent (T); + Insert_Before (P, Decl); + Analyze (Decl); + Set_Has_Master_Entity (Scope (T)); + + -- Now mark the containing scope as a task master + + while Nkind (P) /= N_Compilation_Unit loop + P := Parent (P); + + -- If we fall off the top, we are at the outer level, and the + -- environment task is our effective master, so nothing to mark. + + if Nkind (P) = N_Task_Body + or else Nkind (P) = N_Block_Statement + or else Nkind (P) = N_Subprogram_Body + then + Set_Is_Task_Master (P, True); + exit; + end if; + end loop; + end if; + + -- Now define the renaming of the master_id. + + M_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (T), 'M')); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => M_Id, + Subtype_Mark => New_Reference_To (Standard_Integer, Loc), + Name => Make_Identifier (Loc, Name_uMaster)); + Insert_Before (Parent (T), Decl); + Analyze (Decl); + + Set_Master_Id (T, M_Id); + end Build_Class_Wide_Master; + + -------------------------------- + -- Build_Discr_Checking_Funcs -- + -------------------------------- + + procedure Build_Discr_Checking_Funcs (N : Node_Id) is + Rec_Id : Entity_Id; + Loc : Source_Ptr; + Enclosing_Func_Id : Entity_Id; + Sequence : Nat := 1; + Type_Def : Node_Id; + V : Node_Id; + + function Build_Case_Statement + (Case_Id : Entity_Id; + Variant : Node_Id) + return Node_Id; + -- Need documentation for this spec ??? + + function Build_Dcheck_Function + (Case_Id : Entity_Id; + Variant : Node_Id) + return Entity_Id; + -- Build the discriminant checking function for a given variant + + procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id); + -- Builds the discriminant checking function for each variant of the + -- given variant part of the record type. + + -------------------------- + -- Build_Case_Statement -- + -------------------------- + + function Build_Case_Statement + (Case_Id : Entity_Id; + Variant : Node_Id) + return Node_Id + is + Actuals_List : List_Id; + Alt_List : List_Id := New_List; + Case_Node : Node_Id; + Case_Alt_Node : Node_Id; + Choice : Node_Id; + Choice_List : List_Id; + D : Entity_Id; + Return_Node : Node_Id; + + begin + -- Build a case statement containing only two alternatives. The + -- first alternative corresponds exactly to the discrete choices + -- given on the variant with contains the components that we are + -- generating the checks for. If the discriminant is one of these + -- return False. The other alternative consists of the choice + -- "Others" and will return True indicating the discriminant did + -- not match. + + Case_Node := New_Node (N_Case_Statement, Loc); + + -- Replace the discriminant which controls the variant, with the + -- name of the formal of the checking function. + + Set_Expression (Case_Node, + Make_Identifier (Loc, Chars (Case_Id))); + + Choice := First (Discrete_Choices (Variant)); + + if Nkind (Choice) = N_Others_Choice then + Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); + else + Choice_List := New_Copy_List (Discrete_Choices (Variant)); + end if; + + if not Is_Empty_List (Choice_List) then + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); + Set_Discrete_Choices (Case_Alt_Node, Choice_List); + + -- In case this is a nested variant, we need to return the result + -- of the discriminant checking function for the immediately + -- enclosing variant. + + if Present (Enclosing_Func_Id) then + Actuals_List := New_List; + + D := First_Discriminant (Rec_Id); + while Present (D) loop + Append (Make_Identifier (Loc, Chars (D)), Actuals_List); + Next_Discriminant (D); + end loop; + + Return_Node := + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (Enclosing_Func_Id, Loc), + Parameter_Associations => + Actuals_List)); + + else + Return_Node := + Make_Return_Statement (Loc, + Expression => + New_Reference_To (Standard_False, Loc)); + end if; + + Set_Statements (Case_Alt_Node, New_List (Return_Node)); + Append (Case_Alt_Node, Alt_List); + end if; + + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); + Choice_List := New_List (New_Node (N_Others_Choice, Loc)); + Set_Discrete_Choices (Case_Alt_Node, Choice_List); + + Return_Node := + Make_Return_Statement (Loc, + Expression => + New_Reference_To (Standard_True, Loc)); + + Set_Statements (Case_Alt_Node, New_List (Return_Node)); + Append (Case_Alt_Node, Alt_List); + + Set_Alternatives (Case_Node, Alt_List); + return Case_Node; + end Build_Case_Statement; + + --------------------------- + -- Build_Dcheck_Function -- + --------------------------- + + function Build_Dcheck_Function + (Case_Id : Entity_Id; + Variant : Node_Id) + return Entity_Id + is + Body_Node : Node_Id; + Func_Id : Entity_Id; + Parameter_List : List_Id; + Spec_Node : Node_Id; + + begin + Body_Node := New_Node (N_Subprogram_Body, Loc); + Sequence := Sequence + 1; + + Func_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); + + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + + Parameter_List := Build_Discriminant_Formals (Rec_Id, False); + + Set_Parameter_Specifications (Spec_Node, Parameter_List); + Set_Subtype_Mark (Spec_Node, + New_Reference_To (Standard_Boolean, Loc)); + Set_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Build_Case_Statement (Case_Id, Variant)))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Inlined (Func_Id, True); + Set_Is_Pure (Func_Id, True); + Set_Is_Public (Func_Id, Is_Public (Rec_Id)); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Append_Freeze_Action (Rec_Id, Body_Node); + Set_Dcheck_Function (Variant, Func_Id); + return Func_Id; + end Build_Dcheck_Function; + + ---------------------------- + -- Build_Dcheck_Functions -- + ---------------------------- + + procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is + Component_List_Node : Node_Id; + Decl : Entity_Id; + Discr_Name : Entity_Id; + Func_Id : Entity_Id; + Variant : Node_Id; + Saved_Enclosing_Func_Id : Entity_Id; + + begin + -- Build the discriminant checking function for each variant, label + -- all components of that variant with the function's name. + + Discr_Name := Entity (Name (Variant_Part_Node)); + Variant := First_Non_Pragma (Variants (Variant_Part_Node)); + + while Present (Variant) loop + Func_Id := Build_Dcheck_Function (Discr_Name, Variant); + Component_List_Node := Component_List (Variant); + + if not Null_Present (Component_List_Node) then + Decl := + First_Non_Pragma (Component_Items (Component_List_Node)); + + while Present (Decl) loop + Set_Discriminant_Checking_Func + (Defining_Identifier (Decl), Func_Id); + + Next_Non_Pragma (Decl); + end loop; + + if Present (Variant_Part (Component_List_Node)) then + Saved_Enclosing_Func_Id := Enclosing_Func_Id; + Enclosing_Func_Id := Func_Id; + Build_Dcheck_Functions (Variant_Part (Component_List_Node)); + Enclosing_Func_Id := Saved_Enclosing_Func_Id; + end if; + end if; + + Next_Non_Pragma (Variant); + end loop; + end Build_Dcheck_Functions; + + -- Start of processing for Build_Discr_Checking_Funcs + + begin + -- Only build if not done already + + if not Discr_Check_Funcs_Built (N) then + Type_Def := Type_Definition (N); + + if Nkind (Type_Def) = N_Record_Definition then + if No (Component_List (Type_Def)) then -- null record. + return; + else + V := Variant_Part (Component_List (Type_Def)); + end if; + + else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); + if No (Component_List (Record_Extension_Part (Type_Def))) then + return; + else + V := Variant_Part + (Component_List (Record_Extension_Part (Type_Def))); + end if; + end if; + + Rec_Id := Defining_Identifier (N); + + if Present (V) and then not Is_Unchecked_Union (Rec_Id) then + Loc := Sloc (N); + Enclosing_Func_Id := Empty; + Build_Dcheck_Functions (V); + end if; + + Set_Discr_Check_Funcs_Built (N); + end if; + end Build_Discr_Checking_Funcs; + + -------------------------------- + -- Build_Discriminant_Formals -- + -------------------------------- + + function Build_Discriminant_Formals + (Rec_Id : Entity_Id; + Use_Dl : Boolean) + return List_Id + is + D : Entity_Id; + Formal : Entity_Id; + Loc : Source_Ptr := Sloc (Rec_Id); + Param_Spec_Node : Node_Id; + Parameter_List : List_Id := New_List; + + begin + if Has_Discriminants (Rec_Id) then + D := First_Discriminant (Rec_Id); + + while Present (D) loop + Loc := Sloc (D); + + if Use_Dl then + Formal := Discriminal (D); + else + Formal := Make_Defining_Identifier (Loc, Chars (D)); + end if; + + Param_Spec_Node := + Make_Parameter_Specification (Loc, + Defining_Identifier => Formal, + Parameter_Type => + New_Reference_To (Etype (D), Loc)); + Append (Param_Spec_Node, Parameter_List); + Next_Discriminant (D); + end loop; + end if; + + return Parameter_List; + end Build_Discriminant_Formals; + + ------------------------------- + -- Build_Initialization_Call -- + ------------------------------- + + -- References to a discriminant inside the record type declaration + -- can appear either in the subtype_indication to constrain a + -- record or an array, or as part of a larger expression given for + -- the initial value of a component. In both of these cases N appears + -- in the record initialization procedure and needs to be replaced by + -- the formal parameter of the initialization procedure which + -- corresponds to that discriminant. + + -- In the example below, references to discriminants D1 and D2 in proc_1 + -- are replaced by references to formals with the same name + -- (discriminals) + + -- A similar replacement is done for calls to any record + -- initialization procedure for any components that are themselves + -- of a record type. + + -- type R (D1, D2 : Integer) is record + -- X : Integer := F * D1; + -- Y : Integer := F * D2; + -- end record; + + -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is + -- begin + -- Out_2.D1 := D1; + -- Out_2.D2 := D2; + -- Out_2.X := F * D1; + -- Out_2.Y := F * D2; + -- end; + + function Build_Initialization_Call + (Loc : Source_Ptr; + Id_Ref : Node_Id; + Typ : Entity_Id; + In_Init_Proc : Boolean := False; + Enclos_Type : Entity_Id := Empty; + Discr_Map : Elist_Id := New_Elmt_List) + return List_Id + is + First_Arg : Node_Id; + Args : List_Id; + Decls : List_Id; + Decl : Node_Id; + Discr : Entity_Id; + Arg : Node_Id; + Proc : constant Entity_Id := Base_Init_Proc (Typ); + Init_Type : constant Entity_Id := Etype (First_Formal (Proc)); + Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type); + Res : List_Id := New_List; + Full_Type : Entity_Id := Typ; + Controller_Typ : Entity_Id; + + begin + -- Nothing to do if the Init_Proc is null, unless Initialize_Sclalars + -- is active (in which case we make the call anyway, since in the + -- actual compiled client it may be non null). + + if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then + return Empty_List; + end if; + + -- Go to full view if private type + + if Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Full_Type := Full_View (Typ); + end if; + + -- If Typ is derived, the procedure is the initialization procedure for + -- the root type. Wrap the argument in an conversion to make it type + -- honest. Actually it isn't quite type honest, because there can be + -- conflicts of views in the private type case. That is why we set + -- Conversion_OK in the conversion node. + + if (Is_Record_Type (Typ) + or else Is_Array_Type (Typ) + or else Is_Private_Type (Typ)) + and then Init_Type /= Base_Type (Typ) + then + First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); + Set_Etype (First_Arg, Init_Type); + + else + First_Arg := Id_Ref; + end if; + + Args := New_List (Convert_Concurrent (First_Arg, Typ)); + + -- In the tasks case, add _Master as the value of the _Master parameter + -- and _Chain as the value of the _Chain parameter. At the outer level, + -- these will be variables holding the corresponding values obtained + -- from GNARL. At inner levels, they will be the parameters passed down + -- through the outer routines. + + if Has_Task (Full_Type) then + if Restrictions (No_Task_Hierarchy) then + + -- See comments in System.Tasking.Initialization.Init_RTS + -- for the value 3. + + Append_To (Args, Make_Integer_Literal (Loc, 3)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + + Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type); + Decl := Last (Decls); + + Append_To (Args, + New_Occurrence_Of (Defining_Identifier (Decl), Loc)); + Append_List (Decls, Res); + + else + Decls := No_List; + Decl := Empty; + end if; + + -- Add discriminant values if discriminants are present + + if Has_Discriminants (Full_Init_Type) then + Discr := First_Discriminant (Full_Init_Type); + + while Present (Discr) loop + + -- If this is a discriminated concurrent type, the init_proc + -- for the corresponding record is being called. Use that + -- type directly to find the discriminant value, to handle + -- properly intervening renamed discriminants. + + declare + T : Entity_Id := Full_Type; + + begin + if Is_Protected_Type (T) then + T := Corresponding_Record_Type (T); + end if; + + Arg := + Get_Discriminant_Value ( + Discr, + T, + Discriminant_Constraint (Full_Type)); + end; + + if In_Init_Proc then + + -- Replace any possible references to the discriminant in the + -- call to the record initialization procedure with references + -- to the appropriate formal parameter. + + if Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); + + -- Case of access discriminants. We replace the reference + -- to the type by a reference to the actual object + + elsif Nkind (Arg) = N_Attribute_Reference + and then Is_Access_Type (Etype (Arg)) + and then Is_Entity_Name (Prefix (Arg)) + and then Is_Type (Entity (Prefix (Arg))) + then + Arg := + Make_Attribute_Reference (Loc, + Prefix => New_Copy (Prefix (Id_Ref)), + Attribute_Name => Name_Unrestricted_Access); + + -- Otherwise make a copy of the default expression. Note + -- that we use the current Sloc for this, because we do not + -- want the call to appear to be at the declaration point. + -- Within the expression, replace discriminants with their + -- discriminals. + + else + Arg := + New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); + end if; + + else + if Is_Constrained (Full_Type) then + Arg := Duplicate_Subexpr (Arg); + else + -- The constraints come from the discriminant default + -- exps, they must be reevaluated, so we use New_Copy_Tree + -- but we ensure the proper Sloc (for any embedded calls). + + Arg := New_Copy_Tree (Arg, New_Sloc => Loc); + end if; + end if; + + Append_To (Args, Arg); + + Next_Discriminant (Discr); + end loop; + end if; + + -- If this is a call to initialize the parent component of a derived + -- tagged type, indicate that the tag should not be set in the parent. + + if Is_Tagged_Type (Full_Init_Type) + and then not Is_CPP_Class (Full_Init_Type) + and then Nkind (Id_Ref) = N_Selected_Component + and then Chars (Selector_Name (Id_Ref)) = Name_uParent + then + Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); + end if; + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc, Loc), + Parameter_Associations => Args)); + + if Controlled_Type (Typ) + and then Nkind (Id_Ref) = N_Selected_Component + then + if Chars (Selector_Name (Id_Ref)) /= Name_uParent then + Append_List_To (Res, + Make_Init_Call ( + Ref => New_Copy_Tree (First_Arg), + Typ => Typ, + Flist_Ref => + Find_Final_List (Typ, New_Copy_Tree (First_Arg)), + With_Attach => Make_Integer_Literal (Loc, 1))); + + -- If the enclosing type is an extension with new controlled + -- components, it has his own record controller. If the parent + -- also had a record controller, attach it to the new one. + -- Build_Init_Statements relies on the fact that in this specific + -- case the last statement of the result is the attach call to + -- the controller. If this is changed, it must be synchronized. + + elsif Present (Enclos_Type) + and then Has_New_Controlled_Component (Enclos_Type) + and then Has_Controlled_Component (Typ) + then + if Is_Return_By_Reference_Type (Typ) then + Controller_Typ := RTE (RE_Limited_Record_Controller); + else + Controller_Typ := RTE (RE_Record_Controller); + end if; + + Append_List_To (Res, + Make_Init_Call ( + Ref => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (First_Arg), + Selector_Name => Make_Identifier (Loc, Name_uController)), + Typ => Controller_Typ, + Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + end if; + + -- Discard dynamic string allocated for name after call to init_proc, + -- to avoid storage leaks. This is done for composite types because + -- the allocated name is used as prefix for the id constructed at run- + -- time, and this allocated name is not released when the task itself + -- is freed. + + if Has_Task (Full_Type) + and then not Is_Task_Type (Full_Type) + then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Free_Task_Image), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Defining_Identifier (Decl), Loc)))); + end if; + + return Res; + end Build_Initialization_Call; + + --------------------------- + -- Build_Master_Renaming -- + --------------------------- + + procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + M_Id : Entity_Id; + Decl : Node_Id; + + begin + -- Nothing to do if there is no task hierarchy. + + if Restrictions (No_Task_Hierarchy) then + return; + end if; + + M_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (T), 'M')); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => M_Id, + Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), + Name => Make_Identifier (Loc, Name_uMaster)); + Insert_Before (N, Decl); + Analyze (Decl); + + Set_Master_Id (T, M_Id); + + end Build_Master_Renaming; + + ---------------------------- + -- Build_Record_Init_Proc -- + ---------------------------- + + procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is + Loc : Source_Ptr := Sloc (N); + Proc_Id : Entity_Id; + Rec_Type : Entity_Id; + Discr_Map : Elist_Id := New_Elmt_List; + Set_Tag : Entity_Id := Empty; + + function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; + -- Build a assignment statement node which assigns to record + -- component its default expression if defined. The left hand side + -- of the assignment is marked Assignment_OK so that initialization + -- of limited private records works correctly, Return also the + -- adjustment call for controlled objects + + procedure Build_Discriminant_Assignments (Statement_List : List_Id); + -- If the record has discriminants, adds assignment statements to + -- statement list to initialize the discriminant values from the + -- arguments of the initialization procedure. + + function Build_Init_Statements (Comp_List : Node_Id) return List_Id; + -- Build a list representing a sequence of statements which initialize + -- components of the given component list. This may involve building + -- case statements for the variant parts. + + function Build_Init_Call_Thru + (Parameters : List_Id) + return List_Id; + -- Given a non-tagged type-derivation that declares discriminants, + -- such as + -- + -- type R (R1, R2 : Integer) is record ... end record; + -- + -- type D (D1 : Integer) is new R (1, D1); + -- + -- we make the _init_proc of D be + -- + -- procedure _init_proc(X : D; D1 : Integer) is + -- begin + -- _init_proc( R(X), 1, D1); + -- end _init_proc; + -- + -- This function builds the call statement in this _init_proc. + + procedure Build_Init_Procedure; + -- Build the tree corresponding to the procedure specification and body + -- of the initialization procedure (by calling all the preceding + -- auxiliary routines), and install it as the _init TSS. + + procedure Build_Record_Checks + (S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id); + -- Add range checks to components of disciminated records. S is a + -- subtype indication of a record component. Related_Nod is passed + -- for compatibility with Process_Range_Expr_In_Decl. Check_List is + -- a list to which the check actions are appended. + + function Component_Needs_Simple_Initialization + (T : Entity_Id) + return Boolean; + -- Determines if a component needs simple initialization, given its + -- type T. This is identical to Needs_Simple_Initialization, except + -- that the types Tag and Vtable_Ptr, which are access types which + -- would normally require simple initialization to null, do not + -- require initialization as components, since they are explicitly + -- initialized by other means. + + procedure Constrain_Array + (SI : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id); + -- Called from Build_Record_Checks. + -- Apply a list of index constraints to an unconstrained array type. + -- The first parameter is the entity for the resulting subtype. + -- Related_Nod is passed for compatibility with Process_Range_Expr_In_ + -- Decl. Check_List is a list to which the check actions are appended. + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id); + -- Called from Build_Record_Checks. + -- Process an index constraint in a constrained array declaration. + -- The constraint can be a subtype name, or a range with or without + -- an explicit subtype mark. The index is the corresponding index of the + -- unconstrained array. S is the range expression. Check_List is a list + -- to which the check actions are appended. + + function Parent_Subtype_Renaming_Discrims return Boolean; + -- Returns True for base types N that rename discriminants, else False + + function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; + -- Determines whether a record initialization procedure needs to be + -- generated for the given record type. + + ---------------------- + -- Build_Assignment -- + ---------------------- + + function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is + Exp : Node_Id := N; + Lhs : Node_Id; + Typ : constant Entity_Id := Underlying_Type (Etype (Id)); + Kind : Node_Kind := Nkind (N); + Res : List_Id; + + begin + Loc := Sloc (N); + Lhs := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)); + Set_Assignment_OK (Lhs); + + -- Case of an access attribute applied to the current + -- instance. Replace the reference to the type by a + -- reference to the actual object. (Note that this + -- handles the case of the top level of the expression + -- being given by such an attribute, but doesn't cover + -- uses nested within an initial value expression. + -- Nested uses are unlikely to occur in practice, + -- but theoretically possible. It's not clear how + -- to handle them without fully traversing the + -- expression. ???) + + if Kind = N_Attribute_Reference + and then (Attribute_Name (N) = Name_Unchecked_Access + or else + Attribute_Name (N) = Name_Unrestricted_Access) + and then Is_Entity_Name (Prefix (N)) + and then Is_Type (Entity (Prefix (N))) + and then Entity (Prefix (N)) = Rec_Type + then + Exp := + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Unrestricted_Access); + end if; + + -- For a derived type the default value is copied from the component + -- declaration of the parent. In the analysis of the init_proc for + -- the parent the default value may have been expanded into a local + -- variable, which is of course not usable here. We must copy the + -- original expression and reanalyze. + + if Nkind (Exp) = N_Identifier + and then not Comes_From_Source (Exp) + and then Analyzed (Exp) + and then not In_Open_Scopes (Scope (Entity (Exp))) + and then Nkind (Original_Node (Exp)) = N_Aggregate + then + Exp := New_Copy_Tree (Original_Node (Exp)); + end if; + + Res := New_List ( + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Exp)); + + Set_No_Ctrl_Actions (First (Res)); + + -- Adjust the tag if tagged (because of possible view conversions). + -- Suppress the tag adjustment when Java_VM because JVM tags are + -- represented implicitly in objects. + + if Is_Tagged_Type (Typ) and then not Java_VM then + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Access_Disp_Table (Typ), Loc)))); + end if; + + -- Adjust the component if controlled except if it is an + -- aggregate that will be expanded inline + + if Kind = N_Qualified_Expression then + Kind := Nkind (Parent (N)); + end if; + + if Controlled_Type (Typ) + and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) + then + Append_List_To (Res, + Make_Adjust_Call ( + Ref => New_Copy_Tree (Lhs), + Typ => Etype (Id), + Flist_Ref => + Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + + return Res; + end Build_Assignment; + + ------------------------------------ + -- Build_Discriminant_Assignments -- + ------------------------------------ + + procedure Build_Discriminant_Assignments (Statement_List : List_Id) is + D : Entity_Id; + Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); + + begin + if Has_Discriminants (Rec_Type) + and then not Is_Unchecked_Union (Rec_Type) + then + D := First_Discriminant (Rec_Type); + + while Present (D) loop + -- Don't generate the assignment for discriminants in derived + -- tagged types if the discriminant is a renaming of some + -- ancestor discriminant. This initialization will be done + -- when initializing the _parent field of the derived record. + + if Is_Tagged and then + Present (Corresponding_Discriminant (D)) + then + null; + + else + Loc := Sloc (D); + Append_List_To (Statement_List, + Build_Assignment (D, + New_Reference_To (Discriminal (D), Loc))); + end if; + + Next_Discriminant (D); + end loop; + end if; + end Build_Discriminant_Assignments; + + -------------------------- + -- Build_Init_Call_Thru -- + -------------------------- + + function Build_Init_Call_Thru + (Parameters : List_Id) + return List_Id + is + Parent_Proc : constant Entity_Id := + Base_Init_Proc (Etype (Rec_Type)); + + Parent_Type : constant Entity_Id := + Etype (First_Formal (Parent_Proc)); + + Uparent_Type : constant Entity_Id := + Underlying_Type (Parent_Type); + + First_Discr_Param : Node_Id; + + Parent_Discr : Entity_Id; + First_Arg : Node_Id; + Args : List_Id; + Arg : Node_Id; + Res : List_Id; + + begin + -- First argument (_Init) is the object to be initialized. + -- ??? not sure where to get a reasonable Loc for First_Arg + + First_Arg := + OK_Convert_To (Parent_Type, + New_Reference_To (Defining_Identifier (First (Parameters)), Loc)); + + Set_Etype (First_Arg, Parent_Type); + + Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); + + -- In the tasks case, + -- add _Master as the value of the _Master parameter + -- add _Chain as the value of the _Chain parameter. + -- add _Task_Id as the value of the _Task_Id parameter. + -- At the outer level, these will be variables holding the + -- corresponding values obtained from GNARL or the expander. + -- + -- At inner levels, they will be the parameters passed down through + -- the outer routines. + + First_Discr_Param := Next (First (Parameters)); + + if Has_Task (Rec_Type) then + if Restrictions (No_Task_Hierarchy) then + + -- See comments in System.Tasking.Initialization.Init_RTS + -- for the value 3. + + Append_To (Args, Make_Integer_Literal (Loc, 3)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + Append_To (Args, Make_Identifier (Loc, Name_uTask_Id)); + First_Discr_Param := Next (Next (Next (First_Discr_Param))); + end if; + + -- Append discriminant values + + if Has_Discriminants (Uparent_Type) then + pragma Assert (not Is_Tagged_Type (Uparent_Type)); + + Parent_Discr := First_Discriminant (Uparent_Type); + while Present (Parent_Discr) loop + + -- Get the initial value for this discriminant + -- ?????? needs to be cleaned up to use parent_Discr_Constr + -- directly. + + declare + Discr_Value : Elmt_Id := + First_Elmt + (Girder_Constraint (Rec_Type)); + + Discr : Entity_Id := + First_Girder_Discriminant (Uparent_Type); + begin + while Original_Record_Component (Parent_Discr) /= Discr loop + Next_Girder_Discriminant (Discr); + Next_Elmt (Discr_Value); + end loop; + + Arg := Node (Discr_Value); + end; + + -- Append it to the list + + if Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Append_To (Args, + New_Reference_To (Discriminal (Entity (Arg)), Loc)); + + -- Case of access discriminants. We replace the reference + -- to the type by a reference to the actual object + +-- ??? +-- elsif Nkind (Arg) = N_Attribute_Reference +-- and then Is_Entity_Name (Prefix (Arg)) +-- and then Is_Type (Entity (Prefix (Arg))) +-- then +-- Append_To (Args, +-- Make_Attribute_Reference (Loc, +-- Prefix => New_Copy (Prefix (Id_Ref)), +-- Attribute_Name => Name_Unrestricted_Access)); + + else + Append_To (Args, New_Copy (Arg)); + end if; + + Next_Discriminant (Parent_Discr); + end loop; + end if; + + Res := + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Parent_Proc, Loc), + Parameter_Associations => Args)); + + return Res; + end Build_Init_Call_Thru; + + -------------------------- + -- Build_Init_Procedure -- + -------------------------- + + procedure Build_Init_Procedure is + Body_Node : Node_Id; + Handled_Stmt_Node : Node_Id; + Parameters : List_Id; + Proc_Spec_Node : Node_Id; + Body_Stmts : List_Id; + Record_Extension_Node : Node_Id; + Init_Tag : Node_Id; + + begin + Body_Stmts := New_List; + Body_Node := New_Node (N_Subprogram_Body, Loc); + + Proc_Id := Make_Defining_Identifier (Loc, Name_uInit_Proc); + Set_Ekind (Proc_Id, E_Procedure); + + Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); + Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); + + Parameters := Init_Formals (Rec_Type); + Append_List_To (Parameters, + Build_Discriminant_Formals (Rec_Type, True)); + + -- For tagged types, we add a flag to indicate whether the routine + -- is called to initialize a parent component in the init_proc of + -- a type extension. If the flag is false, we do not set the tag + -- because it has been set already in the extension. + + if Is_Tagged_Type (Rec_Type) + and then not Is_CPP_Class (Rec_Type) + then + Set_Tag := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => Set_Tag, + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc))); + end if; + + Set_Parameter_Specifications (Proc_Spec_Node, Parameters); + Set_Specification (Body_Node, Proc_Spec_Node); + Set_Declarations (Body_Node, New_List); + + if Parent_Subtype_Renaming_Discrims then + + -- N is a Derived_Type_Definition that renames the parameters + -- of the ancestor type. We init it by expanding our discrims + -- and call the ancestor _init_proc with a type-converted object + + Append_List_To (Body_Stmts, + Build_Init_Call_Thru (Parameters)); + + elsif Nkind (Type_Definition (N)) = N_Record_Definition then + Build_Discriminant_Assignments (Body_Stmts); + + if not Null_Present (Type_Definition (N)) then + Append_List_To (Body_Stmts, + Build_Init_Statements ( + Component_List (Type_Definition (N)))); + end if; + + else + -- N is a Derived_Type_Definition with a possible non-empty + -- extension. The initialization of a type extension consists + -- in the initialization of the components in the extension. + + Build_Discriminant_Assignments (Body_Stmts); + + Record_Extension_Node := + Record_Extension_Part (Type_Definition (N)); + + if not Null_Present (Record_Extension_Node) then + declare + Stmts : List_Id := + Build_Init_Statements ( + Component_List (Record_Extension_Node)); + + begin + -- The parent field must be initialized first because + -- the offset of the new discriminants may depend on it + + Prepend_To (Body_Stmts, Remove_Head (Stmts)); + Append_List_To (Body_Stmts, Stmts); + end; + end if; + end if; + + -- Add here the assignment to instantiate the Tag + + -- The assignement corresponds to the code: + + -- _Init._Tag := Typ'Tag; + + -- Suppress the tag assignment when Java_VM because JVM tags are + -- represented implicitly in objects. + + if Is_Tagged_Type (Rec_Type) + and then not Is_CPP_Class (Rec_Type) + and then not Java_VM + then + Init_Tag := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To (Tag_Component (Rec_Type), Loc)), + + Expression => + New_Reference_To (Access_Disp_Table (Rec_Type), Loc)); + + -- The tag must be inserted before the assignments to other + -- components, because the initial value of the component may + -- depend ot the tag (eg. through a dispatching operation on + -- an access to the current type). The tag assignment is not done + -- when initializing the parent component of a type extension, + -- because in that case the tag is set in the extension. + -- Extensions of imported C++ classes add a final complication, + -- because we cannot inhibit tag setting in the constructor for + -- the parent. In that case we insert the tag initialization + -- after the calls to initialize the parent. + + Init_Tag := + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => New_List (Init_Tag)); + + if not Is_CPP_Class (Etype (Rec_Type)) then + Prepend_To (Body_Stmts, Init_Tag); + + else + declare + Nod : Node_Id := First (Body_Stmts); + + begin + -- We assume the first init_proc call is for the parent + + while Present (Next (Nod)) + and then (Nkind (Nod) /= N_Procedure_Call_Statement + or else Chars (Name (Nod)) /= Name_uInit_Proc) + loop + Nod := Next (Nod); + end loop; + + Insert_After (Nod, Init_Tag); + end; + end if; + end if; + + Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); + Set_Statements (Handled_Stmt_Node, Body_Stmts); + Set_Exception_Handlers (Handled_Stmt_Node, No_List); + Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Associate Init_Proc with type, and determine if the procedure + -- is null (happens because of the Initialize_Scalars pragma case, + -- where we have to generate a null procedure in case it is called + -- by a client with Initialize_Scalars set). Such procedures have + -- to be generated, but do not have to be called, so we mark them + -- as null to suppress the call. + + Set_Init_Proc (Rec_Type, Proc_Id); + + if List_Length (Body_Stmts) = 1 + and then Nkind (First (Body_Stmts)) = N_Null_Statement + then + Set_Is_Null_Init_Proc (Proc_Id); + end if; + end Build_Init_Procedure; + + --------------------------- + -- Build_Init_Statements -- + --------------------------- + + function Build_Init_Statements (Comp_List : Node_Id) return List_Id is + Alt_List : List_Id; + Statement_List : List_Id; + Stmts : List_Id; + Check_List : List_Id := New_List; + + Per_Object_Constraint_Components : Boolean; + + Decl : Node_Id; + Variant : Node_Id; + + Id : Entity_Id; + Typ : Entity_Id; + + begin + if Null_Present (Comp_List) then + return New_List (Make_Null_Statement (Loc)); + end if; + + Statement_List := New_List; + + -- Loop through components, skipping pragmas, in 2 steps. The first + -- step deals with regular components. The second step deals with + -- components have per object constraints, and no explicit initia- + -- lization. + + Per_Object_Constraint_Components := False; + + -- First step : regular components. + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Decl) loop + Loc := Sloc (Decl); + Build_Record_Checks + (Subtype_Indication (Decl), + Decl, + Check_List); + + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Per_Object_Constraint (Id) + and then No (Expression (Decl)) + then + -- Skip processing for now and ask for a second pass + + Per_Object_Constraint_Components := True; + else + if Present (Expression (Decl)) then + Stmts := Build_Assignment (Id, Expression (Decl)); + + elsif Has_Non_Null_Base_Init_Proc (Typ) then + Stmts := + Build_Initialization_Call (Loc, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ, True, Rec_Type, Discr_Map => Discr_Map); + + elsif Component_Needs_Simple_Initialization (Typ) then + Stmts := + Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc)); + + else + Stmts := No_List; + end if; + + if Present (Check_List) then + Append_List_To (Statement_List, Check_List); + end if; + + if Present (Stmts) then + + -- Add the initialization of the record controller + -- before the _Parent field is attached to it when + -- the attachment can occur. It does not work to + -- simply initialize the controller first: it must be + -- initialized after the parent if the parent holds + -- discriminants that can be used to compute the + -- offset of the controller. This code relies on + -- the last statement of the initialization call + -- being the attachement of the parent. see + -- Build_Initialization_Call. + + if Chars (Id) = Name_uController + and then Rec_Type /= Etype (Rec_Type) + and then Has_Controlled_Component (Etype (Rec_Type)) + and then Has_New_Controlled_Component (Rec_Type) + then + Insert_List_Before (Last (Statement_List), Stmts); + else + Append_List_To (Statement_List, Stmts); + end if; + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + + if Per_Object_Constraint_Components then + + -- Second pass: components with per-object constraints + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + + while Present (Decl) loop + Loc := Sloc (Decl); + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Per_Object_Constraint (Id) + and then No (Expression (Decl)) + then + if Has_Non_Null_Base_Init_Proc (Typ) then + Append_List_To (Statement_List, + Build_Initialization_Call (Loc, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ, True, Rec_Type, Discr_Map => Discr_Map)); + + elsif Component_Needs_Simple_Initialization (Typ) then + Append_List_To (Statement_List, + Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc))); + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + end if; + + -- Process the variant part + + if Present (Variant_Part (Comp_List)) then + Alt_List := New_List; + Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + + while Present (Variant) loop + Loc := Sloc (Variant); + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Variant)), + Statements => + Build_Init_Statements (Component_List (Variant)))); + + Next_Non_Pragma (Variant); + end loop; + + -- The expression of the case statement which is a reference + -- to one of the discriminants is replaced by the appropriate + -- formal parameter of the initialization procedure. + + Append_To (Statement_List, + Make_Case_Statement (Loc, + Expression => + New_Reference_To (Discriminal ( + Entity (Name (Variant_Part (Comp_List)))), Loc), + Alternatives => Alt_List)); + end if; + + -- For a task record type, add the task create call and calls + -- to bind any interrupt (signal) entries. + + if Is_Task_Record_Type (Rec_Type) then + Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); + + declare + Task_Type : constant Entity_Id := + Corresponding_Concurrent_Type (Rec_Type); + Task_Decl : constant Node_Id := Parent (Task_Type); + Task_Def : constant Node_Id := Task_Definition (Task_Decl); + Vis_Decl : Node_Id; + Ent : Entity_Id; + + begin + if Present (Task_Def) then + Vis_Decl := First (Visible_Declarations (Task_Def)); + while Present (Vis_Decl) loop + Loc := Sloc (Vis_Decl); + + if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then + if Get_Attribute_Id (Chars (Vis_Decl)) = + Attribute_Address + then + Ent := Entity (Name (Vis_Decl)); + + if Ekind (Ent) = E_Entry then + Append_To (Statement_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Bind_Interrupt_To_Entry), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)), + Entry_Index_Expression ( + Loc, Ent, Empty, Task_Type), + Expression (Vis_Decl)))); + end if; + end if; + end if; + + Next (Vis_Decl); + end loop; + end if; + end; + end if; + + -- For a protected type, add statements generated by + -- Make_Initialize_Protection. + + if Is_Protected_Record_Type (Rec_Type) then + Append_List_To (Statement_List, + Make_Initialize_Protection (Rec_Type)); + end if; + + -- If no initializations when generated for component declarations + -- corresponding to this Statement_List, append a null statement + -- to the Statement_List to make it a valid Ada tree. + + if Is_Empty_List (Statement_List) then + Append (New_Node (N_Null_Statement, Loc), Statement_List); + end if; + + return Statement_List; + end Build_Init_Statements; + + ------------------------- + -- Build_Record_Checks -- + ------------------------- + + procedure Build_Record_Checks + (S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id) + is + P : Node_Id; + Subtype_Mark_Id : Entity_Id; + begin + + if Nkind (S) = N_Subtype_Indication then + Find_Type (Subtype_Mark (S)); + P := Parent (S); + Subtype_Mark_Id := Entity (Subtype_Mark (S)); + + -- Remaining processing depends on type + + case Ekind (Subtype_Mark_Id) is + + when Array_Kind => + Constrain_Array (S, Related_Nod, Check_List); + + when others => + null; + end case; + end if; + + end Build_Record_Checks; + + ------------------------------------------- + -- Component_Needs_Simple_Initialization -- + ------------------------------------------- + + function Component_Needs_Simple_Initialization + (T : Entity_Id) + return Boolean + is + begin + return + Needs_Simple_Initialization (T) + and then not Is_RTE (T, RE_Tag) + and then not Is_RTE (T, RE_Vtable_Ptr); + end Component_Needs_Simple_Initialization; + + --------------------- + -- Constrain_Array -- + --------------------- + + procedure Constrain_Array + (SI : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id) + is + C : constant Node_Id := Constraint (SI); + Number_Of_Constraints : Nat := 0; + Index : Node_Id; + S, T : Entity_Id; + + begin + T := Entity (Subtype_Mark (SI)); + + if Ekind (T) in Access_Kind then + T := Designated_Type (T); + end if; + + S := First (Constraints (C)); + + while Present (S) loop + Number_Of_Constraints := Number_Of_Constraints + 1; + Next (S); + end loop; + + -- In either case, the index constraint must provide a discrete + -- range for each index of the array type and the type of each + -- discrete range must be the same as that of the corresponding + -- index. (RM 3.6.1) + + S := First (Constraints (C)); + Index := First_Index (T); + Analyze (Index); + + -- Apply constraints to each index type + + for J in 1 .. Number_Of_Constraints loop + Constrain_Index (Index, S, Related_Nod, Check_List); + Next (Index); + Next (S); + end loop; + + end Constrain_Array; + + --------------------- + -- Constrain_Index -- + --------------------- + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id) + is + T : constant Entity_Id := Etype (Index); + + begin + if Nkind (S) = N_Range then + Process_Range_Expr_In_Decl (S, T, Related_Nod, Check_List); + end if; + end Constrain_Index; + + -------------------------------------- + -- Parent_Subtype_Renaming_Discrims -- + -------------------------------------- + + function Parent_Subtype_Renaming_Discrims return Boolean is + De : Entity_Id; + Dp : Entity_Id; + + begin + if Base_Type (Pe) /= Pe then + return False; + end if; + + if Etype (Pe) = Pe + or else not Has_Discriminants (Pe) + or else Is_Constrained (Pe) + or else Is_Tagged_Type (Pe) + then + return False; + end if; + + -- If there are no explicit girder discriminants we have inherited + -- the root type discriminants so far, so no renamings occurred. + + if First_Discriminant (Pe) = First_Girder_Discriminant (Pe) then + return False; + end if; + + -- Check if we have done some trivial renaming of the parent + -- discriminants, i.e. someting like + -- + -- type DT (X1,X2: int) is new PT (X1,X2); + + De := First_Discriminant (Pe); + Dp := First_Discriminant (Etype (Pe)); + + while Present (De) loop + pragma Assert (Present (Dp)); + + if Corresponding_Discriminant (De) /= Dp then + return True; + end if; + + Next_Discriminant (De); + Next_Discriminant (Dp); + end loop; + + return Present (Dp); + end Parent_Subtype_Renaming_Discrims; + + ------------------------ + -- Requires_Init_Proc -- + ------------------------ + + function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is + Comp_Decl : Node_Id; + Id : Entity_Id; + Typ : Entity_Id; + + begin + -- Definitely do not need one if specifically suppressed + + if Suppress_Init_Proc (Rec_Id) then + return False; + end if; + + -- Otherwise we need to generate an initialization procedure if + -- Is_CPP_Class is False and at least one of the following applies: + + -- 1. Discriminants are present, since they need to be initialized + -- with the appropriate discriminant constraint expressions. + -- However, the discriminant of an unchecked union does not + -- count, since the discriminant is not present. + + -- 2. The type is a tagged type, since the implicit Tag component + -- needs to be initialized with a pointer to the dispatch table. + + -- 3. The type contains tasks + + -- 4. One or more components has an initial value + + -- 5. One or more components is for a type which itself requires + -- an initialization procedure. + + -- 6. One or more components is a type that requires simple + -- initialization (see Needs_Simple_Initialization), except + -- that types Tag and Vtable_Ptr are excluded, since fields + -- of these types are initialized by other means. + + -- 7. The type is the record type built for a task type (since at + -- the very least, Create_Task must be called) + + -- 8. The type is the record type built for a protected type (since + -- at least Initialize_Protection must be called) + + -- 9. The type is marked as a public entity. The reason we add this + -- case (even if none of the above apply) is to properly handle + -- Initialize_Scalars. If a package is compiled without an IS + -- pragma, and the client is compiled with an IS pragma, then + -- the client will think an initialization procedure is present + -- and call it, when in fact no such procedure is required, but + -- since the call is generated, there had better be a routine + -- at the other end of the call, even if it does nothing!) + + -- Note: the reason we exclude the CPP_Class case is ??? + + if Is_CPP_Class (Rec_Id) then + return False; + + elsif Is_Public (Rec_Id) then + return True; + + elsif (Has_Discriminants (Rec_Id) + and then not Is_Unchecked_Union (Rec_Id)) + or else Is_Tagged_Type (Rec_Id) + or else Is_Concurrent_Record_Type (Rec_Id) + or else Has_Task (Rec_Id) + then + return True; + end if; + + Id := First_Component (Rec_Id); + + while Present (Id) loop + Comp_Decl := Parent (Id); + Typ := Etype (Id); + + if Present (Expression (Comp_Decl)) + or else Has_Non_Null_Base_Init_Proc (Typ) + or else Component_Needs_Simple_Initialization (Typ) + then + return True; + end if; + + Next_Component (Id); + end loop; + + return False; + end Requires_Init_Proc; + + -- Start of processing for Build_Record_Init_Proc + + begin + Rec_Type := Defining_Identifier (N); + + -- This may be full declaration of a private type, in which case + -- the visible entity is a record, and the private entity has been + -- exchanged with it in the private part of the current package. + -- The initialization procedure is built for the record type, which + -- is retrievable from the private entity. + + if Is_Incomplete_Or_Private_Type (Rec_Type) then + Rec_Type := Underlying_Type (Rec_Type); + end if; + + -- If there are discriminants, build the discriminant map to replace + -- discriminants by their discriminals in complex bound expressions. + -- These only arise for the corresponding records of protected types. + + if Is_Concurrent_Record_Type (Rec_Type) + and then Has_Discriminants (Rec_Type) + then + declare + Disc : Entity_Id; + + begin + Disc := First_Discriminant (Rec_Type); + + while Present (Disc) loop + Append_Elmt (Disc, Discr_Map); + Append_Elmt (Discriminal (Disc), Discr_Map); + Next_Discriminant (Disc); + end loop; + end; + end if; + + -- Derived types that have no type extension can use the initialization + -- procedure of their parent and do not need a procedure of their own. + -- This is only correct if there are no representation clauses for the + -- type or its parent, and if the parent has in fact been frozen so + -- that its initialization procedure exists. + + if Is_Derived_Type (Rec_Type) + and then not Is_Tagged_Type (Rec_Type) + and then not Has_New_Non_Standard_Rep (Rec_Type) + and then not Parent_Subtype_Renaming_Discrims + and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) + then + Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); + + -- Otherwise if we need an initialization procedure, then build one, + -- mark it as public and inlinable and as having a completion. + + elsif Requires_Init_Proc (Rec_Type) then + Build_Init_Procedure; + Set_Is_Public (Proc_Id, Is_Public (Pe)); + + -- The initialization of protected records is not worth inlining. + -- In addition, when compiled for another unit for inlining purposes, + -- it may make reference to entities that have not been elaborated + -- yet. The initialization of controlled records contains a nested + -- clean-up procedure that makes it impractical to inline as well, + -- and leads to undefined symbols if inlined in a different unit. + + if not Is_Protected_Record_Type (Rec_Type) + and then not Controlled_Type (Rec_Type) + then + Set_Is_Inlined (Proc_Id); + end if; + + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + end if; + end Build_Record_Init_Proc; + + ------------------------------------ + -- Build_Variant_Record_Equality -- + ------------------------------------ + + -- Generates: + -- + -- function _Equality (X, Y : T) return Boolean is + -- begin + -- -- Compare discriminants + + -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then + -- return False; + -- end if; + + -- -- Compare components + + -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then + -- return False; + -- end if; + + -- -- Compare variant part + + -- case X.D1 is + -- when V1 => + -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then + -- return False; + -- end if; + -- ... + -- when Vn => + -- if False or else X.Cn /= Y.Cn then + -- return False; + -- end if; + -- end case; + -- return True; + -- end _Equality; + + procedure Build_Variant_Record_Equality (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + F : constant Entity_Id := Make_Defining_Identifier (Loc, + Name_uEquality); + X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X); + Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y); + Def : constant Node_Id := Parent (Typ); + Comps : constant Node_Id := Component_List (Type_Definition (Def)); + + Function_Body : Node_Id; + Stmts : List_Id := New_List; + + begin + if Is_Derived_Type (Typ) + and then not Has_New_Non_Standard_Rep (Typ) + then + declare + Parent_Eq : Entity_Id := TSS (Root_Type (Typ), Name_uEquality); + + begin + if Present (Parent_Eq) then + Copy_TSS (Parent_Eq, Typ); + return; + end if; + end; + end if; + + Function_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => F, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => X, + Parameter_Type => New_Reference_To (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Y, + Parameter_Type => New_Reference_To (Typ, Loc))), + + Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), + + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + -- For unchecked union case, raise program error. This will only + -- happen in the case of dynamic dispatching for a tagged type, + -- since in the static cases it is a compile time error. + + if Has_Unchecked_Union (Typ) then + Append_To (Stmts, + Make_Raise_Program_Error (Loc)); + + else + Append_To (Stmts, + Make_Eq_If (Typ, + Discriminant_Specifications (Def))); + Append_List_To (Stmts, + Make_Eq_Case (Typ, Comps)); + end if; + + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))); + + Set_TSS (Typ, F); + Set_Is_Pure (F); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (F); + end if; + end Build_Variant_Record_Equality; + + --------------------------- + -- Expand_Derived_Record -- + --------------------------- + + -- Add a field _parent at the beginning of the record extension. This is + -- used to implement inheritance. Here are some examples of expansion: + + -- 1. no discriminants + -- type T2 is new T1 with null record; + -- gives + -- type T2 is new T1 with record + -- _Parent : T1; + -- end record; + + -- 2. renamed discriminants + -- type T2 (B, C : Int) is new T1 (A => B) with record + -- _Parent : T1 (A => B); + -- D : Int; + -- end; + + -- 3. inherited discriminants + -- type T2 is new T1 with record -- discriminant A inherited + -- _Parent : T1 (A); + -- D : Int; + -- end; + + procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is + Indic : constant Node_Id := Subtype_Indication (Def); + Loc : constant Source_Ptr := Sloc (Def); + Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); + Par_Subtype : Entity_Id; + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Parent_N : Node_Id; + D : Entity_Id; + List_Constr : constant List_Id := New_List; + + begin + -- Expand_Tagged_Extension is called directly from the semantics, so + -- we must check to see whether expansion is active before proceeding + + if not Expander_Active then + return; + end if; + + -- This may be a derivation of an untagged private type whose full + -- view is tagged, in which case the Derived_Type_Definition has no + -- extension part. Build an empty one now. + + if No (Rec_Ext_Part) then + Rec_Ext_Part := + Make_Record_Definition (Loc, + End_Label => Empty, + Component_List => Empty, + Null_Present => True); + + Set_Record_Extension_Part (Def, Rec_Ext_Part); + Mark_Rewrite_Insertion (Rec_Ext_Part); + end if; + + Comp_List := Component_List (Rec_Ext_Part); + + Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + + -- If the derived type inherits its discriminants the type of the + -- _parent field must be constrained by the inherited discriminants + + if Has_Discriminants (T) + and then Nkind (Indic) /= N_Subtype_Indication + and then not Is_Constrained (Entity (Indic)) + then + D := First_Discriminant (T); + while (Present (D)) loop + Append_To (List_Constr, New_Occurrence_Of (D, Loc)); + Next_Discriminant (D); + end loop; + + Par_Subtype := + Process_Subtype ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Entity (Indic), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => List_Constr)), + Def); + + -- Otherwise the original subtype_indication is just what is needed + + else + Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); + end if; + + Set_Parent_Subtype (T, Par_Subtype); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Parent_N, + Subtype_Indication => New_Reference_To (Par_Subtype, Loc)); + + if Null_Present (Rec_Ext_Part) then + Set_Component_List (Rec_Ext_Part, + Make_Component_List (Loc, + Component_Items => New_List (Comp_Decl), + Variant_Part => Empty, + Null_Present => False)); + Set_Null_Present (Rec_Ext_Part, False); + + elsif Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; + + Analyze (Comp_Decl); + end Expand_Derived_Record; + + ------------------------------------ + -- Expand_N_Full_Type_Declaration -- + ------------------------------------ + + procedure Expand_N_Full_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + B_Id : Entity_Id := Base_Type (Def_Id); + Par_Id : Entity_Id; + FN : Node_Id; + + begin + if Is_Access_Type (Def_Id) then + + -- Anonymous access types are created for the components of the + -- record parameter for an entry declaration. No master is created + -- for such a type. + + if Has_Task (Designated_Type (Def_Id)) + and then Comes_From_Source (N) + then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Parent (Def_Id), Def_Id); + + -- Create a class-wide master because a Master_Id must be generated + -- for access-to-limited-class-wide types, whose root may be extended + -- with task components. + + elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) + and then Is_Limited_Type (Designated_Type (Def_Id)) + and then Tasking_Allowed + + -- Don't create a class-wide master for types whose convention is + -- Java since these types cannot embed Ada tasks anyway. Note that + -- the following test cannot catch the following case: + -- + -- package java.lang.Object is + -- type Typ is tagged limited private; + -- type Ref is access all Typ'Class; + -- private + -- type Typ is tagged limited ...; + -- pragma Convention (Typ, Java) + -- end; + -- + -- Because the convention appears after we have done the + -- processing for type Ref. + + and then Convention (Designated_Type (Def_Id)) /= Convention_Java + then + Build_Class_Wide_Master (Def_Id); + + elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then + Expand_Access_Protected_Subprogram_Type (N); + end if; + + elsif Has_Task (Def_Id) then + Expand_Previous_Access_Type (N, Def_Id); + end if; + + Par_Id := Etype (B_Id); + + -- The parent type is private then we need to inherit + -- any TSS operations from the full view. + + if Ekind (Par_Id) in Private_Kind + and then Present (Full_View (Par_Id)) + then + Par_Id := Base_Type (Full_View (Par_Id)); + end if; + + if Nkind (Type_Definition (Original_Node (N))) + = N_Derived_Type_Definition + and then not Is_Tagged_Type (Def_Id) + and then Present (Freeze_Node (Par_Id)) + and then Present (TSS_Elist (Freeze_Node (Par_Id))) + then + Ensure_Freeze_Node (B_Id); + FN := Freeze_Node (B_Id); + + if No (TSS_Elist (FN)) then + Set_TSS_Elist (FN, New_Elmt_List); + end if; + + declare + T_E : Elist_Id := TSS_Elist (FN); + Elmt : Elmt_Id; + + begin + Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); + + while Present (Elmt) loop + if Chars (Node (Elmt)) /= Name_uInit then + Append_Elmt (Node (Elmt), T_E); + end if; + + Next_Elmt (Elmt); + end loop; + + -- If the derived type itself is private with a full view, + -- then associate the full view with the inherited TSS_Elist + -- as well. + + if Ekind (B_Id) in Private_Kind + and then Present (Full_View (B_Id)) + then + Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); + Set_TSS_Elist + (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); + end if; + end; + end if; + end Expand_N_Full_Type_Declaration; + + --------------------------------- + -- Expand_N_Object_Declaration -- + --------------------------------- + + -- First we do special processing for objects of a tagged type where this + -- is the point at which the type is frozen. The creation of the dispatch + -- table and the initialization procedure have to be deferred to this + -- point, since we reference previously declared primitive subprograms. + + -- For all types, we call an initialization procedure if there is one + + procedure Expand_N_Object_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + Typ : constant Entity_Id := Etype (Def_Id); + Loc : constant Source_Ptr := Sloc (N); + Expr : Node_Id := Expression (N); + New_Ref : Node_Id; + Id_Ref : Node_Id; + Expr_Q : Node_Id; + + begin + -- Don't do anything for deferred constants. All proper actions will + -- be expanded during the redeclaration. + + if No (Expr) and Constant_Present (N) then + return; + end if; + + -- Make shared memory routines for shared passive variable + + if Is_Shared_Passive (Def_Id) then + Make_Shared_Var_Procs (N); + end if; + + -- If tasks being declared, make sure we have an activation chain + -- defined for the tasks (has no effect if we already have one), and + -- also that a Master variable is established and that the appropriate + -- enclosing construct is established as a task master. + + if Has_Task (Typ) then + Build_Activation_Chain_Entity (N); + Build_Master_Entity (Def_Id); + end if; + + -- Default initialization required, and no expression present + + if No (Expr) then + + -- Expand Initialize call for controlled objects. One may wonder why + -- the Initialize Call is not done in the regular Init procedure + -- attached to the record type. That's because the init procedure is + -- recursively called on each component, including _Parent, thus the + -- Init call for a controlled object would generate not only one + -- Initialize call as it is required but one for each ancestor of + -- its type. This processing is suppressed if No_Initialization set. + + if not Controlled_Type (Typ) + or else No_Initialization (N) + then + null; + + elsif not Abort_Allowed + or else not Comes_From_Source (N) + then + Insert_Actions_After (N, + Make_Init_Call ( + Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1))); + + -- Abort allowed + + else + -- We need to protect the initialize call + + -- begin + -- Defer_Abort.all; + -- Initialize (...); + -- at end + -- Undefer_Abort.all; + -- end; + + -- ??? this won't protect the initialize call for controlled + -- components which are part of the init proc, so this block + -- should probably also contain the call to _init_proc but this + -- requires some code reorganization... + + declare + L : constant List_Id := + Make_Init_Call ( + Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1)); + + Blk : constant Node_Id := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, L)); + + begin + Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Set_At_End_Proc (Handled_Statement_Sequence (Blk), + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + Insert_Actions_After (N, New_List (Blk)); + Expand_At_End_Handler + (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); + end; + end if; + + -- Call type initialization procedure if there is one. We build the + -- call and put it immediately after the object declaration, so that + -- it will be expanded in the usual manner. Note that this will + -- result in proper handling of defaulted discriminants. The call + -- to the Init_Proc is suppressed if No_Initialization is set. + + if Has_Non_Null_Base_Init_Proc (Typ) + and then not No_Initialization (N) + then + -- The call to the initialization procedure does NOT freeze + -- the object being initialized. This is because the call is + -- not a source level call. This works fine, because the only + -- possible statements depending on freeze status that can + -- appear after the _Init call are rep clauses which can + -- safely appear after actual references to the object. + + Id_Ref := New_Reference_To (Def_Id, Loc); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); + + Insert_Actions_After (N, + Build_Initialization_Call (Loc, Id_Ref, Typ)); + + -- If simple initialization is required, then set an appropriate + -- simple initialization expression in place. This special + -- initialization is required even though No_Init_Flag is present. + + elsif Needs_Simple_Initialization (Typ) then + Set_No_Initialization (N, False); + Set_Expression (N, Get_Simple_Init_Val (Typ, Loc)); + Analyze_And_Resolve (Expression (N), Typ); + end if; + + -- Explicit initialization present + + else + -- Obtain actual expression from qualified expression + + if Nkind (Expr) = N_Qualified_Expression then + Expr_Q := Expression (Expr); + else + Expr_Q := Expr; + end if; + + -- When we have the appropriate type of aggregate in the + -- expression (it has been determined during analysis of the + -- aggregate by setting the delay flag), let's perform in + -- place assignment and thus avoid creating a temporay. + + if Is_Delayed_Aggregate (Expr_Q) then + Convert_Aggr_In_Object_Decl (N); + + else + -- In most cases, we must check that the initial value meets + -- any constraint imposed by the declared type. However, there + -- is one very important exception to this rule. If the entity + -- has an unconstrained nominal subtype, then it acquired its + -- constraints from the expression in the first place, and not + -- only does this mean that the constraint check is not needed, + -- but an attempt to perform the constraint check can + -- cause order of elaboration problems. + + if not Is_Constr_Subt_For_U_Nominal (Typ) then + + -- If this is an allocator for an aggregate that has been + -- allocated in place, delay checks until assignments are + -- made, because the discriminants are not initialized. + + if Nkind (Expr) = N_Allocator + and then No_Initialization (Expr) + then + null; + else + Apply_Constraint_Check (Expr, Typ); + end if; + end if; + + -- If the type is controlled we attach the object to the final + -- list and adjust the target after the copy. This + + if Controlled_Type (Typ) then + declare + Flist : Node_Id; + F : Entity_Id; + + begin + -- Attach the result to a dummy final list which will never + -- be finalized if Delay_Finalize_Attachis set. It is + -- important to attach to a dummy final list rather than + -- not attaching at all in order to reset the pointers + -- coming from the initial value. Equivalent code exists + -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator. + + if Delay_Finalize_Attach (N) then + F := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => F, + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + + Flist := New_Reference_To (F, Loc); + + else + Flist := Find_Final_List (Def_Id); + end if; + + Insert_Actions_After (N, + Make_Adjust_Call ( + Ref => New_Reference_To (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Flist, + With_Attach => Make_Integer_Literal (Loc, 1))); + end; + end if; + + -- For tagged types, when an init value is given, the tag has + -- to be re-initialized separately in order to avoid the + -- propagation of a wrong tag coming from a view conversion + -- unless the type is class wide (in this case the tag comes + -- from the init value). Suppress the tag assignment when + -- Java_VM because JVM tags are represented implicitly + -- in objects. Ditto for types that are CPP_CLASS. + + if Is_Tagged_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + and then not Is_CPP_Class (Typ) + and then not Java_VM + then + -- The re-assignment of the tag has to be done even if + -- the object is a constant + + New_Ref := + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Def_Id, Loc), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc)); + + Set_Assignment_OK (New_Ref); + + Insert_After (N, + Make_Assignment_Statement (Loc, + Name => New_Ref, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Access_Disp_Table (Base_Type (Typ)), Loc)))); + + -- For discrete types, set the Is_Known_Valid flag if the + -- initializing value is known to be valid. + + elsif Is_Discrete_Type (Typ) + and then Expr_Known_Valid (Expr) + then + Set_Is_Known_Valid (Def_Id); + end if; + + -- If validity checking on copies, validate initial expression + + if Validity_Checks_On + and then Validity_Check_Copies + then + Ensure_Valid (Expr); + Set_Is_Known_Valid (Def_Id); + end if; + end if; + end if; + + -- For array type, check for size too large + -- We really need this for record types too??? + + if Is_Array_Type (Typ) then + Apply_Array_Size_Check (N, Typ); + end if; + + end Expand_N_Object_Declaration; + + --------------------------------- + -- Expand_N_Subtype_Indication -- + --------------------------------- + + -- Add a check on the range of the subtype. The static case is + -- partially duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, + -- but we still need to check here for the static case in order to + -- avoid generating extraneous expanded code. + + procedure Expand_N_Subtype_Indication (N : Node_Id) is + Ran : Node_Id := Range_Expression (Constraint (N)); + Typ : Entity_Id := Entity (Subtype_Mark (N)); + + begin + if Nkind (Parent (N)) = N_Constrained_Array_Definition or else + Nkind (Parent (N)) = N_Slice + then + Resolve (Ran, Typ); + Apply_Range_Check (Ran, Typ); + end if; + end Expand_N_Subtype_Indication; + + --------------------------- + -- Expand_N_Variant_Part -- + --------------------------- + + -- If the last variant does not contain the Others choice, replace + -- it with an N_Others_Choice node since Gigi always wants an Others. + -- Note that we do not bother to call Analyze on the modified variant + -- part, since it's only effect would be to compute the contents of + -- the Others_Discrete_Choices node laboriously, and of course we + -- already know the list of choices that corresponds to the others + -- choice (it's the list we are replacing!) + + procedure Expand_N_Variant_Part (N : Node_Id) is + Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); + Others_Node : Node_Id; + + begin + if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then + Others_Node := Make_Others_Choice (Sloc (Last_Var)); + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Last_Var)); + Set_Discrete_Choices (Last_Var, New_List (Others_Node)); + end if; + end Expand_N_Variant_Part; + + --------------------------------- + -- Expand_Previous_Access_Type -- + --------------------------------- + + procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id) is + T : Entity_Id := First_Entity (Current_Scope); + + begin + -- Find all access types declared in the current scope, whose + -- designated type is Def_Id. + + while Present (T) loop + if Is_Access_Type (T) + and then Designated_Type (T) = Def_Id + then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Parent (Def_Id), T); + end if; + + Next_Entity (T); + end loop; + end Expand_Previous_Access_Type; + + ------------------------------ + -- Expand_Record_Controller -- + ------------------------------ + + procedure Expand_Record_Controller (T : Entity_Id) is + Def : Node_Id := Type_Definition (Parent (T)); + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Loc : Source_Ptr; + First_Comp : Node_Id; + Controller_Type : Entity_Id; + Ent : Entity_Id; + + begin + if Nkind (Def) = N_Derived_Type_Definition then + Def := Record_Extension_Part (Def); + end if; + + if Null_Present (Def) then + Set_Component_List (Def, + Make_Component_List (Sloc (Def), + Component_Items => Empty_List, + Variant_Part => Empty, + Null_Present => True)); + end if; + + Comp_List := Component_List (Def); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Loc := Sloc (Comp_List); + else + Loc := Sloc (First (Component_Items (Comp_List))); + end if; + + if Is_Return_By_Reference_Type (T) then + Controller_Type := RTE (RE_Limited_Record_Controller); + else + Controller_Type := RTE (RE_Record_Controller); + end if; + + Ent := Make_Defining_Identifier (Loc, Name_uController); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Ent, + Subtype_Indication => New_Reference_To (Controller_Type, Loc)); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + -- The controller cannot be placed before the _Parent field + -- since gigi lays out field in order and _parent must be + -- first to preserve the polymorphism of tagged types. + + First_Comp := First (Component_Items (Comp_List)); + + if Chars (Defining_Identifier (First_Comp)) /= Name_uParent + and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag + then + Insert_Before (First_Comp, Comp_Decl); + else + Insert_After (First_Comp, Comp_Decl); + end if; + end if; + + New_Scope (T); + Analyze (Comp_Decl); + Set_Ekind (Ent, E_Component); + Init_Component_Location (Ent); + + -- Move the _controller entity ahead in the list of internal + -- entities of the enclosing record so that it is selected + -- instead of a potentially inherited one. + + declare + E : Entity_Id := Last_Entity (T); + Comp : Entity_Id; + + begin + pragma Assert (Chars (E) = Name_uController); + + Set_Next_Entity (E, First_Entity (T)); + Set_First_Entity (T, E); + + Comp := Next_Entity (E); + while Next_Entity (Comp) /= E loop + Next_Entity (Comp); + end loop; + + Set_Next_Entity (Comp, Empty); + Set_Last_Entity (T, Comp); + end; + + End_Scope; + end Expand_Record_Controller; + + ------------------------ + -- Expand_Tagged_Root -- + ------------------------ + + procedure Expand_Tagged_Root (T : Entity_Id) is + Def : constant Node_Id := Type_Definition (Parent (T)); + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Sloc_N : Source_Ptr; + + begin + if Null_Present (Def) then + Set_Component_List (Def, + Make_Component_List (Sloc (Def), + Component_Items => Empty_List, + Variant_Part => Empty, + Null_Present => True)); + end if; + + Comp_List := Component_List (Def); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Sloc_N := Sloc (Comp_List); + else + Sloc_N := Sloc (First (Component_Items (Comp_List))); + end if; + + Comp_Decl := + Make_Component_Declaration (Sloc_N, + Defining_Identifier => Tag_Component (T), + Subtype_Indication => + New_Reference_To (RTE (RE_Tag), Sloc_N)); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; + + -- We don't Analyze the whole expansion because the tag component has + -- already been analyzed previously. Here we just insure that the + -- tree is coherent with the semantic decoration + + Find_Type (Subtype_Indication (Comp_Decl)); + end Expand_Tagged_Root; + + ----------------------- + -- Freeze_Array_Type -- + ----------------------- + + procedure Freeze_Array_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Base : constant Entity_Id := Base_Type (Typ); + + begin + -- Nothing to do for packed case + + if not Is_Bit_Packed_Array (Typ) then + + -- If the component contains tasks, so does the array type. + -- This may not be indicated in the array type because the + -- component may have been a private type at the point of + -- definition. Same if component type is controlled. + + Set_Has_Task (Base, Has_Task (Component_Type (Typ))); + Set_Has_Controlled_Component (Base, + Has_Controlled_Component (Component_Type (Typ)) + or else Is_Controlled (Component_Type (Typ))); + + if No (Init_Proc (Base)) then + + -- If this is an anonymous array created for a declaration + -- with an initial value, its init_proc will never be called. + -- The initial value itself may have been expanded into assign- + -- ments, in which case the object declaration is carries the + -- No_Initialization flag. + + if Is_Itype (Base) + and then Nkind (Associated_Node_For_Itype (Base)) = + N_Object_Declaration + and then (Present (Expression (Associated_Node_For_Itype (Base))) + or else + No_Initialization (Associated_Node_For_Itype (Base))) + then + null; + + -- We do not need an init proc for string or wide string, since + -- the only time these need initialization in normalize or + -- initialize scalars mode, and these types are treated specially + -- and do not need initialization procedures. + + elsif Base = Standard_String + or else Base = Standard_Wide_String + then + null; + + -- Otherwise we have to build an init proc for the subtype + + else + Build_Array_Init_Proc (Base, N); + end if; + end if; + + if Typ = Base and then Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); + end if; + end if; + end Freeze_Array_Type; + + ----------------------------- + -- Freeze_Enumeration_Type -- + ----------------------------- + + procedure Freeze_Enumeration_Type (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Entity (N); + Ent : Entity_Id; + Lst : List_Id; + Num : Nat; + Arr : Entity_Id; + Fent : Entity_Id; + Func : Entity_Id; + Ityp : Entity_Id; + + begin + -- Build list of literal references + + Lst := New_List; + Num := 0; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); + Num := Num + 1; + Next_Literal (Ent); + end loop; + + -- Now build an array declaration + + -- typA : array (Natural range 0 .. num - 1) of ctype := + -- (v, v, v, v, v, ....) + + -- where ctype is the corresponding integer type + + Arr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'A')); + + Append_Freeze_Action (Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Arr, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => + Make_Integer_Literal (Loc, Num - 1))))), + + Subtype_Indication => New_Reference_To (Typ, Loc)), + + Expression => + Make_Aggregate (Loc, + Expressions => Lst))); + + Set_Enum_Pos_To_Rep (Typ, Arr); + + -- Now we build the function that converts representation values to + -- position values. This function has the form: + + -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is + -- begin + -- case ityp!(A) is + -- when enum-lit'Enum_Rep => return posval; + -- when enum-lit'Enum_Rep => return posval; + -- ... + -- when others => + -- [raise Program_Error when F] + -- return -1; + -- end case; + -- end; + + -- Note: the F parameter determines whether the others case (no valid + -- representation) raises Program_Error or returns a unique value of + -- minus one. The latter case is used, e.g. in 'Valid code. + + -- Note: the reason we use Enum_Rep values in the case here is to + -- avoid the code generator making inappropriate assumptions about + -- the range of the values in the case where the value is invalid. + -- ityp is a signed or unsigned integer type of appropriate width. + + -- Note: in the case of No_Run_Time mode, where we cannot handle + -- a program error in any case, we suppress the raise and just + -- return -1 unconditionally (this is an erroneous program in any + -- case and there is no obligation to raise Program_Error here!) + -- We also do this if pragma Restrictions (No_Exceptions) is active. + + -- First build list of cases + + Lst := New_List; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), + Intval => Enumeration_Rep (Ent))), + + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, + Intval => Enumeration_Pos (Ent)))))); + + Next_Literal (Ent); + end loop; + + -- Representations are signed + + if Enumeration_Rep (First_Literal (Typ)) < 0 then + if Esize (Typ) <= Standard_Integer_Size then + Ityp := Standard_Integer; + else + Ityp := Universal_Integer; + end if; + + -- Representations are unsigned + + else + if Esize (Typ) <= Standard_Integer_Size then + Ityp := RTE (RE_Unsigned); + else + Ityp := RTE (RE_Long_Long_Unsigned); + end if; + end if; + + -- In normal mode, add the others clause with the test + + if not (No_Run_Time or Restrictions (No_Exceptions)) then + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Program_Error (Loc, + Condition => Make_Identifier (Loc, Name_uF)), + Make_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + + -- If No_Run_Time mode, unconditionally return -1. Same + -- treatment if we have pragma Restrictions (No_Exceptions). + + else + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + end if; + + -- Now we can build the function body + + Fent := + Make_Defining_Identifier (Loc, Name_uRep_To_Pos); + + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uA), + Parameter_Type => New_Reference_To (Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), + + Subtype_Mark => New_Reference_To (Standard_Integer, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Case_Statement (Loc, + Expression => + Unchecked_Convert_To (Ityp, + Make_Identifier (Loc, Name_uA)), + Alternatives => Lst)))); + + Set_TSS (Typ, Fent); + Set_Is_Pure (Fent); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Fent); + end if; + end Freeze_Enumeration_Type; + + ------------------------ + -- Freeze_Record_Type -- + ------------------------ + + procedure Freeze_Record_Type (N : Node_Id) is + Def_Id : constant Node_Id := Entity (N); + Comp : Entity_Id; + Type_Decl : constant Node_Id := Parent (Def_Id); + Predef_List : List_Id; + + Renamed_Eq : Node_Id := Empty; + -- Could use some comments ??? + + begin + -- Build discriminant checking functions if not a derived type (for + -- derived types that are not tagged types, we always use the + -- discriminant checking functions of the parent type). However, for + -- untagged types the derivation may have taken place before the + -- parent was frozen, so we copy explicitly the discriminant checking + -- functions from the parent into the components of the derived type. + + if not Is_Derived_Type (Def_Id) + or else Has_New_Non_Standard_Rep (Def_Id) + or else Is_Tagged_Type (Def_Id) + then + Build_Discr_Checking_Funcs (Type_Decl); + + elsif Is_Derived_Type (Def_Id) + and then not Is_Tagged_Type (Def_Id) + and then Has_Discriminants (Def_Id) + then + declare + Old_Comp : Entity_Id; + + begin + Old_Comp := + First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); + Comp := First_Component (Def_Id); + + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Chars (Comp) = Chars (Old_Comp) + then + Set_Discriminant_Checking_Func (Comp, + Discriminant_Checking_Func (Old_Comp)); + end if; + + Next_Component (Old_Comp); + Next_Component (Comp); + end loop; + end; + end if; + + -- Update task and controlled component flags, because some of the + -- component types may have been private at the point of the record + -- declaration. + + Comp := First_Component (Def_Id); + + while Present (Comp) loop + if Has_Task (Etype (Comp)) then + Set_Has_Task (Def_Id); + + elsif Has_Controlled_Component (Etype (Comp)) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + then + Set_Has_Controlled_Component (Def_Id); + end if; + + Next_Component (Comp); + end loop; + + -- Creation of the Dispatch Table. Note that a Dispatch Table is + -- created for regular tagged types as well as for Ada types + -- deriving from a C++ Class, but not for tagged types directly + -- corresponding to the C++ classes. In the later case we assume + -- that the Vtable is created in the C++ side and we just use it. + + if Is_Tagged_Type (Def_Id) then + + if Is_CPP_Class (Def_Id) then + Set_All_DT_Position (Def_Id); + Set_Default_Constructor (Def_Id); + + else + -- Usually inherited primitives are not delayed but the first + -- Ada extension of a CPP_Class is an exception since the + -- address of the inherited subprogram has to be inserted in + -- the new Ada Dispatch Table and this is a freezing action + -- (usually the inherited primitive address is inserted in the + -- DT by Inherit_DT) + + if Is_CPP_Class (Etype (Def_Id)) then + declare + Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); + Subp : Entity_Id; + + begin + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + Set_Has_Delayed_Freeze (Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + if Underlying_Type (Etype (Def_Id)) = Def_Id then + Expand_Tagged_Root (Def_Id); + end if; + + -- Unfreeze momentarily the type to add the predefined + -- primitives operations. The reason we unfreeze is so + -- that these predefined operations will indeed end up + -- as primitive operations (which must be before the + -- freeze point). + + Set_Is_Frozen (Def_Id, False); + Make_Predefined_Primitive_Specs + (Def_Id, Predef_List, Renamed_Eq); + Insert_List_Before_And_Analyze (N, Predef_List); + Set_Is_Frozen (Def_Id, True); + Set_All_DT_Position (Def_Id); + + -- Add the controlled component before the freezing actions + -- it is referenced in those actions. + + if Has_New_Controlled_Component (Def_Id) then + Expand_Record_Controller (Def_Id); + end if; + + -- Suppress creation of a dispatch table when Java_VM because + -- the dispatching mechanism is handled internally by the JVM. + + if not Java_VM then + Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + end if; + + -- Make sure that the primitives Initialize, Adjust and + -- Finalize are Frozen before other TSS subprograms. We + -- don't want them Frozen inside. + + if Is_Controlled (Def_Id) then + if not Is_Limited_Type (Def_Id) then + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); + end if; + + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); + + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); + end if; + + -- Freeze rest of primitive operations + + Append_Freeze_Actions + (Def_Id, Predefined_Primitive_Freeze (Def_Id)); + end if; + + -- In the non-tagged case, an equality function is provided only + -- for variant records (that are not unchecked unions). + + elsif Has_Discriminants (Def_Id) + and then not Is_Limited_Type (Def_Id) + then + declare + Comps : constant Node_Id := + Component_List (Type_Definition (Type_Decl)); + + begin + if Present (Comps) + and then Present (Variant_Part (Comps)) + and then not Is_Unchecked_Union (Def_Id) + then + Build_Variant_Record_Equality (Def_Id); + end if; + end; + end if; + + -- Before building the record initialization procedure, if we are + -- dealing with a concurrent record value type, then we must go + -- through the discriminants, exchanging discriminals between the + -- concurrent type and the concurrent record value type. See the + -- section "Handling of Discriminants" in the Einfo spec for details. + + if Is_Concurrent_Record_Type (Def_Id) + and then Has_Discriminants (Def_Id) + then + declare + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Def_Id); + Conc_Discr : Entity_Id; + Rec_Discr : Entity_Id; + Temp : Entity_Id; + + begin + Conc_Discr := First_Discriminant (Ctyp); + Rec_Discr := First_Discriminant (Def_Id); + + while Present (Conc_Discr) loop + Temp := Discriminal (Conc_Discr); + Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); + Set_Discriminal (Rec_Discr, Temp); + + Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); + Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); + + Next_Discriminant (Conc_Discr); + Next_Discriminant (Rec_Discr); + end loop; + end; + end if; + + if Has_Controlled_Component (Def_Id) then + if No (Controller_Component (Def_Id)) then + Expand_Record_Controller (Def_Id); + end if; + + Build_Controlling_Procs (Def_Id); + end if; + + Adjust_Discriminants (Def_Id); + Build_Record_Init_Proc (Type_Decl, Def_Id); + + -- For tagged type, build bodies of primitive operations. Note + -- that we do this after building the record initialization + -- experiment, since the primitive operations may need the + -- initialization routine + + if Is_Tagged_Type (Def_Id) then + Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); + Append_Freeze_Actions (Def_Id, Predef_List); + end if; + + end Freeze_Record_Type; + + ----------------- + -- Freeze_Type -- + ----------------- + + -- Full type declarations are expanded at the point at which the type + -- is frozen. The formal N is the Freeze_Node for the type. Any statements + -- or declarations generated by the freezing (e.g. the procedure generated + -- for initialization) are chained in the Acions field list of the freeze + -- node using Append_Freeze_Actions. + + procedure Freeze_Type (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (N); + + begin + -- Process associated access types needing special processing + + if Present (Access_Types_To_Process (N)) then + declare + E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); + begin + while Present (E) loop + + -- If the access type is a RACW, call the expansion procedure + -- for this remote pointer. + + if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then + Remote_Types_Tagged_Full_View_Encountered (Def_Id); + end if; + + E := Next_Elmt (E); + end loop; + end; + end if; + + -- Freeze processing for record types + + if Is_Record_Type (Def_Id) then + if Ekind (Def_Id) = E_Record_Type then + Freeze_Record_Type (N); + + -- The subtype may have been declared before the type was frozen. + -- If the type has controlled components it is necessary to create + -- the entity for the controller explicitly because it did not + -- exist at the point of the subtype declaration. Only the entity is + -- needed, the back-end will obtain the layout from the type. + -- This is only necessary if this is constrained subtype whose + -- component list is not shared with the base type. + + elsif Ekind (Def_Id) = E_Record_Subtype + and then Has_Discriminants (Def_Id) + and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) + and then Present (Controller_Component (Def_Id)) + then + declare + Old_C : Entity_Id := Controller_Component (Def_Id); + New_C : Entity_Id; + + begin + if Scope (Old_C) = Base_Type (Def_Id) then + + -- The entity is the one in the parent. Create new one. + + New_C := New_Copy (Old_C); + Set_Parent (New_C, Parent (Old_C)); + New_Scope (Def_Id); + Enter_Name (New_C); + End_Scope; + end if; + end; + end if; + + -- Freeze processing for array types + + elsif Is_Array_Type (Def_Id) then + Freeze_Array_Type (N); + + -- Freeze processing for access types + + -- For pool-specific access types, find out the pool object used for + -- this type, needs actual expansion of it in some cases. Here are the + -- different cases : + + -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" + -- ---> don't use any storage pool + + -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. + -- Expand: + -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); + + -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" + -- ---> Storage Pool is the specified one + + -- See GNAT Pool packages in the Run-Time for more details + + elsif Ekind (Def_Id) = E_Access_Type + or else Ekind (Def_Id) = E_General_Access_Type + then + declare + Loc : constant Source_Ptr := Sloc (N); + Desig_Type : constant Entity_Id := Designated_Type (Def_Id); + Pool_Object : Entity_Id; + Siz_Exp : Node_Id; + + Freeze_Action_Typ : Entity_Id; + + begin + if Has_Storage_Size_Clause (Def_Id) then + Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); + else + Siz_Exp := Empty; + end if; + + -- Case 1 + + -- Rep Clause "for Def_Id'Storage_Size use 0;" + -- ---> don't use any storage pool + + if Has_Storage_Size_Clause (Def_Id) + and then Compile_Time_Known_Value (Siz_Exp) + and then Expr_Value (Siz_Exp) = 0 + then + null; + + -- Case 2 + + -- Rep Clause : for Def_Id'Storage_Size use Expr. + -- ---> Expand: + -- Def_Id__Pool : Stack_Bounded_Pool + -- (Expr, DT'Size, DT'Alignment); + + elsif Has_Storage_Size_Clause (Def_Id) then + declare + DT_Size : Node_Id; + DT_Align : Node_Id; + + begin + -- For unconstrained composite types we give a size of + -- zero so that the pool knows that it needs a special + -- algorithm for variable size object allocation. + + if Is_Composite_Type (Desig_Type) + and then not Is_Constrained (Desig_Type) + then + DT_Size := + Make_Integer_Literal (Loc, 0); + + DT_Align := + Make_Integer_Literal (Loc, Maximum_Alignment); + + else + DT_Size := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Desig_Type, Loc), + Attribute_Name => Name_Max_Size_In_Storage_Elements); + + DT_Align := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Desig_Type, Loc), + Attribute_Name => Name_Alignment); + end if; + + Pool_Object := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Def_Id), 'P')); + + -- We put the code associated with the pools in the + -- entity that has the later freeze node, usually the + -- acces type but it can also be the designated_type; + -- because the pool code requires both those types to be + -- frozen + + if Is_Frozen (Desig_Type) + and then (not Present (Freeze_Node (Desig_Type)) + or else Analyzed (Freeze_Node (Desig_Type))) + then + Freeze_Action_Typ := Def_Id; + + -- A Taft amendment type cannot get the freeze actions + -- since the full view is not there. + + elsif Is_Incomplete_Or_Private_Type (Desig_Type) + and then No (Full_View (Desig_Type)) + then + Freeze_Action_Typ := Def_Id; + + else + Freeze_Action_Typ := Desig_Type; + end if; + + Append_Freeze_Action (Freeze_Action_Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Pool_Object, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Stack_Bounded_Pool), Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + + -- First discriminant is the Pool Size + + New_Reference_To ( + Storage_Size_Variable (Def_Id), Loc), + + -- Second discriminant is the element size + + DT_Size, + + -- Third discriminant is the alignment + + DT_Align))))); + + end; + + Set_Associated_Storage_Pool (Def_Id, Pool_Object); + + -- Case 3 + + -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" + -- ---> Storage Pool is the specified one + + elsif Present (Associated_Storage_Pool (Def_Id)) then + + -- Nothing to do the associated storage pool has been attached + -- when analyzing the rep. clause + + null; + + end if; + + -- For access-to-controlled types (including class-wide types + -- and Taft-amendment types which potentially have controlled + -- components), expand the list controller object that will + -- store the dynamically allocated objects. Do not do this + -- transformation for expander-generated access types, but do it + -- for types that are the full view of types derived from other + -- private types. Also suppress the list controller in the case + -- of a designated type with convention Java, since this is used + -- when binding to Java API specs, where there's no equivalent + -- of a finalization list and we don't want to pull in the + -- finalization support if not needed. + + if not Comes_From_Source (Def_Id) + and then not Has_Private_Declaration (Def_Id) + then + null; + + elsif (Controlled_Type (Desig_Type) + and then Convention (Desig_Type) /= Convention_Java) + or else (Is_Incomplete_Or_Private_Type (Desig_Type) + and then No (Full_View (Desig_Type)) + + -- An exception is made for types defined in the run-time + -- because Ada.Tags.Tag itself is such a type and cannot + -- afford this unnecessary overhead that would generates a + -- loop in the expansion scheme... + -- Similarly, if No_Run_Time is enabled, the designated type + -- cannot be controlled. + + and then not In_Runtime (Def_Id) + and then not No_Run_Time) + + -- If the designated type is not frozen yet, its controlled + -- status must be retrieved explicitly. + + or else (Is_Array_Type (Desig_Type) + and then not Is_Frozen (Desig_Type) + and then Controlled_Type (Component_Type (Desig_Type))) + then + Set_Associated_Final_Chain (Def_Id, + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Def_Id), 'L'))); + + Append_Freeze_Action (Def_Id, + Make_Object_Declaration (Loc, + Defining_Identifier => Associated_Final_Chain (Def_Id), + Object_Definition => + New_Reference_To (RTE (RE_List_Controller), Loc))); + end if; + end; + + -- Freeze processing for enumeration types + + elsif Ekind (Def_Id) = E_Enumeration_Type then + + -- We only have something to do if we have a non-standard + -- representation (i.e. at least one literal whose pos value + -- is not the same as its representation) + + if Has_Non_Standard_Rep (Def_Id) then + Freeze_Enumeration_Type (N); + end if; + + -- private types that are completed by a derivation from a private + -- type have an internally generated full view, that needs to be + -- frozen. This must be done explicitly because the two views share + -- the freeze node, and the underlying full view is not visible when + -- the freeze node is analyzed. + + elsif Is_Private_Type (Def_Id) + and then Is_Derived_Type (Def_Id) + and then Present (Full_View (Def_Id)) + and then Is_Itype (Full_View (Def_Id)) + and then Has_Private_Declaration (Full_View (Def_Id)) + and then Freeze_Node (Full_View (Def_Id)) = N + then + Set_Entity (N, Full_View (Def_Id)); + Freeze_Type (N); + Set_Entity (N, Def_Id); + + -- All other types require no expander action. There are such + -- cases (e.g. task types and protected types). In such cases, + -- the freeze nodes are there for use by Gigi. + + end if; + end Freeze_Type; + + ------------------------- + -- Get_Simple_Init_Val -- + ------------------------- + + function Get_Simple_Init_Val + (T : Entity_Id; + Loc : Source_Ptr) + return Node_Id + is + Val : Node_Id; + Typ : Node_Id; + Result : Node_Id; + Val_RE : RE_Id; + + begin + -- For scalars, we must have normalize/initialize scalars case + + if Is_Scalar_Type (T) then + pragma Assert (Init_Or_Norm_Scalars); + + -- Processing for Normalize_Scalars case + + if Normalize_Scalars then + + -- First prepare a value (out of subtype range if possible) + + if Is_Real_Type (T) or else Is_Integer_Type (T) then + Val := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Base_Type (T), Loc), + Attribute_Name => Name_First); + + elsif Is_Modular_Integer_Type (T) then + Val := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Base_Type (T), Loc), + Attribute_Name => Name_Last); + + else + pragma Assert (Is_Enumeration_Type (T)); + + if Esize (T) <= 8 then + Typ := RTE (RE_Unsigned_8); + elsif Esize (T) <= 16 then + Typ := RTE (RE_Unsigned_16); + elsif Esize (T) <= 32 then + Typ := RTE (RE_Unsigned_32); + else + Typ := RTE (RE_Unsigned_64); + end if; + + Val := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Last); + end if; + + -- Here for Initialize_Scalars case + + else + if Is_Floating_Point_Type (T) then + if Root_Type (T) = Standard_Short_Float then + Val_RE := RE_IS_Isf; + elsif Root_Type (T) = Standard_Float then + Val_RE := RE_IS_Ifl; + + -- The form of the following test is quite deliberate, it + -- catches the case of architectures (the most common case) + -- where Long_Long_Float is the same as Long_Float, and in + -- such cases initializes Long_Long_Float variables from the + -- Long_Float constant (since the Long_Long_Float constant is + -- only for use on the x86). + + elsif Esize (Root_Type (T)) = Esize (Standard_Long_Float) then + Val_RE := RE_IS_Ilf; + + -- Otherwise we have extended real on an x86 + + else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); + Val_RE := RE_IS_Ill; + end if; + + elsif Is_Unsigned_Type (Base_Type (T)) then + if Esize (T) = 8 then + Val_RE := RE_IS_Iu1; + elsif Esize (T) = 16 then + Val_RE := RE_IS_Iu2; + elsif Esize (T) = 32 then + Val_RE := RE_IS_Iu4; + else pragma Assert (Esize (T) = 64); + Val_RE := RE_IS_Iu8; + end if; + + else -- signed type + if Esize (T) = 8 then + Val_RE := RE_IS_Is1; + elsif Esize (T) = 16 then + Val_RE := RE_IS_Is2; + elsif Esize (T) = 32 then + Val_RE := RE_IS_Is4; + else pragma Assert (Esize (T) = 64); + Val_RE := RE_IS_Is8; + end if; + end if; + + Val := New_Occurrence_Of (RTE (Val_RE), Loc); + end if; + + -- The final expression is obtained by doing an unchecked + -- conversion of this result to the base type of the + -- required subtype. We use the base type to avoid the + -- unchecked conversion from chopping bits, and then we + -- set Kill_Range_Check to preserve the "bad" value. + + Result := Unchecked_Convert_To (Base_Type (T), Val); + + if Nkind (Result) = N_Unchecked_Type_Conversion then + Set_Kill_Range_Check (Result, True); + end if; + + return Result; + + -- String or Wide_String (must have Initialize_Scalars set) + + elsif Root_Type (T) = Standard_String + or else + Root_Type (T) = Standard_Wide_String + then + pragma Assert (Init_Or_Norm_Scalars); + + -- Build aggregate with an explicit qualification, because it + -- may otherwise be ambiguous in context. + + return + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Others_Choice (Loc)), + Expression => + Get_Simple_Init_Val (Component_Type (T), Loc))))); + + -- Access type is initialized to null + + elsif Is_Access_Type (T) then + return + Make_Null (Loc); + + -- We initialize modular packed bit arrays to zero, to make sure that + -- unused bits are zero, as required (see spec of Exp_Pakd). Also note + -- that this improves gigi code, since the value tracing knows that + -- all bits of the variable start out at zero. The value of zero has + -- to be unchecked converted to the proper array type. + + elsif Is_Bit_Packed_Array (T) then + declare + PAT : constant Entity_Id := Packed_Array_Type (T); + Nod : Node_Id; + + begin + pragma Assert (Is_Modular_Integer_Type (PAT)); + + Nod := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Expression => Make_Integer_Literal (Loc, 0)); + + Set_Etype (Expression (Nod), PAT); + return Nod; + end; + + -- Otherwise we have a case of a private type whose underlying type + -- needs simple initialization. In this case, we get the value for + -- the underlying type, then unchecked convert to the private type. + + else + pragma Assert + (Is_Private_Type (T) + and then Present (Underlying_Type (T))); + + Val := Get_Simple_Init_Val (Underlying_Type (T), Loc); + + -- A special case, if the underlying value is null, then qualify + -- it with the underlying type, so that the null is properly typed + + if Nkind (Val) = N_Null then + Val := + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Type (T), Loc), + Expression => Val); + end if; + + return Unchecked_Convert_To (T, Val); + end if; + end Get_Simple_Init_Val; + + ------------------------------ + -- Has_New_Non_Standard_Rep -- + ------------------------------ + + function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is + begin + if not Is_Derived_Type (T) then + return Has_Non_Standard_Rep (T) + or else Has_Non_Standard_Rep (Root_Type (T)); + + -- If Has_Non_Standard_Rep is not set on the derived type, the + -- representation is fully inherited. + + elsif not Has_Non_Standard_Rep (T) then + return False; + + else + return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); + + -- May need a more precise check here: the First_Rep_Item may + -- be a stream attribute, which does not affect the representation + -- of the type ??? + end if; + end Has_New_Non_Standard_Rep; + + ---------------- + -- In_Runtime -- + ---------------- + + function In_Runtime (E : Entity_Id) return Boolean is + S1 : Entity_Id := Scope (E); + + begin + while Scope (S1) /= Standard_Standard loop + S1 := Scope (S1); + end loop; + + return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; + end In_Runtime; + + ------------------ + -- Init_Formals -- + ------------------ + + function Init_Formals (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Formals : List_Id; + + begin + -- First parameter is always _Init : in out typ. Note that we need + -- this to be in/out because in the case of the task record value, + -- there are default record fields (_Priority, _Size, -Task_Info) + -- that may be referenced in the generated initialization routine. + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc))); + + -- For task record value, or type that contains tasks, add two more + -- formals, _Master : Master_Id and _Chain : in out Activation_Chain + -- We also add these parameters for the task record type case. + + if Has_Task (Typ) + or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) + then + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uChain), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Activation_Chain), Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Id), + In_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Task_Image_Type), Loc))); + end if; + + return Formals; + end Init_Formals; + + ------------------ + -- Make_Eq_Case -- + ------------------ + + -- <Make_Eq_if shared components> + -- case X.D1 is + -- when V1 => <Make_Eq_Case> on subcomponents + -- ... + -- when Vn => <Make_Eq_Case> on subcomponents + -- end case; + + function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Node); + Variant : Node_Id; + Alt_List : List_Id; + Result : List_Id := New_List; + + begin + Append_To (Result, Make_Eq_If (Node, Component_Items (CL))); + + if No (Variant_Part (CL)) then + return Result; + end if; + + Variant := First_Non_Pragma (Variants (Variant_Part (CL))); + + if No (Variant) then + return Result; + end if; + + Alt_List := New_List; + + while Present (Variant) loop + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), + Statements => Make_Eq_Case (Node, Component_List (Variant)))); + + Next_Non_Pragma (Variant); + end loop; + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => New_Copy (Name (Variant_Part (CL)))), + Alternatives => Alt_List)); + + return Result; + end Make_Eq_Case; + + ---------------- + -- Make_Eq_If -- + ---------------- + + -- Generates: + + -- if + -- X.C1 /= Y.C1 + -- or else + -- X.C2 /= Y.C2 + -- ... + -- then + -- return False; + -- end if; + + -- or a null statement if the list L is empty + + function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Node); + C : Node_Id; + Field_Name : Name_Id; + Cond : Node_Id; + + begin + if No (L) then + return Make_Null_Statement (Loc); + + else + Cond := Empty; + + C := First_Non_Pragma (L); + while Present (C) loop + Field_Name := Chars (Defining_Identifier (C)); + + -- The tags must not be compared they are not part of the value. + -- Note also that in the following, we use Make_Identifier for + -- the component names. Use of New_Reference_To to identify the + -- components would be incorrect because the wrong entities for + -- discriminants could be picked up in the private type case. + + if Field_Name /= Name_uTag then + Evolve_Or_Else (Cond, + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => + Make_Identifier (Loc, Field_Name)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_Y), + Selector_Name => + Make_Identifier (Loc, Field_Name)))); + end if; + + Next_Non_Pragma (C); + end loop; + + if No (Cond) then + return Make_Null_Statement (Loc); + + else + return + Make_Implicit_If_Statement (Node, + Condition => Cond, + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc)))); + end if; + end if; + end Make_Eq_If; + + ------------------------------------- + -- Make_Predefined_Primitive_Specs -- + ------------------------------------- + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : List_Id := New_List; + Prim : Elmt_Id; + Eq_Needed : Boolean; + Eq_Spec : Node_Id; + Eq_Name : Name_Id := Name_Op_Eq; + + function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a renaming of an unresolved predefined + -- equality operation. + + function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) /= Name_Op_Eq + and then Present (Alias (Prim)) + and then Comes_From_Source (Prim) + and then Is_Intrinsic_Subprogram (Alias (Prim)) + and then Chars (Alias (Prim)) = Name_Op_Eq; + end Is_Predefined_Eq_Renaming; + + -- Start of processing for Make_Predefined_Primitive_Specs + + begin + Renamed_Eq := Empty; + + -- Spec of _Size + + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uSize, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Long_Long_Integer)); + + -- Specs for dispatching stream attributes. We skip these for limited + -- types, since there is no question of dispatching in the limited case. + + -- We also skip these operations in No_Run_Time mode, where + -- dispatching stream operations cannot be used (this is currently + -- a No_Run_Time restriction). + + if not (No_Run_Time or else Is_Limited_Type (Tag_Typ)) then + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uRead)); + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uWrite)); + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uInput)); + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uOutput)); + end if; + + if not Is_Limited_Type (Tag_Typ) then + + -- Spec of "=" if expanded if the type is not limited and if a + -- user defined "=" was not already declared for the non-full + -- view of a private extension + + Eq_Needed := True; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + -- If a primitive is encountered that renames the predefined + -- equality operator before reaching any explicit equality + -- primitive, then we still need to create a predefined + -- equality function, because calls to it can occur via + -- the renaming. A new name is created for the equality + -- to avoid conflicting with any user-defined equality. + -- (Note that this doesn't account for renamings of + -- equality nested within subpackages???) + + if Is_Predefined_Eq_Renaming (Node (Prim)) then + Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then (No (Alias (Node (Prim))) + or else Nkind (Unit_Declaration_Node (Node (Prim))) = + N_Subprogram_Renaming_Declaration) + and then Etype (First_Formal (Node (Prim))) = + Etype (Next_Formal (First_Formal (Node (Prim)))) + + then + Eq_Needed := False; + exit; + + -- If the parent equality is abstract, the inherited equality is + -- abstract as well, and no body can be created for for it. + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then Present (Alias (Node (Prim))) + and then Is_Abstract (Alias (Node (Prim))) + then + Eq_Needed := False; + exit; + end if; + + Next_Elmt (Prim); + end loop; + + -- If a renaming of predefined equality was found + -- but there was no user-defined equality (so Eq_Needed + -- is still true), then set the name back to Name_Op_Eq. + -- But in the case where a user-defined equality was + -- located after such a renaming, then the predefined + -- equality function is still needed, so Eq_Needed must + -- be set back to True. + + if Eq_Name /= Name_Op_Eq then + if Eq_Needed then + Eq_Name := Name_Op_Eq; + else + Eq_Needed := True; + end if; + end if; + + if Eq_Needed then + Eq_Spec := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + Ret_Type => Standard_Boolean); + Append_To (Res, Eq_Spec); + + if Eq_Name /= Name_Op_Eq then + Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + + -- Any renamings of equality that appeared before an + -- overriding equality must be updated to refer to + -- the entity for the predefined equality, otherwise + -- calls via the renaming would get incorrectly + -- resolved to call the user-defined equality function. + + if Is_Predefined_Eq_Renaming (Node (Prim)) then + Set_Alias (Node (Prim), Renamed_Eq); + + -- Exit upon encountering a user-defined equality + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then No (Alias (Node (Prim))) + then + exit; + end if; + + Next_Elmt (Prim); + end loop; + end if; + end if; + + -- Spec for dispatching assignment + + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); + end if; + + -- Specs for finalization actions that may be required in case a + -- future extension contain a controlled element. We generate those + -- only for root tagged types where they will get dummy bodies or + -- when the type has controlled components and their body must be + -- generated. It is also impossible to provide those for tagged + -- types defined within s-finimp since it would involve circularity + -- problems + + if In_Finalization_Root (Tag_Typ) then + null; + + -- We also skip these in No_Run_Time mode where finalization is + -- never permissible. + + elsif No_Run_Time then + null; + + elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then + + if not Is_Limited_Type (Tag_Typ) then + Append_To (Res, + Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust)); + end if; + + Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize)); + end if; + + Predef_List := Res; + end Make_Predefined_Primitive_Specs; + + --------------------------------- + -- Needs_Simple_Initialization -- + --------------------------------- + + function Needs_Simple_Initialization (T : Entity_Id) return Boolean is + begin + -- Cases needing simple initialization are access types, and, if pragma + -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar + -- types. + + if Is_Access_Type (T) + or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) + + or else (Is_Bit_Packed_Array (T) + and then Is_Modular_Integer_Type (Packed_Array_Type (T))) + then + return True; + + -- If Initialize/Normalize_Scalars is in effect, string objects also + -- need initialization, unless they are created in the course of + -- expanding an aggregate (since in the latter case they will be + -- filled with appropriate initializing values before they are used). + + elsif Init_Or_Norm_Scalars + and then + (Root_Type (T) = Standard_String + or else Root_Type (T) = Standard_Wide_String) + and then + (not Is_Itype (T) + or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) + then + return True; + + -- Check for private type, in which case test applies to the + -- underlying type of the private type. + + elsif Is_Private_Type (T) then + declare + RT : constant Entity_Id := Underlying_Type (T); + + begin + if Present (RT) then + return Needs_Simple_Initialization (RT); + else + return False; + end if; + end; + + else + return False; + end if; + end Needs_Simple_Initialization; + + ---------------------- + -- Predef_Deep_Spec -- + ---------------------- + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + For_Body : Boolean := False) + return Node_Id + is + Prof : List_Id; + Type_B : Entity_Id; + + begin + if Name = Name_uDeep_Finalize then + Prof := New_List; + Type_B := Standard_Boolean; + + else + Prof := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + Type_B := Standard_Short_Short_Integer; + end if; + + Append_To (Prof, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc))); + + Append_To (Prof, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), + Parameter_Type => New_Reference_To (Type_B, Loc))); + + return Predef_Spec_Or_Body (Loc, + Name => Name, + Tag_Typ => Tag_Typ, + Profile => Prof, + For_Body => For_Body); + end Predef_Deep_Spec; + + ------------------------- + -- Predef_Spec_Or_Body -- + ------------------------- + + function Predef_Spec_Or_Body + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + Profile : List_Id; + Ret_Type : Entity_Id := Empty; + For_Body : Boolean := False) + return Node_Id + is + Id : Entity_Id := Make_Defining_Identifier (Loc, Name); + Spec : Node_Id; + + begin + Set_Is_Public (Id, Is_Public (Tag_Typ)); + + -- The internal flag is set to mark these declarations because + -- they have specific properties. First they are primitives even + -- if they are not defined in the type scope (the freezing point + -- is not necessarily in the same scope), furthermore the + -- predefined equality can be overridden by a user-defined + -- equality, no body will be generated in this case. + + Set_Is_Internal (Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Id); + end if; + + if No (Ret_Type) then + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => Profile); + else + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => Profile, + Subtype_Mark => + New_Reference_To (Ret_Type, Loc)); + end if; + + -- If body case, return empty subprogram body. Note that this is + -- ill-formed, because there is not even a null statement, and + -- certainly not a return in the function case. The caller is + -- expected to do surgery on the body to add the appropriate stuff. + + if For_Body then + return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); + + -- For the case of _Input and _Ouput applied to an abstract type, + -- generate abstract specifications. These will never be called, + -- but we need the slots allocated in the dispatching table so + -- that typ'Class'Input and typ'Class'Output will work properly. + + elsif (Name = Name_uInput or else Name = Name_uOutput) + and then Is_Abstract (Tag_Typ) + then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- Normal spec case, where we return a subprogram declaration + + else + return Make_Subprogram_Declaration (Loc, Spec); + end if; + end Predef_Spec_Or_Body; + + ----------------------------- + -- Predef_Stream_Attr_Spec -- + ----------------------------- + + function Predef_Stream_Attr_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + For_Body : Boolean := False) + return Node_Id + is + Ret_Type : Entity_Id; + + begin + if Name = Name_uInput then + Ret_Type := Tag_Typ; + else + Ret_Type := Empty; + end if; + + return Predef_Spec_Or_Body (Loc, + Name => Name, + Tag_Typ => Tag_Typ, + Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), + Ret_Type => Ret_Type, + For_Body => For_Body); + end Predef_Stream_Attr_Spec; + + --------------------------------- + -- Predefined_Primitive_Bodies -- + --------------------------------- + + function Predefined_Primitive_Bodies + (Tag_Typ : Entity_Id; + Renamed_Eq : Node_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Decl : Node_Id; + Res : List_Id := New_List; + Prim : Elmt_Id; + Eq_Needed : Boolean; + Eq_Name : Name_Id; + Ent : Entity_Id; + + begin + -- See if we have a predefined "=" operator + + if Present (Renamed_Eq) then + Eq_Needed := True; + Eq_Name := Chars (Renamed_Eq); + + else + Eq_Needed := False; + Eq_Name := No_Name; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then Is_Internal (Node (Prim)) + then + Eq_Needed := True; + Eq_Name := Name_Op_Eq; + end if; + + Next_Elmt (Prim); + end loop; + end if; + + -- Body of _Size + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uSize, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Long_Long_Integer, + For_Body => True); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Attribute_Name => Name_Size))))); + + Append_To (Res, Decl); + + -- Bodies for Dispatching stream IO routines. We need these only for + -- non-limited types (in the limited case there is no dispatching). + -- and we always skip them in No_Run_Time mode where streams are not + -- permitted. + + if not (Is_Limited_Type (Tag_Typ) or else No_Run_Time) then + if No (TSS (Tag_Typ, Name_uRead)) then + Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if No (TSS (Tag_Typ, Name_uWrite)) then + Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + -- Skip bodies of _Input and _Output for the abstract case, since + -- the corresponding specs are abstract (see Predef_Spec_Or_Body) + + if not Is_Abstract (Tag_Typ) then + if No (TSS (Tag_Typ, Name_uInput)) then + Build_Record_Or_Elementary_Input_Function + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if No (TSS (Tag_Typ, Name_uOutput)) then + Build_Record_Or_Elementary_Output_Procedure + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + end if; + end if; + + if not Is_Limited_Type (Tag_Typ) then + + -- Body for equality + + if Eq_Needed then + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Boolean, + For_Body => True); + + declare + Def : constant Node_Id := Parent (Tag_Typ); + Variant_Case : Boolean := Has_Discriminants (Tag_Typ); + Comps : Node_Id := Empty; + Typ_Def : Node_Id := Type_Definition (Def); + Stmts : List_Id := New_List; + + begin + if Variant_Case then + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Typ_Def := Record_Extension_Part (Typ_Def); + end if; + + if Present (Typ_Def) then + Comps := Component_List (Typ_Def); + end if; + + Variant_Case := Present (Comps) + and then Present (Variant_Part (Comps)); + end if; + + if Variant_Case then + Append_To (Stmts, + Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); + Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))); + + else + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => + Expand_Record_Equality (Tag_Typ, + Typ => Tag_Typ, + Lhs => Make_Identifier (Loc, Name_X), + Rhs => Make_Identifier (Loc, Name_Y), + Bodies => Declarations (Decl)))); + end if; + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end; + Append_To (Res, Decl); + end if; + + -- Body for dispatching assignment + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + For_Body => True); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_X), + Expression => Make_Identifier (Loc, Name_Y))))); + + Append_To (Res, Decl); + end if; + + -- Generate dummy bodies for finalization actions of types that have + -- no controlled components. + + -- Skip this processing if we are in the finalization routine in the + -- runtime itself, otherwise we get hopelessly circularly confused! + + if In_Finalization_Root (Tag_Typ) then + null; + + -- Skip this in no run time mode (where finalization is never allowed) + + elsif No_Run_Time then + null; + + elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ)) + and then not Has_Controlled_Component (Tag_Typ) + then + if not Is_Limited_Type (Tag_Typ) then + Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust, True); + + if Is_Controlled (Tag_Typ) then + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Make_Adjust_Call ( + Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ, + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B)))); + + else + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Null_Statement (Loc)))); + end if; + + Append_To (Res, Decl); + end if; + + Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize, True); + + if Is_Controlled (Tag_Typ) then + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Make_Final_Call ( + Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ, + With_Detach => Make_Identifier (Loc, Name_B)))); + + else + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Null_Statement (Loc)))); + end if; + + Append_To (Res, Decl); + end if; + + return Res; + end Predefined_Primitive_Bodies; + + --------------------------------- + -- Predefined_Primitive_Freeze -- + --------------------------------- + + function Predefined_Primitive_Freeze + (Tag_Typ : Entity_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : List_Id := New_List; + Prim : Elmt_Id; + Frnodes : List_Id; + + begin + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Is_Internal (Node (Prim)) then + Frnodes := Freeze_Entity (Node (Prim), Loc); + + if Present (Frnodes) then + Append_List_To (Res, Frnodes); + end if; + end if; + + Next_Elmt (Prim); + end loop; + + return Res; + end Predefined_Primitive_Freeze; + +end Exp_Ch3; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads new file mode 100644 index 00000000000..ff65667b8e5 --- /dev/null +++ b/gcc/ada/exp_ch3.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 3 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.36 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 3 constructs + +with Types; use Types; +with Elists; use Elists; + +package Exp_Ch3 is + + procedure Expand_N_Object_Declaration (N : Node_Id); + procedure Expand_N_Subtype_Indication (N : Node_Id); + procedure Expand_N_Variant_Part (N : Node_Id); + procedure Expand_N_Full_Type_Declaration (N : Node_Id); + + procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id); + -- For a full type declaration that contains tasks, or that is a task, + -- check whether there exists an access type whose designated type is an + -- incomplete declarations for the current composite type. If so, build + -- the master for that access type, now that it is known to denote an + -- object with tasks. + + procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id); + -- Add a field _parent in the extension part of the record. + + procedure Build_Discr_Checking_Funcs (N : Node_Id); + -- Builds function which checks whether the component name is consistent + -- with the current discriminants. N is the full type declaration node, + -- and the discriminant checking functions are inserted after this node. + + function Build_Initialization_Call + (Loc : Source_Ptr; + Id_Ref : Node_Id; + Typ : Entity_Id; + In_Init_Proc : Boolean := False; + Enclos_Type : Entity_Id := Empty; + Discr_Map : Elist_Id := New_Elmt_List) + return List_Id; + -- Builds a call to the initialization procedure of the Id entity. Id_Ref + -- is either a new reference to Id (for record fields), or an indexed + -- component (for array elements). Loc is the source location for the + -- constructed tree, and Typ is the type of the entity (the initialization + -- procedure of the base type is the procedure that actually gets called). + -- In_Init_Proc has to be set to True when the call is itself in an Init + -- procedure in order to enable the use of discriminals. Enclos_type is + -- the type of the init_proc and it is used for various expansion cases + -- including the case where Typ is a task type which is a array component, + -- the indices of the enclosing type are used to build the string that + -- identifies each task at runtime. + -- + -- Discr_Map is used to replace discriminants by their discriminals in + -- expressions used to constrain record components. In the presence of + -- entry families bounded by discriminants, protected type discriminants + -- can appear within expressions in array bounds (not as stand-alone + -- identifiers) and a general replacement is necessary. + + procedure Freeze_Type (N : Node_Id); + -- This procedure executes the freezing actions associated with the given + -- freeze type node N. + + function Needs_Simple_Initialization (T : Entity_Id) return Boolean; + -- Certain types need initialization even though there is no specific + -- initialization routine. In this category are access types (which + -- need initializing to null), packed array types whose implementation + -- is a modular type, and all scalar types if Normalize_Scalars is set, + -- as well as private types whose underlying type is present and meets + -- any of these criteria. Finally, descendants of String and Wide_String + -- also need initialization in Initialize/Normalize_Scalars mode. + + function Get_Simple_Init_Val + (T : Entity_Id; + Loc : Source_Ptr) + return Node_Id; + -- For a type which Needs_Simple_Initialization (see above), prepares + -- the tree for an expression representing the required initial value. + -- Loc is the source location used in constructing this tree which is + -- returned as the result of the call. + +end Exp_Ch3; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb new file mode 100644 index 00000000000..2f140685afb --- /dev/null +++ b/gcc/ada/exp_ch4.adb @@ -0,0 +1,5985 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 4 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.463 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; +with Exp_Fixd; use Exp_Fixd; +with Exp_Pakd; use Exp_Pakd; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; +with Hostparm; use Hostparm; +with Inline; use Inline; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Cat; use Sem_Cat; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Validsw; use Validsw; + +package body Exp_Ch4 is + + ------------------------ + -- Local Subprograms -- + ------------------------ + + procedure Binary_Op_Validity_Checks (N : Node_Id); + pragma Inline (Binary_Op_Validity_Checks); + -- Performs validity checks for a binary operator + + procedure Expand_Array_Comparison (N : Node_Id); + -- This routine handles expansion of the comparison operators (N_Op_Lt, + -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic + -- code for these operators is similar, differing only in the details of + -- the actual comparison call that is made. + + function Expand_Array_Equality + (Nod : Node_Id; + Typ : Entity_Id; + A_Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) + return Node_Id; + -- Expand an array equality into a call to a function implementing this + -- equality, and a call to it. Loc is the location for the generated + -- nodes. Typ is the type of the array, and Lhs, Rhs are the array + -- expressions to be compared. A_Typ is the type of the arguments, + -- which may be a private type, in which case Typ is its full view. + -- Bodies is a list on which to attach bodies of local functions that + -- are created in the process. This is the responsability of the + -- caller to insert those bodies at the right place. Nod provides + -- the Sloc value for the generated code. + + procedure Expand_Boolean_Operator (N : Node_Id); + -- Common expansion processing for Boolean operators (And, Or, Xor) + -- for the case of array type arguments. + + function Expand_Composite_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) + return Node_Id; + -- Local recursive function used to expand equality for nested + -- composite types. Used by Expand_Record/Array_Equality, Bodies + -- is a list on which to attach bodies of local functions that are + -- created in the process. This is the responsability of the caller + -- to insert those bodies at the right place. Nod provides the Sloc + -- value for generated code. + + procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id); + -- This routine handles expansion of concatenation operations, where + -- N is the N_Op_Concat node being expanded and Operands is the list + -- of operands (at least two are present). The caller has dealt with + -- converting any singleton operands into singleton aggregates. + + procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id); + -- Routine to expand concatenation of 2-5 operands (in the list Operands) + -- and replace node Cnode with the result of the contatenation. If there + -- are two operands, they can be string or character. If there are more + -- than two operands, then are always of type string (i.e. the caller has + -- already converted character operands to strings in this case). + + procedure Fixup_Universal_Fixed_Operation (N : Node_Id); + -- N is either an N_Op_Divide or N_Op_Multiply node whose result is + -- universal fixed. We do not have such a type at runtime, so the + -- purpose of this routine is to find the real type by looking up + -- the tree. We also determine if the operation must be rounded. + + procedure Insert_Dereference_Action (N : Node_Id); + -- N is an expression whose type is an access. When the type is derived + -- from Checked_Pool, expands a call to the primitive 'dereference'. + + function Make_Array_Comparison_Op + (Typ : Entity_Id; + Nod : Node_Id) + return Node_Id; + -- Comparisons between arrays are expanded in line. This function + -- produces the body of the implementation of (a > b), where a and b + -- are one-dimensional arrays of some discrete type. The original + -- node is then expanded into the appropriate call to this function. + -- Nod provides the Sloc value for the generated code. + + function Make_Boolean_Array_Op + (Typ : Entity_Id; + N : Node_Id) + return Node_Id; + -- Boolean operations on boolean arrays are expanded in line. This + -- function produce the body for the node N, which is (a and b), + -- (a or b), or (a xor b). It is used only the normal case and not + -- the packed case. The type involved, Typ, is the Boolean array type, + -- and the logical operations in the body are simple boolean operations. + -- Note that Typ is always a constrained type (the caller has ensured + -- this by using Convert_To_Actual_Subtype if necessary). + + procedure Rewrite_Comparison (N : Node_Id); + -- N is the node for a compile time comparison. If this outcome of this + -- comparison can be determined at compile time, then the node N can be + -- rewritten with True or False. If the outcome cannot be determined at + -- compile time, the call has no effect. + + function Tagged_Membership (N : Node_Id) return Node_Id; + -- Construct the expression corresponding to the tagged membership test. + -- Deals with a second operand being (or not) a class-wide type. + + procedure Unary_Op_Validity_Checks (N : Node_Id); + pragma Inline (Unary_Op_Validity_Checks); + -- Performs validity checks for a unary operator + + ------------------------------- + -- Binary_Op_Validity_Checks -- + ------------------------------- + + procedure Binary_Op_Validity_Checks (N : Node_Id) is + begin + if Validity_Checks_On and Validity_Check_Operands then + Ensure_Valid (Left_Opnd (N)); + Ensure_Valid (Right_Opnd (N)); + end if; + end Binary_Op_Validity_Checks; + + ----------------------------- + -- Expand_Array_Comparison -- + ----------------------------- + + -- Expansion is only required in the case of array types. The form of + -- the expansion is: + + -- [body for greater_nn; boolean_expression] + + -- The body is built by Make_Array_Comparison_Op, and the form of the + -- Boolean expression depends on the operator involved. + + procedure Expand_Array_Comparison (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Op1 : Node_Id := Left_Opnd (N); + Op2 : Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + Expr : Node_Id; + Func_Body : Node_Id; + Func_Name : Entity_Id; + + begin + -- For (a <= b) we convert to not (a > b) + + if Chars (N) = Name_Op_Le then + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Op1, + Right_Opnd => Op2))); + Analyze_And_Resolve (N, Standard_Boolean); + return; + + -- For < the Boolean expression is + -- greater__nn (op2, op1) + + elsif Chars (N) = Name_Op_Lt then + Func_Body := Make_Array_Comparison_Op (Typ1, N); + + -- Switch operands + + Op1 := Right_Opnd (N); + Op2 := Left_Opnd (N); + + -- For (a >= b) we convert to not (a < b) + + elsif Chars (N) = Name_Op_Ge then + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Op1, + Right_Opnd => Op2))); + Analyze_And_Resolve (N, Standard_Boolean); + return; + + -- For > the Boolean expression is + -- greater__nn (op1, op2) + + else + pragma Assert (Chars (N) = Name_Op_Gt); + Func_Body := Make_Array_Comparison_Op (Typ1, N); + end if; + + Func_Name := Defining_Unit_Name (Specification (Func_Body)); + Expr := + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => New_List (Op1, Op2)); + + Insert_Action (N, Func_Body); + Rewrite (N, Expr); + Analyze_And_Resolve (N, Standard_Boolean); + + end Expand_Array_Comparison; + + --------------------------- + -- Expand_Array_Equality -- + --------------------------- + + -- Expand an equality function for multi-dimensional arrays. Here is + -- an example of such a function for Nb_Dimension = 2 + + -- function Enn (A : arr; B : arr) return boolean is + -- J1 : integer; + -- J2 : integer; + -- + -- begin + -- if A'length (1) /= B'length (1) then + -- return false; + -- else + -- J1 := B'first (1); + -- for I1 in A'first (1) .. A'last (1) loop + -- if A'length (2) /= B'length (2) then + -- return false; + -- else + -- J2 := B'first (2); + -- for I2 in A'first (2) .. A'last (2) loop + -- if A (I1, I2) /= B (J1, J2) then + -- return false; + -- end if; + -- J2 := Integer'succ (J2); + -- end loop; + -- end if; + -- J1 := Integer'succ (J1); + -- end loop; + -- end if; + -- return true; + -- end Enn; + + function Expand_Array_Equality + (Nod : Node_Id; + Typ : Entity_Id; + A_Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + Actuals : List_Id; + Decls : List_Id := New_List; + Index_List1 : List_Id := New_List; + Index_List2 : List_Id := New_List; + Formals : List_Id; + Stats : Node_Id; + Func_Name : Entity_Id; + Func_Body : Node_Id; + + A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); + B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); + + function Component_Equality (Typ : Entity_Id) return Node_Id; + -- Create one statement to compare corresponding components, designated + -- by a full set of indices. + + function Loop_One_Dimension + (N : Int; + Index : Node_Id) + return Node_Id; + -- Loop over the n'th dimension of the arrays. The single statement + -- in the body of the loop is a loop over the next dimension, or + -- the comparison of corresponding components. + + ------------------------ + -- Component_Equality -- + ------------------------ + + function Component_Equality (Typ : Entity_Id) return Node_Id is + Test : Node_Id; + L, R : Node_Id; + + begin + -- if a(i1...) /= b(j1...) then return false; end if; + + L := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Chars (A)), + Expressions => Index_List1); + + R := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Chars (B)), + Expressions => Index_List2); + + Test := Expand_Composite_Equality + (Nod, Component_Type (Typ), L, R, Decls); + + return + Make_Implicit_If_Statement (Nod, + Condition => Make_Op_Not (Loc, Right_Opnd => Test), + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc)))); + + end Component_Equality; + + ------------------------ + -- Loop_One_Dimension -- + ------------------------ + + function Loop_One_Dimension + (N : Int; + Index : Node_Id) + return Node_Id + is + I : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('I')); + J : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('J')); + Index_Type : Entity_Id; + Stats : Node_Id; + + begin + if N > Number_Dimensions (Typ) then + return Component_Equality (Typ); + + else + -- Generate the following: + + -- j: index_type; + -- ... + + -- if a'length (n) /= b'length (n) then + -- return false; + -- else + -- j := b'first (n); + -- for i in a'range (n) loop + -- -- loop over remaining dimensions. + -- j := index_type'succ (j); + -- end loop; + -- end if; + + -- retrieve index type for current dimension. + + Index_Type := Base_Type (Etype (Index)); + Append (New_Reference_To (I, Loc), Index_List1); + Append (New_Reference_To (J, Loc), Index_List2); + + -- Declare index for j as a local variable to the function. + -- Index i is a loop variable. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => J, + Object_Definition => New_Reference_To (Index_Type, Loc))); + + Stats := + Make_Implicit_If_Statement (Nod, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (A, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (B, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, N)))), + + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc))), + + Else_Statements => New_List ( + + Make_Assignment_Statement (Loc, + Name => New_Reference_To (J, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (B, Loc), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, N)))), + + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => I, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (A, Loc), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))))), + + Statements => New_List ( + Loop_One_Dimension (N + 1, Next_Index (Index)), + Make_Assignment_Statement (Loc, + Name => New_Reference_To (J, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index_Type, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Reference_To (J, Loc)))))))); + + return Stats; + end if; + end Loop_One_Dimension; + + -- Start of processing for Expand_Array_Equality + + begin + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => New_Reference_To (Typ, Loc))); + + Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Stats := Loop_One_Dimension (1, First_Index (Typ)); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => Formals, + Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Stats, + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_True, Loc))))); + + Set_Has_Completion (Func_Name, True); + + -- If the array type is distinct from the type of the arguments, + -- it is the full view of a private type. Apply an unchecked + -- conversion to insure that analysis of the call succeeds. + + if Base_Type (A_Typ) /= Base_Type (Typ) then + Actuals := New_List ( + OK_Convert_To (Typ, Lhs), + OK_Convert_To (Typ, Rhs)); + else + Actuals := New_List (Lhs, Rhs); + end if; + + Append_To (Bodies, Func_Body); + + return + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => Actuals); + end Expand_Array_Equality; + + ----------------------------- + -- Expand_Boolean_Operator -- + ----------------------------- + + -- Note that we first get the actual subtypes of the operands, + -- since we always want to deal with types that have bounds. + + procedure Expand_Boolean_Operator (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + if Is_Bit_Packed_Array (Typ) then + Expand_Packed_Boolean_Operator (N); + + else + + -- For the normal non-packed case, the expansion is + -- to build a function for carrying out the comparison + -- (using Make_Boolean_Array_Op) and then inserting it + -- into the tree. The original operator node is then + -- rewritten as a call to this function. + + declare + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Relocate_Node (Left_Opnd (N)); + R : constant Node_Id := Relocate_Node (Right_Opnd (N)); + Func_Body : Node_Id; + Func_Name : Entity_Id; + begin + Convert_To_Actual_Subtype (L); + Convert_To_Actual_Subtype (R); + Ensure_Defined (Etype (L), N); + Ensure_Defined (Etype (R), N); + Apply_Length_Check (R, Etype (L)); + + Func_Body := Make_Boolean_Array_Op (Etype (L), N); + Func_Name := Defining_Unit_Name (Specification (Func_Body)); + Insert_Action (N, Func_Body); + + -- Now rewrite the expression with a call + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => + New_List + (L, Make_Type_Conversion + (Loc, New_Reference_To (Etype (L), Loc), R)))); + + Analyze_And_Resolve (N, Typ); + end; + end if; + end Expand_Boolean_Operator; + + ------------------------------- + -- Expand_Composite_Equality -- + ------------------------------- + + -- This function is only called for comparing internal fields of composite + -- types when these fields are themselves composites. This is a special + -- case because it is not possible to respect normal Ada visibility rules. + + function Expand_Composite_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + Full_Type : Entity_Id; + Prim : Elmt_Id; + Eq_Op : Entity_Id; + + begin + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Typ); + else + Full_Type := Typ; + end if; + + -- Defense against malformed private types with no completion + -- the error will be diagnosed later by check_completion + + if No (Full_Type) then + return New_Reference_To (Standard_False, Loc); + end if; + + Full_Type := Base_Type (Full_Type); + + if Is_Array_Type (Full_Type) then + + -- If the operand is an elementary type other than a floating-point + -- type, then we can simply use the built-in block bitwise equality, + -- since the predefined equality operators always apply and bitwise + -- equality is fine for all these cases. + + if Is_Elementary_Type (Component_Type (Full_Type)) + and then not Is_Floating_Point_Type (Component_Type (Full_Type)) + then + return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); + + -- For composite component types, and floating-point types, use + -- the expansion. This deals with tagged component types (where + -- we use the applicable equality routine) and floating-point, + -- (where we need to worry about negative zeroes), and also the + -- case of any composite type recursively containing such fields. + + else + return Expand_Array_Equality + (Nod, Full_Type, Typ, Lhs, Rhs, Bodies); + end if; + + elsif Is_Tagged_Type (Full_Type) then + + -- Call the primitive operation "=" of this type + + if Is_Class_Wide_Type (Full_Type) then + Full_Type := Root_Type (Full_Type); + end if; + + -- If this is derived from an untagged private type completed + -- with a tagged type, it does not have a full view, so we + -- use the primitive operations of the private type. + -- This check should no longer be necessary when these + -- types receive their full views ??? + + if Is_Private_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then not Is_Controlled (Typ) + and then Is_Derived_Type (Typ) + and then No (Full_View (Typ)) + then + Prim := First_Elmt (Collect_Primitive_Operations (Typ)); + else + Prim := First_Elmt (Primitive_Operations (Full_Type)); + end if; + + loop + Eq_Op := Node (Prim); + exit when Chars (Eq_Op) = Name_Op_Eq + and then Etype (First_Formal (Eq_Op)) = + Etype (Next_Formal (First_Formal (Eq_Op))); + Next_Elmt (Prim); + pragma Assert (Present (Prim)); + end loop; + + Eq_Op := Node (Prim); + + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => + New_List + (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), + Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs))); + + elsif Is_Record_Type (Full_Type) then + Eq_Op := TSS (Full_Type, Name_uEquality); + + if Present (Eq_Op) then + if Etype (First_Formal (Eq_Op)) /= Full_Type then + + -- Inherited equality from parent type. Convert the actuals + -- to match signature of operation. + + declare + T : Entity_Id := Etype (First_Formal (Eq_Op)); + + begin + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => + New_List (OK_Convert_To (T, Lhs), + OK_Convert_To (T, Rhs))); + end; + + else + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => New_List (Lhs, Rhs)); + end if; + + else + return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies); + end if; + + else + -- It can be a simple record or the full view of a scalar private + + return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); + end if; + end Expand_Composite_Equality; + + ------------------------------ + -- Expand_Concatenate_Other -- + ------------------------------ + + -- Let n be the number of array operands to be concatenated, Base_Typ + -- their base type, Ind_Typ their index type, and Arr_Typ the original + -- array type to which the concatenantion operator applies, then the + -- following subprogram is constructed: + -- + -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is + -- L : Ind_Typ; + -- begin + -- if S1'Length /= 0 then + -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained + -- XXX = Arr_Typ'First otherwise + -- elsif S2'Length /= 0 then + -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained + -- YYY = Arr_Typ'First otherwise + -- ... + -- elsif Sn-1'Length /= 0 then + -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained + -- ZZZ = Arr_Typ'First otherwise + -- else + -- return Sn; + -- end if; + -- + -- declare + -- P : Ind_Typ; + -- H : Ind_Typ := + -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length) + -- + Ind_Typ'Pos (L)); + -- R : Base_Typ (L .. H); + -- begin + -- if S1'Length /= 0 then + -- P := S1'First; + -- loop + -- R (L) := S1 (P); + -- L := Ind_Typ'Succ (L); + -- exit when P = S1'Last; + -- P := Ind_Typ'Succ (P); + -- end loop; + -- end if; + -- + -- if S2'Length /= 0 then + -- L := Ind_Typ'Succ (L); + -- loop + -- R (L) := S2 (P); + -- L := Ind_Typ'Succ (L); + -- exit when P = S2'Last; + -- P := Ind_Typ'Succ (P); + -- end loop; + -- end if; + -- + -- ... + -- + -- if Sn'Length /= 0 then + -- P := Sn'First; + -- loop + -- R (L) := Sn (P); + -- L := Ind_Typ'Succ (L); + -- exit when P = Sn'Last; + -- P := Ind_Typ'Succ (P); + -- end loop; + -- end if; + -- + -- return R; + -- end; + -- end Cnn;] + + procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is + Loc : constant Source_Ptr := Sloc (Cnode); + Nb_Opnds : constant Nat := List_Length (Opnds); + + Arr_Typ : constant Entity_Id := Etype (Entity (Cnode)); + Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode)); + Ind_Typ : constant Entity_Id := Etype (First_Index (Base_Typ)); + + Func_Id : Node_Id; + Func_Spec : Node_Id; + Param_Specs : List_Id; + + Func_Body : Node_Id; + Func_Decls : List_Id; + Func_Stmts : List_Id; + + L_Decl : Node_Id; + + If_Stmt : Node_Id; + Elsif_List : List_Id; + + Declare_Block : Node_Id; + Declare_Decls : List_Id; + Declare_Stmts : List_Id; + + H_Decl : Node_Id; + H_Init : Node_Id; + P_Decl : Node_Id; + R_Decl : Node_Id; + R_Constr : Node_Id; + R_Range : Node_Id; + + Params : List_Id; + Operand : Node_Id; + + function Copy_Into_R_S (I : Nat) return List_Id; + -- Builds the sequence of statement: + -- P := Si'First; + -- loop + -- R (L) := Si (P); + -- L := Ind_Typ'Succ (L); + -- exit when P = Si'Last; + -- P := Ind_Typ'Succ (P); + -- end loop; + -- + -- where i is the input parameter I given. + + function Init_L (I : Nat) return Node_Id; + -- Builds the statement: + -- L := Arr_Typ'First; If Arr_Typ is constrained + -- L := Si'First; otherwise (where I is the input param given) + + function H return Node_Id; + -- Builds reference to identifier H. + + function Ind_Val (E : Node_Id) return Node_Id; + -- Builds expression Ind_Typ'Val (E); + + function L return Node_Id; + -- Builds reference to identifier L. + + function L_Pos return Node_Id; + -- Builds expression Ind_Typ'Pos (L). + + function L_Succ return Node_Id; + -- Builds expression Ind_Typ'Succ (L). + + function One return Node_Id; + -- Builds integer literal one. + + function P return Node_Id; + -- Builds reference to identifier P. + + function P_Succ return Node_Id; + -- Builds expression Ind_Typ'Succ (P). + + function R return Node_Id; + -- Builds reference to identifier R. + + function S (I : Nat) return Node_Id; + -- Builds reference to identifier Si, where I is the value given. + + function S_First (I : Nat) return Node_Id; + -- Builds expression Si'First, where I is the value given. + + function S_Last (I : Nat) return Node_Id; + -- Builds expression Si'Last, where I is the value given. + + function S_Length (I : Nat) return Node_Id; + -- Builds expression Si'Length, where I is the value given. + + function S_Length_Test (I : Nat) return Node_Id; + -- Builds expression Si'Length /= 0, where I is the value given. + + ------------------- + -- Copy_Into_R_S -- + ------------------- + + function Copy_Into_R_S (I : Nat) return List_Id is + Stmts : List_Id := New_List; + P_Start : Node_Id; + Loop_Stmt : Node_Id; + R_Copy : Node_Id; + Exit_Stmt : Node_Id; + L_Inc : Node_Id; + P_Inc : Node_Id; + + begin + -- First construct the initializations + + P_Start := Make_Assignment_Statement (Loc, + Name => P, + Expression => S_First (I)); + Append_To (Stmts, P_Start); + + -- Then build the loop + + R_Copy := Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => R, + Expressions => New_List (L)), + Expression => Make_Indexed_Component (Loc, + Prefix => S (I), + Expressions => New_List (P))); + + L_Inc := Make_Assignment_Statement (Loc, + Name => L, + Expression => L_Succ); + + Exit_Stmt := Make_Exit_Statement (Loc, + Condition => Make_Op_Eq (Loc, P, S_Last (I))); + + P_Inc := Make_Assignment_Statement (Loc, + Name => P, + Expression => P_Succ); + + Loop_Stmt := + Make_Implicit_Loop_Statement (Cnode, + Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc)); + + Append_To (Stmts, Loop_Stmt); + + return Stmts; + end Copy_Into_R_S; + + ------- + -- H -- + ------- + + function H return Node_Id is + begin + return Make_Identifier (Loc, Name_uH); + end H; + + ------------- + -- Ind_Val -- + ------------- + + function Ind_Val (E : Node_Id) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (E)); + end Ind_Val; + + ------------ + -- Init_L -- + ------------ + + function Init_L (I : Nat) return Node_Id is + E : Node_Id; + + begin + if Is_Constrained (Arr_Typ) then + E := Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Arr_Typ, Loc), + Attribute_Name => Name_First); + + else + E := S_First (I); + end if; + + return Make_Assignment_Statement (Loc, Name => L, Expression => E); + end Init_L; + + ------- + -- L -- + ------- + + function L return Node_Id is + begin + return Make_Identifier (Loc, Name_uL); + end L; + + ----------- + -- L_Pos -- + ----------- + + function L_Pos return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (L)); + end L_Pos; + + ------------ + -- L_Succ -- + ------------ + + function L_Succ return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List (L)); + end L_Succ; + + --------- + -- One -- + --------- + + function One return Node_Id is + begin + return Make_Integer_Literal (Loc, 1); + end One; + + ------- + -- P -- + ------- + + function P return Node_Id is + begin + return Make_Identifier (Loc, Name_uP); + end P; + + ------------ + -- P_Succ -- + ------------ + + function P_Succ return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List (P)); + end P_Succ; + + ------- + -- R -- + ------- + + function R return Node_Id is + begin + return Make_Identifier (Loc, Name_uR); + end R; + + ------- + -- S -- + ------- + + function S (I : Nat) return Node_Id is + begin + return Make_Identifier (Loc, New_External_Name ('S', I)); + end S; + + ------------- + -- S_First -- + ------------- + + function S_First (I : Nat) return Node_Id is + begin + return Make_Attribute_Reference (Loc, + Prefix => S (I), + Attribute_Name => Name_First); + end S_First; + + ------------ + -- S_Last -- + ------------ + + function S_Last (I : Nat) return Node_Id is + begin + return Make_Attribute_Reference (Loc, + Prefix => S (I), + Attribute_Name => Name_Last); + end S_Last; + + -------------- + -- S_Length -- + -------------- + + function S_Length (I : Nat) return Node_Id is + begin + return Make_Attribute_Reference (Loc, + Prefix => S (I), + Attribute_Name => Name_Length); + end S_Length; + + ------------------- + -- S_Length_Test -- + ------------------- + + function S_Length_Test (I : Nat) return Node_Id is + begin + return + Make_Op_Ne (Loc, + Left_Opnd => S_Length (I), + Right_Opnd => Make_Integer_Literal (Loc, 0)); + end S_Length_Test; + + -- Start of processing for Expand_Concatenate_Other + + begin + -- Construct the parameter specs and the overall function spec + + Param_Specs := New_List; + for I in 1 .. Nb_Opnds loop + Append_To + (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_External_Name ('S', I)), + Parameter_Type => New_Reference_To (Base_Typ, Loc))); + end loop; + + Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Id, + Parameter_Specifications => Param_Specs, + Subtype_Mark => New_Reference_To (Base_Typ, Loc)); + + -- Construct L's object declaration + + L_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL), + Object_Definition => New_Reference_To (Ind_Typ, Loc)); + + Func_Decls := New_List (L_Decl); + + -- Construct the if-then-elsif statements + + Elsif_List := New_List; + for I in 2 .. Nb_Opnds - 1 loop + Append_To (Elsif_List, Make_Elsif_Part (Loc, + Condition => S_Length_Test (I), + Then_Statements => New_List (Init_L (I)))); + end loop; + + If_Stmt := + Make_Implicit_If_Statement (Cnode, + Condition => S_Length_Test (1), + Then_Statements => New_List (Init_L (1)), + Elsif_Parts => Elsif_List, + Else_Statements => New_List (Make_Return_Statement (Loc, + Expression => S (Nb_Opnds)))); + + -- Construct the declaration for H + + P_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), + Object_Definition => New_Reference_To (Ind_Typ, Loc)); + + H_Init := Make_Op_Subtract (Loc, S_Length (1), One); + for I in 2 .. Nb_Opnds loop + H_Init := Make_Op_Add (Loc, H_Init, S_Length (I)); + end loop; + H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos)); + + H_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH), + Object_Definition => New_Reference_To (Ind_Typ, Loc), + Expression => H_Init); + + -- Construct the declaration for R + + R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H); + R_Constr := + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List (R_Range)); + + R_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR), + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Base_Typ, Loc), + Constraint => R_Constr)); + + -- Construct the declarations for the declare block + + Declare_Decls := New_List (P_Decl, H_Decl, R_Decl); + + -- Construct list of statements for the declare block + + Declare_Stmts := New_List; + for I in 1 .. Nb_Opnds loop + Append_To (Declare_Stmts, + Make_Implicit_If_Statement (Cnode, + Condition => S_Length_Test (I), + Then_Statements => Copy_Into_R_S (I))); + end loop; + + Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R)); + + -- Construct the declare block + + Declare_Block := Make_Block_Statement (Loc, + Declarations => Declare_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts)); + + -- Construct the list of function statements + + Func_Stmts := New_List (If_Stmt, Declare_Block); + + -- Construct the function body + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => Func_Spec, + Declarations => Func_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts)); + + -- Insert the newly generated function in the code. This is analyzed + -- with all checks off, since we have completed all the checks. + + -- Note that this does *not* fix the array concatenation bug when the + -- low bound is Integer'first sibce that bug comes from the pointer + -- derefencing an unconstrained array. An there we need a constraint + -- check to make sure the length of the concatenated array is ok. ??? + + Insert_Action (Cnode, Func_Body, Suppress => All_Checks); + + -- Construct list of arguments for the function call + + Params := New_List; + Operand := First (Opnds); + for I in 1 .. Nb_Opnds loop + Append_To (Params, Relocate_Node (Operand)); + Next (Operand); + end loop; + + -- Insert the function call + + Rewrite + (Cnode, + Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params)); + + Analyze_And_Resolve (Cnode, Base_Typ); + Set_Is_Inlined (Func_Id); + end Expand_Concatenate_Other; + + ------------------------------- + -- Expand_Concatenate_String -- + ------------------------------- + + procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is + Loc : constant Source_Ptr := Sloc (Cnode); + Opnd1 : constant Node_Id := First (Opnds); + Opnd2 : constant Node_Id := Next (Opnd1); + Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1)); + Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2)); + + R : RE_Id; + -- RE_Id value for function to be called + + begin + -- In all cases, we build a call to a routine giving the list of + -- arguments as the parameter list to the routine. + + case List_Length (Opnds) is + when 2 => + if Typ1 = Standard_Character then + if Typ2 = Standard_Character then + R := RE_Str_Concat_CC; + + else + pragma Assert (Typ2 = Standard_String); + R := RE_Str_Concat_CS; + end if; + + elsif Typ1 = Standard_String then + if Typ2 = Standard_Character then + R := RE_Str_Concat_SC; + + else + pragma Assert (Typ2 = Standard_String); + R := RE_Str_Concat; + end if; + + -- If we have anything other than Standard_Character or + -- Standard_String, then we must have had an error earlier. + -- So we just abandon the attempt at expansion. + + else + pragma Assert (Errors_Detected > 0); + return; + end if; + + when 3 => + R := RE_Str_Concat_3; + + when 4 => + R := RE_Str_Concat_4; + + when 5 => + R := RE_Str_Concat_5; + + when others => + R := RE_Null; + raise Program_Error; + end case; + + -- Now generate the appropriate call + + Rewrite (Cnode, + Make_Function_Call (Sloc (Cnode), + Name => New_Occurrence_Of (RTE (R), Loc), + Parameter_Associations => Opnds)); + + Analyze_And_Resolve (Cnode, Standard_String); + end Expand_Concatenate_String; + + ------------------------ + -- Expand_N_Allocator -- + ------------------------ + + procedure Expand_N_Allocator (N : Node_Id) is + PtrT : constant Entity_Id := Etype (N); + Desig : Entity_Id; + Loc : constant Source_Ptr := Sloc (N); + Temp : Entity_Id; + Node : Node_Id; + + begin + -- RM E.2.3(22). We enforce that the expected type of an allocator + -- shall not be a remote access-to-class-wide-limited-private type + + -- Why is this being done at expansion time, seems clearly wrong ??? + + Validate_Remote_Access_To_Class_Wide_Type (N); + + -- Set the Storage Pool + + Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT))); + + if Present (Storage_Pool (N)) then + if Is_RTE (Storage_Pool (N), RE_SS_Pool) then + if not Java_VM then + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); + end if; + else + Set_Procedure_To_Call (N, + Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate)); + end if; + end if; + + -- Under certain circumstances we can replace an allocator by an + -- access to statically allocated storage. The conditions, as noted + -- in AARM 3.10 (10c) are as follows: + + -- Size and initial value is known at compile time + -- Access type is access-to-constant + + if Is_Access_Constant (PtrT) + and then Nkind (Expression (N)) = N_Qualified_Expression + and then Compile_Time_Known_Value (Expression (Expression (N))) + and then Size_Known_At_Compile_Time (Etype (Expression + (Expression (N)))) + then + -- Here we can do the optimization. For the allocator + + -- new x'(y) + + -- We insert an object declaration + + -- Tnn : aliased x := y; + + -- and replace the allocator by Tnn'Unrestricted_Access. + -- Tnn is marked as requiring static allocation. + + Temp := + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + Desig := Subtype_Mark (Expression (N)); + + -- If context is constrained, use constrained subtype directly, + -- so that the constant is not labelled as having a nomimally + -- unconstrained subtype. + + if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then + Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc); + end if; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Aliased_Present => True, + Constant_Present => Is_Access_Constant (PtrT), + Object_Definition => Desig, + Expression => Expression (Expression (N)))); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + Analyze_And_Resolve (N, PtrT); + + -- We set the variable as statically allocated, since we don't + -- want it going on the stack of the current procedure! + + Set_Is_Statically_Allocated (Temp); + return; + end if; + + -- If the allocator is for a type which requires initialization, and + -- there is no initial value (i.e. the operand is a subtype indication + -- rather than a qualifed expression), then we must generate a call to + -- the initialization routine. This is done using an expression actions + -- node: + -- + -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] + -- + -- Here ptr_T is the pointer type for the allocator, and T is the + -- subtype of the allocator. A special case arises if the designated + -- type of the access type is a task or contains tasks. In this case + -- the call to Init (Temp.all ...) is replaced by code that ensures + -- that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block + -- for details). In addition, if the type T is a task T, then the first + -- argument to Init must be converted to the task record type. + + if Nkind (Expression (N)) = N_Qualified_Expression then + declare + Indic : constant Node_Id := Subtype_Mark (Expression (N)); + T : constant Entity_Id := Entity (Indic); + Exp : constant Node_Id := Expression (Expression (N)); + + Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); + + Tag_Assign : Node_Id; + Tmp_Node : Node_Id; + + begin + if Is_Tagged_Type (T) or else Controlled_Type (T) then + + -- Actions inserted before: + -- Temp : constant ptr_T := new T'(Expression); + -- <no CW> Temp._tag := T'tag; + -- <CTRL> Adjust (Finalizable (Temp.all)); + -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all)); + + -- We analyze by hand the new internal allocator to avoid + -- any recursion and inappropriate call to Initialize + if not Aggr_In_Place then + Remove_Side_Effects (Exp); + end if; + + Temp := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + -- For a class wide allocation generate the following code: + + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is <Class_Wide_Subytpe>; + -- temp : PtrT := new CW'(CW!(expr)); + + if Is_Class_Wide_Type (T) then + Expand_Subtype_From_Expr (Empty, T, Indic, Exp); + + Set_Expression (Expression (N), + Unchecked_Convert_To (Entity (Indic), Exp)); + + Analyze_And_Resolve (Expression (N), Entity (Indic)); + end if; + + if Aggr_In_Place then + Tmp_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Make_Allocator (Loc, + New_Reference_To (Etype (Exp), Loc))); + + Set_No_Initialization (Expression (Tmp_Node)); + Insert_Action (N, Tmp_Node); + Convert_Aggr_In_Allocator (Tmp_Node, Exp); + else + Node := Relocate_Node (N); + Set_Analyzed (Node); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Node)); + end if; + + -- Suppress the tag assignment when Java_VM because JVM tags + -- are represented implicitly in objects. + + if Is_Tagged_Type (T) + and then not Is_Class_Wide_Type (T) + and then not Java_VM + then + Tag_Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Temp, Loc), + Selector_Name => + New_Reference_To (Tag_Component (T), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Access_Disp_Table (T), Loc))); + + -- The previous assignment has to be done in any case + + Set_Assignment_OK (Name (Tag_Assign)); + Insert_Action (N, Tag_Assign); + + elsif Is_Private_Type (T) + and then Is_Tagged_Type (Underlying_Type (T)) + and then not Java_VM + then + declare + Utyp : constant Entity_Id := Underlying_Type (T); + Ref : constant Node_Id := + Unchecked_Convert_To (Utyp, + Make_Explicit_Dereference (Loc, + New_Reference_To (Temp, Loc))); + + begin + Tag_Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Ref, + Selector_Name => + New_Reference_To (Tag_Component (Utyp), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To ( + Access_Disp_Table (Utyp), Loc))); + + Set_Assignment_OK (Name (Tag_Assign)); + Insert_Action (N, Tag_Assign); + end; + end if; + + if Controlled_Type (Designated_Type (PtrT)) + and then Controlled_Type (T) + then + declare + Flist : Node_Id; + Attach : Node_Id; + Apool : constant Entity_Id := + Associated_Storage_Pool (PtrT); + + begin + -- If it is an allocation on the secondary stack + -- (i.e. a value returned from a function), the object + -- is attached on the caller side as soon as the call + -- is completed (see Expand_Ctrl_Function_Call) + + if Is_RTE (Apool, RE_SS_Pool) then + declare + F : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('F')); + begin + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => F, + Object_Definition => New_Reference_To (RTE + (RE_Finalizable_Ptr), Loc))); + + Flist := New_Reference_To (F, Loc); + Attach := Make_Integer_Literal (Loc, 1); + end; + + -- Normal case, not a secondary stack allocation + + else + Flist := Find_Final_List (PtrT); + Attach := Make_Integer_Literal (Loc, 2); + end if; + + if not Aggr_In_Place then + Insert_Actions (N, + Make_Adjust_Call ( + Ref => + + -- An unchecked conversion is needed in the + -- classwide case because the designated type + -- can be an ancestor of the subtype mark of + -- the allocator. + + Unchecked_Convert_To (T, + Make_Explicit_Dereference (Loc, + New_Reference_To (Temp, Loc))), + + Typ => T, + Flist_Ref => Flist, + With_Attach => Attach)); + end if; + end; + end if; + + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + + elsif Aggr_In_Place then + Temp := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Tmp_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Make_Allocator (Loc, + New_Reference_To (Etype (Exp), Loc))); + + Set_No_Initialization (Expression (Tmp_Node)); + Insert_Action (N, Tmp_Node); + Convert_Aggr_In_Allocator (Tmp_Node, Exp); + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + + elsif Is_Access_Type (Designated_Type (PtrT)) + and then Nkind (Exp) = N_Allocator + and then Nkind (Expression (Exp)) /= N_Qualified_Expression + then + -- Apply constraint to designated subtype indication. + + Apply_Constraint_Check (Expression (Exp), + Designated_Type (Designated_Type (PtrT)), + No_Sliding => True); + + if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then + + -- Propagate constraint_error to enclosing allocator. + + Rewrite + (Exp, New_Copy (Expression (Exp))); + end if; + else + -- First check against the type of the qualified expression + -- + -- NOTE: The commented call should be correct, but for + -- some reason causes the compiler to bomb (sigsegv) on + -- ACVC test c34007g, so for now we just perform the old + -- (incorrect) test against the designated subtype with + -- no sliding in the else part of the if statement below. + -- ??? + -- + -- Apply_Constraint_Check (Exp, T, No_Sliding => True); + + -- A check is also needed in cases where the designated + -- subtype is constrained and differs from the subtype + -- given in the qualified expression. Note that the check + -- on the qualified expression does not allow sliding, + -- but this check does (a relaxation from Ada 83). + + if Is_Constrained (Designated_Type (PtrT)) + and then not Subtypes_Statically_Match + (T, Designated_Type (PtrT)) + then + Apply_Constraint_Check + (Exp, Designated_Type (PtrT), No_Sliding => False); + + -- The nonsliding check should really be performed + -- (unconditionally) against the subtype of the + -- qualified expression, but that causes a problem + -- with c34007g (see above), so for now we retain this. + + else + Apply_Constraint_Check + (Exp, Designated_Type (PtrT), No_Sliding => True); + end if; + end if; + end; + + -- Here if not qualified expression case. + -- In this case, an initialization routine may be required + + else + declare + T : constant Entity_Id := Entity (Expression (N)); + Init : Entity_Id; + Arg1 : Node_Id; + Args : List_Id; + Decls : List_Id; + Decl : Node_Id; + Discr : Elmt_Id; + Flist : Node_Id; + Temp_Decl : Node_Id; + Temp_Type : Entity_Id; + + begin + + if No_Initialization (N) then + null; + + -- Case of no initialization procedure present + + elsif not Has_Non_Null_Base_Init_Proc (T) then + + -- Case of simple initialization required + + if Needs_Simple_Initialization (T) then + Rewrite (Expression (N), + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Expression => Get_Simple_Init_Val (T, Loc))); + + Analyze_And_Resolve (Expression (Expression (N)), T); + Analyze_And_Resolve (Expression (N), T); + Set_Paren_Count (Expression (Expression (N)), 1); + Expand_N_Allocator (N); + + -- No initialization required + + else + null; + end if; + + -- Case of initialization procedure present, must be called + + else + Init := Base_Init_Proc (T); + Node := N; + Temp := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + -- Construct argument list for the initialization routine call + -- The CPP constructor needs the address directly + + if Is_CPP_Class (T) then + Arg1 := New_Reference_To (Temp, Loc); + Temp_Type := T; + + else + Arg1 := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc)); + Set_Assignment_OK (Arg1); + Temp_Type := PtrT; + + -- The initialization procedure expects a specific type. + -- if the context is access to class wide, indicate that + -- the object being allocated has the right specific type. + + if Is_Class_Wide_Type (Designated_Type (PtrT)) then + Arg1 := Unchecked_Convert_To (T, Arg1); + end if; + end if; + + -- If designated type is a concurrent type or if it is a + -- private type whose definition is a concurrent type, + -- the first argument in the Init routine has to be + -- unchecked conversion to the corresponding record type. + -- If the designated type is a derived type, we also + -- convert the argument to its root type. + + if Is_Concurrent_Type (T) then + Arg1 := + Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Concurrent_Type (Full_View (T)) + then + Arg1 := + Unchecked_Convert_To + (Corresponding_Record_Type (Full_View (T)), Arg1); + + elsif Etype (First_Formal (Init)) /= Base_Type (T) then + + declare + Ftyp : constant Entity_Id := Etype (First_Formal (Init)); + + begin + Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); + Set_Etype (Arg1, Ftyp); + end; + end if; + + Args := New_List (Arg1); + + -- For the task case, pass the Master_Id of the access type + -- as the value of the _Master parameter, and _Chain as the + -- value of the _Chain parameter (_Chain will be defined as + -- part of the generated code for the allocator). + + if Has_Task (T) then + + if No (Master_Id (Base_Type (PtrT))) then + + -- The designated type was an incomplete type, and + -- the access type did not get expanded. Salvage + -- it now. + + Expand_N_Full_Type_Declaration + (Parent (Base_Type (PtrT))); + end if; + + -- If the context of the allocator is a declaration or + -- an assignment, we can generate a meaningful image for + -- it, even though subsequent assignments might remove + -- the connection between task and entity. + + if Nkind (Parent (N)) = N_Assignment_Statement then + declare + Nam : constant Node_Id := Name (Parent (N)); + + begin + if Is_Entity_Name (Nam) then + Decls := + Build_Task_Image_Decls ( + Loc, + New_Occurrence_Of + (Entity (Nam), Sloc (Nam)), T); + + else + Decls := Build_Task_Image_Decls (Loc, T, T); + end if; + end; + + elsif Nkind (Parent (N)) = N_Object_Declaration then + Decls := + Build_Task_Image_Decls ( + Loc, Defining_Identifier (Parent (N)), T); + + else + Decls := Build_Task_Image_Decls (Loc, T, T); + end if; + + Append_To (Args, + New_Reference_To + (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + + Decl := Last (Decls); + Append_To (Args, + New_Occurrence_Of (Defining_Identifier (Decl), Loc)); + + -- Has_Task is false, Decls not used + + else + Decls := No_List; + end if; + + -- Add discriminants if discriminated type + + if Has_Discriminants (T) then + Discr := First_Elmt (Discriminant_Constraint (T)); + + while Present (Discr) loop + Append (New_Copy (Elists.Node (Discr)), Args); + Next_Elmt (Discr); + end loop; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Has_Discriminants (Full_View (T)) + then + Discr := + First_Elmt (Discriminant_Constraint (Full_View (T))); + + while Present (Discr) loop + Append (New_Copy (Elists.Node (Discr)), Args); + Next_Elmt (Discr); + end loop; + end if; + + -- We set the allocator as analyzed so that when we analyze the + -- expression actions node, we do not get an unwanted recursive + -- expansion of the allocator expression. + + Set_Analyzed (N, True); + Node := Relocate_Node (N); + + -- Here is the transformation: + -- input: new T + -- output: Temp : constant ptr_T := new T; + -- Init (Temp.all, ...); + -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all)); + -- <CTRL> Initialize (Finalizable (Temp.all)); + + -- Here ptr_T is the pointer type for the allocator, and T + -- is the subtype of the allocator. + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (Temp_Type, Loc), + Expression => Node); + + Set_Assignment_OK (Temp_Decl); + + if Is_CPP_Class (T) then + Set_Aliased_Present (Temp_Decl); + end if; + + Insert_Action (N, Temp_Decl, Suppress => All_Checks); + + -- Case of designated type is task or contains task + -- Create block to activate created tasks, and insert + -- declaration for Task_Image variable ahead of call. + + if Has_Task (T) then + declare + L : List_Id := New_List; + Blk : Node_Id; + + begin + Build_Task_Allocate_Block (L, Node, Args); + Blk := Last (L); + + Insert_List_Before (First (Declarations (Blk)), Decls); + Insert_Actions (N, L); + end; + + else + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Init, Loc), + Parameter_Associations => Args)); + end if; + + if Controlled_Type (T) then + + -- If the context is an access parameter, we need to create + -- a non-anonymous access type in order to have a usable + -- final list, because there is otherwise no pool to which + -- the allocated object can belong. We create both the type + -- and the finalization chain here, because freezing an + -- internal type does not create such a chain. + + if Ekind (PtrT) = E_Anonymous_Access_Type then + declare + Acc : Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('I')); + begin + Insert_Action (N, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (T, Loc)))); + + Build_Final_List (N, Acc); + Flist := Find_Final_List (Acc); + end; + + else + Flist := Find_Final_List (PtrT); + end if; + + Insert_Actions (N, + Make_Init_Call ( + Ref => New_Copy_Tree (Arg1), + Typ => T, + Flist_Ref => Flist, + With_Attach => Make_Integer_Literal (Loc, 2))); + end if; + + if Is_CPP_Class (T) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Temp, Loc), + Attribute_Name => Name_Unchecked_Access)); + else + Rewrite (N, New_Reference_To (Temp, Loc)); + end if; + + Analyze_And_Resolve (N, PtrT); + end if; + end; + end if; + end Expand_N_Allocator; + + ----------------------- + -- Expand_N_And_Then -- + ----------------------- + + -- Expand into conditional expression if Actions present, and also + -- deal with optimizing case of arguments being True or False. + + procedure Expand_N_And_Then (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Actlist : List_Id; + + begin + -- Deal with non-standard booleans + + if Is_Boolean_Type (Typ) then + Adjust_Condition (Left); + Adjust_Condition (Right); + Set_Etype (N, Standard_Boolean); + end if; + + -- Check for cases of left argument is True or False + + if Nkind (Left) = N_Identifier then + + -- If left argument is True, change (True and then Right) to Right. + -- Any actions associated with Right will be executed unconditionally + -- and can thus be inserted into the tree unconditionally. + + if Entity (Left) = Standard_True then + if Present (Actions (N)) then + Insert_Actions (N, Actions (N)); + end if; + + Rewrite (N, Right); + Adjust_Result_Type (N, Typ); + return; + + -- If left argument is False, change (False and then Right) to + -- False. In this case we can forget the actions associated with + -- Right, since they will never be executed. + + elsif Entity (Left) = Standard_False then + Kill_Dead_Code (Right); + Kill_Dead_Code (Actions (N)); + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + Adjust_Result_Type (N, Typ); + return; + end if; + end if; + + -- If Actions are present, we expand + + -- left and then right + + -- into + + -- if left then right else false end + + -- with the actions becoming the Then_Actions of the conditional + -- expression. This conditional expression is then further expanded + -- (and will eventually disappear) + + if Present (Actions (N)) then + Actlist := Actions (N); + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Left, + Right, + New_Occurrence_Of (Standard_False, Loc)))); + + Set_Then_Actions (N, Actlist); + Analyze_And_Resolve (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + return; + end if; + + -- No actions present, check for cases of right argument True/False + + if Nkind (Right) = N_Identifier then + + -- Change (Left and then True) to Left. Note that we know there + -- are no actions associated with the True operand, since we + -- just checked for this case above. + + if Entity (Right) = Standard_True then + Rewrite (N, Left); + + -- Change (Left and then False) to False, making sure to preserve + -- any side effects associated with the Left operand. + + elsif Entity (Right) = Standard_False then + Remove_Side_Effects (Left); + Rewrite + (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + end if; + + Adjust_Result_Type (N, Typ); + end Expand_N_And_Then; + + ------------------------------------- + -- Expand_N_Conditional_Expression -- + ------------------------------------- + + -- Expand into expression actions if then/else actions present + + procedure Expand_N_Conditional_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Cond : constant Node_Id := First (Expressions (N)); + Thenx : constant Node_Id := Next (Cond); + Elsex : constant Node_Id := Next (Thenx); + Typ : constant Entity_Id := Etype (N); + Cnn : Entity_Id; + New_If : Node_Id; + + begin + -- If either then or else actions are present, then given: + + -- if cond then then-expr else else-expr end + + -- we insert the following sequence of actions (using Insert_Actions): + + -- Cnn : typ; + -- if cond then + -- <<then actions>> + -- Cnn := then-expr; + -- else + -- <<else actions>> + -- Cnn := else-expr + -- end if; + + -- and replace the conditional expression by a reference to Cnn. + + if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then + Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => Relocate_Node (Thenx))), + + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => Relocate_Node (Elsex)))); + + if Present (Then_Actions (N)) then + Insert_List_Before + (First (Then_Statements (New_If)), Then_Actions (N)); + end if; + + if Present (Else_Actions (N)) then + Insert_List_Before + (First (Else_Statements (New_If)), Else_Actions (N)); + end if; + + Rewrite (N, New_Occurrence_Of (Cnn, Loc)); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => New_Occurrence_Of (Typ, Loc))); + + Insert_Action (N, New_If); + Analyze_And_Resolve (N, Typ); + end if; + end Expand_N_Conditional_Expression; + + ----------------------------------- + -- Expand_N_Explicit_Dereference -- + ----------------------------------- + + procedure Expand_N_Explicit_Dereference (N : Node_Id) is + begin + -- The only processing required is an insertion of an explicit + -- dereference call for the checked storage pool case. + + Insert_Dereference_Action (Prefix (N)); + end Expand_N_Explicit_Dereference; + + ----------------- + -- Expand_N_In -- + ----------------- + + procedure Expand_N_In (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtyp : constant Entity_Id := Etype (N); + + begin + -- No expansion is required if we have an explicit range + + if Nkind (Right_Opnd (N)) = N_Range then + return; + + -- Here right operand is a subtype mark + + else + declare + Typ : Entity_Id := Etype (Right_Opnd (N)); + Obj : Node_Id := Left_Opnd (N); + Cond : Node_Id := Empty; + Is_Acc : Boolean := Is_Access_Type (Typ); + + begin + Remove_Side_Effects (Obj); + + -- For tagged type, do tagged membership operation + + if Is_Tagged_Type (Typ) then + -- No expansion will be performed when Java_VM, as the + -- JVM back end will handle the membership tests directly + -- (tags are not explicitly represented in Java objects, + -- so the normal tagged membership expansion is not what + -- we want). + + if not Java_VM then + Rewrite (N, Tagged_Membership (N)); + Analyze_And_Resolve (N, Rtyp); + end if; + + return; + + -- If type is scalar type, rewrite as x in t'first .. t'last + -- This reason we do this is that the bounds may have the wrong + -- type if they come from the original type definition. + + elsif Is_Scalar_Type (Typ) then + Rewrite (Right_Opnd (N), + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Reference_To (Typ, Loc)), + + High_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Reference_To (Typ, Loc)))); + Analyze_And_Resolve (N, Rtyp); + return; + end if; + + if Is_Acc then + Typ := Designated_Type (Typ); + end if; + + if not Is_Constrained (Typ) then + Rewrite (N, + New_Reference_To (Standard_True, Loc)); + Analyze_And_Resolve (N, Rtyp); + + -- For the constrained array case, we have to check the + -- subscripts for an exact match if the lengths are + -- non-zero (the lengths must match in any case). + + elsif Is_Array_Type (Typ) then + + declare + function Construct_Attribute_Reference + (E : Node_Id; + Nam : Name_Id; + Dim : Nat) + return Node_Id; + -- Build attribute reference E'Nam(Dim) + + function Construct_Attribute_Reference + (E : Node_Id; + Nam : Name_Id; + Dim : Nat) + return Node_Id + is + begin + return + Make_Attribute_Reference (Loc, + Prefix => E, + Attribute_Name => Nam, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))); + end Construct_Attribute_Reference; + + begin + for J in 1 .. Number_Dimensions (Typ) loop + Evolve_And_Then (Cond, + Make_Op_Eq (Loc, + Left_Opnd => + Construct_Attribute_Reference + (Duplicate_Subexpr (Obj), Name_First, J), + Right_Opnd => + Construct_Attribute_Reference + (New_Occurrence_Of (Typ, Loc), Name_First, J))); + + Evolve_And_Then (Cond, + Make_Op_Eq (Loc, + Left_Opnd => + Construct_Attribute_Reference + (Duplicate_Subexpr (Obj), Name_Last, J), + Right_Opnd => + Construct_Attribute_Reference + (New_Occurrence_Of (Typ, Loc), Name_Last, J))); + end loop; + + if Is_Acc then + Cond := Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Obj, + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Cond); + end if; + + Rewrite (N, Cond); + Analyze_And_Resolve (N, Rtyp); + end; + + -- These are the cases where constraint checks may be + -- required, e.g. records with possible discriminants + + else + -- Expand the test into a series of discriminant comparisons. + -- The expression that is built is the negation of the one + -- that is used for checking discriminant constraints. + + Obj := Relocate_Node (Left_Opnd (N)); + + if Has_Discriminants (Typ) then + Cond := Make_Op_Not (Loc, + Right_Opnd => Build_Discriminant_Checks (Obj, Typ)); + + if Is_Acc then + Cond := Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Obj, + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Cond); + end if; + + else + Cond := New_Occurrence_Of (Standard_True, Loc); + end if; + + Rewrite (N, Cond); + Analyze_And_Resolve (N, Rtyp); + end if; + end; + end if; + end Expand_N_In; + + -------------------------------- + -- Expand_N_Indexed_Component -- + -------------------------------- + + procedure Expand_N_Indexed_Component (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + P : constant Node_Id := Prefix (N); + T : constant Entity_Id := Etype (P); + + begin + -- A special optimization, if we have an indexed component that + -- is selecting from a slice, then we can eliminate the slice, + -- since, for example, x (i .. j)(k) is identical to x(k). The + -- only difference is the range check required by the slice. The + -- range check for the slice itself has already been generated. + -- The range check for the subscripting operation is ensured + -- by converting the subject to the subtype of the slice. + + -- This optimization not only generates better code, avoiding + -- slice messing especially in the packed case, but more importantly + -- bypasses some problems in handling this peculiar case, for + -- example, the issue of dealing specially with object renamings. + + if Nkind (P) = N_Slice then + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => Prefix (P), + Expressions => New_List ( + Convert_To + (Etype (First_Index (Etype (P))), + First (Expressions (N)))))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- If the prefix is an access type, then we unconditionally rewrite + -- if as an explicit deference. This simplifies processing for several + -- cases, including packed array cases and certain cases in which + -- checks must be generated. We used to try to do this only when it + -- was necessary, but it cleans up the code to do it all the time. + + if Is_Access_Type (T) then + Rewrite (P, + Make_Explicit_Dereference (Sloc (N), + Prefix => Relocate_Node (P))); + Analyze_And_Resolve (P, Designated_Type (T)); + end if; + + if Validity_Checks_On and then Validity_Check_Subscripts then + Apply_Subscript_Validity_Checks (N); + end if; + + -- All done for the non-packed case + + if not Is_Packed (Etype (Prefix (N))) then + return; + end if; + + -- For packed arrays that are not bit-packed (i.e. the case of an array + -- with one or more index types with a non-coniguous enumeration type), + -- we can always use the normal packed element get circuit. + + if not Is_Bit_Packed_Array (Etype (Prefix (N))) then + Expand_Packed_Element_Reference (N); + return; + end if; + + -- For a reference to a component of a bit packed array, we have to + -- convert it to a reference to the corresponding Packed_Array_Type. + -- We only want to do this for simple references, and not for: + + -- Left side of assignment (or prefix of left side of assignment) + -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement + + -- Renaming objects in renaming associations + -- This case is handled when a use of the renamed variable occurs + + -- Actual parameters for a procedure call + -- This case is handled in Exp_Ch6.Expand_Actuals + + -- The second expression in a 'Read attribute reference + + -- The prefix of an address or size attribute reference + + -- The following circuit detects these exceptions + + declare + Child : Node_Id := N; + Parnt : Node_Id := Parent (N); + + begin + loop + if Nkind (Parnt) = N_Unchecked_Expression then + null; + + elsif Nkind (Parnt) = N_Object_Renaming_Declaration + or else Nkind (Parnt) = N_Procedure_Call_Statement + or else (Nkind (Parnt) = N_Parameter_Association + and then + Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) + then + return; + + elsif Nkind (Parnt) = N_Attribute_Reference + and then (Attribute_Name (Parnt) = Name_Address + or else + Attribute_Name (Parnt) = Name_Size) + and then Prefix (Parnt) = Child + then + return; + + elsif Nkind (Parnt) = N_Assignment_Statement + and then Name (Parnt) = Child + then + return; + + elsif Nkind (Parnt) = N_Attribute_Reference + and then Attribute_Name (Parnt) = Name_Read + and then Next (First (Expressions (Parnt))) = Child + then + return; + + elsif (Nkind (Parnt) = N_Indexed_Component + or else Nkind (Parnt) = N_Selected_Component) + and then Prefix (Parnt) = Child + then + null; + + else + Expand_Packed_Element_Reference (N); + return; + end if; + + -- Keep looking up tree for unchecked expression, or if we are + -- the prefix of a possible assignment left side. + + Child := Parnt; + Parnt := Parent (Child); + end loop; + end; + + end Expand_N_Indexed_Component; + + --------------------- + -- Expand_N_Not_In -- + --------------------- + + -- Replace a not in b by not (a in b) so that the expansions for (a in b) + -- can be done. This avoids needing to duplicate this expansion code. + + procedure Expand_N_Not_In (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_In (Loc, + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N)))); + Analyze_And_Resolve (N, Typ); + end Expand_N_Not_In; + + ------------------- + -- Expand_N_Null -- + ------------------- + + -- The only replacement required is for the case of a null of type + -- that is an access to protected subprogram. We represent such + -- access values as a record, and so we must replace the occurrence + -- of null by the equivalent record (with a null address and a null + -- pointer in it), so that the backend creates the proper value. + + procedure Expand_N_Null (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Agg : Node_Id; + + begin + if Ekind (Typ) = E_Access_Protected_Subprogram_Type then + Agg := + Make_Aggregate (Loc, + Expressions => New_List ( + New_Occurrence_Of (RTE (RE_Null_Address), Loc), + Make_Null (Loc))); + + Rewrite (N, Agg); + Analyze_And_Resolve (N, Equivalent_Type (Typ)); + + -- For subsequent semantic analysis, the node must retain its + -- type. Gigi in any case replaces this type by the corresponding + -- record type before processing the node. + + Set_Etype (N, Typ); + end if; + end Expand_N_Null; + + --------------------- + -- Expand_N_Op_Abs -- + --------------------- + + procedure Expand_N_Op_Abs (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Expr : constant Node_Id := Right_Opnd (N); + + begin + Unary_Op_Validity_Checks (N); + + -- Deal with software overflow checking + + if Software_Overflow_Checking + and then Is_Signed_Integer_Type (Etype (N)) + and then Do_Overflow_Check (N) + then + -- Software overflow checking expands abs (expr) into + + -- (if expr >= 0 then expr else -expr) + + -- with the usual Duplicate_Subexpr use coding for expr + + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Ge (Loc, + Left_Opnd => Duplicate_Subexpr (Expr), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + + Duplicate_Subexpr (Expr), + + Make_Op_Minus (Loc, + Right_Opnd => Duplicate_Subexpr (Expr))))); + + Analyze_And_Resolve (N); + + -- Vax floating-point types case + + elsif Vax_Float (Etype (N)) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Abs; + + --------------------- + -- Expand_N_Op_Add -- + --------------------- + + procedure Expand_N_Op_Add (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + -- N + 0 = 0 + N = N for integer types + + if Is_Integer_Type (Typ) then + if Compile_Time_Known_Value (Right_Opnd (N)) + and then Expr_Value (Right_Opnd (N)) = Uint_0 + then + Rewrite (N, Left_Opnd (N)); + return; + + elsif Compile_Time_Known_Value (Left_Opnd (N)) + and then Expr_Value (Left_Opnd (N)) = Uint_0 + then + Rewrite (N, Right_Opnd (N)); + return; + end if; + end if; + + -- Arithemtic overflow checks for signed integer/fixed point types + + if Is_Signed_Integer_Type (Typ) + or else Is_Fixed_Point_Type (Typ) + then + Apply_Arithmetic_Overflow_Check (N); + return; + + -- Vax floating-point types case + + elsif Vax_Float (Typ) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Add; + + --------------------- + -- Expand_N_Op_And -- + --------------------- + + procedure Expand_N_Op_And (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Etype (N)) then + Expand_Boolean_Operator (N); + + elsif Is_Boolean_Type (Etype (N)) then + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + end Expand_N_Op_And; + + ------------------------ + -- Expand_N_Op_Concat -- + ------------------------ + + procedure Expand_N_Op_Concat (N : Node_Id) is + + Opnds : List_Id; + -- List of operands to be concatenated + + Opnd : Node_Id; + -- Single operand for concatenation + + Cnode : Node_Id; + -- Node which is to be replaced by the result of concatenating + -- the nodes in the list Opnds. + + Atyp : Entity_Id; + -- Array type of concatenation result type + + Ctyp : Entity_Id; + -- Component type of concatenation represented by Cnode + + begin + Binary_Op_Validity_Checks (N); + + -- If we are the left operand of a concatenation higher up the + -- tree, then do nothing for now, since we want to deal with a + -- series of concatenations as a unit. + + if Nkind (Parent (N)) = N_Op_Concat + and then N = Left_Opnd (Parent (N)) + then + return; + end if; + + -- We get here with a concatenation whose left operand may be a + -- concatenation itself with a consistent type. We need to process + -- these concatenation operands from left to right, which means + -- from the deepest node in the tree to the highest node. + + Cnode := N; + while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop + Cnode := Left_Opnd (Cnode); + end loop; + + -- Now Opnd is the deepest Opnd, and its parents are the concatenation + -- nodes above, so now we process bottom up, doing the operations. We + -- gather a string that is as long as possible up to five operands + + -- The outer loop runs more than once if there are more than five + -- concatenations of type Standard.String, the most we handle for + -- this case, or if more than one concatenation type is involved. + + Outer : loop + Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); + Set_Parent (Opnds, N); + + -- The inner loop gathers concatenation operands + + Inner : while Cnode /= N + and then (Base_Type (Etype (Cnode)) /= Standard_String + or else + List_Length (Opnds) < 5) + and then Base_Type (Etype (Cnode)) = + Base_Type (Etype (Parent (Cnode))) + loop + Cnode := Parent (Cnode); + Append (Right_Opnd (Cnode), Opnds); + end loop Inner; + + -- Here we process the collected operands. First we convert + -- singleton operands to singleton aggregates. This is skipped + -- however for the case of two operands of type String, since + -- we have special routines for these cases. + + Atyp := Base_Type (Etype (Cnode)); + Ctyp := Base_Type (Component_Type (Etype (Cnode))); + + if List_Length (Opnds) > 2 or else Atyp /= Standard_String then + Opnd := First (Opnds); + loop + if Base_Type (Etype (Opnd)) = Ctyp then + Rewrite (Opnd, + Make_Aggregate (Sloc (Cnode), + Expressions => New_List (Relocate_Node (Opnd)))); + Analyze_And_Resolve (Opnd, Atyp); + end if; + + Next (Opnd); + exit when No (Opnd); + end loop; + end if; + + -- Now call appropriate continuation routine + + if Atyp = Standard_String then + Expand_Concatenate_String (Cnode, Opnds); + else + Expand_Concatenate_Other (Cnode, Opnds); + end if; + + exit Outer when Cnode = N; + Cnode := Parent (Cnode); + end loop Outer; + end Expand_N_Op_Concat; + + ------------------------ + -- Expand_N_Op_Divide -- + ------------------------ + + procedure Expand_N_Op_Divide (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ltyp : constant Entity_Id := Etype (Left_Opnd (N)); + Rtyp : constant Entity_Id := Etype (Right_Opnd (N)); + Typ : Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + -- Vax_Float is a special case + + if Vax_Float (Typ) then + Expand_Vax_Arith (N); + return; + end if; + + -- N / 1 = N for integer types + + if Is_Integer_Type (Typ) + and then Compile_Time_Known_Value (Right_Opnd (N)) + and then Expr_Value (Right_Opnd (N)) = Uint_1 + then + Rewrite (N, Left_Opnd (N)); + return; + end if; + + -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that + -- Is_Power_Of_2_For_Shift is set means that we know that our left + -- operand is an unsigned integer, as required for this to work. + + if Nkind (Right_Opnd (N)) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Right_Opnd (N)) + then + Rewrite (N, + Make_Op_Shift_Right (Loc, + Left_Opnd => Left_Opnd (N), + Right_Opnd => + Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N))))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Do required fixup of universal fixed operation + + if Typ = Universal_Fixed then + Fixup_Universal_Fixed_Operation (N); + Typ := Etype (N); + end if; + + -- Divisions with fixed-point results + + if Is_Fixed_Point_Type (Typ) then + + -- No special processing if Treat_Fixed_As_Integer is set, + -- since from a semantic point of view such operations are + -- simply integer operations and will be treated that way. + + if not Treat_Fixed_As_Integer (N) then + if Is_Integer_Type (Rtyp) then + Expand_Divide_Fixed_By_Integer_Giving_Fixed (N); + else + Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N); + end if; + end if; + + -- Other cases of division of fixed-point operands. Again we + -- exclude the case where Treat_Fixed_As_Integer is set. + + elsif (Is_Fixed_Point_Type (Ltyp) or else + Is_Fixed_Point_Type (Rtyp)) + and then not Treat_Fixed_As_Integer (N) + then + if Is_Integer_Type (Typ) then + Expand_Divide_Fixed_By_Fixed_Giving_Integer (N); + else + pragma Assert (Is_Floating_Point_Type (Typ)); + Expand_Divide_Fixed_By_Fixed_Giving_Float (N); + end if; + + -- Mixed-mode operations can appear in a non-static universal + -- context, in which case the integer argument must be converted + -- explicitly. + + elsif Typ = Universal_Real + and then Is_Integer_Type (Rtyp) + then + Rewrite (Right_Opnd (N), + Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N)))); + + Analyze_And_Resolve (Right_Opnd (N), Universal_Real); + + elsif Typ = Universal_Real + and then Is_Integer_Type (Ltyp) + then + Rewrite (Left_Opnd (N), + Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N)))); + + Analyze_And_Resolve (Left_Opnd (N), Universal_Real); + + -- Non-fixed point cases, do zero divide and overflow checks + + elsif Is_Integer_Type (Typ) then + Apply_Divide_Check (N); + end if; + end Expand_N_Op_Divide; + + -------------------- + -- Expand_N_Op_Eq -- + -------------------- + + procedure Expand_N_Op_Eq (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Lhs : constant Node_Id := Left_Opnd (N); + Rhs : constant Node_Id := Right_Opnd (N); + A_Typ : Entity_Id := Etype (Lhs); + Typl : Entity_Id := A_Typ; + Op_Name : Entity_Id; + Prim : Elmt_Id; + Bodies : List_Id := New_List; + + procedure Build_Equality_Call (Eq : Entity_Id); + -- If a constructed equality exists for the type or for its parent, + -- build and analyze call, adding conversions if the operation is + -- inherited. + + ------------------------- + -- Build_Equality_Call -- + ------------------------- + + procedure Build_Equality_Call (Eq : Entity_Id) is + Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); + L_Exp : Node_Id := Relocate_Node (Lhs); + R_Exp : Node_Id := Relocate_Node (Rhs); + + begin + if Base_Type (Op_Type) /= Base_Type (A_Typ) + and then not Is_Class_Wide_Type (A_Typ) + then + L_Exp := OK_Convert_To (Op_Type, L_Exp); + R_Exp := OK_Convert_To (Op_Type, R_Exp); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Eq, Loc), + Parameter_Associations => New_List (L_Exp, R_Exp))); + + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end Build_Equality_Call; + + -- Start of processing for Expand_N_Op_Eq + + begin + Binary_Op_Validity_Checks (N); + + if Ekind (Typl) = E_Private_Type then + Typl := Underlying_Type (Typl); + + elsif Ekind (Typl) = E_Private_Subtype then + Typl := Underlying_Type (Base_Type (Typl)); + end if; + + -- It may happen in error situations that the underlying type is not + -- set. The error will be detected later, here we just defend the + -- expander code. + + if No (Typl) then + return; + end if; + + Typl := Base_Type (Typl); + + -- Vax float types + + if Vax_Float (Typl) then + Expand_Vax_Comparison (N); + return; + + -- Boolean types (requiring handling of non-standard case) + + elsif Is_Boolean_Type (Typl) then + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + + -- Array types + + elsif Is_Array_Type (Typl) then + + -- Packed case + + if Is_Bit_Packed_Array (Typl) then + Expand_Packed_Eq (N); + + -- For non-floating-point elementary types, the primitive equality + -- always applies, and block-bit comparison is fine. Floating-point + -- is an exception because of negative zeroes. + + -- However, we never use block bit comparison in No_Run_Time mode, + -- since this may result in a call to a run time routine + + elsif Is_Elementary_Type (Component_Type (Typl)) + and then not Is_Floating_Point_Type (Component_Type (Typl)) + and then not No_Run_Time + then + null; + + -- For composite and floating-point cases, expand equality loop + -- to make sure of using proper comparisons for tagged types, + -- and correctly handling the floating-point case. + + else + Rewrite (N, + Expand_Array_Equality (N, Typl, A_Typ, + Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies)); + + Insert_Actions (N, Bodies, Suppress => All_Checks); + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end if; + + -- Record Types + + elsif Is_Record_Type (Typl) then + + -- For tagged types, use the primitive "=" + + if Is_Tagged_Type (Typl) then + + -- If this is derived from an untagged private type completed + -- with a tagged type, it does not have a full view, so we + -- use the primitive operations of the private type. + -- This check should no longer be necessary when these + -- types receive their full views ??? + + if Is_Private_Type (A_Typ) + and then not Is_Tagged_Type (A_Typ) + and then Is_Derived_Type (A_Typ) + and then No (Full_View (A_Typ)) + then + Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); + + while Chars (Node (Prim)) /= Name_Op_Eq loop + Next_Elmt (Prim); + pragma Assert (Present (Prim)); + end loop; + + Op_Name := Node (Prim); + else + Op_Name := Find_Prim_Op (Typl, Name_Op_Eq); + end if; + + Build_Equality_Call (Op_Name); + + -- If a type support function is present (for complex cases), use it + + elsif Present (TSS (Root_Type (Typl), Name_uEquality)) then + Build_Equality_Call (TSS (Root_Type (Typl), Name_uEquality)); + + -- Otherwise expand the component by component equality. Note that + -- we never use block-bit coparisons for records, because of the + -- problems with gaps. The backend will often be able to recombine + -- the separate comparisons that we generate here. + + else + Remove_Side_Effects (Lhs); + Remove_Side_Effects (Rhs); + Rewrite (N, + Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies)); + + Insert_Actions (N, Bodies, Suppress => All_Checks); + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end if; + end if; + + -- If we still have an equality comparison (i.e. it was not rewritten + -- in some way), then we can test if result is needed at compile time). + + if Nkind (N) = N_Op_Eq then + Rewrite_Comparison (N); + end if; + end Expand_N_Op_Eq; + + ----------------------- + -- Expand_N_Op_Expon -- + ----------------------- + + procedure Expand_N_Op_Expon (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Rtyp : constant Entity_Id := Root_Type (Typ); + Base : constant Node_Id := Relocate_Node (Left_Opnd (N)); + Exp : constant Node_Id := Relocate_Node (Right_Opnd (N)); + Exptyp : constant Entity_Id := Etype (Exp); + Ovflo : constant Boolean := Do_Overflow_Check (N); + Expv : Uint; + Xnode : Node_Id; + Temp : Node_Id; + Rent : RE_Id; + Ent : Entity_Id; + + begin + Binary_Op_Validity_Checks (N); + + -- At this point the exponentiation must be dynamic since the static + -- case has already been folded after Resolve by Eval_Op_Expon. + + -- Test for case of literal right argument + + if Compile_Time_Known_Value (Exp) then + Expv := Expr_Value (Exp); + + -- We only fold small non-negative exponents. You might think we + -- could fold small negative exponents for the real case, but we + -- can't because we are required to raise Constraint_Error for + -- the case of 0.0 ** (negative) even if Machine_Overflows = False. + -- See ACVC test C4A012B. + + if Expv >= 0 and then Expv <= 4 then + + -- X ** 0 = 1 (or 1.0) + + if Expv = 0 then + if Ekind (Typ) in Integer_Kind then + Xnode := Make_Integer_Literal (Loc, Intval => 1); + else + Xnode := Make_Real_Literal (Loc, Ureal_1); + end if; + + -- X ** 1 = X + + elsif Expv = 1 then + Xnode := Base; + + -- X ** 2 = X * X + + elsif Expv = 2 then + Xnode := + Make_Op_Multiply (Loc, + Left_Opnd => Duplicate_Subexpr (Base), + Right_Opnd => Duplicate_Subexpr (Base)); + + -- X ** 3 = X * X * X + + elsif Expv = 3 then + Xnode := + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => Duplicate_Subexpr (Base), + Right_Opnd => Duplicate_Subexpr (Base)), + Right_Opnd => Duplicate_Subexpr (Base)); + + -- X ** 4 -> + -- En : constant base'type := base * base; + -- ... + -- En * En + + else -- Expv = 4 + Temp := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (Typ, Loc), + Expression => + Make_Op_Multiply (Loc, + Left_Opnd => Duplicate_Subexpr (Base), + Right_Opnd => Duplicate_Subexpr (Base))))); + + Xnode := + Make_Op_Multiply (Loc, + Left_Opnd => New_Reference_To (Temp, Loc), + Right_Opnd => New_Reference_To (Temp, Loc)); + end if; + + Rewrite (N, Xnode); + Analyze_And_Resolve (N, Typ); + return; + end if; + end if; + + -- Case of (2 ** expression) appearing as an argument of an integer + -- multiplication, or as the right argument of a division of a non- + -- negative integer. In such cases we lave the node untouched, setting + -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion + -- of the higher level node converts it into a shift. + + if Nkind (Base) = N_Integer_Literal + and then Intval (Base) = 2 + and then Is_Integer_Type (Root_Type (Exptyp)) + and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) + and then Is_Unsigned_Type (Exptyp) + and then not Ovflo + and then Nkind (Parent (N)) in N_Binary_Op + then + declare + P : constant Node_Id := Parent (N); + L : constant Node_Id := Left_Opnd (P); + R : constant Node_Id := Right_Opnd (P); + + begin + if (Nkind (P) = N_Op_Multiply + and then + ((Is_Integer_Type (Etype (L)) and then R = N) + or else + (Is_Integer_Type (Etype (R)) and then L = N)) + and then not Do_Overflow_Check (P)) + + or else + (Nkind (P) = N_Op_Divide + and then Is_Integer_Type (Etype (L)) + and then Is_Unsigned_Type (Etype (L)) + and then R = N + and then not Do_Overflow_Check (P)) + then + Set_Is_Power_Of_2_For_Shift (N); + return; + end if; + end; + end if; + + -- Fall through if exponentiation must be done using a runtime routine. + + -- First deal with modular case. + + if Is_Modular_Integer_Type (Rtyp) then + + -- Non-binary case, we call the special exponentiation routine for + -- the non-binary case, converting the argument to Long_Long_Integer + -- and passing the modulus value. Then the result is converted back + -- to the base type. + + if Non_Binary_Modulus (Rtyp) then + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Exp_Modular), Loc), + Parameter_Associations => New_List ( + Convert_To (Standard_Integer, Base), + Make_Integer_Literal (Loc, Modulus (Rtyp)), + Exp)))); + + -- Binary case, in this case, we call one of two routines, either + -- the unsigned integer case, or the unsigned long long integer + -- case, with a final "and" operation to do the required mod. + + else + if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then + Ent := RTE (RE_Exp_Unsigned); + else + Ent := RTE (RE_Exp_Long_Long_Unsigned); + end if; + + Rewrite (N, + Convert_To (Typ, + Make_Op_And (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => New_Reference_To (Ent, Loc), + Parameter_Associations => New_List ( + Convert_To (Etype (First_Formal (Ent)), Base), + Exp)), + Right_Opnd => + Make_Integer_Literal (Loc, Modulus (Rtyp) - 1)))); + + end if; + + -- Common exit point for modular type case + + Analyze_And_Resolve (N, Typ); + return; + + -- Signed integer cases + + elsif Rtyp = Base_Type (Standard_Integer) then + if Ovflo then + Rent := RE_Exp_Integer; + else + Rent := RE_Exn_Integer; + end if; + + elsif Rtyp = Base_Type (Standard_Short_Integer) then + if Ovflo then + Rent := RE_Exp_Short_Integer; + else + Rent := RE_Exn_Short_Integer; + end if; + + elsif Rtyp = Base_Type (Standard_Short_Short_Integer) then + if Ovflo then + Rent := RE_Exp_Short_Short_Integer; + else + Rent := RE_Exn_Short_Short_Integer; + end if; + + elsif Rtyp = Base_Type (Standard_Long_Integer) then + if Ovflo then + Rent := RE_Exp_Long_Integer; + else + Rent := RE_Exn_Long_Integer; + end if; + + elsif (Rtyp = Base_Type (Standard_Long_Long_Integer) + or else Rtyp = Universal_Integer) + then + if Ovflo then + Rent := RE_Exp_Long_Long_Integer; + else + Rent := RE_Exn_Long_Long_Integer; + end if; + + -- Floating-point cases + + elsif Rtyp = Standard_Float then + if Ovflo then + Rent := RE_Exp_Float; + else + Rent := RE_Exn_Float; + end if; + + elsif Rtyp = Standard_Short_Float then + if Ovflo then + Rent := RE_Exp_Short_Float; + else + Rent := RE_Exn_Short_Float; + end if; + + elsif Rtyp = Standard_Long_Float then + if Ovflo then + Rent := RE_Exp_Long_Float; + else + Rent := RE_Exn_Long_Float; + end if; + + else + pragma Assert + (Rtyp = Standard_Long_Long_Float or else Rtyp = Universal_Real); + + if Ovflo then + Rent := RE_Exp_Long_Long_Float; + else + Rent := RE_Exn_Long_Long_Float; + end if; + end if; + + -- Common processing for integer cases and floating-point cases. + -- If we are in the base type, we can call runtime routine directly + + if Typ = Rtyp + and then Rtyp /= Universal_Integer + and then Rtyp /= Universal_Real + then + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Rent), Loc), + Parameter_Associations => New_List (Base, Exp))); + + -- Otherwise we have to introduce conversions (conversions are also + -- required in the universal cases, since the runtime routine was + -- typed using the largest integer or real case. + + else + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Rent), Loc), + Parameter_Associations => New_List ( + Convert_To (Rtyp, Base), + Exp)))); + end if; + + Analyze_And_Resolve (N, Typ); + return; + + end Expand_N_Op_Expon; + + -------------------- + -- Expand_N_Op_Ge -- + -------------------- + + procedure Expand_N_Op_Ge (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Vax_Float (Typ1) then + Expand_Vax_Comparison (N); + return; + + elsif Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + end Expand_N_Op_Ge; + + -------------------- + -- Expand_N_Op_Gt -- + -------------------- + + procedure Expand_N_Op_Gt (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Vax_Float (Typ1) then + Expand_Vax_Comparison (N); + return; + + elsif Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + end Expand_N_Op_Gt; + + -------------------- + -- Expand_N_Op_Le -- + -------------------- + + procedure Expand_N_Op_Le (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Vax_Float (Typ1) then + Expand_Vax_Comparison (N); + return; + + elsif Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + end Expand_N_Op_Le; + + -------------------- + -- Expand_N_Op_Lt -- + -------------------- + + procedure Expand_N_Op_Lt (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Vax_Float (Typ1) then + Expand_Vax_Comparison (N); + return; + + elsif Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + end Expand_N_Op_Lt; + + ----------------------- + -- Expand_N_Op_Minus -- + ----------------------- + + procedure Expand_N_Op_Minus (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + Unary_Op_Validity_Checks (N); + + if Software_Overflow_Checking + and then Is_Signed_Integer_Type (Etype (N)) + and then Do_Overflow_Check (N) + then + -- Software overflow checking expands -expr into (0 - expr) + + Rewrite (N, + Make_Op_Subtract (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 0), + Right_Opnd => Right_Opnd (N))); + + Analyze_And_Resolve (N, Typ); + + -- Vax floating-point types case + + elsif Vax_Float (Etype (N)) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Minus; + + --------------------- + -- Expand_N_Op_Mod -- + --------------------- + + procedure Expand_N_Op_Mod (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + T : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + DOC : constant Boolean := Do_Overflow_Check (N); + DDC : constant Boolean := Do_Division_Check (N); + + LLB : Uint; + Llo : Uint; + Lhi : Uint; + LOK : Boolean; + Rlo : Uint; + Rhi : Uint; + ROK : Boolean; + + begin + Binary_Op_Validity_Checks (N); + + Determine_Range (Right, ROK, Rlo, Rhi); + Determine_Range (Left, LOK, Llo, Lhi); + + -- Convert mod to rem if operands are known non-negative. We do this + -- since it is quite likely that this will improve the quality of code, + -- (the operation now corresponds to the hardware remainder), and it + -- does not seem likely that it could be harmful. + + if LOK and then Llo >= 0 + and then + ROK and then Rlo >= 0 + then + Rewrite (N, + Make_Op_Rem (Sloc (N), + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N))); + + -- Instead of reanalyzing the node we do the analysis manually. + -- This avoids anomalies when the replacement is done in an + -- instance and is epsilon more efficient. + + Set_Entity (N, Standard_Entity (S_Op_Rem)); + Set_Etype (N, T); + Set_Do_Overflow_Check (N, DOC); + Set_Do_Division_Check (N, DDC); + Expand_N_Op_Rem (N); + Set_Analyzed (N); + + -- Otherwise, normal mod processing + + else + if Is_Integer_Type (Etype (N)) then + Apply_Divide_Check (N); + end if; + + -- Deal with annoying case of largest negative number remainder + -- minus one. Gigi does not handle this case correctly, because + -- it generates a divide instruction which may trap in this case. + + -- In fact the check is quite easy, if the right operand is -1, + -- then the mod value is always 0, and we can just ignore the + -- left operand completely in this case. + + LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left)))); + + if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) + and then + ((not LOK) or else (Llo = LLB)) + then + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Right), + Right_Opnd => + Make_Integer_Literal (Loc, -1)), + Make_Integer_Literal (Loc, Uint_0), + Relocate_Node (N)))); + + Set_Analyzed (Next (Next (First (Expressions (N))))); + Analyze_And_Resolve (N, T); + end if; + end if; + end Expand_N_Op_Mod; + + -------------------------- + -- Expand_N_Op_Multiply -- + -------------------------- + + procedure Expand_N_Op_Multiply (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lop : constant Node_Id := Left_Opnd (N); + Rop : constant Node_Id := Right_Opnd (N); + Ltyp : constant Entity_Id := Etype (Lop); + Rtyp : constant Entity_Id := Etype (Rop); + Typ : Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + -- Special optimizations for integer types + + if Is_Integer_Type (Typ) then + + -- N * 0 = 0 * N = 0 for integer types + + if (Compile_Time_Known_Value (Right_Opnd (N)) + and then Expr_Value (Right_Opnd (N)) = Uint_0) + or else + (Compile_Time_Known_Value (Left_Opnd (N)) + and then Expr_Value (Left_Opnd (N)) = Uint_0) + then + Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- N * 1 = 1 * N = N for integer types + + if Compile_Time_Known_Value (Right_Opnd (N)) + and then Expr_Value (Right_Opnd (N)) = Uint_1 + then + Rewrite (N, Left_Opnd (N)); + return; + + elsif Compile_Time_Known_Value (Left_Opnd (N)) + and then Expr_Value (Left_Opnd (N)) = Uint_1 + then + Rewrite (N, Right_Opnd (N)); + return; + end if; + end if; + + -- Deal with VAX float case + + if Vax_Float (Typ) then + Expand_Vax_Arith (N); + return; + end if; + + -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that + -- Is_Power_Of_2_For_Shift is set means that we know that our left + -- operand is an integer, as required for this to work. + + if Nkind (Rop) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Rop) + then + if Nkind (Lop) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Lop) + then + + -- convert 2 ** A * 2 ** B into 2 ** (A + B) + + Rewrite (N, + Make_Op_Expon (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 2), + Right_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Right_Opnd (Lop), + Right_Opnd => Right_Opnd (Rop)))); + Analyze_And_Resolve (N, Typ); + return; + + else + Rewrite (N, + Make_Op_Shift_Left (Loc, + Left_Opnd => Lop, + Right_Opnd => + Convert_To (Standard_Natural, Right_Opnd (Rop)))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Same processing for the operands the other way round + + elsif Nkind (Lop) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Lop) + then + Rewrite (N, + Make_Op_Shift_Left (Loc, + Left_Opnd => Rop, + Right_Opnd => + Convert_To (Standard_Natural, Right_Opnd (Lop)))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Do required fixup of universal fixed operation + + if Typ = Universal_Fixed then + Fixup_Universal_Fixed_Operation (N); + Typ := Etype (N); + end if; + + -- Multiplications with fixed-point results + + if Is_Fixed_Point_Type (Typ) then + + -- No special processing if Treat_Fixed_As_Integer is set, + -- since from a semantic point of view such operations are + -- simply integer operations and will be treated that way. + + if not Treat_Fixed_As_Integer (N) then + + -- Case of fixed * integer => fixed + + if Is_Integer_Type (Rtyp) then + Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N); + + -- Case of integer * fixed => fixed + + elsif Is_Integer_Type (Ltyp) then + Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N); + + -- Case of fixed * fixed => fixed + + else + Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N); + end if; + end if; + + -- Other cases of multiplication of fixed-point operands. Again + -- we exclude the cases where Treat_Fixed_As_Integer flag is set. + + elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) + and then not Treat_Fixed_As_Integer (N) + then + if Is_Integer_Type (Typ) then + Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N); + else + pragma Assert (Is_Floating_Point_Type (Typ)); + Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); + end if; + + -- Mixed-mode operations can appear in a non-static universal + -- context, in which case the integer argument must be converted + -- explicitly. + + elsif Typ = Universal_Real + and then Is_Integer_Type (Rtyp) + then + Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); + + Analyze_And_Resolve (Rop, Universal_Real); + + elsif Typ = Universal_Real + and then Is_Integer_Type (Ltyp) + then + Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); + + Analyze_And_Resolve (Lop, Universal_Real); + + -- Non-fixed point cases, check software overflow checking required + + elsif Is_Signed_Integer_Type (Etype (N)) then + Apply_Arithmetic_Overflow_Check (N); + end if; + end Expand_N_Op_Multiply; + + -------------------- + -- Expand_N_Op_Ne -- + -------------------- + + -- Rewrite node as the negation of an equality operation, and reanalyze. + -- The equality to be used is defined in the same scope and has the same + -- signature. It must be set explicitly because in an instance it may not + -- have the same visibility as in the generic unit. + + procedure Expand_N_Op_Ne (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Neg : Node_Id; + Ne : constant Entity_Id := Entity (N); + + begin + Binary_Op_Validity_Checks (N); + + Neg := + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N))); + Set_Paren_Count (Right_Opnd (Neg), 1); + + if Scope (Ne) /= Standard_Standard then + Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); + end if; + + Rewrite (N, Neg); + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_N_Op_Ne; + + --------------------- + -- Expand_N_Op_Not -- + --------------------- + + -- If the argument is other than a Boolean array type, there is no + -- special expansion required. + + -- For the packed case, we call the special routine in Exp_Pakd, except + -- that if the component size is greater than one, we use the standard + -- routine generating a gruesome loop (it is so peculiar to have packed + -- arrays with non-standard Boolean representations anyway, so it does + -- not matter that we do not handle this case efficiently). + + -- For the unpacked case (and for the special packed case where we have + -- non standard Booleans, as discussed above), we generate and insert + -- into the tree the following function definition: + + -- function Nnnn (A : arr) is + -- B : arr; + -- begin + -- for J in a'range loop + -- B (J) := not A (J); + -- end loop; + -- return B; + -- end Nnnn; + + -- Here arr is the actual subtype of the parameter (and hence always + -- constrained). Then we replace the not with a call to this function. + + procedure Expand_N_Op_Not (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Opnd : Node_Id; + Arr : Entity_Id; + A : Entity_Id; + B : Entity_Id; + J : Entity_Id; + A_J : Node_Id; + B_J : Node_Id; + + Func_Name : Entity_Id; + Loop_Statement : Node_Id; + + begin + Unary_Op_Validity_Checks (N); + + -- For boolean operand, deal with non-standard booleans + + if Is_Boolean_Type (Typ) then + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + return; + end if; + + -- Only array types need any other processing + + if not Is_Array_Type (Typ) then + return; + end if; + + -- Case of array operand. If bit packed, handle it in Exp_Pakd + + if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then + Expand_Packed_Not (N); + return; + end if; + + -- Case of array operand which is not bit-packed + + Opnd := Relocate_Node (Right_Opnd (N)); + Convert_To_Actual_Subtype (Opnd); + Arr := Etype (Opnd); + Ensure_Defined (Arr, N); + + A := Make_Defining_Identifier (Loc, Name_uA); + B := Make_Defining_Identifier (Loc, Name_uB); + J := Make_Defining_Identifier (Loc, Name_uJ); + + A_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (A, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + B_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (B, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + Loop_Statement := + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => J, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Chars (A)), + Attribute_Name => Name_Range))), + + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => B_J, + Expression => Make_Op_Not (Loc, A_J)))); + + Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); + Set_Is_Inlined (Func_Name); + + Insert_Action (N, + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Typ, Loc))), + Subtype_Mark => New_Reference_To (Typ, Loc)), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Arr, Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Loop_Statement, + Make_Return_Statement (Loc, + Expression => + Make_Identifier (Loc, Chars (B))))))); + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => New_List (Opnd))); + + Analyze_And_Resolve (N, Typ); + end Expand_N_Op_Not; + + -------------------- + -- Expand_N_Op_Or -- + -------------------- + + procedure Expand_N_Op_Or (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Etype (N)) then + Expand_Boolean_Operator (N); + + elsif Is_Boolean_Type (Etype (N)) then + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + end Expand_N_Op_Or; + + ---------------------- + -- Expand_N_Op_Plus -- + ---------------------- + + procedure Expand_N_Op_Plus (N : Node_Id) is + begin + Unary_Op_Validity_Checks (N); + end Expand_N_Op_Plus; + + --------------------- + -- Expand_N_Op_Rem -- + --------------------- + + procedure Expand_N_Op_Rem (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + LLB : Uint; + Llo : Uint; + Lhi : Uint; + LOK : Boolean; + Rlo : Uint; + Rhi : Uint; + ROK : Boolean; + Typ : Entity_Id; + + begin + Binary_Op_Validity_Checks (N); + + if Is_Integer_Type (Etype (N)) then + Apply_Divide_Check (N); + end if; + + -- Deal with annoying case of largest negative number remainder + -- minus one. Gigi does not handle this case correctly, because + -- it generates a divide instruction which may trap in this case. + + -- In fact the check is quite easy, if the right operand is -1, + -- then the remainder is always 0, and we can just ignore the + -- left operand completely in this case. + + Determine_Range (Right, ROK, Rlo, Rhi); + Determine_Range (Left, LOK, Llo, Lhi); + LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left)))); + Typ := Etype (N); + + if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) + and then + ((not LOK) or else (Llo = LLB)) + then + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Right), + Right_Opnd => + Make_Integer_Literal (Loc, -1)), + + Make_Integer_Literal (Loc, Uint_0), + + Relocate_Node (N)))); + + Set_Analyzed (Next (Next (First (Expressions (N))))); + Analyze_And_Resolve (N, Typ); + end if; + end Expand_N_Op_Rem; + + ----------------------------- + -- Expand_N_Op_Rotate_Left -- + ----------------------------- + + procedure Expand_N_Op_Rotate_Left (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Rotate_Left; + + ------------------------------ + -- Expand_N_Op_Rotate_Right -- + ------------------------------ + + procedure Expand_N_Op_Rotate_Right (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Rotate_Right; + + ---------------------------- + -- Expand_N_Op_Shift_Left -- + ---------------------------- + + procedure Expand_N_Op_Shift_Left (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Shift_Left; + + ----------------------------- + -- Expand_N_Op_Shift_Right -- + ----------------------------- + + procedure Expand_N_Op_Shift_Right (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Shift_Right; + + ---------------------------------------- + -- Expand_N_Op_Shift_Right_Arithmetic -- + ---------------------------------------- + + procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Shift_Right_Arithmetic; + + -------------------------- + -- Expand_N_Op_Subtract -- + -------------------------- + + procedure Expand_N_Op_Subtract (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + -- N - 0 = N for integer types + + if Is_Integer_Type (Typ) + and then Compile_Time_Known_Value (Right_Opnd (N)) + and then Expr_Value (Right_Opnd (N)) = 0 + then + Rewrite (N, Left_Opnd (N)); + return; + end if; + + -- Arithemtic overflow checks for signed integer/fixed point types + + if Is_Signed_Integer_Type (Typ) + or else Is_Fixed_Point_Type (Typ) + then + Apply_Arithmetic_Overflow_Check (N); + + -- Vax floating-point types case + + elsif Vax_Float (Typ) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Subtract; + + --------------------- + -- Expand_N_Op_Xor -- + --------------------- + + procedure Expand_N_Op_Xor (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Etype (N)) then + Expand_Boolean_Operator (N); + + elsif Is_Boolean_Type (Etype (N)) then + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + end Expand_N_Op_Xor; + + ---------------------- + -- Expand_N_Or_Else -- + ---------------------- + + -- Expand into conditional expression if Actions present, and also + -- deal with optimizing case of arguments being True or False. + + procedure Expand_N_Or_Else (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Actlist : List_Id; + + begin + -- Deal with non-standard booleans + + if Is_Boolean_Type (Typ) then + Adjust_Condition (Left); + Adjust_Condition (Right); + Set_Etype (N, Standard_Boolean); + + -- Check for cases of left argument is True or False + + elsif Nkind (Left) = N_Identifier then + + -- If left argument is False, change (False or else Right) to Right. + -- Any actions associated with Right will be executed unconditionally + -- and can thus be inserted into the tree unconditionally. + + if Entity (Left) = Standard_False then + if Present (Actions (N)) then + Insert_Actions (N, Actions (N)); + end if; + + Rewrite (N, Right); + Adjust_Result_Type (N, Typ); + return; + + -- If left argument is True, change (True and then Right) to + -- True. In this case we can forget the actions associated with + -- Right, since they will never be executed. + + elsif Entity (Left) = Standard_True then + Kill_Dead_Code (Right); + Kill_Dead_Code (Actions (N)); + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + Adjust_Result_Type (N, Typ); + return; + end if; + end if; + + -- If Actions are present, we expand + + -- left or else right + + -- into + + -- if left then True else right end + + -- with the actions becoming the Else_Actions of the conditional + -- expression. This conditional expression is then further expanded + -- (and will eventually disappear) + + if Present (Actions (N)) then + Actlist := Actions (N); + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Left, + New_Occurrence_Of (Standard_True, Loc), + Right))); + + Set_Else_Actions (N, Actlist); + Analyze_And_Resolve (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + return; + end if; + + -- No actions present, check for cases of right argument True/False + + if Nkind (Right) = N_Identifier then + + -- Change (Left or else False) to Left. Note that we know there + -- are no actions associated with the True operand, since we + -- just checked for this case above. + + if Entity (Right) = Standard_False then + Rewrite (N, Left); + + -- Change (Left or else True) to True, making sure to preserve + -- any side effects associated with the Left operand. + + elsif Entity (Right) = Standard_True then + Remove_Side_Effects (Left); + Rewrite + (N, New_Occurrence_Of (Standard_True, Loc)); + end if; + end if; + + Adjust_Result_Type (N, Typ); + end Expand_N_Or_Else; + + ----------------------------------- + -- Expand_N_Qualified_Expression -- + ----------------------------------- + + procedure Expand_N_Qualified_Expression (N : Node_Id) is + Operand : constant Node_Id := Expression (N); + Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); + + begin + Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); + end Expand_N_Qualified_Expression; + + --------------------------------- + -- Expand_N_Selected_Component -- + --------------------------------- + + -- If the selector is a discriminant of a concurrent object, rewrite the + -- prefix to denote the corresponding record type. + + procedure Expand_N_Selected_Component (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Par : constant Node_Id := Parent (N); + P : constant Node_Id := Prefix (N); + Disc : Entity_Id; + Ptyp : Entity_Id := Underlying_Type (Etype (P)); + New_N : Node_Id; + + function In_Left_Hand_Side (Comp : Node_Id) return Boolean; + -- Gigi needs a temporary for prefixes that depend on a discriminant, + -- unless the context of an assignment can provide size information. + + function In_Left_Hand_Side (Comp : Node_Id) return Boolean is + begin + return + (Nkind (Parent (Comp)) = N_Assignment_Statement + and then Comp = Name (Parent (Comp))) + or else + (Present (Parent (Comp)) + and then Nkind (Parent (Comp)) in N_Subexpr + and then In_Left_Hand_Side (Parent (Comp))); + end In_Left_Hand_Side; + + begin + if Do_Discriminant_Check (N) then + + -- Present the discrminant checking function to the backend, + -- so that it can inline the call to the function. + + Add_Inlined_Body + (Discriminant_Checking_Func + (Original_Record_Component (Entity (Selector_Name (N))))); + end if; + + -- Insert explicit dereference call for the checked storage pool case + + if Is_Access_Type (Ptyp) then + Insert_Dereference_Action (P); + return; + end if; + + -- Gigi cannot handle unchecked conversions that are the prefix of + -- a selected component with discriminants. This must be checked + -- during expansion, because during analysis the type of the selector + -- is not known at the point the prefix is analyzed. If the conversion + -- is the target of an assignment, we cannot force the evaluation, of + -- course. + + if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion + and then Has_Discriminants (Etype (N)) + and then not In_Left_Hand_Side (N) + then + Force_Evaluation (Prefix (N)); + end if; + + -- Remaining processing applies only if selector is a discriminant + + if Ekind (Entity (Selector_Name (N))) = E_Discriminant then + + -- If the selector is a discriminant of a constrained record type, + -- rewrite the expression with the actual value of the discriminant. + -- Don't do this on the left hand of an assignment statement (this + -- happens in generated code, and means we really want to set it!) + -- We also only do this optimization for discrete types, and not + -- for access types (access discriminants get us into trouble!) + -- We also do not expand the prefix of an attribute or the + -- operand of an object renaming declaration. + + if Is_Record_Type (Ptyp) + and then Has_Discriminants (Ptyp) + and then Is_Constrained (Ptyp) + and then Is_Discrete_Type (Etype (N)) + and then (Nkind (Par) /= N_Assignment_Statement + or else Name (Par) /= N) + and then (Nkind (Par) /= N_Attribute_Reference + or else Prefix (Par) /= N) + and then not Is_Renamed_Object (N) + then + declare + D : Entity_Id; + E : Elmt_Id; + + begin + D := First_Discriminant (Ptyp); + E := First_Elmt (Discriminant_Constraint (Ptyp)); + + while Present (E) loop + if D = Entity (Selector_Name (N)) then + + -- In the context of a case statement, the expression + -- may have the base type of the discriminant, and we + -- need to preserve the constraint to avoid spurious + -- errors on missing cases. + + if Nkind (Parent (N)) = N_Case_Statement + and then Etype (Node (E)) /= Etype (D) + then + Rewrite (N, + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), + Expression => New_Copy (Node (E)))); + Analyze (N); + else + Rewrite (N, New_Copy (Node (E))); + end if; + + Set_Is_Static_Expression (N, False); + return; + end if; + + Next_Elmt (E); + Next_Discriminant (D); + end loop; + + -- Note: the above loop should always terminate, but if + -- it does not, we just missed an optimization due to + -- some glitch (perhaps a previous error), so ignore! + end; + end if; + + -- The only remaining processing is in the case of a discriminant of + -- a concurrent object, where we rewrite the prefix to denote the + -- corresponding record type. If the type is derived and has renamed + -- discriminants, use corresponding discriminant, which is the one + -- that appears in the corresponding record. + + if not Is_Concurrent_Type (Ptyp) then + return; + end if; + + Disc := Entity (Selector_Name (N)); + + if Is_Derived_Type (Ptyp) + and then Present (Corresponding_Discriminant (Disc)) + then + Disc := Corresponding_Discriminant (Disc); + end if; + + New_N := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Ptyp), + New_Copy_Tree (P)), + Selector_Name => Make_Identifier (Loc, Chars (Disc))); + + Rewrite (N, New_N); + Analyze (N); + end if; + + end Expand_N_Selected_Component; + + -------------------- + -- Expand_N_Slice -- + -------------------- + + procedure Expand_N_Slice (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pfx : constant Node_Id := Prefix (N); + Ptp : Entity_Id := Etype (Pfx); + Ent : Entity_Id; + Decl : Node_Id; + + begin + -- Special handling for access types + + if Is_Access_Type (Ptp) then + + -- Check for explicit dereference required for checked pool + + Insert_Dereference_Action (Pfx); + + -- If we have an access to a packed array type, then put in an + -- explicit dereference. We do this in case the slice must be + -- expanded, and we want to make sure we get an access check. + + Ptp := Designated_Type (Ptp); + + if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then + Rewrite (Pfx, + Make_Explicit_Dereference (Sloc (N), + Prefix => Relocate_Node (Pfx))); + + Analyze_And_Resolve (Pfx, Ptp); + + -- The prefix will now carry the Access_Check flag for the back + -- end, remove it from slice itself. + + Set_Do_Access_Check (N, False); + end if; + end if; + + -- Range checks are potentially also needed for cases involving + -- a slice indexed by a subtype indication, but Do_Range_Check + -- can currently only be set for expressions ??? + + if not Index_Checks_Suppressed (Ptp) + and then (not Is_Entity_Name (Pfx) + or else not Index_Checks_Suppressed (Entity (Pfx))) + and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication + then + Enable_Range_Check (Discrete_Range (N)); + end if; + + -- The remaining case to be handled is packed slices. We can leave + -- packed slices as they are in the following situations: + + -- 1. Right or left side of an assignment (we can handle this + -- situation correctly in the assignment statement expansion). + + -- 2. Prefix of indexed component (the slide is optimized away + -- in this case, see the start of Expand_N_Slice. + + -- 3. Object renaming declaration, since we want the name of + -- the slice, not the value. + + -- 4. Argument to procedure call, since copy-in/copy-out handling + -- may be required, and this is handled in the expansion of + -- call itself. + + -- 5. Prefix of an address attribute (this is an error which + -- is caught elsewhere, and the expansion would intefere + -- with generating the error message). + + if Is_Packed (Typ) + and then Nkind (Parent (N)) /= N_Assignment_Statement + and then Nkind (Parent (N)) /= N_Indexed_Component + and then not Is_Renamed_Object (N) + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement + and then (Nkind (Parent (N)) /= N_Attribute_Reference + or else + Attribute_Name (Parent (N)) /= Name_Address) + then + Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Set_No_Initialization (Decl); + + Insert_Actions (N, New_List ( + Decl, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Expression => Relocate_Node (N)))); + + Rewrite (N, New_Occurrence_Of (Ent, Loc)); + Analyze_And_Resolve (N, Typ); + end if; + end Expand_N_Slice; + + ------------------------------ + -- Expand_N_Type_Conversion -- + ------------------------------ + + procedure Expand_N_Type_Conversion (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Operand : constant Node_Id := Expression (N); + Target_Type : constant Entity_Id := Etype (N); + Operand_Type : Entity_Id := Etype (Operand); + + procedure Handle_Changed_Representation; + -- This is called in the case of record and array type conversions + -- to see if there is a change of representation to be handled. + -- Change of representation is actually handled at the assignment + -- statement level, and what this procedure does is rewrite node N + -- conversion as an assignment to temporary. If there is no change + -- of representation, then the conversion node is unchanged. + + procedure Real_Range_Check; + -- Handles generation of range check for real target value + + ----------------------------------- + -- Handle_Changed_Representation -- + ----------------------------------- + + procedure Handle_Changed_Representation is + Temp : Entity_Id; + Decl : Node_Id; + Odef : Node_Id; + Disc : Node_Id; + N_Ix : Node_Id; + Cons : List_Id; + + begin + -- Nothing to do if no change of representation + + if Same_Representation (Operand_Type, Target_Type) then + return; + + -- The real change of representation work is done by the assignment + -- statement processing. So if this type conversion is appearing as + -- the expression of an assignment statement, nothing needs to be + -- done to the conversion. + + elsif Nkind (Parent (N)) = N_Assignment_Statement then + return; + + -- Otherwise we need to generate a temporary variable, and do the + -- change of representation assignment into that temporary variable. + -- The conversion is then replaced by a reference to this variable. + + else + Cons := No_List; + + -- If type is unconstrained we have to add a constraint, + -- copied from the actual value of the left hand side. + + if not Is_Constrained (Target_Type) then + if Has_Discriminants (Operand_Type) then + Disc := First_Discriminant (Operand_Type); + Cons := New_List; + while Present (Disc) loop + Append_To (Cons, + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Operand), + Selector_Name => + Make_Identifier (Loc, Chars (Disc)))); + Next_Discriminant (Disc); + end loop; + + elsif Is_Array_Type (Operand_Type) then + N_Ix := First_Index (Target_Type); + Cons := New_List; + + for J in 1 .. Number_Dimensions (Operand_Type) loop + + -- We convert the bounds explicitly. We use an unchecked + -- conversion because bounds checks are done elsewhere. + + Append_To (Cons, + Make_Range (Loc, + Low_Bound => + Unchecked_Convert_To (Etype (N_Ix), + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr + (Operand, Name_Req => True), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))), + + High_Bound => + Unchecked_Convert_To (Etype (N_Ix), + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr + (Operand, Name_Req => True), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Next_Index (N_Ix); + end loop; + end if; + end if; + + Odef := New_Occurrence_Of (Target_Type, Loc); + + if Present (Cons) then + Odef := + Make_Subtype_Indication (Loc, + Subtype_Mark => Odef, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Cons)); + end if; + + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => Odef); + + Set_No_Initialization (Decl, True); + + -- Insert required actions. It is essential to suppress checks + -- since we have suppressed default initialization, which means + -- that the variable we create may have no discriminants. + + Insert_Actions (N, + New_List ( + Decl, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp, Loc), + Expression => Relocate_Node (N))), + Suppress => All_Checks); + + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + return; + end if; + end Handle_Changed_Representation; + + ---------------------- + -- Real_Range_Check -- + ---------------------- + + -- Case of conversions to floating-point or fixed-point. If range + -- checks are enabled and the target type has a range constraint, + -- we convert: + + -- typ (x) + + -- to + + -- Tnn : typ'Base := typ'Base (x); + -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] + -- Tnn + + procedure Real_Range_Check is + Btyp : constant Entity_Id := Base_Type (Target_Type); + Lo : constant Node_Id := Type_Low_Bound (Target_Type); + Hi : constant Node_Id := Type_High_Bound (Target_Type); + Conv : Node_Id; + Tnn : Entity_Id; + + begin + -- Nothing to do if conversion was rewritten + + if Nkind (N) /= N_Type_Conversion then + return; + end if; + + -- Nothing to do if range checks suppressed, or target has the + -- same range as the base type (or is the base type). + + if Range_Checks_Suppressed (Target_Type) + or else (Lo = Type_Low_Bound (Btyp) + and then + Hi = Type_High_Bound (Btyp)) + then + return; + end if; + + -- Nothing to do if expression is an entity on which checks + -- have been suppressed. + + if Is_Entity_Name (Expression (N)) + and then Range_Checks_Suppressed (Entity (Expression (N))) + then + return; + end if; + + -- Here we rewrite the conversion as described above + + Conv := Relocate_Node (N); + Rewrite + (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); + Set_Etype (Conv, Btyp); + + -- Skip overflow check for integer to float conversions, + -- since it is not needed, and in any case gigi generates + -- incorrect code for such overflow checks ??? + + if not Is_Integer_Type (Etype (Expression (N))) then + Set_Do_Overflow_Check (Conv, True); + end if; + + Tnn := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Btyp, Loc), + Expression => Conv), + + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => + New_Occurrence_Of (Target_Type, Loc))), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => + New_Occurrence_Of (Target_Type, Loc))))))); + + Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + Analyze_And_Resolve (N, Btyp); + end Real_Range_Check; + + -- Start of processing for Expand_N_Type_Conversion + + begin + -- Nothing at all to do if conversion is to the identical type + -- so remove the conversion completely, it is useless. + + if Operand_Type = Target_Type then + Rewrite (N, Relocate_Node (Expression (N))); + return; + end if; + + -- Deal with Vax floating-point cases + + if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then + Expand_Vax_Conversion (N); + return; + end if; + + -- Nothing to do if this is the second argument of read. This + -- is a "backwards" conversion that will be handled by the + -- specialized code in attribute processing. + + if Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Read + and then Next (First (Expressions (Parent (N)))) = N + then + return; + end if; + + -- Here if we may need to expand conversion + + -- Special case of converting from non-standard boolean type + + if Is_Boolean_Type (Operand_Type) + and then (Nonzero_Is_True (Operand_Type)) + then + Adjust_Condition (Operand); + Set_Etype (Operand, Standard_Boolean); + Operand_Type := Standard_Boolean; + end if; + + -- Case of converting to an access type + + if Is_Access_Type (Target_Type) then + + -- Apply an accessibility check if the operand is an + -- access parameter. Note that other checks may still + -- need to be applied below (such as tagged type checks). + + if Is_Entity_Name (Operand) + and then Ekind (Entity (Operand)) in Formal_Kind + and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type + then + Apply_Accessibility_Check (Operand, Target_Type); + + -- If the level of the operand type is statically deeper + -- then the level of the target type, then force Program_Error. + -- Note that this can only occur for cases where the attribute + -- is within the body of an instantiation (otherwise the + -- conversion will already have been rejected as illegal). + -- Note: warnings are issued by the analyzer for the instance + -- cases. + + elsif In_Instance_Body + and then Type_Access_Level (Operand_Type) + > Type_Access_Level (Target_Type) + then + Rewrite (N, Make_Raise_Program_Error (Sloc (N))); + Set_Etype (N, Target_Type); + + -- When the operand is a selected access discriminant + -- the check needs to be made against the level of the + -- object denoted by the prefix of the selected name. + -- Force Program_Error for this case as well (this + -- accessibility violation can only happen if within + -- the body of an instantiation). + + elsif In_Instance_Body + and then Ekind (Operand_Type) = E_Anonymous_Access_Type + and then Nkind (Operand) = N_Selected_Component + and then Object_Access_Level (Operand) > + Type_Access_Level (Target_Type) + then + Rewrite (N, Make_Raise_Program_Error (Sloc (N))); + Set_Etype (N, Target_Type); + end if; + end if; + + -- Case of conversions of tagged types and access to tagged types + + -- When needed, that is to say when the expression is class-wide, + -- Add runtime a tag check for (strict) downward conversion by using + -- the membership test, generating: + + -- [constraint_error when Operand not in Target_Type'Class] + + -- or in the access type case + + -- [constraint_error + -- when Operand /= null + -- and then Operand.all not in + -- Designated_Type (Target_Type)'Class] + + if (Is_Access_Type (Target_Type) + and then Is_Tagged_Type (Designated_Type (Target_Type))) + or else Is_Tagged_Type (Target_Type) + then + -- Do not do any expansion in the access type case if the + -- parent is a renaming, since this is an error situation + -- which will be caught by Sem_Ch8, and the expansion can + -- intefere with this error check. + + if Is_Access_Type (Target_Type) + and then Is_Renamed_Object (N) + then + return; + end if; + + -- Oherwise, proceed with processing tagged conversion + + declare + Actual_Operand_Type : Entity_Id; + Actual_Target_Type : Entity_Id; + + Cond : Node_Id; + + begin + if Is_Access_Type (Target_Type) then + Actual_Operand_Type := Designated_Type (Operand_Type); + Actual_Target_Type := Designated_Type (Target_Type); + + else + Actual_Operand_Type := Operand_Type; + Actual_Target_Type := Target_Type; + end if; + + if Is_Class_Wide_Type (Actual_Operand_Type) + and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type + and then Is_Ancestor + (Root_Type (Actual_Operand_Type), + Actual_Target_Type) + and then not Tag_Checks_Suppressed (Actual_Target_Type) + then + -- The conversion is valid for any descendant of the + -- target type + + Actual_Target_Type := Class_Wide_Type (Actual_Target_Type); + + if Is_Access_Type (Target_Type) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Operand), + Right_Opnd => Make_Null (Loc)), + + Right_Opnd => + Make_Not_In (Loc, + Left_Opnd => + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr (Operand)), + Right_Opnd => + New_Reference_To (Actual_Target_Type, Loc))); + + else + Cond := + Make_Not_In (Loc, + Left_Opnd => Duplicate_Subexpr (Operand), + Right_Opnd => + New_Reference_To (Actual_Target_Type, Loc)); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond)); + + Change_Conversion_To_Unchecked (N); + Analyze_And_Resolve (N, Target_Type); + end if; + end; + + -- Case of other access type conversions + + elsif Is_Access_Type (Target_Type) then + Apply_Constraint_Check (Operand, Target_Type); + + -- Case of conversions from a fixed-point type + + -- These conversions require special expansion and processing, found + -- in the Exp_Fixd package. We ignore cases where Conversion_OK is + -- set, since from a semantic point of view, these are simple integer + -- conversions, which do not need further processing. + + elsif Is_Fixed_Point_Type (Operand_Type) + and then not Conversion_OK (N) + then + -- We should never see universal fixed at this case, since the + -- expansion of the constituent divide or multiply should have + -- eliminated the explicit mention of universal fixed. + + pragma Assert (Operand_Type /= Universal_Fixed); + + -- Check for special case of the conversion to universal real + -- that occurs as a result of the use of a round attribute. + -- In this case, the real type for the conversion is taken + -- from the target type of the Round attribute and the + -- result must be marked as rounded. + + if Target_Type = Universal_Real + and then Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Round + then + Set_Rounded_Result (N); + Set_Etype (N, Etype (Parent (N))); + end if; + + -- Otherwise do correct fixed-conversion, but skip these if the + -- Conversion_OK flag is set, because from a semantic point of + -- view these are simple integer conversions needing no further + -- processing (the backend will simply treat them as integers) + + if not Conversion_OK (N) then + if Is_Fixed_Point_Type (Etype (N)) then + Expand_Convert_Fixed_To_Fixed (N); + Real_Range_Check; + + elsif Is_Integer_Type (Etype (N)) then + Expand_Convert_Fixed_To_Integer (N); + + else + pragma Assert (Is_Floating_Point_Type (Etype (N))); + Expand_Convert_Fixed_To_Float (N); + Real_Range_Check; + end if; + end if; + + -- Case of conversions to a fixed-point type + + -- These conversions require special expansion and processing, found + -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK + -- is set, since from a semantic point of view, these are simple + -- integer conversions, which do not need further processing. + + elsif Is_Fixed_Point_Type (Target_Type) + and then not Conversion_OK (N) + then + if Is_Integer_Type (Operand_Type) then + Expand_Convert_Integer_To_Fixed (N); + Real_Range_Check; + else + pragma Assert (Is_Floating_Point_Type (Operand_Type)); + Expand_Convert_Float_To_Fixed (N); + Real_Range_Check; + end if; + + -- Case of float-to-integer conversions + + -- We also handle float-to-fixed conversions with Conversion_OK set + -- since semantically the fixed-point target is treated as though it + -- were an integer in such cases. + + elsif Is_Floating_Point_Type (Operand_Type) + and then + (Is_Integer_Type (Target_Type) + or else + (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N))) + then + -- Special processing required if the conversion is the expression + -- of a Truncation attribute reference. In this case we replace: + + -- ityp (ftyp'Truncation (x)) + + -- by + + -- ityp (x) + + -- with the Float_Truncate flag set. This is clearly more efficient. + + if Nkind (Operand) = N_Attribute_Reference + and then Attribute_Name (Operand) = Name_Truncation + then + Rewrite (Operand, + Relocate_Node (First (Expressions (Operand)))); + Set_Float_Truncate (N, True); + end if; + + -- One more check here, gcc is still not able to do conversions of + -- this type with proper overflow checking, and so gigi is doing an + -- approximation of what is required by doing floating-point compares + -- with the end-point. But that can lose precision in some cases, and + -- give a wrong result. Converting the operand to Long_Long_Float is + -- helpful, but still does not catch all cases with 64-bit integers + -- on targets with only 64-bit floats ??? + + if Do_Range_Check (Expression (N)) then + Rewrite (Expression (N), + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Long_Long_Float, Loc), + Expression => + Relocate_Node (Expression (N)))); + + Set_Etype (Expression (N), Standard_Long_Long_Float); + Enable_Range_Check (Expression (N)); + Set_Do_Range_Check (Expression (Expression (N)), False); + end if; + + -- Case of array conversions + + -- Expansion of array conversions, add required length/range checks + -- but only do this if there is no change of representation. For + -- handling of this case, see Handle_Changed_Representation. + + elsif Is_Array_Type (Target_Type) then + + if Is_Constrained (Target_Type) then + Apply_Length_Check (Operand, Target_Type); + else + Apply_Range_Check (Operand, Target_Type); + end if; + + Handle_Changed_Representation; + + -- Case of conversions of discriminated types + + -- Add required discriminant checks if target is constrained. Again + -- this change is skipped if we have a change of representation. + + elsif Has_Discriminants (Target_Type) + and then Is_Constrained (Target_Type) + then + Apply_Discriminant_Check (Operand, Target_Type); + Handle_Changed_Representation; + + -- Case of all other record conversions. The only processing required + -- is to check for a change of representation requiring the special + -- assignment processing. + + elsif Is_Record_Type (Target_Type) then + Handle_Changed_Representation; + + -- Case of conversions of enumeration types + + elsif Is_Enumeration_Type (Target_Type) then + + -- Special processing is required if there is a change of + -- representation (from enumeration representation clauses) + + if not Same_Representation (Target_Type, Operand_Type) then + + -- Convert: x(y) to x'val (ytyp'val (y)) + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Operand_Type, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Operand))))); + + Analyze_And_Resolve (N, Target_Type); + end if; + + -- Case of conversions to floating-point + + elsif Is_Floating_Point_Type (Target_Type) then + Real_Range_Check; + + -- The remaining cases require no front end processing + + else + null; + end if; + + -- At this stage, either the conversion node has been transformed + -- into some other equivalent expression, or left as a conversion + -- that can be handled by Gigi. The conversions that Gigi can handle + -- are the following: + + -- Conversions with no change of representation or type + + -- Numeric conversions involving integer values, floating-point + -- values, and fixed-point values. Fixed-point values are allowed + -- only if Conversion_OK is set, i.e. if the fixed-point values + -- are to be treated as integers. + + -- No other conversions should be passed to Gigi. + + end Expand_N_Type_Conversion; + + ----------------------------------- + -- Expand_N_Unchecked_Expression -- + ----------------------------------- + + -- Remove the unchecked expression node from the tree. It's job was simply + -- to make sure that its constituent expression was handled with checks + -- off, and now that that is done, we can remove it from the tree, and + -- indeed must, since gigi does not expect to see these nodes. + + procedure Expand_N_Unchecked_Expression (N : Node_Id) is + Exp : constant Node_Id := Expression (N); + + begin + Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp)); + Rewrite (N, Exp); + end Expand_N_Unchecked_Expression; + + ---------------------------------------- + -- Expand_N_Unchecked_Type_Conversion -- + ---------------------------------------- + + -- If this cannot be handled by Gigi and we haven't already made + -- a temporary for it, do it now. + + procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is + Target_Type : constant Entity_Id := Etype (N); + Operand : constant Node_Id := Expression (N); + Operand_Type : constant Entity_Id := Etype (Operand); + + begin + -- If we have a conversion of a compile time known value to a target + -- type and the value is in range of the target type, then we can simply + -- replace the construct by an integer literal of the correct type. We + -- only apply this to integer types being converted. Possibly it may + -- apply in other cases, but it is too much trouble to worry about. + + -- Note that we do not do this transformation if the Kill_Range_Check + -- flag is set, since then the value may be outside the expected range. + -- This happens in the Normalize_Scalars case. + + if Is_Integer_Type (Target_Type) + and then Is_Integer_Type (Operand_Type) + and then Compile_Time_Known_Value (Operand) + and then not Kill_Range_Check (N) + then + declare + Val : constant Uint := Expr_Value (Operand); + + begin + if Compile_Time_Known_Value (Type_Low_Bound (Target_Type)) + and then + Compile_Time_Known_Value (Type_High_Bound (Target_Type)) + and then + Val >= Expr_Value (Type_Low_Bound (Target_Type)) + and then + Val <= Expr_Value (Type_High_Bound (Target_Type)) + then + Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); + Analyze_And_Resolve (N, Target_Type); + return; + end if; + end; + end if; + + -- Nothing to do if conversion is safe + + if Safe_Unchecked_Type_Conversion (N) then + return; + end if; + + -- Otherwise force evaluation unless Assignment_OK flag is set (this + -- flag indicates ??? -- more comments needed here) + + if Assignment_OK (N) then + null; + else + Force_Evaluation (N); + end if; + end Expand_N_Unchecked_Type_Conversion; + + ---------------------------- + -- Expand_Record_Equality -- + ---------------------------- + + -- For non-variant records, Equality is expanded when needed into: + + -- and then Lhs.Discr1 = Rhs.Discr1 + -- and then ... + -- and then Lhs.Discrn = Rhs.Discrn + -- and then Lhs.Cmp1 = Rhs.Cmp1 + -- and then ... + -- and then Lhs.Cmpn = Rhs.Cmpn + + -- The expression is folded by the back-end for adjacent fields. This + -- function is called for tagged record in only one occasion: for imple- + -- menting predefined primitive equality (see Predefined_Primitives_Bodies) + -- otherwise the primitive "=" is used directly. + + function Expand_Record_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + + function Suitable_Element (C : Entity_Id) return Entity_Id; + -- Return the first field to compare beginning with C, skipping the + -- inherited components + + function Suitable_Element (C : Entity_Id) return Entity_Id is + begin + if No (C) then + return Empty; + + elsif Ekind (C) /= E_Discriminant + and then Ekind (C) /= E_Component + then + return Suitable_Element (Next_Entity (C)); + + elsif Is_Tagged_Type (Typ) + and then C /= Original_Record_Component (C) + then + return Suitable_Element (Next_Entity (C)); + + elsif Chars (C) = Name_uController + or else Chars (C) = Name_uTag + then + return Suitable_Element (Next_Entity (C)); + + else + return C; + end if; + end Suitable_Element; + + Result : Node_Id; + C : Entity_Id; + + First_Time : Boolean := True; + + -- Start of processing for Expand_Record_Equality + + begin + -- Special processing for the unchecked union case, which will occur + -- only in the context of tagged types and dynamic dispatching, since + -- other cases are handled statically. We return True, but insert a + -- raise Program_Error statement. + + if Is_Unchecked_Union (Typ) then + + -- If this is a component of an enclosing record, return the Raise + -- statement directly. + + if No (Parent (Lhs)) then + Result := Make_Raise_Program_Error (Loc); + Set_Etype (Result, Standard_Boolean); + return Result; + + else + Insert_Action (Lhs, + Make_Raise_Program_Error (Loc)); + return New_Occurrence_Of (Standard_True, Loc); + end if; + end if; + + -- Generates the following code: (assuming that Typ has one Discr and + -- component C2 is also a record) + + -- True + -- and then Lhs.Discr1 = Rhs.Discr1 + -- and then Lhs.C1 = Rhs.C1 + -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn + -- and then ... + -- and then Lhs.Cmpn = Rhs.Cmpn + + Result := New_Reference_To (Standard_True, Loc); + C := Suitable_Element (First_Entity (Typ)); + + while Present (C) loop + + declare + New_Lhs : Node_Id; + New_Rhs : Node_Id; + + begin + if First_Time then + First_Time := False; + New_Lhs := Lhs; + New_Rhs := Rhs; + + else + New_Lhs := New_Copy_Tree (Lhs); + New_Rhs := New_Copy_Tree (Rhs); + end if; + + Result := + Make_And_Then (Loc, + Left_Opnd => Result, + Right_Opnd => + Expand_Composite_Equality (Nod, Etype (C), + Lhs => + Make_Selected_Component (Loc, + Prefix => New_Lhs, + Selector_Name => New_Reference_To (C, Loc)), + Rhs => + Make_Selected_Component (Loc, + Prefix => New_Rhs, + Selector_Name => New_Reference_To (C, Loc)), + Bodies => Bodies)); + end; + + C := Suitable_Element (Next_Entity (C)); + end loop; + + return Result; + end Expand_Record_Equality; + + ------------------------------------- + -- Fixup_Universal_Fixed_Operation -- + ------------------------------------- + + procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is + Conv : constant Node_Id := Parent (N); + + begin + -- We must have a type conversion immediately above us + + pragma Assert (Nkind (Conv) = N_Type_Conversion); + + -- Normally the type conversion gives our target type. The exception + -- occurs in the case of the Round attribute, where the conversion + -- will be to universal real, and our real type comes from the Round + -- attribute (as well as an indication that we must round the result) + + if Nkind (Parent (Conv)) = N_Attribute_Reference + and then Attribute_Name (Parent (Conv)) = Name_Round + then + Set_Etype (N, Etype (Parent (Conv))); + Set_Rounded_Result (N); + + -- Normal case where type comes from conversion above us + + else + Set_Etype (N, Etype (Conv)); + end if; + end Fixup_Universal_Fixed_Operation; + + ------------------------------- + -- Insert_Dereference_Action -- + ------------------------------- + + procedure Insert_Dereference_Action (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pool : constant Entity_Id := Associated_Storage_Pool (Typ); + + function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; + -- return true if type of P is derived from Checked_Pool; + + function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is + T : Entity_Id; + + begin + if No (P) then + return False; + end if; + + T := Etype (P); + while T /= Etype (T) loop + if Is_RTE (T, RE_Checked_Pool) then + return True; + else + T := Etype (T); + end if; + end loop; + + return False; + end Is_Checked_Storage_Pool; + + -- Start of processing for Insert_Dereference_Action + + begin + if not Comes_From_Source (Parent (N)) then + return; + + elsif not Is_Checked_Storage_Pool (Pool) then + return; + end if; + + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Etype (Pool), Name_Dereference), Loc), + + Parameter_Associations => New_List ( + + -- Pool + + New_Reference_To (Pool, Loc), + + -- Storage_Address + + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)), + Attribute_Name => Name_Address), + + -- Size_In_Storage_Elements + + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)), + Attribute_Name => Name_Size), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)), + + -- Alignment + + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)), + Attribute_Name => Name_Alignment)))); + + end Insert_Dereference_Action; + + ------------------------------ + -- Make_Array_Comparison_Op -- + ------------------------------ + + -- This is a hand-coded expansion of the following generic function: + + -- generic + -- type elem is (<>); + -- type index is (<>); + -- type a is array (index range <>) of elem; + -- + -- function Gnnn (X : a; Y: a) return boolean is + -- J : index := Y'first; + -- + -- begin + -- if X'length = 0 then + -- return false; + -- + -- elsif Y'length = 0 then + -- return true; + -- + -- else + -- for I in X'range loop + -- if X (I) = Y (J) then + -- if J = Y'last then + -- exit; + -- else + -- J := index'succ (J); + -- end if; + -- + -- else + -- return X (I) > Y (J); + -- end if; + -- end loop; + -- + -- return X'length > Y'length; + -- end if; + -- end Gnnn; + + -- Note that since we are essentially doing this expansion by hand, we + -- do not need to generate an actual or formal generic part, just the + -- instantiated function itself. + + function Make_Array_Comparison_Op + (Typ : Entity_Id; + Nod : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + + X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX); + Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY); + I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI); + J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); + + Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); + + Loop_Statement : Node_Id; + Loop_Body : Node_Id; + If_Stat : Node_Id; + Inner_If : Node_Id; + Final_Expr : Node_Id; + Func_Body : Node_Id; + Func_Name : Entity_Id; + Formals : List_Id; + Length1 : Node_Id; + Length2 : Node_Id; + + begin + -- if J = Y'last then + -- exit; + -- else + -- J := index'succ (J); + -- end if; + + Inner_If := + Make_Implicit_If_Statement (Nod, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (J, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_Last)), + + Then_Statements => New_List ( + Make_Exit_Statement (Loc)), + + Else_Statements => + New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (J, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List (New_Reference_To (J, Loc)))))); + + -- if X (I) = Y (J) then + -- if ... end if; + -- else + -- return X (I) > Y (J); + -- end if; + + Loop_Body := + Make_Implicit_If_Statement (Nod, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (X, Loc), + Expressions => New_List (New_Reference_To (I, Loc))), + + Right_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Y, Loc), + Expressions => New_List (New_Reference_To (J, Loc)))), + + Then_Statements => New_List (Inner_If), + + Else_Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Op_Gt (Loc, + Left_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (X, Loc), + Expressions => New_List (New_Reference_To (I, Loc))), + + Right_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Y, Loc), + Expressions => New_List ( + New_Reference_To (J, Loc))))))); + + -- for I in X'range loop + -- if ... end if; + -- end loop; + + Loop_Statement := + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => I, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (X, Loc), + Attribute_Name => Name_Range))), + + Statements => New_List (Loop_Body)); + + -- if X'length = 0 then + -- return false; + -- elsif Y'length = 0 then + -- return true; + -- else + -- for ... loop ... end loop; + -- return X'length > Y'length; + -- end if; + + Length1 := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (X, Loc), + Attribute_Name => Name_Length); + + Length2 := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_Length); + + Final_Expr := + Make_Op_Gt (Loc, + Left_Opnd => Length1, + Right_Opnd => Length2); + + If_Stat := + Make_Implicit_If_Statement (Nod, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (X, Loc), + Attribute_Name => Name_Length), + Right_Opnd => + Make_Integer_Literal (Loc, 0)), + + Then_Statements => + New_List ( + Make_Return_Statement (Loc, + Expression => New_Reference_To (Standard_False, Loc))), + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_Length), + Right_Opnd => + Make_Integer_Literal (Loc, 0)), + + Then_Statements => + New_List ( + Make_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))))), + + Else_Statements => New_List ( + Loop_Statement, + Make_Return_Statement (Loc, + Expression => Final_Expr))); + + -- (X : a; Y: a) + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => X, + Parameter_Type => New_Reference_To (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Y, + Parameter_Type => New_Reference_To (Typ, Loc))); + + -- function Gnnn (...) return boolean is + -- J : index := Y'first; + -- begin + -- if ... end if; + -- end Gnnn; + + Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => Formals, + Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => J, + Object_Definition => New_Reference_To (Index, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_First))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (If_Stat))); + + return Func_Body; + + end Make_Array_Comparison_Op; + + --------------------------- + -- Make_Boolean_Array_Op -- + --------------------------- + + -- For logical operations on boolean arrays, expand in line the + -- following, replacing 'and' with 'or' or 'xor' where needed: + + -- function Annn (A : typ; B: typ) return typ is + -- C : typ; + -- begin + -- for J in A'range loop + -- C (J) := A (J) op B (J); + -- end loop; + -- return C; + -- end Annn; + + -- Here typ is the boolean array type + + function Make_Boolean_Array_Op + (Typ : Entity_Id; + N : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); + B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); + C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); + J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); + + A_J : Node_Id; + B_J : Node_Id; + C_J : Node_Id; + Op : Node_Id; + + Formals : List_Id; + Func_Name : Entity_Id; + Func_Body : Node_Id; + Loop_Statement : Node_Id; + + begin + A_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (A, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + B_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (B, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + C_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (C, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + if Nkind (N) = N_Op_And then + Op := + Make_Op_And (Loc, + Left_Opnd => A_J, + Right_Opnd => B_J); + + elsif Nkind (N) = N_Op_Or then + Op := + Make_Op_Or (Loc, + Left_Opnd => A_J, + Right_Opnd => B_J); + + else + Op := + Make_Op_Xor (Loc, + Left_Opnd => A_J, + Right_Opnd => B_J); + end if; + + Loop_Statement := + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => J, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (A, Loc), + Attribute_Name => Name_Range))), + + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => C_J, + Expression => Op))); + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => New_Reference_To (Typ, Loc))); + + Func_Name := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Set_Is_Inlined (Func_Name); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => Formals, + Subtype_Mark => New_Reference_To (Typ, Loc)), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => C, + Object_Definition => New_Reference_To (Typ, Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Loop_Statement, + Make_Return_Statement (Loc, + Expression => New_Reference_To (C, Loc))))); + + return Func_Body; + end Make_Boolean_Array_Op; + + ------------------------ + -- Rewrite_Comparison -- + ------------------------ + + procedure Rewrite_Comparison (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + + Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2); + -- Res indicates if compare outcome can be determined at compile time + + True_Result : Boolean; + False_Result : Boolean; + + begin + case N_Op_Compare (Nkind (N)) is + when N_Op_Eq => + True_Result := Res = EQ; + False_Result := Res = LT or else Res = GT or else Res = NE; + + when N_Op_Ge => + True_Result := Res in Compare_GE; + False_Result := Res = LT; + + when N_Op_Gt => + True_Result := Res = GT; + False_Result := Res in Compare_LE; + + when N_Op_Lt => + True_Result := Res = LT; + False_Result := Res in Compare_GE; + + when N_Op_Le => + True_Result := Res in Compare_LE; + False_Result := Res = GT; + + when N_Op_Ne => + True_Result := Res = NE; + False_Result := Res = LT or else Res = GT or else Res = EQ; + end case; + + if True_Result then + Rewrite (N, + Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)))); + Analyze_And_Resolve (N, Typ); + + elsif False_Result then + Rewrite (N, + Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N)))); + Analyze_And_Resolve (N, Typ); + end if; + end Rewrite_Comparison; + + ----------------------- + -- Tagged_Membership -- + ----------------------- + + -- There are two different cases to consider depending on whether + -- the right operand is a class-wide type or not. If not we just + -- compare the actual tag of the left expr to the target type tag: + -- + -- Left_Expr.Tag = Right_Type'Tag; + -- + -- If it is a class-wide type we use the RT function CW_Membership which + -- is usually implemented by looking in the ancestor tables contained in + -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag + + function Tagged_Membership (N : Node_Id) return Node_Id is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Loc : constant Source_Ptr := Sloc (N); + + Left_Type : Entity_Id; + Right_Type : Entity_Id; + Obj_Tag : Node_Id; + + begin + Left_Type := Etype (Left); + Right_Type := Etype (Right); + + if Is_Class_Wide_Type (Left_Type) then + Left_Type := Root_Type (Left_Type); + end if; + + Obj_Tag := + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Left), + Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc)); + + if Is_Class_Wide_Type (Right_Type) then + return + Make_DT_Access_Action (Left_Type, + Action => CW_Membership, + Args => New_List ( + Obj_Tag, + New_Reference_To ( + Access_Disp_Table (Root_Type (Right_Type)), Loc))); + else + return + Make_Op_Eq (Loc, + Left_Opnd => Obj_Tag, + Right_Opnd => + New_Reference_To (Access_Disp_Table (Right_Type), Loc)); + end if; + + end Tagged_Membership; + + ------------------------------ + -- Unary_Op_Validity_Checks -- + ------------------------------ + + procedure Unary_Op_Validity_Checks (N : Node_Id) is + begin + if Validity_Checks_On and Validity_Check_Operands then + Ensure_Valid (Right_Opnd (N)); + end if; + end Unary_Op_Validity_Checks; + +end Exp_Ch4; diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads new file mode 100644 index 00000000000..c7e24180d87 --- /dev/null +++ b/gcc/ada/exp_ch4.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 4 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.42 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 4 constructs + +with Types; use Types; + +package Exp_Ch4 is + + procedure Expand_N_Allocator (N : Node_Id); + procedure Expand_N_And_Then (N : Node_Id); + procedure Expand_N_Conditional_Expression (N : Node_Id); + procedure Expand_N_In (N : Node_Id); + procedure Expand_N_Explicit_Dereference (N : Node_Id); + procedure Expand_N_Indexed_Component (N : Node_Id); + procedure Expand_N_Not_In (N : Node_Id); + procedure Expand_N_Null (N : Node_Id); + procedure Expand_N_Op_Abs (N : Node_Id); + procedure Expand_N_Op_Add (N : Node_Id); + procedure Expand_N_Op_And (N : Node_Id); + procedure Expand_N_Op_Concat (N : Node_Id); + procedure Expand_N_Op_Divide (N : Node_Id); + procedure Expand_N_Op_Expon (N : Node_Id); + procedure Expand_N_Op_Eq (N : Node_Id); + procedure Expand_N_Op_Ge (N : Node_Id); + procedure Expand_N_Op_Gt (N : Node_Id); + procedure Expand_N_Op_Le (N : Node_Id); + procedure Expand_N_Op_Lt (N : Node_Id); + procedure Expand_N_Op_Minus (N : Node_Id); + procedure Expand_N_Op_Mod (N : Node_Id); + procedure Expand_N_Op_Multiply (N : Node_Id); + procedure Expand_N_Op_Ne (N : Node_Id); + procedure Expand_N_Op_Not (N : Node_Id); + procedure Expand_N_Op_Or (N : Node_Id); + procedure Expand_N_Op_Plus (N : Node_Id); + procedure Expand_N_Op_Rem (N : Node_Id); + procedure Expand_N_Op_Rotate_Left (N : Node_Id); + procedure Expand_N_Op_Rotate_Right (N : Node_Id); + procedure Expand_N_Op_Shift_Left (N : Node_Id); + procedure Expand_N_Op_Shift_Right (N : Node_Id); + procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id); + procedure Expand_N_Op_Subtract (N : Node_Id); + procedure Expand_N_Op_Xor (N : Node_Id); + procedure Expand_N_Or_Else (N : Node_Id); + procedure Expand_N_Qualified_Expression (N : Node_Id); + procedure Expand_N_Selected_Component (N : Node_Id); + procedure Expand_N_Slice (N : Node_Id); + procedure Expand_N_Type_Conversion (N : Node_Id); + procedure Expand_N_Unchecked_Expression (N : Node_Id); + procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id); + + function Expand_Record_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) + return Node_Id; + -- Expand a record equality into an expression that compares the fields + -- individually to yield the required Boolean result. Loc is the + -- location for the generated nodes. Typ is the type of the record, and + -- Lhs, Rhs are the record expressions to be compared, these + -- expressions need not to be analyzed but have to be side-effect free. + -- Bodies is a list on which to attach bodies of local functions that + -- are created in the process. This is the responsability of the caller + -- to insert those bodies at the right place. Nod provdies the Sloc + -- value for generated code. + +end Exp_Ch4; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb new file mode 100644 index 00000000000..8c56fe386b0 --- /dev/null +++ b/gcc/ada/exp_ch5.adb @@ -0,0 +1,2858 @@ +----------------------------------------------------------------------------- +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.216 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Exp_Aggr; use Exp_Aggr; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; +with Exp_Pakd; use Exp_Pakd; +with Exp_Util; use Exp_Util; +with Hostparm; use Hostparm; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Ch5 is + + function Change_Of_Representation (N : Node_Id) return Boolean; + -- Determine if the right hand side of the assignment N is a type + -- conversion which requires a change of representation. Called + -- only for the array and record cases. + + procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id); + -- N is an assignment which assigns an array value. This routine process + -- the various special cases and checks required for such assignments, + -- including change of representation. Rhs is normally simply the right + -- hand side of the assignment, except that if the right hand side is + -- a type conversion or a qualified expression, then the Rhs is the + -- actual expression inside any such type conversions or qualifications. + + function Expand_Assign_Array_Loop + (N : Node_Id; + Larray : Entity_Id; + Rarray : Entity_Id; + L_Type : Entity_Id; + R_Type : Entity_Id; + Ndim : Pos; + Rev : Boolean) + return Node_Id; + -- N is an assignment statement which assigns an array value. This routine + -- expands the assignment into a loop (or nested loops for the case of a + -- multi-dimensional array) to do the assignment component by component. + -- Larray and Rarray are the entities of the actual arrays on the left + -- hand and right hand sides. L_Type and R_Type are the types of these + -- arrays (which may not be the same, due to either sliding, or to a + -- change of representation case). Ndim is the number of dimensions and + -- the parameter Rev indicates if the loops run normally (Rev = False), + -- or reversed (Rev = True). The value returned is the constructed + -- loop statement. Auxiliary declarations are inserted before node N + -- using the standard Insert_Actions mechanism. + + procedure Expand_Assign_Record (N : Node_Id); + -- N is an assignment of a non-tagged record value. This routine handles + -- the special cases and checks required for such assignments, including + -- change of representation. + + function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; + -- Generate the necessary code for controlled and Tagged assignment, + -- that is to say, finalization of the target before, adjustement of + -- the target after and save and restore of the tag and finalization + -- pointers which are not 'part of the value' and must not be changed + -- upon assignment. N is the original Assignment node. + + ------------------------------ + -- Change_Of_Representation -- + ------------------------------ + + function Change_Of_Representation (N : Node_Id) return Boolean is + Rhs : constant Node_Id := Expression (N); + + begin + return + Nkind (Rhs) = N_Type_Conversion + and then + not Same_Representation (Etype (Rhs), Etype (Expression (Rhs))); + end Change_Of_Representation; + + ------------------------- + -- Expand_Assign_Array -- + ------------------------- + + -- There are two issues here. First, do we let Gigi do a block move, or + -- do we expand out into a loop? Second, we need to set the two flags + -- Forwards_OK and Backwards_OK which show whether the block move (or + -- corresponding loops) can be legitimately done in a forwards (low to + -- high) or backwards (high to low) manner. + + procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Lhs : constant Node_Id := Name (N); + + Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs); + Act_Rhs : Node_Id := Get_Referenced_Object (Rhs); + + L_Type : constant Entity_Id := + Underlying_Type (Get_Actual_Subtype (Act_Lhs)); + R_Type : Entity_Id := + Underlying_Type (Get_Actual_Subtype (Act_Rhs)); + + L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice; + R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice; + + Crep : constant Boolean := Change_Of_Representation (N); + + Larray : Node_Id; + Rarray : Node_Id; + + Ndim : constant Pos := Number_Dimensions (L_Type); + + Loop_Required : Boolean := False; + -- This switch is set to True if the array move must be done using + -- an explicit front end generated loop. + + function Has_Address_Clause (Exp : Node_Id) return Boolean; + -- Test if Exp is a reference to an array whose declaration has + -- an address clause, or it is a slice of such an array. + + function Is_Formal_Array (Exp : Node_Id) return Boolean; + -- Test if Exp is a reference to an array which is either a formal + -- parameter or a slice of a formal parameter. These are the cases + -- where hidden aliasing can occur. + + function Is_Non_Local_Array (Exp : Node_Id) return Boolean; + -- Determine if Exp is a reference to an array variable which is other + -- than an object defined in the current scope, or a slice of such + -- an object. Such objects can be aliased to parameters (unlike local + -- array references). + + function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean; + -- Returns True if Arg (either the left or right hand side of the + -- assignment) is a slice that could be unaligned wrt the array type. + -- This is true if Arg is a component of a packed record, or is + -- a record component to which a component clause applies. This + -- is a little pessimistic, but the result of an unnecessary + -- decision that something is possibly unaligned is only to + -- generate a front end loop, which is not so terrible. + -- It would really be better if backend handled this ??? + + ------------------------ + -- Has_Address_Clause -- + ------------------------ + + function Has_Address_Clause (Exp : Node_Id) return Boolean is + begin + return + (Is_Entity_Name (Exp) and then + Present (Address_Clause (Entity (Exp)))) + or else + (Nkind (Exp) = N_Slice and then Has_Address_Clause (Prefix (Exp))); + end Has_Address_Clause; + + --------------------- + -- Is_Formal_Array -- + --------------------- + + function Is_Formal_Array (Exp : Node_Id) return Boolean is + begin + return + (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp))) + or else + (Nkind (Exp) = N_Slice and then Is_Formal_Array (Prefix (Exp))); + end Is_Formal_Array; + + ------------------------ + -- Is_Non_Local_Array -- + ------------------------ + + function Is_Non_Local_Array (Exp : Node_Id) return Boolean is + begin + return (Is_Entity_Name (Exp) + and then Scope (Entity (Exp)) /= Current_Scope) + or else (Nkind (Exp) = N_Slice + and then Is_Non_Local_Array (Prefix (Exp))); + end Is_Non_Local_Array; + + ------------------------------ + -- Possible_Unaligned_Slice -- + ------------------------------ + + function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean is + begin + -- No issue if this is not a slice, or else strict alignment + -- is not required in any case. + + if Nkind (Arg) /= N_Slice + or else not Target_Strict_Alignment + then + return False; + end if; + + -- No issue if the component type is a byte or byte aligned + + declare + Array_Typ : constant Entity_Id := Etype (Arg); + Comp_Typ : constant Entity_Id := Component_Type (Array_Typ); + Pref : constant Node_Id := Prefix (Arg); + + begin + if Known_Alignment (Array_Typ) then + if Alignment (Array_Typ) = 1 then + return False; + end if; + + elsif Known_Component_Size (Array_Typ) then + if Component_Size (Array_Typ) = 1 then + return False; + end if; + + elsif Known_Esize (Comp_Typ) then + if Esize (Comp_Typ) <= System_Storage_Unit then + return False; + end if; + end if; + + -- No issue if this is not a selected component + + if Nkind (Pref) /= N_Selected_Component then + return False; + end if; + + -- Else we test for a possibly unaligned component + + return + Is_Packed (Etype (Pref)) + or else + Present (Component_Clause (Entity (Selector_Name (Pref)))); + end; + end Possible_Unaligned_Slice; + + -- Determine if Lhs, Rhs are formal arrays or non-local arrays + + Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs); + Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs); + + Lhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Lhs); + Rhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Rhs); + + -- Start of processing for Expand_Assign_Array + + begin + -- Deal with length check, note that the length check is done with + -- respect to the right hand side as given, not a possible underlying + -- renamed object, since this would generate incorrect extra checks. + + Apply_Length_Check (Rhs, L_Type); + + -- We start by assuming that the move can be done in either + -- direction, i.e. that the two sides are completely disjoint. + + Set_Forwards_OK (N, True); + Set_Backwards_OK (N, True); + + -- Normally it is only the slice case that can lead to overlap, + -- and explicit checks for slices are made below. But there is + -- one case where the slice can be implicit and invisible to us + -- and that is the case where we have a one dimensional array, + -- and either both operands are parameters, or one is a parameter + -- and the other is a global variable. In this case the parameter + -- could be a slice that overlaps with the other parameter. + + -- Check for the case of slices requiring an explicit loop. Normally + -- it is only the explicit slice cases that bother us, but in the + -- case of one dimensional arrays, parameters can be slices that + -- are passed by reference, so we can have aliasing for assignments + -- from one parameter to another, or assignments between parameters + -- and non-local variables. + + -- Note: overlap is never possible if there is a change of + -- representation, so we can exclude this case + + -- In the case of compiling for the Java Virtual Machine, + -- slices are always passed by making a copy, so we don't + -- have to worry about overlap. We also want to prevent + -- generation of "<" comparisons for array addresses, + -- since that's a meaningless operation on the JVM. + + if Ndim = 1 + and then not Crep + and then + ((Lhs_Formal and Rhs_Formal) + or else + (Lhs_Formal and Rhs_Non_Local_Var) + or else + (Rhs_Formal and Lhs_Non_Local_Var)) + and then not Java_VM + then + Set_Forwards_OK (N, False); + Set_Backwards_OK (N, False); + + -- Note: the bit-packed case is not worrisome here, since if + -- we have a slice passed as a parameter, it is always aligned + -- on a byte boundary, and if there are no explicit slices, the + -- assignment can be performed directly. + end if; + + -- We certainly must use a loop for change of representation + -- and also we use the operand of the conversion on the right + -- hand side as the effective right hand side (the component + -- types must match in this situation). + + if Crep then + Act_Rhs := Get_Referenced_Object (Rhs); + R_Type := Get_Actual_Subtype (Act_Rhs); + Loop_Required := True; + + -- Arrays with controlled components are expanded into a loop + -- to force calls to adjust at the component level. + + elsif Has_Controlled_Component (L_Type) then + Loop_Required := True; + + -- The only remaining cases involve slice assignments. If no slices + -- are involved, then the assignment can definitely be handled by gigi. + -- unless we have the parameter case mentioned above. + + elsif not L_Slice and not R_Slice then + + -- The following is temporary code??? It is not clear why it is + -- necessary. For further investigation, look at the following + -- short program which fails: + + -- procedure C52 is + -- type BITS is array(INTEGER range <>) of BOOLEAN; + -- pragma PACK(BITS); + -- type A is access BITS; + -- P1,P2 : A; + -- begin + -- P1 := new BITS (1 .. 65_535); + -- P2 := new BITS (1 .. 65_535); + -- P2.ALL := P1.ALL; + -- end C52; + + -- To deal with the above, we expand out if either of the operands + -- is an explicit dereference to an unconstrained bit packed array. + + Temporary_Code : declare + function Is_Deref_Of_UBP (Opnd : Node_Id) return Boolean; + -- Function to perform required test for special case above + + function Is_Deref_Of_UBP (Opnd : Node_Id) return Boolean is + P_Type : Entity_Id; + Des_Type : Entity_Id; + + begin + if Nkind (Opnd) /= N_Explicit_Dereference then + return False; + else + P_Type := Etype (Prefix (Opnd)); + + if not Is_Access_Type (P_Type) then + return False; + + else + Des_Type := Designated_Type (P_Type); + return + Is_Bit_Packed_Array (Des_Type) + and then not Is_Constrained (Des_Type); + end if; + end if; + end Is_Deref_Of_UBP; + + -- Start of processing for temporary code + + begin + if Is_Deref_Of_UBP (Lhs) + or else + Is_Deref_Of_UBP (Rhs) + then + Loop_Required := True; + + -- Normal case (will be only case when above temp code removed ??? + + elsif Forwards_OK (N) then + return; + end if; + end Temporary_Code; + + -- Gigi can always handle the assignment if the right side is a string + -- literal (note that overlap is definitely impossible in this case). + + elsif Nkind (Rhs) = N_String_Literal then + return; + + -- If either operand is bit packed, then we need a loop, since we + -- can't be sure that the slice is byte aligned. Similarly, if either + -- operand is a possibly unaligned slice, then we need a loop (since + -- gigi cannot handle unaligned slices). + + elsif Is_Bit_Packed_Array (L_Type) + or else Is_Bit_Packed_Array (R_Type) + or else Possible_Unaligned_Slice (Lhs) + or else Possible_Unaligned_Slice (Rhs) + then + Loop_Required := True; + + -- If we are not bit-packed, and we have only one slice, then no + -- overlap is possible except in the parameter case, so we can let + -- gigi handle things. + + elsif not (L_Slice and R_Slice) then + if Forwards_OK (N) then + return; + end if; + end if; + + -- Come here to compelete the analysis + + -- Loop_Required: Set to True if we know that a loop is required + -- regardless of overlap considerations. + + -- Forwards_OK: Set to False if we already know that a forwards + -- move is not safe, else set to True. + + -- Backwards_OK: Set to False if we already know that a backwards + -- move is not safe, else set to True + + -- Our task at this stage is to complete the overlap analysis, which + -- can result in possibly setting Forwards_OK or Backwards_OK to + -- False, and then generating the final code, either by deciding + -- that it is OK after all to let Gigi handle it, or by generating + -- appropriate code in the front end. + + declare + L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + + Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); + Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ); + Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ); + Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ); + + Act_L_Array : Node_Id; + Act_R_Array : Node_Id; + + Cleft_Lo : Node_Id; + Cright_Lo : Node_Id; + Condition : Node_Id; + + Cresult : Compare_Result; + + begin + -- Get the expressions for the arrays. If we are dealing with a + -- private type, then convert to the underlying type. We can do + -- direct assignments to an array that is a private type, but + -- we cannot assign to elements of the array without this extra + -- unchecked conversion. + + if Nkind (Act_Lhs) = N_Slice then + Larray := Prefix (Act_Lhs); + else + Larray := Act_Lhs; + + if Is_Private_Type (Etype (Larray)) then + Larray := + Unchecked_Convert_To + (Underlying_Type (Etype (Larray)), Larray); + end if; + end if; + + if Nkind (Act_Rhs) = N_Slice then + Rarray := Prefix (Act_Rhs); + else + Rarray := Act_Rhs; + + if Is_Private_Type (Etype (Rarray)) then + Rarray := + Unchecked_Convert_To + (Underlying_Type (Etype (Rarray)), Rarray); + end if; + end if; + + -- If both sides are slices, we must figure out whether + -- it is safe to do the move in one direction or the other + -- It is always safe if there is a change of representation + -- since obviously two arrays with different representations + -- cannot possibly overlap. + + if (not Crep) and L_Slice and R_Slice then + Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs)); + Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs)); + + -- If both left and right hand arrays are entity names, and + -- refer to different entities, then we know that the move + -- is safe (the two storage areas are completely disjoint). + + if Is_Entity_Name (Act_L_Array) + and then Is_Entity_Name (Act_R_Array) + and then Entity (Act_L_Array) /= Entity (Act_R_Array) + then + null; + + -- Otherwise, we assume the worst, which is that the two + -- arrays are the same array. There is no need to check if + -- we know that is the case, because if we don't know it, + -- we still have to assume it! + + -- Generally if the same array is involved, then we have + -- an overlapping case. We will have to really assume the + -- worst (i.e. set neither of the OK flags) unless we can + -- determine the lower or upper bounds at compile time and + -- compare them. + + else + Cresult := Compile_Time_Compare (Left_Lo, Right_Lo); + + if Cresult = Unknown then + Cresult := Compile_Time_Compare (Left_Hi, Right_Hi); + end if; + + case Cresult is + when LT | LE | EQ => Set_Backwards_OK (N, False); + when GT | GE => Set_Forwards_OK (N, False); + when NE | Unknown => Set_Backwards_OK (N, False); + Set_Forwards_OK (N, False); + end case; + end if; + end if; + + -- If after that analysis, Forwards_OK is still True, and + -- Loop_Required is False, meaning that we have not discovered + -- some non-overlap reason for requiring a loop, then we can + -- still let gigi handle it. + + if not Loop_Required then + if Forwards_OK (N) then + return; + + else + null; + -- Here is where a memmove would be appropriate ??? + end if; + end if; + + -- At this stage we have to generate an explicit loop, and + -- we have the following cases: + + -- Forwards_OK = True + + -- Rnn : right_index := right_index'First; + -- for Lnn in left-index loop + -- left (Lnn) := right (Rnn); + -- Rnn := right_index'Succ (Rnn); + -- end loop; + + -- Note: the above code MUST be analyzed with checks off, + -- because otherwise the Succ could overflow. But in any + -- case this is more efficient! + + -- Forwards_OK = False, Backwards_OK = True + + -- Rnn : right_index := right_index'Last; + -- for Lnn in reverse left-index loop + -- left (Lnn) := right (Rnn); + -- Rnn := right_index'Pred (Rnn); + -- end loop; + + -- Note: the above code MUST be analyzed with checks off, + -- because otherwise the Pred could overflow. But in any + -- case this is more efficient! + + -- Forwards_OK = Backwards_OK = False + + -- This only happens if we have the same array on each side. It is + -- possible to create situations using overlays that violate this, + -- but we simply do not promise to get this "right" in this case. + + -- There are two possible subcases. If the No_Implicit_Conditionals + -- restriction is set, then we generate the following code: + + -- declare + -- T : constant <operand-type> := rhs; + -- begin + -- lhs := T; + -- end; + + -- If implicit conditionals are permitted, then we generate: + + -- if Left_Lo <= Right_Lo then + -- <code for Forwards_OK = True above> + -- else + -- <code for Backwards_OK = True above> + -- end if; + + -- Cases where either Forwards_OK or Backwards_OK is true + + if Forwards_OK (N) or else Backwards_OK (N) then + Rewrite (N, + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => not Forwards_OK (N))); + + -- Case of both are false with No_Implicit_Conditionals + + elsif Restrictions (No_Implicit_Conditionals) then + declare + T : Entity_Id := Make_Defining_Identifier (Loc, + Chars => Name_T); + + begin + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => T, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Etype (Rhs), Loc), + Expression => Relocate_Node (Rhs))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => Relocate_Node (Lhs), + Expression => New_Occurrence_Of (T, Loc)))))); + end; + + -- Case of both are false with implicit conditionals allowed + + else + -- Before we generate this code, we must ensure that the + -- left and right side array types are defined. They may + -- be itypes, and we cannot let them be defined inside the + -- if, since the first use in the then may not be executed. + + Ensure_Defined (L_Type, N); + Ensure_Defined (R_Type, N); + + -- We normally compare addresses to find out which way round + -- to do the loop, since this is realiable, and handles the + -- cases of parameters, conversions etc. But we can't do that + -- in the bit packed case or the Java VM case, because addresses + -- don't work there. + + if not Is_Bit_Packed_Array (L_Type) and then not Java_VM then + Condition := + Make_Op_Le (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + Duplicate_Subexpr (Larray, True), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (L_Index_Typ, Loc), + Attribute_Name => Name_First))), + Attribute_Name => Name_Address)), + + Right_Opnd => + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + Duplicate_Subexpr (Rarray, True), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (R_Index_Typ, Loc), + Attribute_Name => Name_First))), + Attribute_Name => Name_Address))); + + -- For the bit packed and Java VM cases we use the bounds. + -- That's OK, because we don't have to worry about parameters, + -- since they cannot cause overlap. Perhaps we should worry + -- about weird slice conversions ??? + + else + -- Copy the bounds and reset the Analyzed flag, because the + -- bounds of the index type itself may be universal, and must + -- must be reaanalyzed to acquire the proper type for Gigi. + + Cleft_Lo := New_Copy_Tree (Left_Lo); + Cright_Lo := New_Copy_Tree (Right_Lo); + Set_Analyzed (Cleft_Lo, False); + Set_Analyzed (Cright_Lo, False); + + Condition := + Make_Op_Le (Loc, + Left_Opnd => Cleft_Lo, + Right_Opnd => Cright_Lo); + end if; + + Rewrite (N, + Make_Implicit_If_Statement (N, + Condition => Condition, + + Then_Statements => New_List ( + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => False)), + + Else_Statements => New_List ( + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => True)))); + end if; + + Analyze (N, Suppress => All_Checks); + end; + end Expand_Assign_Array; + + ------------------------------ + -- Expand_Assign_Array_Loop -- + ------------------------------ + + -- The following is an example of the loop generated for the case of + -- a two-dimensional array: + + -- declare + -- R2b : Tm1X1 := 1; + -- begin + -- for L1b in 1 .. 100 loop + -- declare + -- R4b : Tm1X2 := 1; + -- begin + -- for L3b in 1 .. 100 loop + -- vm1 (L1b, L3b) := vm2 (R2b, R4b); + -- R4b := Tm1X2'succ(R4b); + -- end loop; + -- end; + -- R2b := Tm1X1'succ(R2b); + -- end loop; + -- end; + + -- Here Rev is False, and Tm1Xn are the subscript types for the right + -- hand side. The declarations of R2b and R4b are inserted before the + -- original assignment statement. + + function Expand_Assign_Array_Loop + (N : Node_Id; + Larray : Entity_Id; + Rarray : Entity_Id; + L_Type : Entity_Id; + R_Type : Entity_Id; + Ndim : Pos; + Rev : Boolean) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + Lnn : array (1 .. Ndim) of Entity_Id; + Rnn : array (1 .. Ndim) of Entity_Id; + -- Entities used as subscripts on left and right sides + + L_Index_Type : array (1 .. Ndim) of Entity_Id; + R_Index_Type : array (1 .. Ndim) of Entity_Id; + -- Left and right index types + + Assign : Node_Id; + + F_Or_L : Name_Id; + S_Or_P : Name_Id; + + begin + if Rev then + F_Or_L := Name_Last; + S_Or_P := Name_Pred; + else + F_Or_L := Name_First; + S_Or_P := Name_Succ; + end if; + + -- Setup index types and subscript entities + + declare + L_Index : Node_Id; + R_Index : Node_Id; + + begin + L_Index := First_Index (L_Type); + R_Index := First_Index (R_Type); + + for J in 1 .. Ndim loop + Lnn (J) := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Rnn (J) := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + + L_Index_Type (J) := Etype (L_Index); + R_Index_Type (J) := Etype (R_Index); + + Next_Index (L_Index); + Next_Index (R_Index); + end loop; + end; + + -- Now construct the assignment statement + + declare + ExprL : List_Id := New_List; + ExprR : List_Id := New_List; + + begin + for J in 1 .. Ndim loop + Append_To (ExprL, New_Occurrence_Of (Lnn (J), Loc)); + Append_To (ExprR, New_Occurrence_Of (Rnn (J), Loc)); + end loop; + + Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr (Larray, Name_Req => True), + Expressions => ExprL), + Expression => + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr (Rarray, Name_Req => True), + Expressions => ExprR)); + + -- Propagate the No_Ctrl_Actions flag to individual assignments + + Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); + end; + + -- Now construct the loop from the inside out, with the last subscript + -- varying most rapidly. Note that Assign is first the raw assignment + -- statement, and then subsequently the loop that wraps it up. + + for J in reverse 1 .. Ndim loop + Assign := + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn (J), + Object_Definition => + New_Occurrence_Of (R_Index_Type (J), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (R_Index_Type (J), Loc), + Attribute_Name => F_Or_L))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Lnn (J), + Reverse_Present => Rev, + Discrete_Subtype_Definition => + New_Reference_To (L_Index_Type (J), Loc))), + + Statements => New_List ( + Assign, + + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn (J), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (R_Index_Type (J), Loc), + Attribute_Name => S_Or_P, + Expressions => New_List ( + New_Occurrence_Of (Rnn (J), Loc))))))))); + end loop; + + return Assign; + end Expand_Assign_Array_Loop; + + -------------------------- + -- Expand_Assign_Record -- + -------------------------- + + -- The only processing required is in the change of representation + -- case, where we must expand the assignment to a series of field + -- by field assignments. + + procedure Expand_Assign_Record (N : Node_Id) is + begin + if not Change_Of_Representation (N) then + return; + end if; + + -- At this stage we know that the right hand side is a conversion + + declare + Loc : constant Source_Ptr := Sloc (N); + Lhs : constant Node_Id := Name (N); + Rhs : constant Node_Id := Expression (Expression (N)); + R_Rec : constant Node_Id := Expression (Expression (N)); + R_Typ : constant Entity_Id := Base_Type (Etype (R_Rec)); + L_Typ : constant Entity_Id := Etype (Lhs); + Decl : constant Node_Id := Declaration_Node (R_Typ); + RDef : Node_Id; + F : Entity_Id; + + function Find_Component + (Typ : Entity_Id; + Comp : Entity_Id) + return Entity_Id; + -- Find the component with the given name in the underlying record + -- declaration for Typ. We need to use the actual entity because + -- the type may be private and resolution by identifier alone would + -- fail. + + function Make_Component_List_Assign (CL : Node_Id) return List_Id; + -- Returns a sequence of statements to assign the components that + -- are referenced in the given component list. + + function Make_Field_Assign (C : Entity_Id) return Node_Id; + -- Given C, the entity for a discriminant or component, build + -- an assignment for the corresponding field values. + + function Make_Field_Assigns (CI : List_Id) return List_Id; + -- Given CI, a component items list, construct series of statements + -- for fieldwise assignment of the corresponding components. + + -------------------- + -- Find_Component -- + -------------------- + + function Find_Component + (Typ : Entity_Id; + Comp : Entity_Id) + return Entity_Id + + is + Utyp : constant Entity_Id := Underlying_Type (Typ); + C : Entity_Id; + + begin + C := First_Entity (Utyp); + + while Present (C) loop + if Chars (C) = Chars (Comp) then + return C; + end if; + Next_Entity (C); + end loop; + + raise Program_Error; + end Find_Component; + + -------------------------------- + -- Make_Component_List_Assign -- + -------------------------------- + + function Make_Component_List_Assign (CL : Node_Id) return List_Id is + CI : constant List_Id := Component_Items (CL); + VP : constant Node_Id := Variant_Part (CL); + + Result : List_Id; + Alts : List_Id; + V : Node_Id; + DC : Node_Id; + DCH : List_Id; + + begin + Result := Make_Field_Assigns (CI); + + if Present (VP) then + + V := First_Non_Pragma (Variants (VP)); + Alts := New_List; + while Present (V) loop + + DCH := New_List; + DC := First (Discrete_Choices (V)); + while Present (DC) loop + Append_To (DCH, New_Copy_Tree (DC)); + Next (DC); + end loop; + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => DCH, + Statements => + Make_Component_List_Assign (Component_List (V)))); + Next_Non_Pragma (V); + end loop; + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Selector_Name => + Make_Identifier (Loc, Chars (Name (VP)))), + Alternatives => Alts)); + + end if; + + return Result; + end Make_Component_List_Assign; + + ----------------------- + -- Make_Field_Assign -- + ----------------------- + + function Make_Field_Assign (C : Entity_Id) return Node_Id is + A : Node_Id; + + begin + A := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Selector_Name => + New_Occurrence_Of (Find_Component (L_Typ, C), Loc)), + Expression => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Selector_Name => New_Occurrence_Of (C, Loc))); + + -- Set Assignment_OK, so discriminants can be assigned + + Set_Assignment_OK (Name (A), True); + return A; + end Make_Field_Assign; + + ------------------------ + -- Make_Field_Assigns -- + ------------------------ + + function Make_Field_Assigns (CI : List_Id) return List_Id is + Item : Node_Id; + Result : List_Id; + + begin + Item := First (CI); + Result := New_List; + + while Present (Item) loop + if Nkind (Item) = N_Component_Declaration then + Append_To + (Result, Make_Field_Assign (Defining_Identifier (Item))); + end if; + + Next (Item); + end loop; + + return Result; + end Make_Field_Assigns; + + -- Start of processing for Expand_Assign_Record + + begin + -- Note that we use the base type for this processing. This results + -- in some extra work in the constrained case, but the change of + -- representation case is so unusual that it is not worth the effort. + + -- First copy the discriminants. This is done unconditionally. It + -- is required in the unconstrained left side case, and also in the + -- case where this assignment was constructed during the expansion + -- of a type conversion (since initialization of discriminants is + -- suppressed in this case). It is unnecessary but harmless in + -- other cases. + + if Has_Discriminants (L_Typ) then + F := First_Discriminant (R_Typ); + while Present (F) loop + Insert_Action (N, Make_Field_Assign (F)); + Next_Discriminant (F); + end loop; + end if; + + -- We know the underlying type is a record, but its current view + -- may be private. We must retrieve the usable record declaration. + + if Nkind (Decl) = N_Private_Type_Declaration + and then Present (Full_View (R_Typ)) + then + RDef := Type_Definition (Declaration_Node (Full_View (R_Typ))); + else + RDef := Type_Definition (Decl); + end if; + + if Nkind (RDef) = N_Record_Definition + and then Present (Component_List (RDef)) + then + Insert_Actions + (N, Make_Component_List_Assign (Component_List (RDef))); + + Rewrite (N, Make_Null_Statement (Loc)); + end if; + + end; + end Expand_Assign_Record; + + ----------------------------------- + -- Expand_N_Assignment_Statement -- + ----------------------------------- + + -- For array types, deal with slice assignments and setting the flags + -- to indicate if it can be statically determined which direction the + -- move should go in. Also deal with generating length checks. + + procedure Expand_N_Assignment_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lhs : constant Node_Id := Name (N); + Rhs : constant Node_Id := Expression (N); + Typ : constant Entity_Id := Underlying_Type (Etype (Lhs)); + Exp : Node_Id; + + begin + -- Check for a special case where a high level transformation is + -- required. If we have either of: + + -- P.field := rhs; + -- P (sub) := rhs; + + -- where P is a reference to a bit packed array, then we have to unwind + -- the assignment. The exact meaning of being a reference to a bit + -- packed array is as follows: + + -- An indexed component whose prefix is a bit packed array is a + -- reference to a bit packed array. + + -- An indexed component or selected component whose prefix is a + -- reference to a bit packed array is itself a reference ot a + -- bit packed array. + + -- The required transformation is + + -- Tnn : prefix_type := P; + -- Tnn.field := rhs; + -- P := Tnn; + + -- or + + -- Tnn : prefix_type := P; + -- Tnn (subscr) := rhs; + -- P := Tnn; + + -- Since P is going to be evaluated more than once, any subscripts + -- in P must have their evaluation forced. + + if (Nkind (Lhs) = N_Indexed_Component + or else + Nkind (Lhs) = N_Selected_Component) + and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs)) + then + declare + BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs)); + BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr); + Tnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + begin + -- Insert the post assignment first, because we want to copy + -- the BPAR_Expr tree before it gets analyzed in the context + -- of the pre assignment. Note that we do not analyze the + -- post assignment yet (we cannot till we have completed the + -- analysis of the pre assignment). As usual, the analysis + -- of this post assignment will happen on its own when we + -- "run into" it after finishing the current assignment. + + Insert_After (N, + Make_Assignment_Statement (Loc, + Name => New_Copy_Tree (BPAR_Expr), + Expression => New_Occurrence_Of (Tnn, Loc))); + + -- At this stage BPAR_Expr is a reference to a bit packed + -- array where the reference was not expanded in the original + -- tree, since it was on the left side of an assignment. But + -- in the pre-assignment statement (the object definition), + -- BPAR_Expr will end up on the right hand side, and must be + -- reexpanded. To achieve this, we reset the analyzed flag + -- of all selected and indexed components down to the actual + -- indexed component for the packed array. + + Exp := BPAR_Expr; + loop + Set_Analyzed (Exp, False); + + if Nkind (Exp) = N_Selected_Component + or else + Nkind (Exp) = N_Indexed_Component + then + Exp := Prefix (Exp); + else + exit; + end if; + end loop; + + -- Now we can insert and analyze the pre-assignment. + + -- If the right-hand side requires a transient scope, it has + -- already been placed on the stack. However, the declaration is + -- inserted in the tree outside of this scope, and must reflect + -- the proper scope for its variable. This awkward bit is forced + -- by the stricter scope discipline imposed by GCC 2.97. + + declare + Uses_Transient_Scope : constant Boolean := + Scope_Is_Transient and then N = Node_To_Be_Wrapped; + + begin + if Uses_Transient_Scope then + New_Scope (Scope (Current_Scope)); + end if; + + Insert_Before_And_Analyze (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (BPAR_Typ, Loc), + Expression => BPAR_Expr)); + + if Uses_Transient_Scope then + Pop_Scope; + end if; + end; + + -- Now fix up the original assignment and continue processing + + Rewrite (Prefix (Lhs), + New_Occurrence_Of (Tnn, Loc)); + end; + end if; + + -- When we have the appropriate type of aggregate in the + -- expression (it has been determined during analysis of the + -- aggregate by setting the delay flag), let's perform in place + -- assignment and thus avoid creating a temporay. + + if Is_Delayed_Aggregate (Rhs) then + Convert_Aggr_In_Assignment (N); + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; + + -- Apply discriminant check if required. If Lhs is an access type + -- to a designated type with discriminants, we must always check. + + if Has_Discriminants (Etype (Lhs)) then + + -- Skip discriminant check if change of representation. Will be + -- done when the change of representation is expanded out. + + if not Change_Of_Representation (N) then + Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs); + end if; + + -- If the type is private without discriminants, and the full type + -- has discriminants (necessarily with defaults) a check may still be + -- necessary if the Lhs is aliased. The private determinants must be + -- visible to build the discriminant constraints. + + elsif Is_Private_Type (Etype (Lhs)) + and then Has_Discriminants (Typ) + and then Nkind (Lhs) = N_Explicit_Dereference + then + declare + Lt : constant Entity_Id := Etype (Lhs); + begin + Set_Etype (Lhs, Typ); + Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); + Apply_Discriminant_Check (Rhs, Typ, Lhs); + Set_Etype (Lhs, Lt); + end; + + -- If the Lhs has a private type with unknown discriminants, it + -- may have a full view with discriminants, but those are nameable + -- only in the underlying type, so convert the Rhs to it before + -- potential checking. + + elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) + and then Has_Discriminants (Typ) + then + Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); + Apply_Discriminant_Check (Rhs, Typ, Lhs); + + -- In the access type case, we need the same discriminant check, + -- and also range checks if we have an access to constrained array. + + elsif Is_Access_Type (Etype (Lhs)) + and then Is_Constrained (Designated_Type (Etype (Lhs))) + then + if Has_Discriminants (Designated_Type (Etype (Lhs))) then + + -- Skip discriminant check if change of representation. Will be + -- done when the change of representation is expanded out. + + if not Change_Of_Representation (N) then + Apply_Discriminant_Check (Rhs, Etype (Lhs)); + end if; + + elsif Is_Array_Type (Designated_Type (Etype (Lhs))) then + Apply_Range_Check (Rhs, Etype (Lhs)); + + if Is_Constrained (Etype (Lhs)) then + Apply_Length_Check (Rhs, Etype (Lhs)); + end if; + + if Nkind (Rhs) = N_Allocator then + declare + Target_Typ : constant Entity_Id := Etype (Expression (Rhs)); + C_Es : Check_Result; + + begin + C_Es := + Range_Check + (Lhs, + Target_Typ, + Etype (Designated_Type (Etype (Lhs)))); + + Insert_Range_Checks + (C_Es, + N, + Target_Typ, + Sloc (Lhs), + Lhs); + end; + end if; + end if; + + -- Apply range check for access type case + + elsif Is_Access_Type (Etype (Lhs)) + and then Nkind (Rhs) = N_Allocator + and then Nkind (Expression (Rhs)) = N_Qualified_Expression + then + Analyze_And_Resolve (Expression (Rhs)); + Apply_Range_Check + (Expression (Rhs), Designated_Type (Etype (Lhs))); + end if; + + -- Case of assignment to a bit packed array element + + if Nkind (Lhs) = N_Indexed_Component + and then Is_Bit_Packed_Array (Etype (Prefix (Lhs))) + then + Expand_Bit_Packed_Element_Set (N); + return; + + -- Case of tagged type assignment + + elsif Is_Tagged_Type (Typ) + or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ)) + then + Tagged_Case : declare + L : List_Id := No_List; + Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N); + + begin + -- In the controlled case, we need to make sure that function + -- calls are evaluated before finalizing the target. In all + -- cases, it makes the expansion easier if the side-effects + -- are removed first. + + Remove_Side_Effects (Lhs); + Remove_Side_Effects (Rhs); + + -- Avoid recursion in the mechanism + + Set_Analyzed (N); + + -- If dispatching assignment, we need to dispatch to _assign + + if Is_Class_Wide_Type (Typ) + + -- If the type is tagged, we may as well use the predefined + -- primitive assignment. This avoids inlining a lot of code + -- and in the class-wide case, the assignment is replaced by + -- a dispatch call to _assign. Note that this cannot be done + -- when discriminant checks are locally suppressed (as in + -- extension aggregate expansions) because otherwise the + -- discriminant check will be performed within the _assign + -- call. + + or else (Is_Tagged_Type (Typ) + and then Chars (Current_Scope) /= Name_uAssign + and then Expand_Ctrl_Actions + and then not Discriminant_Checks_Suppressed (Empty)) + then + -- Fetch the primitive op _assign and proper type to call + -- it. Because of possible conflits between private and + -- full view the proper type is fetched directly from the + -- operation profile. + + declare + Op : constant Entity_Id + := Find_Prim_Op (Typ, Name_uAssign); + F_Typ : Entity_Id := Etype (First_Formal (Op)); + + begin + -- If the assignment is dispatching, make sure to use the + -- ??? where is rest of this comment ??? + + if Is_Class_Wide_Type (Typ) then + F_Typ := Class_Wide_Type (F_Typ); + end if; + + L := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Op, Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (F_Typ, Duplicate_Subexpr (Lhs)), + Unchecked_Convert_To (F_Typ, + Duplicate_Subexpr (Rhs))))); + end; + + else + L := Make_Tag_Ctrl_Assignment (N); + + -- We can't afford to have destructive Finalization Actions + -- in the Self assignment case, so if the target and the + -- source are not obviously different, code is generated to + -- avoid the self assignment case + -- + -- if lhs'address /= rhs'address then + -- <code for controlled and/or tagged assignment> + -- end if; + + if not Statically_Different (Lhs, Rhs) + and then Expand_Ctrl_Actions + then + L := New_List ( + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Attribute_Name => Name_Address), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Attribute_Name => Name_Address)), + + Then_Statements => L)); + end if; + + -- We need to set up an exception handler for implementing + -- 7.6.1 (18). The remaining adjustments are tackled by the + -- implementation of adjust for record_controllers (see + -- s-finimp.adb) + + -- This is skipped in No_Run_Time mode, where we in any + -- case exclude the possibility of finalization going on! + + if Expand_Ctrl_Actions and then not No_Run_Time then + L := New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => L, + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Program_Error (Loc))))))); + end if; + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); + + -- If no restrictions on aborts, protect the whole assignement + -- for controlled objects as per 9.8(11) + + if Controlled_Type (Typ) + and then Expand_Ctrl_Actions + and then Abort_Allowed + then + declare + Blk : constant Entity_Id := + New_Internal_Entity ( + E_Block, Current_Scope, Sloc (N), 'B'); + + begin + Set_Scope (Blk, Current_Scope); + Set_Etype (Blk, Standard_Void_Type); + Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); + + Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Set_At_End_Proc (Handled_Statement_Sequence (N), + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + Expand_At_End_Handler + (Handled_Statement_Sequence (N), Blk); + end; + end if; + + Analyze (N); + return; + end Tagged_Case; + + -- Array types + + elsif Is_Array_Type (Typ) then + declare + Actual_Rhs : Node_Id := Rhs; + + begin + while Nkind (Actual_Rhs) = N_Type_Conversion + or else + Nkind (Actual_Rhs) = N_Qualified_Expression + loop + Actual_Rhs := Expression (Actual_Rhs); + end loop; + + Expand_Assign_Array (N, Actual_Rhs); + return; + end; + + -- Record types + + elsif Is_Record_Type (Typ) then + Expand_Assign_Record (N); + return; + + -- Scalar types. This is where we perform the processing related + -- to the requirements of (RM 13.9.1(9-11)) concerning the handling + -- of invalid scalar values. + + elsif Is_Scalar_Type (Typ) then + + -- Case where right side is known valid + + if Expr_Known_Valid (Rhs) then + + -- Here the right side is valid, so it is fine. The case to + -- deal with is when the left side is a local variable reference + -- whose value is not currently known to be valid. If this is + -- the case, and the assignment appears in an unconditional + -- context, then we can mark the left side as now being valid. + + if Is_Local_Variable_Reference (Lhs) + and then not Is_Known_Valid (Entity (Lhs)) + and then In_Unconditional_Context (N) + then + Set_Is_Known_Valid (Entity (Lhs), True); + end if; + + -- Case where right side may be invalid in the sense of the RM + -- reference above. The RM does not require that we check for + -- the validity on an assignment, but it does require that the + -- assignment of an invalid value not cause erroneous behavior. + + -- The general approach in GNAT is to use the Is_Known_Valid flag + -- to avoid the need for validity checking on assignments. However + -- in some cases, we have to do validity checking in order to make + -- sure that the setting of this flag is correct. + + else + -- Validate right side if we are validating copies + + if Validity_Checks_On + and then Validity_Check_Copies + then + Ensure_Valid (Rhs); + + -- We can propagate this to the left side where appropriate + + if Is_Local_Variable_Reference (Lhs) + and then not Is_Known_Valid (Entity (Lhs)) + and then In_Unconditional_Context (N) + then + Set_Is_Known_Valid (Entity (Lhs), True); + end if; + + -- Otherwise check to see what should be done + + -- If left side is a local variable, then we just set its + -- flag to indicate that its value may no longer be valid, + -- since we are copying a potentially invalid value. + + elsif Is_Local_Variable_Reference (Lhs) then + Set_Is_Known_Valid (Entity (Lhs), False); + + -- Check for case of a non-local variable on the left side + -- which is currently known to be valid. In this case, we + -- simply ensure that the right side is valid. We only play + -- the game of copying validity status for local variables, + -- since we are doing this statically, not by tracing the + -- full flow graph. + + elsif Is_Entity_Name (Lhs) + and then Is_Known_Valid (Entity (Lhs)) + then + -- Note that the Ensure_Valid call is ignored if the + -- Validity_Checking mode is set to none so we do not + -- need to worry about that case here. + + Ensure_Valid (Rhs); + + -- In all other cases, we can safely copy an invalid value + -- without worrying about the status of the left side. Since + -- it is not a variable reference it will not be considered + -- as being known to be valid in any case. + + else + null; + end if; + end if; + end if; + + -- Defend against invalid subscripts on left side if we are in + -- standard validity checking mode. No need to do this if we + -- are checking all subscripts. + + if Validity_Checks_On + and then Validity_Check_Default + and then not Validity_Check_Subscripts + then + Check_Valid_Lvalue_Subscripts (Lhs); + end if; + end Expand_N_Assignment_Statement; + + ------------------------------ + -- Expand_N_Block_Statement -- + ------------------------------ + + -- Encode entity names defined in block statement + + procedure Expand_N_Block_Statement (N : Node_Id) is + begin + Qualify_Entity_Names (N); + end Expand_N_Block_Statement; + + ----------------------------- + -- Expand_N_Case_Statement -- + ----------------------------- + + procedure Expand_N_Case_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Expr : constant Node_Id := Expression (N); + + begin + -- Check for the situation where we know at compile time which + -- branch will be taken + + if Compile_Time_Known_Value (Expr) then + declare + Val : constant Uint := Expr_Value (Expr); + Alt : Node_Id; + Choice : Node_Id; + + begin + Alt := First (Alternatives (N)); + Search : loop + Choice := First (Discrete_Choices (Alt)); + while Present (Choice) loop + + -- Others choice, always matches + + if Nkind (Choice) = N_Others_Choice then + exit Search; + + -- Range, check if value is in the range + + elsif Nkind (Choice) = N_Range then + exit Search when + Val >= Expr_Value (Low_Bound (Choice)) + and then + Val <= Expr_Value (High_Bound (Choice)); + + -- Choice is a subtype name. Note that we know it must + -- be a static subtype, since otherwise it would have + -- been diagnosed as illegal. + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + exit when Is_In_Range (Expr, Etype (Choice)); + + -- Choice is a subtype indication + + elsif Nkind (Choice) = N_Subtype_Indication then + declare + C : constant Node_Id := Constraint (Choice); + R : constant Node_Id := Range_Expression (C); + + begin + exit Search when + Val >= Expr_Value (Low_Bound (R)) + and then + Val <= Expr_Value (High_Bound (R)); + end; + + -- Choice is a simple expression + + else + exit Search when Val = Expr_Value (Choice); + end if; + + Next (Choice); + end loop; + + Next (Alt); + pragma Assert (Present (Alt)); + end loop Search; + + -- The above loop *must* terminate by finding a match, since + -- we know the case statement is valid, and the value of the + -- expression is known at compile time. When we fall out of + -- the loop, Alt points to the alternative that we know will + -- be selected at run time. + + -- Move the statements from this alternative after the case + -- statement. They are already analyzed, so will be skipped + -- by the analyzer. + + Insert_List_After (N, Statements (Alt)); + + -- That leaves the case statement as a shell. The alternative + -- that wlil be executed is reset to a null list. So now we can + -- kill the entire case statement. + + Kill_Dead_Code (Expression (N)); + Kill_Dead_Code (Alternatives (N)); + Rewrite (N, Make_Null_Statement (Loc)); + end; + + -- Here if the choice is not determined at compile time + + -- If the last alternative is not an Others choice, replace it with an + -- N_Others_Choice. Note that we do not bother to call Analyze on the + -- modified case statement, since it's only effect would be to compute + -- the contents of the Others_Discrete_Choices node laboriously, and of + -- course we already know the list of choices that corresponds to the + -- others choice (it's the list we are replacing!) + + else + declare + Altnode : constant Node_Id := Last (Alternatives (N)); + Others_Node : Node_Id; + + begin + if Nkind (First (Discrete_Choices (Altnode))) + /= N_Others_Choice + then + Others_Node := Make_Others_Choice (Sloc (Altnode)); + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Altnode)); + Set_Discrete_Choices (Altnode, New_List (Others_Node)); + end if; + + -- If checks are on, ensure argument is valid (RM 5.4(13)). This + -- is only done for case statements frpm in the source program. + -- We don't just call Ensure_Valid here, because the requirement + -- is more strenous than usual, in that it is required that + -- Constraint_Error be raised. + + if Comes_From_Source (N) + and then Validity_Checks_On + and then Validity_Check_Default + and then not Expr_Known_Valid (Expr) + then + Insert_Valid_Check (Expr); + end if; + end; + end if; + end Expand_N_Case_Statement; + + ----------------------------- + -- Expand_N_Exit_Statement -- + ----------------------------- + + -- The only processing required is to deal with a possible C/Fortran + -- boolean value used as the condition for the exit statement. + + procedure Expand_N_Exit_Statement (N : Node_Id) is + begin + Adjust_Condition (Condition (N)); + end Expand_N_Exit_Statement; + + ----------------------------- + -- Expand_N_Goto_Statement -- + ----------------------------- + + -- Add poll before goto if polling active + + procedure Expand_N_Goto_Statement (N : Node_Id) is + begin + Generate_Poll_Call (N); + end Expand_N_Goto_Statement; + + --------------------------- + -- Expand_N_If_Statement -- + --------------------------- + + -- First we deal with the case of C and Fortran convention boolean + -- values, with zero/non-zero semantics. + + -- Second, we deal with the obvious rewriting for the cases where the + -- condition of the IF is known at compile time to be True or False. + + -- Third, we remove elsif parts which have non-empty Condition_Actions + -- and rewrite as independent if statements. For example: + + -- if x then xs + -- elsif y then ys + -- ... + -- end if; + + -- becomes + -- + -- if x then xs + -- else + -- <<condition actions of y>> + -- if y then ys + -- ... + -- end if; + -- end if; + + -- This rewriting is needed if at least one elsif part has a non-empty + -- Condition_Actions list. We also do the same processing if there is + -- a constant condition in an elsif part (in conjunction with the first + -- processing step mentioned above, for the recursive call made to deal + -- with the created inner if, this deals with properly optimizing the + -- cases of constant elsif conditions). + + procedure Expand_N_If_Statement (N : Node_Id) is + Hed : Node_Id; + E : Node_Id; + New_If : Node_Id; + + begin + Adjust_Condition (Condition (N)); + + -- The following loop deals with constant conditions for the IF. We + -- need a loop because as we eliminate False conditions, we grab the + -- first elsif condition and use it as the primary condition. + + while Compile_Time_Known_Value (Condition (N)) loop + + -- If condition is True, we can simply rewrite the if statement + -- now by replacing it by the series of then statements. + + if Is_True (Expr_Value (Condition (N))) then + + -- All the else parts can be killed + + Kill_Dead_Code (Elsif_Parts (N)); + Kill_Dead_Code (Else_Statements (N)); + + Hed := Remove_Head (Then_Statements (N)); + Insert_List_After (N, Then_Statements (N)); + Rewrite (N, Hed); + return; + + -- If condition is False, then we can delete the condition and + -- the Then statements + + else + Kill_Dead_Code (Condition (N)); + Kill_Dead_Code (Then_Statements (N)); + + -- If there are no elsif statements, then we simply replace + -- the entire if statement by the sequence of else statements. + + if No (Elsif_Parts (N)) then + + if No (Else_Statements (N)) + or else Is_Empty_List (Else_Statements (N)) + then + Rewrite (N, + Make_Null_Statement (Sloc (N))); + + else + Hed := Remove_Head (Else_Statements (N)); + Insert_List_After (N, Else_Statements (N)); + Rewrite (N, Hed); + end if; + + return; + + -- If there are elsif statements, the first of them becomes + -- the if/then section of the rebuilt if statement This is + -- the case where we loop to reprocess this copied condition. + + else + Hed := Remove_Head (Elsif_Parts (N)); + Insert_Actions (N, Condition_Actions (Hed)); + Set_Condition (N, Condition (Hed)); + Set_Then_Statements (N, Then_Statements (Hed)); + + if Is_Empty_List (Elsif_Parts (N)) then + Set_Elsif_Parts (N, No_List); + end if; + end if; + end if; + end loop; + + -- Loop through elsif parts, dealing with constant conditions and + -- possible expression actions that are present. + + if Present (Elsif_Parts (N)) then + E := First (Elsif_Parts (N)); + while Present (E) loop + Adjust_Condition (Condition (E)); + + -- If there are condition actions, then we rewrite the if + -- statement as indicated above. We also do the same rewrite + -- if the condition is True or False. The further processing + -- of this constant condition is then done by the recursive + -- call to expand the newly created if statement + + if Present (Condition_Actions (E)) + or else Compile_Time_Known_Value (Condition (E)) + then + -- Note this is not an implicit if statement, since it is + -- part of an explicit if statement in the source (or of an + -- implicit if statement that has already been tested). + + New_If := + Make_If_Statement (Sloc (E), + Condition => Condition (E), + Then_Statements => Then_Statements (E), + Elsif_Parts => No_List, + Else_Statements => Else_Statements (N)); + + -- Elsif parts for new if come from remaining elsif's of parent + + while Present (Next (E)) loop + if No (Elsif_Parts (New_If)) then + Set_Elsif_Parts (New_If, New_List); + end if; + + Append (Remove_Next (E), Elsif_Parts (New_If)); + end loop; + + Set_Else_Statements (N, New_List (New_If)); + + if Present (Condition_Actions (E)) then + Insert_List_Before (New_If, Condition_Actions (E)); + end if; + + Remove (E); + + if Is_Empty_List (Elsif_Parts (N)) then + Set_Elsif_Parts (N, No_List); + end if; + + Analyze (New_If); + return; + + -- No special processing for that elsif part, move to next + + else + Next (E); + end if; + end loop; + end if; + end Expand_N_If_Statement; + + ----------------------------- + -- Expand_N_Loop_Statement -- + ----------------------------- + + -- 1. Deal with while condition for C/Fortran boolean + -- 2. Deal with loops with a non-standard enumeration type range + -- 3. Deal with while loops where Condition_Actions is set + -- 4. Insert polling call if required + + procedure Expand_N_Loop_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Isc : constant Node_Id := Iteration_Scheme (N); + + begin + if Present (Isc) then + Adjust_Condition (Condition (Isc)); + end if; + + if Is_Non_Empty_List (Statements (N)) then + Generate_Poll_Call (First (Statements (N))); + end if; + + if No (Isc) then + return; + end if; + + -- Handle the case where we have a for loop with the range type being + -- an enumeration type with non-standard representation. In this case + -- we expand: + + -- for x in [reverse] a .. b loop + -- ... + -- end loop; + + -- to + + -- for xP in [reverse] integer + -- range etype'Pos (a) .. etype'Pos (b) loop + -- declare + -- x : constant etype := Pos_To_Rep (xP); + -- begin + -- ... + -- end; + -- end loop; + + if Present (Loop_Parameter_Specification (Isc)) then + declare + LPS : constant Node_Id := Loop_Parameter_Specification (Isc); + Loop_Id : constant Entity_Id := Defining_Identifier (LPS); + Ltype : constant Entity_Id := Etype (Loop_Id); + Btype : constant Entity_Id := Base_Type (Ltype); + New_Id : Entity_Id; + Lo, Hi : Node_Id; + + begin + if not Is_Enumeration_Type (Btype) + or else No (Enum_Pos_To_Rep (Btype)) + then + return; + end if; + + New_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Loop_Id), 'P')); + + Lo := Type_Low_Bound (Ltype); + Hi := Type_High_Bound (Ltype); + + Rewrite (N, + Make_Loop_Statement (Loc, + Identifier => Identifier (N), + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => New_Id, + Reverse_Present => Reverse_Present (LPS), + + Discrete_Subtype_Definition => + Make_Subtype_Indication (Loc, + + Subtype_Mark => + New_Reference_To (Standard_Natural, Loc), + + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Btype, Loc), + + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Relocate_Node + (Type_Low_Bound (Ltype)))), + + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Btype, Loc), + + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Relocate_Node + (Type_High_Bound (Ltype))))))))), + + Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Constant_Present => True, + Object_Definition => New_Reference_To (Ltype, Loc), + Expression => + Make_Indexed_Component (Loc, + Prefix => + New_Reference_To (Enum_Pos_To_Rep (Btype), Loc), + Expressions => New_List ( + New_Reference_To (New_Id, Loc))))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements (N)))), + + End_Label => End_Label (N))); + + Analyze (N); + end; + + -- Second case, if we have a while loop with Condition_Actions set, + -- then we change it into a plain loop: + + -- while C loop + -- ... + -- end loop; + + -- changed to: + + -- loop + -- <<condition actions>> + -- exit when not C; + -- ... + -- end loop + + elsif Present (Isc) + and then Present (Condition_Actions (Isc)) + then + declare + ES : Node_Id; + + begin + ES := + Make_Exit_Statement (Sloc (Condition (Isc)), + Condition => + Make_Op_Not (Sloc (Condition (Isc)), + Right_Opnd => Condition (Isc))); + + Prepend (ES, Statements (N)); + Insert_List_Before (ES, Condition_Actions (Isc)); + + -- This is not an implicit loop, since it is generated in + -- response to the loop statement being processed. If this + -- is itself implicit, the restriction has already been + -- checked. If not, it is an explicit loop. + + Rewrite (N, + Make_Loop_Statement (Sloc (N), + Identifier => Identifier (N), + Statements => Statements (N), + End_Label => End_Label (N))); + + Analyze (N); + end; + end if; + end Expand_N_Loop_Statement; + + ------------------------------- + -- Expand_N_Return_Statement -- + ------------------------------- + + procedure Expand_N_Return_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Exp : constant Node_Id := Expression (N); + Exptyp : Entity_Id; + T : Entity_Id; + Utyp : Entity_Id; + Scope_Id : Entity_Id; + Kind : Entity_Kind; + Call : Node_Id; + Acc_Stat : Node_Id; + Goto_Stat : Node_Id; + Lab_Node : Node_Id; + Cur_Idx : Nat; + Return_Type : Entity_Id; + Result_Exp : Node_Id; + Result_Id : Entity_Id; + Result_Obj : Node_Id; + + begin + -- Case where returned expression is present + + if Present (Exp) then + + -- Always normalize C/Fortran boolean result. This is not always + -- necessary, but it seems a good idea to minimize the passing + -- around of non-normalized values, and in any case this handles + -- the processing of barrier functions for protected types, which + -- turn the condition into a return statement. + + Exptyp := Etype (Exp); + + if Is_Boolean_Type (Exptyp) + and then Nonzero_Is_True (Exptyp) + then + Adjust_Condition (Exp); + Adjust_Result_Type (Exp, Exptyp); + end if; + + -- Do validity check if enabled for returns + + if Validity_Checks_On + and then Validity_Check_Returns + then + Ensure_Valid (Exp); + end if; + end if; + + -- Find relevant enclosing scope from which return is returning + + Cur_Idx := Scope_Stack.Last; + loop + Scope_Id := Scope_Stack.Table (Cur_Idx).Entity; + + if Ekind (Scope_Id) /= E_Block + and then Ekind (Scope_Id) /= E_Loop + then + exit; + + else + Cur_Idx := Cur_Idx - 1; + pragma Assert (Cur_Idx >= 0); + end if; + end loop; + + if No (Exp) then + Kind := Ekind (Scope_Id); + + -- If it is a return from procedures do no extra steps. + + if Kind = E_Procedure or else Kind = E_Generic_Procedure then + return; + end if; + + pragma Assert (Is_Entry (Scope_Id)); + + -- Look at the enclosing block to see whether the return is from + -- an accept statement or an entry body. + + for J in reverse 0 .. Cur_Idx loop + Scope_Id := Scope_Stack.Table (J).Entity; + exit when Is_Concurrent_Type (Scope_Id); + end loop; + + -- If it is a return from accept statement it should be expanded + -- as a call to RTS Complete_Rendezvous and a goto to the end of + -- the accept body. + + -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, + -- Expand_N_Accept_Alternative in exp_ch9.adb) + + if Is_Task_Type (Scope_Id) then + + Call := (Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Complete_Rendezvous), Loc))); + Insert_Before (N, Call); + -- why not insert actions here??? + Analyze (Call); + + Acc_Stat := Parent (N); + while Nkind (Acc_Stat) /= N_Accept_Statement loop + Acc_Stat := Parent (Acc_Stat); + end loop; + + Lab_Node := Last (Statements + (Handled_Statement_Sequence (Acc_Stat))); + + Goto_Stat := Make_Goto_Statement (Loc, + Name => New_Occurrence_Of + (Entity (Identifier (Lab_Node)), Loc)); + + Set_Analyzed (Goto_Stat); + + Rewrite (N, Goto_Stat); + Analyze (N); + + -- If it is a return from an entry body, put a Complete_Entry_Body + -- call in front of the return. + + elsif Is_Protected_Type (Scope_Id) then + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Complete_Entry_Body), Loc), + Parameter_Associations => New_List + (Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Object_Ref + (Corresponding_Body (Parent (Scope_Id))), + Loc), + Attribute_Name => Name_Unchecked_Access))); + + Insert_Before (N, Call); + Analyze (Call); + + end if; + + return; + end if; + + T := Etype (Exp); + Return_Type := Etype (Scope_Id); + Utyp := Underlying_Type (Return_Type); + + -- Check the result expression of a scalar function against + -- the subtype of the function by inserting a conversion. + -- This conversion must eventually be performed for other + -- classes of types, but for now it's only done for scalars. + -- ??? + + if Is_Scalar_Type (T) then + Rewrite (Exp, Convert_To (Return_Type, Exp)); + Analyze (Exp); + end if; + + -- Implement the rules of 6.5(8-10), which require a tag check in + -- the case of a limited tagged return type, and tag reassignment + -- for nonlimited tagged results. These actions are needed when + -- the return type is a specific tagged type and the result + -- expression is a conversion or a formal parameter, because in + -- that case the tag of the expression might differ from the tag + -- of the specific result type. + + if Is_Tagged_Type (Utyp) + and then not Is_Class_Wide_Type (Utyp) + and then (Nkind (Exp) = N_Type_Conversion + or else Nkind (Exp) = N_Unchecked_Type_Conversion + or else (Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) in Formal_Kind)) + then + -- When the return type is limited, perform a check that the + -- tag of the result is the same as the tag of the return type. + + if Is_Limited_Type (Return_Type) then + Insert_Action (Exp, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Exp), + Selector_Name => + New_Reference_To (Tag_Component (Utyp), Loc)), + Right_Opnd => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Access_Disp_Table (Base_Type (Utyp)), Loc))))); + + -- If the result type is a specific nonlimited tagged type, + -- then we have to ensure that the tag of the result is that + -- of the result type. This is handled by making a copy of the + -- expression in the case where it might have a different tag, + -- namely when the expression is a conversion or a formal + -- parameter. We create a new object of the result type and + -- initialize it from the expression, which will implicitly + -- force the tag to be set appropriately. + + else + Result_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Result_Exp := New_Reference_To (Result_Id, Loc); + + Result_Obj := + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Id, + Object_Definition => New_Reference_To (Return_Type, Loc), + Constant_Present => True, + Expression => Relocate_Node (Exp)); + + Set_Assignment_OK (Result_Obj); + Insert_Action (Exp, Result_Obj); + + Rewrite (Exp, Result_Exp); + Analyze_And_Resolve (Exp, Return_Type); + end if; + end if; + + -- Deal with returning variable length objects and controlled types + + -- Nothing to do if we are returning by reference, or this is not + -- a type that requires special processing (indicated by the fact + -- that it requires a cleanup scope for the secondary stack case) + + if Is_Return_By_Reference_Type (T) + or else not Requires_Transient_Scope (Return_Type) + then + null; + + -- Case of secondary stack not used + + elsif Function_Returns_With_DSP (Scope_Id) then + + -- Here what we need to do is to always return by reference, since + -- we will return with the stack pointer depressed. We may need to + -- do a copy to a local temporary before doing this return. + + No_Secondary_Stack_Case : declare + Local_Copy_Required : Boolean := False; + -- Set to True if a local copy is required + + Copy_Ent : Entity_Id; + -- Used for the target entity if a copy is required + + Decl : Node_Id; + -- Declaration used to create copy if needed + + procedure Test_Copy_Required (Expr : Node_Id); + -- Determines if Expr represents a return value for which a + -- copy is required. More specifically, a copy is not required + -- if Expr represents an object or component of an object that + -- is either in the local subprogram frame, or is constant. + -- If a copy is required, then Local_Copy_Required is set True. + + ------------------------ + -- Test_Copy_Required -- + ------------------------ + + procedure Test_Copy_Required (Expr : Node_Id) is + Ent : Entity_Id; + + begin + -- If component, test prefix (object containing component) + + if Nkind (Expr) = N_Indexed_Component + or else + Nkind (Expr) = N_Selected_Component + then + Test_Copy_Required (Prefix (Expr)); + return; + + -- See if we have an entity name + + elsif Is_Entity_Name (Expr) then + Ent := Entity (Expr); + + -- Constant entity is always OK, no copy required + + if Ekind (Ent) = E_Constant then + return; + + -- No copy required for local variable + + elsif Ekind (Ent) = E_Variable + and then Scope (Ent) = Current_Subprogram + then + return; + end if; + end if; + + -- All other cases require a copy + + Local_Copy_Required := True; + end Test_Copy_Required; + + -- Start of processing for No_Secondary_Stack_Case + + begin + -- No copy needed if result is from a function call for the + -- same type with the same constrainedness (is the latter a + -- necessary check, or could gigi produce the bounds ???). + -- In this case the result is already being returned by + -- reference with the stack pointer depressed. + + if Requires_Transient_Scope (T) + and then Is_Constrained (T) = Is_Constrained (Return_Type) + and then (Nkind (Exp) = N_Function_Call + or else + Nkind (Original_Node (Exp)) = N_Function_Call) + then + Set_By_Ref (N); + + -- We always need a local copy for a controlled type, since + -- we are required to finalize the local value before return. + -- The copy will automatically include the required finalize. + -- Moreover, gigi cannot make this copy, since we need special + -- processing to ensure proper behavior for finalization. + + -- Note: the reason we are returning with a depressed stack + -- pointer in the controlled case (even if the type involved + -- is constrained) is that we must make a local copy to deal + -- properly with the requirement that the local result be + -- finalized. + + elsif Controlled_Type (Utyp) then + Copy_Ent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + + -- Build declaration to do the copy, and insert it, setting + -- Assignment_OK, because we may be copying a limited type. + -- In addition we set the special flag to inhibit finalize + -- attachment if this is a controlled type (since this attach + -- must be done by the caller, otherwise if we attach it here + -- we will finalize the returned result prematurely). + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Copy_Ent, + Object_Definition => New_Occurrence_Of (Return_Type, Loc), + Expression => Relocate_Node (Exp)); + + Set_Assignment_OK (Decl); + Set_Delay_Finalize_Attach (Decl); + Insert_Action (N, Decl); + + -- Now the actual return uses the copied value + + Rewrite (Exp, New_Occurrence_Of (Copy_Ent, Loc)); + Analyze_And_Resolve (Exp, Return_Type); + + -- Since we have made the copy, gigi does not have to, so + -- we set the By_Ref flag to prevent another copy being made. + + Set_By_Ref (N); + + -- Non-controlled cases + + else + Test_Copy_Required (Exp); + + -- If a local copy is required, then gigi will make the + -- copy, otherwise, we can return the result directly, + -- so set By_Ref to suppress the gigi copy. + + if not Local_Copy_Required then + Set_By_Ref (N); + end if; + end if; + end No_Secondary_Stack_Case; + + -- Here if secondary stack is used + + else + -- Make sure that no surrounding block will reclaim the + -- secondary-stack on which we are going to put the result. + -- Not only may this introduce secondary stack leaks but worse, + -- if the reclamation is done too early, then the result we are + -- returning may get clobbered. See example in 7417-003. + + declare + S : Entity_Id := Current_Scope; + + begin + while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop + Set_Sec_Stack_Needed_For_Return (S, True); + S := Enclosing_Dynamic_Scope (S); + end loop; + end; + + -- Optimize the case where the result is from a function call for + -- the same type with the same constrainedness (is the latter a + -- necessary check, or could gigi produce the bounds ???). In this + -- case either the result is already on the secondary stack, or is + -- already being returned with the stack pointer depressed and no + -- further processing is required except to set the By_Ref flag to + -- ensure that gigi does not attempt an extra unnecessary copy. + -- (actually not just unncessary but harmfully wrong in the case + -- of a controlled type, where gigi does not know how to do a copy). + + if Requires_Transient_Scope (T) + and then Is_Constrained (T) = Is_Constrained (Return_Type) + and then (Nkind (Exp) = N_Function_Call + or else Nkind (Original_Node (Exp)) = N_Function_Call) + then + Set_By_Ref (N); + + -- For controlled types, do the allocation on the sec-stack + -- manually in order to call adjust at the right time + -- type Anon1 is access Return_Type; + -- for Anon1'Storage_pool use ss_pool; + -- Anon2 : anon1 := new Return_Type'(expr); + -- return Anon2.all; + + elsif Controlled_Type (Utyp) then + declare + Loc : constant Source_Ptr := Sloc (N); + Temp : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + Acc_Typ : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + Alloc_Node : Node_Id; + + begin + Set_Ekind (Acc_Typ, E_Access_Type); + + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + + Alloc_Node := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (Etype (Exp), Loc), + Expression => Relocate_Node (Exp))); + + Insert_List_Before_And_Analyze (N, New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Return_Type, Loc))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (Acc_Typ, Loc), + Expression => Alloc_Node))); + + Rewrite (Exp, + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))); + + Analyze_And_Resolve (Exp, Return_Type); + end; + + -- Otherwise use the gigi mechanism to allocate result on the + -- secondary stack. + + else + Set_Storage_Pool (N, RTE (RE_SS_Pool)); + + -- If we are generating code for the Java VM do not use + -- SS_Allocate since everything is heap-allocated anyway. + + if not Java_VM then + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); + end if; + end if; + end if; + end Expand_N_Return_Statement; + + ------------------------------ + -- Make_Tag_Ctrl_Assignment -- + ------------------------------ + + function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Name (N); + T : constant Entity_Id := Underlying_Type (Etype (L)); + + Ctrl_Act : constant Boolean := Controlled_Type (T) + and then not No_Ctrl_Actions (N); + + Save_Tag : constant Boolean := Is_Tagged_Type (T) + and then not No_Ctrl_Actions (N) + and then not Java_VM; + -- Tags are not saved and restored when Java_VM because JVM tags + -- are represented implicitly in objects. + + Res : List_Id; + Tag_Tmp : Entity_Id; + Prev_Tmp : Entity_Id; + Next_Tmp : Entity_Id; + Ctrl_Ref : Node_Id; + + begin + Res := New_List; + + -- Finalize the target of the assignment when controlled. + -- We have two exceptions here: + + -- 1. If we are in an init_proc since it is an initialization + -- more than an assignment + + -- 2. If the left-hand side is a temporary that was not initialized + -- (or the parent part of a temporary since it is the case in + -- extension aggregates). Such a temporary does not come from + -- source. We must examine the original node for the prefix, because + -- it may be a component of an entry formal, in which case it has + -- been rewritten and does not appear to come from source either. + + -- Init_Proc case + + if not Ctrl_Act then + null; + + -- The left hand side is an uninitialized temporary + + elsif Nkind (L) = N_Type_Conversion + and then Is_Entity_Name (Expression (L)) + and then No_Initialization (Parent (Entity (Expression (L)))) + then + null; + + elsif Nkind (L) = N_Indexed_Component + and then Is_Entity_Name (Original_Node (Prefix (L))) + and then Is_Entry_Formal (Entity (Original_Node (Prefix (L)))) + then + null; + + else + Append_List_To (Res, + Make_Final_Call ( + Ref => Duplicate_Subexpr (L), + Typ => Etype (L), + With_Detach => New_Reference_To (Standard_False, Loc))); + end if; + + Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + + -- Save the Tag in a local variable Tag_Tmp + + if Save_Tag then + Tag_Tmp := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Tag_Tmp, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (L), + Selector_Name => New_Reference_To (Tag_Component (T), Loc)))); + + -- Otherwise Tag_Tmp not used + + else + Tag_Tmp := Empty; + end if; + + -- Save the Finalization Pointers in local variables Prev_Tmp and + -- Next_Tmp. For objects with Has_Controlled_Component set, these + -- pointers are in the Record_Controller + + if Ctrl_Act then + Ctrl_Ref := Duplicate_Subexpr (L); + + if Has_Controlled_Component (T) then + Ctrl_Ref := + Make_Selected_Component (Loc, + Prefix => Ctrl_Ref, + Selector_Name => + New_Reference_To (Controller_Component (T), Loc)); + end if; + + Prev_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Prev_Tmp, + + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref), + Selector_Name => Make_Identifier (Loc, Name_Prev)))); + + Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Next_Tmp, + + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Ctrl_Ref)), + Selector_Name => Make_Identifier (Loc, Name_Next)))); + + -- If not controlled type, then Prev_Tmp and Ctrl_Ref unused + + else + Prev_Tmp := Empty; + Ctrl_Ref := Empty; + end if; + + -- Do the Assignment + + Append_To (Res, Relocate_Node (N)); + + -- Restore the Tag + + if Save_Tag then + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (L), + Selector_Name => New_Reference_To (Tag_Component (T), Loc)), + Expression => New_Reference_To (Tag_Tmp, Loc))); + end if; + + -- Restore the finalization pointers + + if Ctrl_Act then + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Ctrl_Ref)), + Selector_Name => Make_Identifier (Loc, Name_Prev)), + Expression => New_Reference_To (Prev_Tmp, Loc))); + + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Ctrl_Ref)), + Selector_Name => Make_Identifier (Loc, Name_Next)), + Expression => New_Reference_To (Next_Tmp, Loc))); + end if; + + -- Adjust the target after the assignment when controlled. (not in + -- the init_proc since it is an initialization more than an + -- assignment) + + if Ctrl_Act then + Append_List_To (Res, + Make_Adjust_Call ( + Ref => Duplicate_Subexpr (L), + Typ => Etype (L), + Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc), + With_Attach => Make_Integer_Literal (Loc, 0))); + end if; + + return Res; + end Make_Tag_Ctrl_Assignment; + +end Exp_Ch5; diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads new file mode 100644 index 00000000000..eb45c52233e --- /dev/null +++ b/gcc/ada/exp_ch5.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 5 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1992-1999, 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 5 constructs + +with Types; use Types; + +package Exp_Ch5 is + procedure Expand_N_Assignment_Statement (N : Node_Id); + procedure Expand_N_Block_Statement (N : Node_Id); + procedure Expand_N_Case_Statement (N : Node_Id); + procedure Expand_N_Exit_Statement (N : Node_Id); + procedure Expand_N_Goto_Statement (N : Node_Id); + procedure Expand_N_If_Statement (N : Node_Id); + procedure Expand_N_Loop_Statement (N : Node_Id); + procedure Expand_N_Return_Statement (N : Node_Id); +end Exp_Ch5; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb new file mode 100644 index 00000000000..e15328519cb --- /dev/null +++ b/gcc/ada/exp_ch6.adb @@ -0,0 +1,3227 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 6 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.343 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Elists; use Elists; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Intr; use Exp_Intr; +with Exp_Pakd; use Exp_Pakd; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Hostparm; use Hostparm; +with Inline; use Inline; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Ch6 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Overriding_Operation (Subp : Entity_Id); + -- Subp is a dispatching operation. Check whether it may override an + -- inherited private operation, in which case its DT entry is that of + -- the hidden operation, not the one it may have received earlier. + -- This must be done before emitting the code to set the corresponding + -- DT to the address of the subprogram. The actual placement of Subp in + -- the proper place in the list of primitive operations is done in + -- Declare_Inherited_Private_Subprograms, which also has to deal with + -- implicit operations. This duplication is unavoidable for now??? + + procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); + -- This procedure is called only if the subprogram body N, whose spec + -- has the given entity Spec, contains a parameterless recursive call. + -- It attempts to generate runtime code to detect if this a case of + -- infinite recursion. + -- + -- The body is scanned to determine dependencies. If the only external + -- dependencies are on a small set of scalar variables, then the values + -- of these variables are captured on entry to the subprogram, and if + -- the values are not changed for the call, we know immediately that + -- we have an infinite recursion. + + procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); + -- For each actual of an in-out parameter which is a numeric conversion + -- of the form T(A), where A denotes a variable, we insert the declaration: + -- + -- Temp : T := T(A); + -- + -- prior to the call. Then we replace the actual with a reference to Temp, + -- and append the assignment: + -- + -- A := T' (Temp); + -- + -- after the call. Here T' is the actual type of variable A. + -- For out parameters, the initial declaration has no expression. + -- If A is not an entity name, we generate instead: + -- + -- Var : T' renames A; + -- Temp : T := Var; -- omitting expression for out parameter. + -- ... + -- Var := T' (Temp); + -- + -- For other in-out parameters, we emit the required constraint checks + -- before and/or after the call. + + -- For all parameter modes, actuals that denote components and slices + -- of packed arrays are expanded into suitable temporaries. + + procedure Expand_Inlined_Call + (N : Node_Id; + Subp : Entity_Id; + Orig_Subp : Entity_Id); + -- If called subprogram can be inlined by the front-end, retrieve the + -- analyzed body, replace formals with actuals and expand call in place. + -- Generate thunks for actuals that are expressions, and insert the + -- corresponding constant declarations before the call. If the original + -- call is to a derived operation, the return type is the one of the + -- derived operation, but the body is that of the original, so return + -- expressions in the body must be converted to the desired type (which + -- is simply not noted in the tree without inline expansion). + + function Expand_Protected_Object_Reference + (N : Node_Id; + Scop : Entity_Id) + return Node_Id; + + procedure Expand_Protected_Subprogram_Call + (N : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id); + -- A call to a protected subprogram within the protected object may appear + -- as a regular call. The list of actuals must be expanded to contain a + -- reference to the object itself, and the call becomes a call to the + -- corresponding protected subprogram. + + --------------------------------- + -- Check_Overriding_Operation -- + --------------------------------- + + procedure Check_Overriding_Operation (Subp : Entity_Id) is + Typ : constant Entity_Id := Find_Dispatching_Type (Subp); + Op_List : constant Elist_Id := Primitive_Operations (Typ); + Op_Elmt : Elmt_Id; + Prim_Op : Entity_Id; + Par_Op : Entity_Id; + + begin + if Is_Derived_Type (Typ) + and then not Is_Private_Type (Typ) + and then In_Open_Scopes (Scope (Etype (Typ))) + and then Typ = Base_Type (Typ) + then + -- Subp overrides an inherited private operation if there is + -- an inherited operation with a different name than Subp (see + -- Derive_Subprogram) whose Alias is a hidden subprogram with + -- the same name as Subp. + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Prim_Op := Node (Op_Elmt); + Par_Op := Alias (Prim_Op); + + if Present (Par_Op) + and then not Comes_From_Source (Prim_Op) + and then Chars (Prim_Op) /= Chars (Par_Op) + and then Chars (Par_Op) = Chars (Subp) + and then Is_Hidden (Par_Op) + and then Type_Conformant (Prim_Op, Subp) + then + Set_DT_Position (Subp, DT_Position (Prim_Op)); + end if; + + Next_Elmt (Op_Elmt); + end loop; + end if; + end Check_Overriding_Operation; + + ------------------------------- + -- Detect_Infinite_Recursion -- + ------------------------------- + + procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Var_List : Elist_Id := New_Elmt_List; + -- List of globals referenced by body of procedure + + Call_List : Elist_Id := New_Elmt_List; + -- List of recursive calls in body of procedure + + Shad_List : Elist_Id := New_Elmt_List; + -- List of entity id's for entities created to capture the + -- value of referenced globals on entry to the procedure. + + Scop : constant Uint := Scope_Depth (Spec); + -- This is used to record the scope depth of the current + -- procedure, so that we can identify global references. + + Max_Vars : constant := 4; + -- Do not test more than four global variables + + Count_Vars : Natural := 0; + -- Count variables found so far + + Var : Entity_Id; + Elm : Elmt_Id; + Ent : Entity_Id; + Call : Elmt_Id; + Decl : Node_Id; + Test : Node_Id; + Elm1 : Elmt_Id; + Elm2 : Elmt_Id; + Last : Node_Id; + + function Process (Nod : Node_Id) return Traverse_Result; + -- Function to traverse the subprogram body (using Traverse_Func) + + ------------- + -- Process -- + ------------- + + function Process (Nod : Node_Id) return Traverse_Result is + begin + -- Procedure call + + if Nkind (Nod) = N_Procedure_Call_Statement then + + -- Case of one of the detected recursive calls + + if Is_Entity_Name (Name (Nod)) + and then Has_Recursive_Call (Entity (Name (Nod))) + and then Entity (Name (Nod)) = Spec + then + Append_Elmt (Nod, Call_List); + return Skip; + + -- Any other procedure call may have side effects + + else + return Abandon; + end if; + + -- A call to a pure function can always be ignored + + elsif Nkind (Nod) = N_Function_Call + and then Is_Entity_Name (Name (Nod)) + and then Is_Pure (Entity (Name (Nod))) + then + return Skip; + + -- Case of an identifier reference + + elsif Nkind (Nod) = N_Identifier then + Ent := Entity (Nod); + + -- If no entity, then ignore the reference + + -- Not clear why this can happen. To investigate, remove this + -- test and look at the crash that occurs here in 3401-004 ??? + + if No (Ent) then + return Skip; + + -- Ignore entities with no Scope, again not clear how this + -- can happen, to investigate, look at 4108-008 ??? + + elsif No (Scope (Ent)) then + return Skip; + + -- Ignore the reference if not to a more global object + + elsif Scope_Depth (Scope (Ent)) >= Scop then + return Skip; + + -- References to types, exceptions and constants are always OK + + elsif Is_Type (Ent) + or else Ekind (Ent) = E_Exception + or else Ekind (Ent) = E_Constant + then + return Skip; + + -- If other than a non-volatile scalar variable, we have some + -- kind of global reference (e.g. to a function) that we cannot + -- deal with so we forget the attempt. + + elsif Ekind (Ent) /= E_Variable + or else not Is_Scalar_Type (Etype (Ent)) + or else Is_Volatile (Ent) + then + return Abandon; + + -- Otherwise we have a reference to a global scalar + + else + -- Loop through global entities already detected + + Elm := First_Elmt (Var_List); + loop + -- If not detected before, record this new global reference + + if No (Elm) then + Count_Vars := Count_Vars + 1; + + if Count_Vars <= Max_Vars then + Append_Elmt (Entity (Nod), Var_List); + else + return Abandon; + end if; + + exit; + + -- If recorded before, ignore + + elsif Node (Elm) = Entity (Nod) then + return Skip; + + -- Otherwise keep looking + + else + Next_Elmt (Elm); + end if; + end loop; + + return Skip; + end if; + + -- For all other node kinds, recursively visit syntactic children + + else + return OK; + end if; + end Process; + + function Traverse_Body is new Traverse_Func; + + -- Start of processing for Detect_Infinite_Recursion + + begin + -- Do not attempt detection in No_Implicit_Conditional mode, + -- since we won't be able to generate the code to handle the + -- recursion in any case. + + if Restrictions (No_Implicit_Conditionals) then + return; + end if; + + -- Otherwise do traversal and quit if we get abandon signal + + if Traverse_Body (N) = Abandon then + return; + + -- We must have a call, since Has_Recursive_Call was set. If not + -- just ignore (this is only an error check, so if we have a funny + -- situation, due to bugs or errors, we do not want to bomb!) + + elsif Is_Empty_Elmt_List (Call_List) then + return; + end if; + + -- Here is the case where we detect recursion at compile time + + -- Push our current scope for analyzing the declarations and + -- code that we will insert for the checking. + + New_Scope (Spec); + + -- This loop builds temporary variables for each of the + -- referenced globals, so that at the end of the loop the + -- list Shad_List contains these temporaries in one-to-one + -- correspondence with the elements in Var_List. + + Last := Empty; + Elm := First_Elmt (Var_List); + while Present (Elm) loop + Var := Node (Elm); + Ent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + Append_Elmt (Ent, Shad_List); + + -- Insert a declaration for this temporary at the start of + -- the declarations for the procedure. The temporaries are + -- declared as constant objects initialized to the current + -- values of the corresponding temporaries. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => New_Occurrence_Of (Etype (Var), Loc), + Constant_Present => True, + Expression => New_Occurrence_Of (Var, Loc)); + + if No (Last) then + Prepend (Decl, Declarations (N)); + else + Insert_After (Last, Decl); + end if; + + Last := Decl; + Analyze (Decl); + Next_Elmt (Elm); + end loop; + + -- Loop through calls + + Call := First_Elmt (Call_List); + while Present (Call) loop + + -- Build a predicate expression of the form + + -- True + -- and then global1 = temp1 + -- and then global2 = temp2 + -- ... + + -- This predicate determines if any of the global values + -- referenced by the procedure have changed since the + -- current call, if not an infinite recursion is assured. + + Test := New_Occurrence_Of (Standard_True, Loc); + + Elm1 := First_Elmt (Var_List); + Elm2 := First_Elmt (Shad_List); + while Present (Elm1) loop + Test := + Make_And_Then (Loc, + Left_Opnd => Test, + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), + Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); + + Next_Elmt (Elm1); + Next_Elmt (Elm2); + end loop; + + -- Now we replace the call with the sequence + + -- if no-changes (see above) then + -- raise Storage_Error; + -- else + -- original-call + -- end if; + + Rewrite (Node (Call), + Make_If_Statement (Loc, + Condition => Test, + Then_Statements => New_List ( + Make_Raise_Storage_Error (Loc)), + + Else_Statements => New_List ( + Relocate_Node (Node (Call))))); + + Analyze (Node (Call)); + + Next_Elmt (Call); + end loop; + + -- Remove temporary scope stack entry used for analysis + + Pop_Scope; + end Detect_Infinite_Recursion; + + -------------------- + -- Expand_Actuals -- + -------------------- + + procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Actual : Node_Id; + Formal : Entity_Id; + N_Node : Node_Id; + Post_Call : List_Id; + E_Formal : Entity_Id; + + procedure Add_Call_By_Copy_Code; + -- For In and In-Out parameters, where the parameter must be passed + -- by copy, this routine generates a temporary variable into which + -- the actual is copied, and then passes this as the parameter. This + -- routine also takes care of any constraint checks required for the + -- type conversion case (on both the way in and the way out). + + procedure Add_Packed_Call_By_Copy_Code; + -- This is used when the actual involves a reference to an element + -- of a packed array, where we can appropriately use a simpler + -- approach than the full call by copy code. We just copy the value + -- in and out of an apropriate temporary. + + procedure Check_Fortran_Logical; + -- A value of type Logical that is passed through a formal parameter + -- must be normalized because .TRUE. usually does not have the same + -- representation as True. We assume that .FALSE. = False = 0. + -- What about functions that return a logical type ??? + + function Make_Var (Actual : Node_Id) return Entity_Id; + -- Returns an entity that refers to the given actual parameter, + -- Actual (not including any type conversion). If Actual is an + -- entity name, then this entity is returned unchanged, otherwise + -- a renaming is created to provide an entity for the actual. + + procedure Reset_Packed_Prefix; + -- The expansion of a packed array component reference is delayed in + -- the context of a call. Now we need to complete the expansion, so we + -- unmark the analyzed bits in all prefixes. + + --------------------------- + -- Add_Call_By_Copy_Code -- + --------------------------- + + procedure Add_Call_By_Copy_Code is + Expr : Node_Id; + Init : Node_Id; + Temp : Entity_Id; + Var : Entity_Id; + V_Typ : Entity_Id; + Crep : Boolean; + + begin + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + if Nkind (Actual) = N_Type_Conversion then + V_Typ := Etype (Expression (Actual)); + Var := Make_Var (Expression (Actual)); + Crep := not Same_Representation + (Etype (Formal), Etype (Expression (Actual))); + else + V_Typ := Etype (Actual); + Var := Make_Var (Actual); + Crep := False; + end if; + + -- Setup initialization for case of in out parameter, or an out + -- parameter where the formal is an unconstrained array (in the + -- latter case, we have to pass in an object with bounds). + + if Ekind (Formal) = E_In_Out_Parameter + or else (Is_Array_Type (Etype (Formal)) + and then + not Is_Constrained (Etype (Formal))) + then + if Nkind (Actual) = N_Type_Conversion then + if Conversion_OK (Actual) then + Init := OK_Convert_To + (Etype (Formal), New_Occurrence_Of (Var, Loc)); + else + Init := Convert_To + (Etype (Formal), New_Occurrence_Of (Var, Loc)); + end if; + else + Init := New_Occurrence_Of (Var, Loc); + end if; + + -- An initialization is created for packed conversions as + -- actuals for out parameters to enable Make_Object_Declaration + -- to determine the proper subtype for N_Node. Note that this + -- is wasteful because the extra copying on the call side is + -- not required for such out parameters. ??? + + elsif Ekind (Formal) = E_Out_Parameter + and then Nkind (Actual) = N_Type_Conversion + and then (Is_Bit_Packed_Array (Etype (Formal)) + or else + Is_Bit_Packed_Array (Etype (Expression (Actual)))) + then + if Conversion_OK (Actual) then + Init := + OK_Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); + else + Init := + Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); + end if; + else + Init := Empty; + end if; + + N_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => Init); + Set_Assignment_OK (N_Node); + Insert_Action (N, N_Node); + + -- Now, normally the deal here is that we use the defining + -- identifier created by that object declaration. There is + -- one exception to this. In the change of representation case + -- the above declaration will end up looking like: + + -- temp : type := identifier; + + -- And in this case we might as well use the identifier directly + -- and eliminate the temporary. Note that the analysis of the + -- declaration was not a waste of time in that case, since it is + -- what generated the necessary change of representation code. If + -- the change of representation introduced additional code, as in + -- a fixed-integer conversion, the expression is not an identifier + -- and must be kept. + + if Crep + and then Present (Expression (N_Node)) + and then Is_Entity_Name (Expression (N_Node)) + then + Temp := Entity (Expression (N_Node)); + Rewrite (N_Node, Make_Null_Statement (Loc)); + end if; + + -- If type conversion, use reverse conversion on exit + + if Nkind (Actual) = N_Type_Conversion then + if Conversion_OK (Actual) then + Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); + else + Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); + end if; + else + Expr := New_Occurrence_Of (Temp, Loc); + end if; + + Rewrite (Actual, New_Reference_To (Temp, Loc)); + Analyze (Actual); + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Var, Loc), + Expression => Expr)); + + Set_Assignment_OK (Name (Last (Post_Call))); + end Add_Call_By_Copy_Code; + + ---------------------------------- + -- Add_Packed_Call_By_Copy_Code -- + ---------------------------------- + + procedure Add_Packed_Call_By_Copy_Code is + Temp : Entity_Id; + Incod : Node_Id; + Outcod : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; + + begin + Reset_Packed_Prefix; + + -- Prepare to generate code + + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Incod := Relocate_Node (Actual); + Outcod := New_Copy_Tree (Incod); + + -- Generate declaration of temporary variable, initializing it + -- with the input parameter unless we have an OUT variable. + + if Ekind (Formal) = E_Out_Parameter then + Incod := Empty; + end if; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => Incod)); + + -- The actual is simply a reference to the temporary + + Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); + + -- Generate copy out if OUT or IN OUT parameter + + if Ekind (Formal) /= E_In_Parameter then + Lhs := Outcod; + Rhs := New_Occurrence_Of (Temp, Loc); + + -- Deal with conversion + + if Nkind (Lhs) = N_Type_Conversion then + Lhs := Expression (Lhs); + Rhs := Convert_To (Etype (Actual), Rhs); + end if; + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Rhs)); + end if; + end Add_Packed_Call_By_Copy_Code; + + --------------------------- + -- Check_Fortran_Logical -- + --------------------------- + + procedure Check_Fortran_Logical is + Logical : Entity_Id := Etype (Formal); + Var : Entity_Id; + + -- Note: this is very incomplete, e.g. it does not handle arrays + -- of logical values. This is really not the right approach at all???) + + begin + if Convention (Subp) = Convention_Fortran + and then Root_Type (Etype (Formal)) = Standard_Boolean + and then Ekind (Formal) /= E_In_Parameter + then + Var := Make_Var (Actual); + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Var, Loc), + Expression => + Unchecked_Convert_To ( + Logical, + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Var, Loc), + Right_Opnd => + Unchecked_Convert_To ( + Logical, + New_Occurrence_Of (Standard_False, Loc)))))); + end if; + end Check_Fortran_Logical; + + -------------- + -- Make_Var -- + -------------- + + function Make_Var (Actual : Node_Id) return Entity_Id is + Var : Entity_Id; + + begin + if Is_Entity_Name (Actual) then + return Entity (Actual); + + else + Var := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + N_Node := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Var, + Subtype_Mark => + New_Occurrence_Of (Etype (Actual), Loc), + Name => Relocate_Node (Actual)); + + Insert_Action (N, N_Node); + return Var; + end if; + end Make_Var; + + ------------------------- + -- Reset_Packed_Prefix -- + ------------------------- + + procedure Reset_Packed_Prefix is + Pfx : Node_Id := Actual; + + begin + loop + Set_Analyzed (Pfx, False); + exit when Nkind (Pfx) /= N_Selected_Component + and then Nkind (Pfx) /= N_Indexed_Component; + Pfx := Prefix (Pfx); + end loop; + end Reset_Packed_Prefix; + + -- Start of processing for Expand_Actuals + + begin + Formal := First_Formal (Subp); + Actual := First_Actual (N); + + Post_Call := New_List; + + while Present (Formal) loop + E_Formal := Etype (Formal); + + if Is_Scalar_Type (E_Formal) + or else Nkind (Actual) = N_Slice + then + Check_Fortran_Logical; + + -- RM 6.4.1 (11) + + elsif Ekind (Formal) /= E_Out_Parameter then + + -- The unusual case of the current instance of a protected type + -- requires special handling. This can only occur in the context + -- of a call within the body of a protected operation. + + if Is_Entity_Name (Actual) + and then Ekind (Entity (Actual)) = E_Protected_Type + and then In_Open_Scopes (Entity (Actual)) + then + if Scope (Subp) /= Entity (Actual) then + Error_Msg_N ("operation outside protected type may not " + & "call back its protected operations?", Actual); + end if; + + Rewrite (Actual, + Expand_Protected_Object_Reference (N, Entity (Actual))); + end if; + + Apply_Constraint_Check (Actual, E_Formal); + + -- Out parameter case. No constraint checks on access type + -- RM 6.4.1 (13) + + elsif Is_Access_Type (E_Formal) then + null; + + -- RM 6.4.1 (14) + + elsif Has_Discriminants (Base_Type (E_Formal)) + or else Has_Non_Null_Base_Init_Proc (E_Formal) + then + Apply_Constraint_Check (Actual, E_Formal); + + -- RM 6.4.1 (15) + + else + Apply_Constraint_Check (Actual, Base_Type (E_Formal)); + end if; + + -- Processing for IN-OUT and OUT parameters + + if Ekind (Formal) /= E_In_Parameter then + + -- For type conversions of arrays, apply length/range checks + + if Is_Array_Type (E_Formal) + and then Nkind (Actual) = N_Type_Conversion + then + if Is_Constrained (E_Formal) then + Apply_Length_Check (Expression (Actual), E_Formal); + else + Apply_Range_Check (Expression (Actual), E_Formal); + end if; + end if; + + -- If argument is a type conversion for a type that is passed + -- by copy, then we must pass the parameter by copy. + + if Nkind (Actual) = N_Type_Conversion + and then + (Is_Numeric_Type (E_Formal) + or else Is_Access_Type (E_Formal) + or else Is_Enumeration_Type (E_Formal) + or else Is_Bit_Packed_Array (Etype (Formal)) + or else Is_Bit_Packed_Array (Etype (Expression (Actual))) + + -- Also pass by copy if change of representation + + or else not Same_Representation + (Etype (Formal), + Etype (Expression (Actual)))) + then + Add_Call_By_Copy_Code; + + -- References to components of bit packed arrays are expanded + -- at this point, rather than at the point of analysis of the + -- actuals, to handle the expansion of the assignment to + -- [in] out parameters. + + elsif Is_Ref_To_Bit_Packed_Array (Actual) then + Add_Packed_Call_By_Copy_Code; + + -- References to slices of bit packed arrays are expanded + + elsif Is_Ref_To_Bit_Packed_Slice (Actual) then + Add_Call_By_Copy_Code; + + -- Deal with access types where the actual subtpe and the + -- formal subtype are not the same, requiring a check. + + -- It is neccessary to exclude tagged types because of "downward + -- conversion" errors and a strange assertion error in namet + -- from gnatf in bug 1215-001 ??? + + elsif Is_Access_Type (E_Formal) + and then not Same_Type (E_Formal, Etype (Actual)) + and then not Is_Tagged_Type (Designated_Type (E_Formal)) + then + Add_Call_By_Copy_Code; + + elsif Is_Entity_Name (Actual) + and then Is_Volatile (Entity (Actual)) + and then not Is_Scalar_Type (Etype (Entity (Actual))) + and then not Is_Volatile (E_Formal) + then + Add_Call_By_Copy_Code; + + elsif Nkind (Actual) = N_Indexed_Component + and then Is_Entity_Name (Prefix (Actual)) + and then Has_Volatile_Components (Entity (Prefix (Actual))) + then + Add_Call_By_Copy_Code; + end if; + + -- The only processing required for IN parameters is in the packed + -- array case, where we expand the indexed component (the circuit + -- in Exp_Ch4 deliberately left indexed components appearing as + -- actuals untouched, so that the special processing above for + -- the OUT and IN OUT cases could be performed. We could make the + -- test in Exp_Ch4 more complex and have it detect the parameter + -- mode, but it is easier simply to handle all cases here. + + -- Similarly, we have to expand slices of packed arrays here + + else + if Nkind (Actual) = N_Indexed_Component + and then Is_Packed (Etype (Prefix (Actual))) + then + Reset_Packed_Prefix; + Expand_Packed_Element_Reference (Actual); + + elsif Is_Ref_To_Bit_Packed_Array (Actual) then + Add_Packed_Call_By_Copy_Code; + + elsif Is_Ref_To_Bit_Packed_Slice (Actual) then + declare + Typ : constant Entity_Id := Etype (Actual); + + Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => + New_Occurrence_Of (Typ, Loc)); + + begin + Set_No_Initialization (Decl); + + Insert_Actions (N, New_List ( + Decl, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Expression => Relocate_Node (Actual)))); + + Rewrite + (Actual, New_Occurrence_Of (Ent, Loc)); + Analyze_And_Resolve (Actual, Typ); + end; + end if; + end if; + + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + + -- Find right place to put post call stuff if it is present + + if not Is_Empty_List (Post_Call) then + + -- If call is not a list member, it must be the triggering + -- statement of a triggering alternative or an entry call + -- alternative, and we can add the post call stuff to the + -- corresponding statement list. + + if not Is_List_Member (N) then + declare + P : constant Node_Id := Parent (N); + + begin + pragma Assert (Nkind (P) = N_Triggering_Alternative + or else Nkind (P) = N_Entry_Call_Alternative); + + if Is_Non_Empty_List (Statements (P)) then + Insert_List_Before_And_Analyze + (First (Statements (P)), Post_Call); + else + Set_Statements (P, Post_Call); + end if; + end; + + -- Otherwise, normal case where N is in a statement sequence, + -- just put the post-call stuff after the call statement. + + else + Insert_Actions_After (N, Post_Call); + end if; + end if; + + -- The call node itself is re-analyzed in Expand_Call. + + end Expand_Actuals; + + ----------------- + -- Expand_Call -- + ----------------- + + -- This procedure handles expansion of function calls and procedure call + -- statements (i.e. it serves as the body for Expand_N_Function_Call and + -- Expand_N_Procedure_Call_Statement. Processing for calls includes: + + -- Replace call to Raise_Exception by Raise_Exception always if possible + -- Provide values of actuals for all formals in Extra_Formals list + -- Replace "call" to enumeration literal function by literal itself + -- Rewrite call to predefined operator as operator + -- Replace actuals to in-out parameters that are numeric conversions, + -- with explicit assignment to temporaries before and after the call. + -- Remove optional actuals if First_Optional_Parameter specified. + + -- Note that the list of actuals has been filled with default expressions + -- during semantic analysis of the call. Only the extra actuals required + -- for the 'Constrained attribute and for accessibility checks are added + -- at this point. + + procedure Expand_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Remote : constant Boolean := Is_Remote_Call (N); + Subp : Entity_Id; + Orig_Subp : Entity_Id := Empty; + Parent_Subp : Entity_Id; + Parent_Formal : Entity_Id; + Actual : Node_Id; + Formal : Entity_Id; + Prev : Node_Id := Empty; + Prev_Orig : Node_Id; + Scop : Entity_Id; + Extra_Actuals : List_Id := No_List; + Cond : Node_Id; + + procedure Add_Actual_Parameter (Insert_Param : Node_Id); + -- Adds one entry to the end of the actual parameter list. Used for + -- default parameters and for extra actuals (for Extra_Formals). + -- The argument is an N_Parameter_Association node. + + procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); + -- Adds an extra actual to the list of extra actuals. Expr + -- is the expression for the value of the actual, EF is the + -- entity for the extra formal. + + function Inherited_From_Formal (S : Entity_Id) return Entity_Id; + -- Within an instance, a type derived from a non-tagged formal derived + -- type inherits from the original parent, not from the actual. This is + -- tested in 4723-003. The current derivation mechanism has the derived + -- type inherit from the actual, which is only correct outside of the + -- instance. If the subprogram is inherited, we test for this particular + -- case through a convoluted tree traversal before setting the proper + -- subprogram to be called. + + -------------------------- + -- Add_Actual_Parameter -- + -------------------------- + + procedure Add_Actual_Parameter (Insert_Param : Node_Id) is + Actual_Expr : constant Node_Id := + Explicit_Actual_Parameter (Insert_Param); + + begin + -- Case of insertion is first named actual + + if No (Prev) or else + Nkind (Parent (Prev)) /= N_Parameter_Association + then + Set_Next_Named_Actual (Insert_Param, First_Named_Actual (N)); + Set_First_Named_Actual (N, Actual_Expr); + + if No (Prev) then + if not Present (Parameter_Associations (N)) then + Set_Parameter_Associations (N, New_List); + Append (Insert_Param, Parameter_Associations (N)); + end if; + else + Insert_After (Prev, Insert_Param); + end if; + + -- Case of insertion is not first named actual + + else + Set_Next_Named_Actual + (Insert_Param, Next_Named_Actual (Parent (Prev))); + Set_Next_Named_Actual (Parent (Prev), Actual_Expr); + Append (Insert_Param, Parameter_Associations (N)); + end if; + + Prev := Actual_Expr; + end Add_Actual_Parameter; + + ---------------------- + -- Add_Extra_Actual -- + ---------------------- + + procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + if Extra_Actuals = No_List then + Extra_Actuals := New_List; + Set_Parent (Extra_Actuals, N); + end if; + + Append_To (Extra_Actuals, + Make_Parameter_Association (Loc, + Explicit_Actual_Parameter => Expr, + Selector_Name => + Make_Identifier (Loc, Chars (EF)))); + + Analyze_And_Resolve (Expr, Etype (EF)); + + end Add_Extra_Actual; + + --------------------------- + -- Inherited_From_Formal -- + --------------------------- + + function Inherited_From_Formal (S : Entity_Id) return Entity_Id is + Par : Entity_Id; + Gen_Par : Entity_Id; + Gen_Prim : Elist_Id; + Elmt : Elmt_Id; + Indic : Node_Id; + + begin + -- If the operation is inherited, it is attached to the corresponding + -- type derivation. If the parent in the derivation is a generic + -- actual, it is a subtype of the actual, and we have to recover the + -- original derived type declaration to find the proper parent. + + if Nkind (Parent (S)) /= N_Full_Type_Declaration + or else not Is_Derived_Type (Defining_Identifier (Parent (S))) + or else Nkind (Type_Definition (Original_Node (Parent (S)))) + /= N_Derived_Type_Definition + then + return Empty; + + else + Indic := + (Subtype_Indication + (Type_Definition (Original_Node (Parent (S))))); + + if Nkind (Indic) = N_Subtype_Indication then + Par := Entity (Subtype_Mark (Indic)); + else + Par := Entity (Indic); + end if; + end if; + + if not Is_Generic_Actual_Type (Par) + or else Is_Tagged_Type (Par) + or else Nkind (Parent (Par)) /= N_Subtype_Declaration + or else not In_Open_Scopes (Scope (Par)) + or else not In_Instance + then + return Empty; + + else + Gen_Par := Generic_Parent_Type (Parent (Par)); + end if; + + Gen_Prim := Collect_Primitive_Operations (Gen_Par); + Elmt := First_Elmt (Gen_Prim); + + while Present (Elmt) loop + if Chars (Node (Elmt)) = Chars (S) then + declare + F1 : Entity_Id; + F2 : Entity_Id; + begin + + F1 := First_Formal (S); + F2 := First_Formal (Node (Elmt)); + + while Present (F1) + and then Present (F2) + loop + + if Etype (F1) = Etype (F2) + or else Etype (F2) = Gen_Par + then + Next_Formal (F1); + Next_Formal (F2); + else + Next_Elmt (Elmt); + exit; -- not the right subprogram + end if; + + return Node (Elmt); + end loop; + end; + + else + Next_Elmt (Elmt); + end if; + end loop; + + raise Program_Error; + end Inherited_From_Formal; + + -- Start of processing for Expand_Call + + begin + -- Call using access to subprogram with explicit dereference + + if Nkind (Name (N)) = N_Explicit_Dereference then + Subp := Etype (Name (N)); + Parent_Subp := Empty; + + -- Case of call to simple entry, where the Name is a selected component + -- whose prefix is the task, and whose selector name is the entry name + + elsif Nkind (Name (N)) = N_Selected_Component then + Subp := Entity (Selector_Name (Name (N))); + Parent_Subp := Empty; + + -- Case of call to member of entry family, where Name is an indexed + -- component, with the prefix being a selected component giving the + -- task and entry family name, and the index being the entry index. + + elsif Nkind (Name (N)) = N_Indexed_Component then + Subp := Entity (Selector_Name (Prefix (Name (N)))); + Parent_Subp := Empty; + + -- Normal case + + else + Subp := Entity (Name (N)); + Parent_Subp := Alias (Subp); + + -- Replace call to Raise_Exception by call to Raise_Exception_Always + -- if we can tell that the first parameter cannot possibly be null. + + if not Restrictions (No_Exception_Handlers) + and then Is_RTE (Subp, RE_Raise_Exception) + then + declare + FA : constant Node_Id := Original_Node (First_Actual (N)); + + begin + -- The case we catch is where the first argument is obtained + -- using the Identity attribute (which must always be non-null) + + if Nkind (FA) = N_Attribute_Reference + and then Attribute_Name (FA) = Name_Identity + then + Subp := RTE (RE_Raise_Exception_Always); + Set_Entity (Name (N), Subp); + end if; + end; + end if; + + if Ekind (Subp) = E_Entry then + Parent_Subp := Empty; + end if; + end if; + + -- First step, compute extra actuals, corresponding to any + -- Extra_Formals present. Note that we do not access Extra_Formals + -- directly, instead we simply note the presence of the extra + -- formals as we process the regular formals and collect the + -- corresponding actuals in Extra_Actuals. + + Formal := First_Formal (Subp); + Actual := First_Actual (N); + + while Present (Formal) loop + Prev := Actual; + Prev_Orig := Original_Node (Prev); + + -- Create possible extra actual for constrained case. Usually, + -- the extra actual is of the form actual'constrained, but since + -- this attribute is only available for unconstrained records, + -- TRUE is expanded if the type of the formal happens to be + -- constrained (for instance when this procedure is inherited + -- from an unconstrained record to a constrained one) or if the + -- actual has no discriminant (its type is constrained). An + -- exception to this is the case of a private type without + -- discriminants. In this case we pass FALSE because the + -- object has underlying discriminants with defaults. + + if Present (Extra_Constrained (Formal)) then + if Ekind (Etype (Prev)) in Private_Kind + and then not Has_Discriminants (Base_Type (Etype (Prev))) + then + Add_Extra_Actual ( + New_Occurrence_Of (Standard_False, Loc), + Extra_Constrained (Formal)); + + elsif Is_Constrained (Etype (Formal)) + or else not Has_Discriminants (Etype (Prev)) + then + Add_Extra_Actual ( + New_Occurrence_Of (Standard_True, Loc), + Extra_Constrained (Formal)); + + else + -- If the actual is a type conversion, then the constrained + -- test applies to the actual, not the target type. + + declare + Act_Prev : Node_Id := Prev; + + begin + -- Test for unchecked conversions as well, which can + -- occur as out parameter actuals on calls to stream + -- procedures. + + if Nkind (Act_Prev) = N_Type_Conversion + or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion + then + Act_Prev := Expression (Act_Prev); + end if; + + Add_Extra_Actual ( + Make_Attribute_Reference (Sloc (Prev), + Prefix => Duplicate_Subexpr (Act_Prev, Name_Req => True), + Attribute_Name => Name_Constrained), + Extra_Constrained (Formal)); + end; + end if; + end if; + + -- Create possible extra actual for accessibility level + + if Present (Extra_Accessibility (Formal)) then + if Is_Entity_Name (Prev_Orig) then + + -- When passing an access parameter as the actual to another + -- access parameter we need to pass along the actual's own + -- associated access level parameter. This is done is we are + -- in the scope of the formal access parameter (if this is an + -- inlined body the extra formal is irrelevant). + + if Ekind (Entity (Prev_Orig)) in Formal_Kind + and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type + and then In_Open_Scopes (Scope (Entity (Prev_Orig))) + then + declare + Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); + + begin + pragma Assert (Present (Parm_Ent)); + + if Present (Extra_Accessibility (Parm_Ent)) then + Add_Extra_Actual ( + New_Occurrence_Of + (Extra_Accessibility (Parm_Ent), Loc), + Extra_Accessibility (Formal)); + + -- If the actual access parameter does not have an + -- associated extra formal providing its scope level, + -- then treat the actual as having library-level + -- accessibility. + + else + Add_Extra_Actual ( + Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + Extra_Accessibility (Formal)); + end if; + end; + + -- The actual is a normal access value, so just pass the + -- level of the actual's access type. + + else + Add_Extra_Actual ( + Make_Integer_Literal (Loc, + Intval => Type_Access_Level (Etype (Prev_Orig))), + Extra_Accessibility (Formal)); + end if; + + else + case Nkind (Prev_Orig) is + + when N_Attribute_Reference => + + case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is + + -- For X'Access, pass on the level of the prefix X + + when Attribute_Access => + Add_Extra_Actual ( + Make_Integer_Literal (Loc, + Intval => + Object_Access_Level (Prefix (Prev_Orig))), + Extra_Accessibility (Formal)); + + -- Treat the unchecked attributes as library-level + + when Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => + Add_Extra_Actual ( + Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + Extra_Accessibility (Formal)); + + -- No other cases of attributes returning access + -- values that can be passed to access parameters + + when others => + raise Program_Error; + + end case; + + -- For allocators we pass the level of the execution of + -- the called subprogram, which is one greater than the + -- current scope level. + + when N_Allocator => + Add_Extra_Actual ( + Make_Integer_Literal (Loc, + Scope_Depth (Current_Scope) + 1), + Extra_Accessibility (Formal)); + + -- For other cases we simply pass the level of the + -- actual's access type. + + when others => + Add_Extra_Actual ( + Make_Integer_Literal (Loc, + Intval => Type_Access_Level (Etype (Prev_Orig))), + Extra_Accessibility (Formal)); + + end case; + end if; + end if; + + -- Perform the check of 4.6(49) that prevents a null value + -- from being passed as an actual to an access parameter. + -- Note that the check is elided in the common cases of + -- passing an access attribute or access parameter as an + -- actual. Also, we currently don't enforce this check for + -- expander-generated actuals and when -gnatdj is set. + + if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type + or else Suppress_Accessibility_Checks (Subp) + then + null; + + elsif Debug_Flag_J then + null; + + elsif not Comes_From_Source (Prev) then + null; + + elsif Is_Entity_Name (Prev) + and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type + then + null; + + elsif Nkind (Prev) = N_Allocator + or else Nkind (Prev) = N_Attribute_Reference + then + null; + + -- Suppress null checks when passing to access parameters + -- of Java subprograms. (Should this be done for other + -- foreign conventions as well ???) + + elsif Convention (Subp) = Convention_Java then + null; + + else + Cond := + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Prev), + Right_Opnd => Make_Null (Loc)); + Insert_Action (Prev, Make_Raise_Constraint_Error (Loc, Cond)); + end if; + + -- Perform apropriate validity checks on parameters + + if Validity_Checks_On then + + if Ekind (Formal) = E_In_Parameter + and then Validity_Check_In_Params + then + Ensure_Valid (Actual); + + elsif Ekind (Formal) = E_In_Out_Parameter + and then Validity_Check_In_Out_Params + then + Ensure_Valid (Actual); + end if; + end if; + + -- For IN OUT and OUT parameters, ensure that subscripts are valid + -- since this is a left side reference. We only do this for calls + -- from the source program since we assume that compiler generated + -- calls explicitly generate any required checks. We also need it + -- only if we are doing standard validity checks, since clearly it + -- is not needed if validity checks are off, and in subscript + -- validity checking mode, all indexed components are checked with + -- a call directly from Expand_N_Indexed_Component. + + if Comes_From_Source (N) + and then Ekind (Formal) /= E_In_Parameter + and then Validity_Checks_On + and then Validity_Check_Default + and then not Validity_Check_Subscripts + then + Check_Valid_Lvalue_Subscripts (Actual); + end if; + + -- If the formal is class wide and the actual is an aggregate, force + -- evaluation so that the back end who does not know about class-wide + -- type, does not generate a temporary of the wrong size. + + if not Is_Class_Wide_Type (Etype (Formal)) then + null; + + elsif Nkind (Actual) = N_Aggregate + or else (Nkind (Actual) = N_Qualified_Expression + and then Nkind (Expression (Actual)) = N_Aggregate) + then + Force_Evaluation (Actual); + end if; + + -- In a remote call, if the formal is of a class-wide type, check + -- that the actual meets the requirements described in E.4(18). + + if Remote + and then Is_Class_Wide_Type (Etype (Formal)) + then + Insert_Action (Actual, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + Get_Remotely_Callable (Duplicate_Subexpr (Actual))), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + New_Occurrence_Of (RTE + (RE_Raise_Program_Error_For_E_4_18), Loc))))); + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + -- If we are expanding a rhs of an assignement we need to check if + -- tag propagation is needed. This code belongs theorically in Analyze + -- Assignment but has to be done earlier (bottom-up) because the + -- assignment might be transformed into a declaration for an uncons- + -- trained value, if the expression is classwide. + + if Nkind (N) = N_Function_Call + and then Is_Tag_Indeterminate (N) + and then Is_Entity_Name (Name (N)) + then + declare + Ass : Node_Id := Empty; + + begin + if Nkind (Parent (N)) = N_Assignment_Statement then + Ass := Parent (N); + + elsif Nkind (Parent (N)) = N_Qualified_Expression + and then Nkind (Parent (Parent (N))) = N_Assignment_Statement + then + Ass := Parent (Parent (N)); + end if; + + if Present (Ass) + and then Is_Class_Wide_Type (Etype (Name (Ass))) + then + Propagate_Tag (Name (Ass), N); + return; + end if; + end; + end if; + + -- Deals with Dispatch_Call if we still have a call, before expanding + -- extra actuals since this will be done on the re-analysis of the + -- dispatching call. Note that we do not try to shorten the actual + -- list for a dispatching call, it would not make sense to do so. + -- Expansion of dispatching calls is suppressed when Java_VM, because + -- the JVM back end directly handles the generation of dispatching + -- calls and would have to undo any expansion to an indirect call. + + if (Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement) + and then Present (Controlling_Argument (N)) + and then not Java_VM + then + Expand_Dispatch_Call (N); + return; + + -- Similarly, expand calls to RCI subprograms on which pragma + -- All_Calls_Remote applies. The rewriting will be reanalyzed + -- later. Do this only when the call comes from source since we do + -- not want such a rewritting to occur in expanded code. + + elsif Is_All_Remote_Call (N) then + Expand_All_Calls_Remote_Subprogram_Call (N); + + -- Similarly, do not add extra actuals for an entry call whose entity + -- is a protected procedure, or for an internal protected subprogram + -- call, because it will be rewritten as a protected subprogram call + -- and reanalyzed (see Expand_Protected_Subprogram_Call). + + elsif Is_Protected_Type (Scope (Subp)) + and then (Ekind (Subp) = E_Procedure + or else Ekind (Subp) = E_Function) + then + null; + + -- During that loop we gathered the extra actuals (the ones that + -- correspond to Extra_Formals), so now they can be appended. + + else + while Is_Non_Empty_List (Extra_Actuals) loop + Add_Actual_Parameter (Remove_Head (Extra_Actuals)); + end loop; + end if; + + if Ekind (Subp) = E_Procedure + or else (Ekind (Subp) = E_Subprogram_Type + and then Etype (Subp) = Standard_Void_Type) + or else Is_Entry (Subp) + then + Expand_Actuals (N, Subp); + end if; + + -- If the subprogram is a renaming, or if it is inherited, replace it + -- in the call with the name of the actual subprogram being called. + -- If this is a dispatching call, the run-time decides what to call. + -- The Alias attribute does not apply to entries. + + if Nkind (N) /= N_Entry_Call_Statement + and then No (Controlling_Argument (N)) + and then Present (Parent_Subp) + then + if Present (Inherited_From_Formal (Subp)) then + Parent_Subp := Inherited_From_Formal (Subp); + else + while Present (Alias (Parent_Subp)) loop + Parent_Subp := Alias (Parent_Subp); + end loop; + end if; + + Set_Entity (Name (N), Parent_Subp); + + if Is_Abstract (Parent_Subp) + and then not In_Instance + then + Error_Msg_NE + ("cannot call abstract subprogram &!", Name (N), Parent_Subp); + end if; + + -- Add an explicit conversion for parameter of the derived type. + -- This is only done for scalar and access in-parameters. Others + -- have been expanded in expand_actuals. + + Formal := First_Formal (Subp); + Parent_Formal := First_Formal (Parent_Subp); + Actual := First_Actual (N); + + -- It is not clear that conversion is needed for intrinsic + -- subprograms, but it certainly is for those that are user- + -- defined, and that can be inherited on derivation, namely + -- unchecked conversion and deallocation. + -- General case needs study ??? + + if not Is_Intrinsic_Subprogram (Parent_Subp) + or else Is_Generic_Instance (Parent_Subp) + then + while Present (Formal) loop + + if Etype (Formal) /= Etype (Parent_Formal) + and then Is_Scalar_Type (Etype (Formal)) + and then Ekind (Formal) = E_In_Parameter + then + Rewrite (Actual, + OK_Convert_To (Etype (Parent_Formal), + Relocate_Node (Actual))); + + Analyze (Actual); + Resolve (Actual, Etype (Parent_Formal)); + Enable_Range_Check (Actual); + + elsif Is_Access_Type (Etype (Formal)) + and then Base_Type (Etype (Parent_Formal)) + /= Base_Type (Etype (Actual)) + then + if Ekind (Formal) /= E_In_Parameter then + Rewrite (Actual, + Convert_To (Etype (Parent_Formal), + Relocate_Node (Actual))); + + Analyze (Actual); + Resolve (Actual, Etype (Parent_Formal)); + + elsif + Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type + and then + Designated_Type (Etype (Parent_Formal)) + /= Designated_Type (Etype (Actual)) + and then not Is_Controlling_Formal (Formal) + then + + -- This unchecked conversion is not necessary unless + -- inlining is unabled, because in that case the type + -- mismatch may become visible in the body about to be + -- inlined. + + Rewrite (Actual, + Unchecked_Convert_To (Etype (Parent_Formal), + Relocate_Node (Actual))); + + Analyze (Actual); + Resolve (Actual, Etype (Parent_Formal)); + end if; + end if; + + Next_Formal (Formal); + Next_Formal (Parent_Formal); + Next_Actual (Actual); + end loop; + end if; + + Orig_Subp := Subp; + Subp := Parent_Subp; + end if; + + -- Some more special cases for cases other than explicit dereference + + if Nkind (Name (N)) /= N_Explicit_Dereference then + + -- Calls to an enumeration literal are replaced by the literal + -- This case occurs only when we have a call to a function that + -- is a renaming of an enumeration literal. The normal case of + -- a direct reference to an enumeration literal has already been + -- been dealt with by Resolve_Call. If the function is itself + -- inherited (see 7423-001) the literal of the parent type must + -- be explicitly converted to the return type of the function. + + if Ekind (Subp) = E_Enumeration_Literal then + if Base_Type (Etype (Subp)) /= Base_Type (Etype (N)) then + Rewrite + (N, Convert_To (Etype (N), New_Occurrence_Of (Subp, Loc))); + else + Rewrite (N, New_Occurrence_Of (Subp, Loc)); + Resolve (N, Etype (N)); + end if; + end if; + + -- Handle case of access to protected subprogram type + + else + if Ekind (Base_Type (Etype (Prefix (Name (N))))) = + E_Access_Protected_Subprogram_Type + then + -- If this is a call through an access to protected operation, + -- the prefix has the form (object'address, operation'access). + -- Rewrite as a for other protected calls: the object is the + -- first parameter of the list of actuals. + + declare + Call : Node_Id; + Parm : List_Id; + Nam : Node_Id; + Obj : Node_Id; + Ptr : Node_Id := Prefix (Name (N)); + T : Entity_Id := Equivalent_Type (Base_Type (Etype (Ptr))); + D_T : Entity_Id := Designated_Type (Base_Type (Etype (Ptr))); + + begin + Obj := Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => New_Occurrence_Of (First_Entity (T), Loc)); + + Nam := Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => New_Occurrence_Of ( + Next_Entity (First_Entity (T)), Loc)); + + Nam := Make_Explicit_Dereference (Loc, Nam); + + if Present (Parameter_Associations (N)) then + Parm := Parameter_Associations (N); + else + Parm := New_List; + end if; + + Prepend (Obj, Parm); + + if Etype (D_T) = Standard_Void_Type then + Call := Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => Parm); + else + Call := Make_Function_Call (Loc, + Name => Nam, + Parameter_Associations => Parm); + end if; + + Set_First_Named_Actual (Call, First_Named_Actual (N)); + + Set_Etype (Call, Etype (D_T)); + + -- We do not re-analyze the call to avoid infinite recursion. + -- We analyze separately the prefix and the object, and set + -- the checks on the prefix that would otherwise be emitted + -- when resolving a call. + + Rewrite (N, Call); + Analyze (Nam); + Apply_Access_Check (Nam); + Analyze (Obj); + return; + end; + end if; + end if; + + -- If this is a call to an intrinsic subprogram, then perform the + -- appropriate expansion to the corresponding tree node and we + -- are all done (since after that the call is gone!) + + if Is_Intrinsic_Subprogram (Subp) then + Expand_Intrinsic_Call (N, Subp); + return; + end if; + + if Ekind (Subp) = E_Function + or else Ekind (Subp) = E_Procedure + then + if Is_Inlined (Subp) then + + declare + Spec : constant Node_Id := Unit_Declaration_Node (Subp); + + begin + -- Verify that the body to inline has already been seen, + -- and that if the body is in the current unit the inlining + -- does not occur earlier. This avoids order-of-elaboration + -- problems in gigi. + + if Present (Spec) + and then Nkind (Spec) = N_Subprogram_Declaration + and then Present (Body_To_Inline (Spec)) + and then (In_Extended_Main_Code_Unit (N) + or else In_Extended_Main_Code_Unit (Parent (N))) + and then (not In_Same_Extended_Unit + (Sloc (Body_To_Inline (Spec)), Loc) + or else + Earlier_In_Extended_Unit + (Sloc (Body_To_Inline (Spec)), Loc)) + then + Expand_Inlined_Call (N, Subp, Orig_Subp); + + else + -- Let the back-end handle it. + + Add_Inlined_Body (Subp); + + if Front_End_Inlining + and then Nkind (Spec) = N_Subprogram_Declaration + and then (In_Extended_Main_Code_Unit (N)) + and then No (Body_To_Inline (Spec)) + and then not Has_Completion (Subp) + and then In_Same_Extended_Unit (Sloc (Spec), Loc) + and then Ineffective_Inline_Warnings + then + Error_Msg_N + ("call cannot be inlined before body is seen?", N); + end if; + end if; + end; + end if; + end if; + + -- Check for a protected subprogram. This is either an intra-object + -- call, or a protected function call. Protected procedure calls are + -- rewritten as entry calls and handled accordingly. + + Scop := Scope (Subp); + + if Nkind (N) /= N_Entry_Call_Statement + and then Is_Protected_Type (Scop) + then + -- If the call is an internal one, it is rewritten as a call to + -- to the corresponding unprotected subprogram. + + Expand_Protected_Subprogram_Call (N, Subp, Scop); + end if; + + -- Functions returning controlled objects need special attention + + if Controlled_Type (Etype (Subp)) + and then not Is_Return_By_Reference_Type (Etype (Subp)) + then + Expand_Ctrl_Function_Call (N); + end if; + + -- Test for First_Optional_Parameter, and if so, truncate parameter + -- list if there are optional parameters at the trailing end. + -- Note we never delete procedures for call via a pointer. + + if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) + and then Present (First_Optional_Parameter (Subp)) + then + declare + Last_Keep_Arg : Node_Id; + + begin + -- Last_Keep_Arg will hold the last actual that should be + -- retained. If it remains empty at the end, it means that + -- all parameters are optional. + + Last_Keep_Arg := Empty; + + -- Find first optional parameter, must be present since we + -- checked the validity of the parameter before setting it. + + Formal := First_Formal (Subp); + Actual := First_Actual (N); + while Formal /= First_Optional_Parameter (Subp) loop + Last_Keep_Arg := Actual; + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + + -- Now we have Formal and Actual pointing to the first + -- potentially droppable argument. We can drop all the + -- trailing arguments whose actual matches the default. + -- Note that we know that all remaining formals have + -- defaults, because we checked that this requirement + -- was met before setting First_Optional_Parameter. + + -- We use Fully_Conformant_Expressions to check for identity + -- between formals and actuals, which may miss some cases, but + -- on the other hand, this is only an optimization (if we fail + -- to truncate a parameter it does not affect functionality). + -- So if the default is 3 and the actual is 1+2, we consider + -- them unequal, which hardly seems worrisome. + + while Present (Formal) loop + if not Fully_Conformant_Expressions + (Actual, Default_Value (Formal)) + then + Last_Keep_Arg := Actual; + end if; + + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + + -- If no arguments, delete entire list, this is the easy case + + if No (Last_Keep_Arg) then + while Is_Non_Empty_List (Parameter_Associations (N)) loop + Delete_Tree (Remove_Head (Parameter_Associations (N))); + end loop; + + Set_Parameter_Associations (N, No_List); + Set_First_Named_Actual (N, Empty); + + -- Case where at the last retained argument is positional. This + -- is also an easy case, since the retained arguments are already + -- in the right form, and we don't need to worry about the order + -- of arguments that get eliminated. + + elsif Is_List_Member (Last_Keep_Arg) then + while Present (Next (Last_Keep_Arg)) loop + Delete_Tree (Remove_Next (Last_Keep_Arg)); + end loop; + + Set_First_Named_Actual (N, Empty); + + -- This is the annoying case where the last retained argument + -- is a named parameter. Since the original arguments are not + -- in declaration order, we may have to delete some fairly + -- random collection of arguments. + + else + declare + Temp : Node_Id; + Passoc : Node_Id; + Junk : Node_Id; + + begin + -- First step, remove all the named parameters from the + -- list (they are still chained using First_Named_Actual + -- and Next_Named_Actual, so we have not lost them!) + + Temp := First (Parameter_Associations (N)); + + -- Case of all parameters named, remove them all + + if Nkind (Temp) = N_Parameter_Association then + while Is_Non_Empty_List (Parameter_Associations (N)) loop + Temp := Remove_Head (Parameter_Associations (N)); + end loop; + + -- Case of mixed positional/named, remove named parameters + + else + while Nkind (Next (Temp)) /= N_Parameter_Association loop + Next (Temp); + end loop; + + while Present (Next (Temp)) loop + Junk := Remove_Next (Temp); + end loop; + end if; + + -- Now we loop through the named parameters, till we get + -- to the last one to be retained, adding them to the list. + -- Note that the Next_Named_Actual list does not need to be + -- touched since we are only reordering them on the actual + -- parameter association list. + + Passoc := Parent (First_Named_Actual (N)); + loop + Temp := Relocate_Node (Passoc); + Append_To + (Parameter_Associations (N), Temp); + exit when + Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); + Passoc := Parent (Next_Named_Actual (Passoc)); + end loop; + + Set_Next_Named_Actual (Temp, Empty); + + loop + Temp := Next_Named_Actual (Passoc); + exit when No (Temp); + Set_Next_Named_Actual + (Passoc, Next_Named_Actual (Parent (Temp))); + Delete_Tree (Temp); + end loop; + end; + end if; + end; + end if; + + end Expand_Call; + + -------------------------- + -- Expand_Inlined_Call -- + -------------------------- + + procedure Expand_Inlined_Call + (N : Node_Id; + Subp : Entity_Id; + Orig_Subp : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Blk : Node_Id; + Bod : Node_Id; + Decl : Node_Id; + Exit_Lab : Entity_Id := Empty; + F : Entity_Id; + A : Node_Id; + Lab_Decl : Node_Id; + Lab_Id : Node_Id; + New_A : Node_Id; + Num_Ret : Int := 0; + Orig_Bod : constant Node_Id := + Body_To_Inline (Unit_Declaration_Node (Subp)); + Ret_Type : Entity_Id; + Targ : Node_Id; + Temp : Entity_Id; + Temp_Typ : Entity_Id; + + procedure Make_Exit_Label; + -- Build declaration for exit label to be used in Return statements. + + function Process_Formals (N : Node_Id) return Traverse_Result; + -- Replace occurrence of a formal with the corresponding actual, or + -- the thunk generated for it. + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); + -- If the function body is a single expression, replace call with + -- expression, else insert block appropriately. + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); + -- If procedure body has no local variables, inline body without + -- creating block, otherwise rewrite call with block. + + --------------------- + -- Make_Exit_Label -- + --------------------- + + procedure Make_Exit_Label is + begin + -- Create exit label for subprogram, if one doesn't exist yet. + + if No (Exit_Lab) then + Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); + Set_Entity (Lab_Id, + Make_Defining_Identifier (Loc, Chars (Lab_Id))); + Exit_Lab := Make_Label (Loc, Lab_Id); + + Lab_Decl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Lab_Id), + Label_Construct => Exit_Lab); + end if; + end Make_Exit_Label; + + --------------------- + -- Process_Formals -- + --------------------- + + function Process_Formals (N : Node_Id) return Traverse_Result is + A : Entity_Id; + E : Entity_Id; + Ret : Node_Id; + + begin + if Is_Entity_Name (N) + and then Present (Entity (N)) + then + E := Entity (N); + + if Is_Formal (E) + and then Scope (E) = Subp + then + A := Renamed_Object (E); + + if Is_Entity_Name (A) then + Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); + + elsif Nkind (A) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (A, Loc)); + + else -- numeric literal + Rewrite (N, New_Copy (A)); + end if; + end if; + + return Skip; + + elsif Nkind (N) = N_Return_Statement then + + if No (Expression (N)) then + Make_Exit_Label; + Rewrite (N, Make_Goto_Statement (Loc, + Name => New_Copy (Lab_Id))); + + else + if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Parent (N))) = N_Subprogram_Body + then + -- function body is a single expression. No need for + -- exit label. + null; + + else + Num_Ret := Num_Ret + 1; + Make_Exit_Label; + end if; + + -- Because of the presence of private types, the views of the + -- expression and the context may be different, so place an + -- unchecked conversion to the context type to avoid spurious + -- errors, eg. when the expression is a numeric literal and + -- the context is private. If the expression is an aggregate, + -- use a qualified expression, because an aggregate is not a + -- legal argument of a conversion. + + if Nkind (Expression (N)) = N_Aggregate then + Ret := + Make_Qualified_Expression (Sloc (N), + Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), + Expression => Relocate_Node (Expression (N))); + else + Ret := + Unchecked_Convert_To + (Ret_Type, Relocate_Node (Expression (N))); + end if; + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Ret)); + else + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Ret)); + end if; + + Set_Assignment_OK (Name (N)); + + if Present (Exit_Lab) then + Insert_After (N, + Make_Goto_Statement (Loc, + Name => New_Copy (Lab_Id))); + end if; + end if; + + return OK; + + else + return OK; + end if; + end Process_Formals; + + procedure Replace_Formals is new Traverse_Proc (Process_Formals); + + --------------------------- + -- Rewrite_Function_Call -- + --------------------------- + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is + HSS : Node_Id := Handled_Statement_Sequence (Blk); + Fst : Node_Id := First (Statements (HSS)); + + begin + + -- Optimize simple case: function body is a single return statement, + -- which has been expanded into an assignment. + + if Is_Empty_List (Declarations (Blk)) + and then Nkind (Fst) = N_Assignment_Statement + and then No (Next (Fst)) + then + + -- The function call may have been rewritten as the temporary + -- that holds the result of the call, in which case remove the + -- now useless declaration. + + if Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); + end if; + + Rewrite (N, Expression (Fst)); + + elsif Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + + -- The block assigns the result of the call to the temporary. + + Insert_After (Parent (Entity (N)), Blk); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (N))) + then + + -- replace assignment with the block. + + Rewrite (Parent (N), Blk); + + elsif Nkind (Parent (N)) = N_Object_Declaration then + Set_Expression (Parent (N), Empty); + Insert_After (Parent (N), Blk); + end if; + end Rewrite_Function_Call; + + ---------------------------- + -- Rewrite_Procedure_Call -- + ---------------------------- + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is + HSS : Node_Id := Handled_Statement_Sequence (Blk); + + begin + if Is_Empty_List (Declarations (Blk)) then + Insert_List_After (N, Statements (HSS)); + Rewrite (N, Make_Null_Statement (Loc)); + else + Rewrite (N, Blk); + end if; + end Rewrite_Procedure_Call; + + -- Start of processing for Expand_Inlined_Call + + begin + if Nkind (Orig_Bod) = N_Defining_Identifier then + + -- Subprogram is a renaming_as_body. Calls appearing after the + -- renaming can be replaced with calls to the renamed entity + -- directly, because the subprograms are subtype conformant. + + Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); + return; + end if; + + -- Use generic machinery to copy body of inlined subprogram, as if it + -- were an instantiation, resetting source locations appropriately, so + -- that nested inlined calls appear in the main unit. + + Save_Env (Subp, Empty); + Set_Copied_Sloc (N, Defining_Entity (Orig_Bod)); + + Bod := + Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); + + Blk := + Make_Block_Statement (Loc, + Declarations => Declarations (Bod), + Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); + + if No (Declarations (Bod)) then + Set_Declarations (Blk, New_List); + end if; + + -- If this is a derived function, establish the proper return type. + + if Present (Orig_Subp) + and then Orig_Subp /= Subp + then + Ret_Type := Etype (Orig_Subp); + else + Ret_Type := Etype (Subp); + end if; + + F := First_Formal (Subp); + A := First_Actual (N); + + -- Create temporaries for the actuals that are expressions, or that + -- are scalars and require copying to preserve semantics. + + while Present (F) loop + + if Present (Renamed_Object (F)) then + Error_Msg_N (" cannot inline call to recursive subprogram", N); + return; + end if; + + -- If the argument may be a controlling argument in a call within + -- the inlined body, we must preserve its classwide nature to + -- insure that dynamic dispatching take place subsequently. + -- If the formal has a constraint it must be preserved to retain + -- the semantics of the body. + + if Is_Class_Wide_Type (Etype (F)) + or else (Is_Access_Type (Etype (F)) + and then + Is_Class_Wide_Type (Designated_Type (Etype (F)))) + then + Temp_Typ := Etype (F); + + elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) + and then Etype (F) /= Base_Type (Etype (F)) + then + Temp_Typ := Etype (F); + + else + Temp_Typ := Etype (A); + end if; + + if (not Is_Entity_Name (A) + and then Nkind (A) /= N_Integer_Literal + and then Nkind (A) /= N_Real_Literal) + + or else Is_Scalar_Type (Etype (A)) + then + Temp := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('C')); + + -- If the actual for an in/in-out parameter is a view conversion, + -- make it into an unchecked conversion, given that an untagged + -- type conversion is not a proper object for a renaming. + -- In-out conversions that involve real conversions have already + -- been transformed in Expand_Actuals. + + if Nkind (A) = N_Type_Conversion + and then + (Ekind (F) = E_In_Out_Parameter + or else not Is_Tagged_Type (Etype (F))) + then + New_A := Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), + Expression => Relocate_Node (Expression (A))); + + elsif Etype (F) /= Etype (A) then + New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); + Temp_Typ := Etype (F); + + else + New_A := Relocate_Node (A); + end if; + + Set_Sloc (New_A, Sloc (N)); + + if Ekind (F) = E_In_Parameter + and then not Is_Limited_Type (Etype (A)) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), + Expression => New_A); + else + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), + Name => New_A); + end if; + + Prepend (Decl, Declarations (Blk)); + Set_Renamed_Object (F, Temp); + + else + if Etype (F) /= Etype (A) then + Set_Renamed_Object + (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); + else + Set_Renamed_Object (F, A); + end if; + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + -- Establish target of function call. If context is not assignment or + -- declaration, create a temporary as a target. The declaration for + -- the temporary may be subsequently optimized away if the body is a + -- single expression, or if the left-hand side of the assignment is + -- simple enough. + + if Ekind (Subp) = E_Function then + if Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (N))) + then + Targ := Name (Parent (N)); + + else + -- Replace call with temporary, and create its declaration. + + Temp := + Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Ret_Type, Loc)); + + Set_No_Initialization (Decl); + Insert_Action (N, Decl); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Targ := Temp; + end if; + end if; + + -- Traverse the tree and replace formals with actuals or their thunks. + -- Attach block to tree before analysis and rewriting. + + Replace_Formals (Blk); + Set_Parent (Blk, N); + + if Present (Exit_Lab) then + + -- If the body was a single expression, the single return statement + -- and the corresponding label are useless. + + if Num_Ret = 1 + and then + Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = + N_Goto_Statement + then + Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); + else + Append (Lab_Decl, (Declarations (Blk))); + Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); + end if; + end if; + + -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on + -- conflicting private views that Gigi would ignore. + + declare + I_Flag : constant Boolean := In_Inlined_Body; + + begin + In_Inlined_Body := True; + Analyze (Blk); + In_Inlined_Body := I_Flag; + end; + + if Ekind (Subp) = E_Procedure then + Rewrite_Procedure_Call (N, Blk); + else + Rewrite_Function_Call (N, Blk); + end if; + + Restore_Env; + + -- Cleanup mapping between formals and actuals, for other expansions. + + F := First_Formal (Subp); + + while Present (F) loop + Set_Renamed_Object (F, Empty); + Next_Formal (F); + end loop; + end Expand_Inlined_Call; + + ---------------------------- + -- Expand_N_Function_Call -- + ---------------------------- + + procedure Expand_N_Function_Call (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + function Returned_By_Reference return Boolean; + -- If the return type is returned through the secondary stack. i.e. + -- by reference, we don't want to create a temporary to force stack + -- checking. + + function Returned_By_Reference return Boolean is + S : Entity_Id := Current_Scope; + + begin + if Is_Return_By_Reference_Type (Typ) then + return True; + + elsif Nkind (Parent (N)) /= N_Return_Statement then + return False; + + elsif Requires_Transient_Scope (Typ) then + + -- Verify that the return type of the enclosing function has + -- the same constrained status as that of the expression. + + while Ekind (S) /= E_Function loop + S := Scope (S); + end loop; + + return Is_Constrained (Typ) = Is_Constrained (Etype (S)); + else + return False; + end if; + end Returned_By_Reference; + + -- Start of processing for Expand_N_Function_Call + + begin + -- A special check. If stack checking is enabled, and the return type + -- might generate a large temporary, and the call is not the right + -- side of an assignment, then generate an explicit temporary. We do + -- this because otherwise gigi may generate a large temporary on the + -- fly and this can cause trouble with stack checking. + + if May_Generate_Large_Temp (Typ) + and then Nkind (Parent (N)) /= N_Assignment_Statement + and then + (Nkind (Parent (N)) /= N_Object_Declaration + or else Expression (Parent (N)) /= N) + and then not Returned_By_Reference + then + -- Note: it might be thought that it would be OK to use a call to + -- Force_Evaluation here, but that's not good enough, because that + -- results in a 'Reference construct that may still need a temporary. + + declare + Loc : constant Source_Ptr := Sloc (N); + Temp_Obj : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('F')); + Temp_Typ : Entity_Id := Typ; + Decl : Node_Id; + A : Node_Id; + F : Entity_Id; + Proc : Entity_Id; + + begin + if Is_Tagged_Type (Typ) + and then Present (Controlling_Argument (N)) + then + if Nkind (Parent (N)) /= N_Procedure_Call_Statement + and then Nkind (Parent (N)) /= N_Function_Call + then + -- If this is a tag-indeterminate call, the object must + -- be classwide. + + if Is_Tag_Indeterminate (N) then + Temp_Typ := Class_Wide_Type (Typ); + end if; + + else + -- If this is a dispatching call that is itself the + -- controlling argument of an enclosing call, the nominal + -- subtype of the object that replaces it must be classwide, + -- so that dispatching will take place properly. If it is + -- not a controlling argument, the object is not classwide. + + Proc := Entity (Name (Parent (N))); + F := First_Formal (Proc); + A := First_Actual (Parent (N)); + + while A /= N loop + Next_Formal (F); + Next_Actual (A); + end loop; + + if Is_Controlling_Formal (F) then + Temp_Typ := Class_Wide_Type (Typ); + end if; + end if; + end if; + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Obj, + Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), + Constant_Present => True, + Expression => Relocate_Node (N)); + Set_Assignment_OK (Decl); + + Insert_Actions (N, New_List (Decl)); + Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc)); + end; + + -- Normal case, expand the call + + else + Expand_Call (N); + end if; + end Expand_N_Function_Call; + + --------------------------------------- + -- Expand_N_Procedure_Call_Statement -- + --------------------------------------- + + procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is + begin + Expand_Call (N); + end Expand_N_Procedure_Call_Statement; + + ------------------------------ + -- Expand_N_Subprogram_Body -- + ------------------------------ + + -- Add poll call if ATC polling is enabled + + -- Add return statement if last statement in body is not a return + -- statement (this makes things easier on Gigi which does not want + -- to have to handle a missing return). + + -- Add call to Activate_Tasks if body is a task activator + + -- Deal with possible detection of infinite recursion + + -- Eliminate body completely if convention stubbed + + -- Encode entity names within body, since we will not need to reference + -- these entities any longer in the front end. + + -- Initialize scalar out parameters if Initialize/Normalize_Scalars + + procedure Expand_N_Subprogram_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + H : constant Node_Id := Handled_Statement_Sequence (N); + Spec_Id : Entity_Id; + Except_H : Node_Id; + Scop : Entity_Id; + Dec : Node_Id; + Next_Op : Node_Id; + L : List_Id; + + procedure Add_Return (S : List_Id); + -- Append a return statement to the statement sequence S if the last + -- statement is not already a return or a goto statement. Note that + -- the latter test is not critical, it does not matter if we add a + -- few extra returns, since they get eliminated anyway later on. + + ---------------- + -- Add_Return -- + ---------------- + + procedure Add_Return (S : List_Id) is + Last_S : constant Node_Id := Last (S); + -- Get original node, in case raise has been rewritten + + begin + if not Is_Transfer (Last_S) then + Append_To (S, Make_Return_Statement (Sloc (Last_S))); + end if; + end Add_Return; + + -- Start of processing for Expand_N_Subprogram_Body + + begin + -- Set L to either the list of declarations if present, or + -- to the list of statements if no declarations are present. + -- This is used to insert new stuff at the start. + + if Is_Non_Empty_List (Declarations (N)) then + L := Declarations (N); + else + L := Statements (Handled_Statement_Sequence (N)); + end if; + + -- Need poll on entry to subprogram if polling enabled. We only + -- do this for non-empty subprograms, since it does not seem + -- necessary to poll for a dummy null subprogram. + + if Is_Non_Empty_List (L) then + Generate_Poll_Call (First (L)); + end if; + + -- Find entity for subprogram + + if Present (Corresponding_Spec (N)) then + Spec_Id := Corresponding_Spec (N); + else + Spec_Id := Defining_Entity (N); + end if; + + -- Initialize any scalar OUT args if Initialize/Normalize_Scalars + + if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then + declare + F : Entity_Id := First_Formal (Spec_Id); + V : constant Boolean := Validity_Checks_On; + + begin + -- We turn off validity checking, since we do not want any + -- check on the initializing value itself (which we know + -- may well be invalid!) + + Validity_Checks_On := False; + + -- Loop through formals + + while Present (F) loop + if Is_Scalar_Type (Etype (F)) + and then Ekind (F) = E_Out_Parameter + then + Insert_Before_And_Analyze (First (L), + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (F, Loc), + Expression => Get_Simple_Init_Val (Etype (F), Loc))); + end if; + + Next_Formal (F); + end loop; + + Validity_Checks_On := V; + end; + end if; + + -- Clear out statement list for stubbed procedure + + if Present (Corresponding_Spec (N)) then + Set_Elaboration_Flag (N, Spec_Id); + + if Convention (Spec_Id) = Convention_Stubbed + or else Is_Eliminated (Spec_Id) + then + Set_Declarations (N, Empty_List); + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Null_Statement (Loc)))); + return; + end if; + end if; + + Scop := Scope (Spec_Id); + + -- Returns_By_Ref flag is normally set when the subprogram is frozen + -- but subprograms with no specs are not frozen + + declare + Typ : constant Entity_Id := Etype (Spec_Id); + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + if not Acts_As_Spec (N) + and then Nkind (Parent (Parent (Spec_Id))) /= + N_Subprogram_Body_Stub + then + null; + + elsif Is_Return_By_Reference_Type (Typ) then + Set_Returns_By_Ref (Spec_Id); + + elsif Present (Utyp) and then Controlled_Type (Utyp) then + Set_Returns_By_Ref (Spec_Id); + end if; + end; + + -- For a procedure, we add a return for all possible syntactic ends + -- of the subprogram. Note that reanalysis is not necessary in this + -- case since it would require a lot of work and accomplish nothing. + + if Ekind (Spec_Id) = E_Procedure + or else Ekind (Spec_Id) = E_Generic_Procedure + then + Add_Return (Statements (H)); + + if Present (Exception_Handlers (H)) then + Except_H := First_Non_Pragma (Exception_Handlers (H)); + + while Present (Except_H) loop + Add_Return (Statements (Except_H)); + Next_Non_Pragma (Except_H); + end loop; + end if; + + -- For a function, we must deal with the case where there is at + -- least one missing return. What we do is to wrap the entire body + -- of the function in a block: + + -- begin + -- ... + -- end; + + -- becomes + + -- begin + -- begin + -- ... + -- end; + + -- raise Program_Error; + -- end; + + -- This approach is necessary because the raise must be signalled + -- to the caller, not handled by any local handler (RM 6.4(11)). + + -- Note: we do not need to analyze the constructed sequence here, + -- since it has no handler, and an attempt to analyze the handled + -- statement sequence twice is risky in various ways (e.g. the + -- issue of expanding cleanup actions twice). + + elsif Has_Missing_Return (Spec_Id) then + declare + Hloc : constant Source_Ptr := Sloc (H); + Blok : constant Node_Id := + Make_Block_Statement (Hloc, + Handled_Statement_Sequence => H); + Rais : constant Node_Id := + Make_Raise_Program_Error (Hloc); + + begin + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Hloc, + Statements => New_List (Blok, Rais))); + + New_Scope (Spec_Id); + Analyze (Blok); + Analyze (Rais); + Pop_Scope; + end; + end if; + + -- Add discriminal renamings to protected subprograms. + -- Install new discriminals for expansion of the next + -- subprogram of this protected type, if any. + + if Is_List_Member (N) + and then Present (Parent (List_Containing (N))) + and then Nkind (Parent (List_Containing (N))) = N_Protected_Body + then + Add_Discriminal_Declarations + (Declarations (N), Scop, Name_uObject, Loc); + Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc); + + -- Associate privals and discriminals with the next protected + -- operation body to be expanded. These are used to expand + -- references to private data objects and discriminants, + -- respectively. + + Next_Op := Next_Protected_Operation (N); + + if Present (Next_Op) then + Dec := Parent (Base_Type (Scop)); + Set_Privals (Dec, Next_Op, Loc); + Set_Discriminals (Dec, Next_Op, Loc); + end if; + + end if; + + -- If subprogram contains a parameterless recursive call, then we may + -- have an infinite recursion, so see if we can generate code to check + -- for this possibility if storage checks are not suppressed. + + if Ekind (Spec_Id) = E_Procedure + and then Has_Recursive_Call (Spec_Id) + and then not Storage_Checks_Suppressed (Spec_Id) + then + Detect_Infinite_Recursion (N, Spec_Id); + end if; + + -- Finally, if we are in Normalize_Scalars mode, then any scalar out + -- parameters must be initialized to the appropriate default value. + + if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then + declare + Floc : Source_Ptr; + Formal : Entity_Id; + Stm : Node_Id; + + begin + Formal := First_Formal (Spec_Id); + + while Present (Formal) loop + Floc := Sloc (Formal); + + if Ekind (Formal) = E_Out_Parameter + and then Is_Scalar_Type (Etype (Formal)) + then + Stm := + Make_Assignment_Statement (Floc, + Name => New_Occurrence_Of (Formal, Floc), + Expression => + Get_Simple_Init_Val (Etype (Formal), Floc)); + Prepend (Stm, Declarations (N)); + Analyze (Stm); + end if; + + Next_Formal (Formal); + end loop; + end; + end if; + + -- If the subprogram does not have pending instantiations, then we + -- must generate the subprogram descriptor now, since the code for + -- the subprogram is complete, and this is our last chance. However + -- if there are pending instantiations, then the code is not + -- complete, and we will delay the generation. + + if Is_Subprogram (Spec_Id) + and then not Delay_Subprogram_Descriptors (Spec_Id) + then + Generate_Subprogram_Descriptor_For_Subprogram (N, Spec_Id); + end if; + + -- Set to encode entity names in package body before gigi is called + + Qualify_Entity_Names (N); + end Expand_N_Subprogram_Body; + + ----------------------------------- + -- Expand_N_Subprogram_Body_Stub -- + ----------------------------------- + + procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is + begin + if Present (Corresponding_Body (N)) then + Expand_N_Subprogram_Body ( + Unit_Declaration_Node (Corresponding_Body (N))); + end if; + + end Expand_N_Subprogram_Body_Stub; + + ------------------------------------- + -- Expand_N_Subprogram_Declaration -- + ------------------------------------- + + -- The first task to be performed is the construction of default + -- expression functions for in parameters with default values. These + -- are parameterless inlined functions that are used to evaluate + -- default expressions that are more complicated than simple literals + -- or identifiers referencing constants and variables. + + -- If the declaration appears within a protected body, it is a private + -- operation of the protected type. We must create the corresponding + -- protected subprogram an associated formals. For a normal protected + -- operation, this is done when expanding the protected type declaration. + + procedure Expand_N_Subprogram_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Subp : Entity_Id := Defining_Entity (N); + Scop : Entity_Id := Scope (Subp); + Prot_Sub : Entity_Id; + Prot_Bod : Node_Id; + + begin + -- Deal with case of protected subprogram + + if Is_List_Member (N) + and then Present (Parent (List_Containing (N))) + and then Nkind (Parent (List_Containing (N))) = N_Protected_Body + and then Is_Protected_Type (Scop) + then + if No (Protected_Body_Subprogram (Subp)) then + Prot_Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (N, Scop, Unprotected => True)); + + -- The protected subprogram is declared outside of the protected + -- body. Given that the body has frozen all entities so far, we + -- freeze the subprogram explicitly. If the body is a subunit, + -- the insertion point is before the stub in the parent. + + Prot_Bod := Parent (List_Containing (N)); + + if Nkind (Parent (Prot_Bod)) = N_Subunit then + Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); + end if; + + Insert_Before (Prot_Bod, Prot_Sub); + + New_Scope (Scope (Scop)); + Analyze (Prot_Sub); + Set_Protected_Body_Subprogram (Subp, + Defining_Unit_Name (Specification (Prot_Sub))); + Pop_Scope; + end if; + end if; + end Expand_N_Subprogram_Declaration; + + --------------------------------------- + -- Expand_Protected_Object_Reference -- + --------------------------------------- + + function Expand_Protected_Object_Reference + (N : Node_Id; + Scop : Entity_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Corr : Entity_Id; + Rec : Node_Id; + Param : Entity_Id; + Proc : Entity_Id; + + begin + Rec := Make_Identifier (Loc, Name_uObject); + Set_Etype (Rec, Corresponding_Record_Type (Scop)); + + -- Find enclosing protected operation, and retrieve its first + -- parameter, which denotes the enclosing protected object. + -- If the enclosing operation is an entry, we are immediately + -- within the protected body, and we can retrieve the object + -- from the service entries procedure. A barrier function has + -- has the same signature as an entry. A barrier function is + -- compiled within the protected object, but unlike protected + -- operations its never needs locks, so that its protected body + -- subprogram points to itself. + + Proc := Current_Scope; + + while Present (Proc) + and then Scope (Proc) /= Scop + loop + Proc := Scope (Proc); + end loop; + + Corr := Protected_Body_Subprogram (Proc); + + if No (Corr) then + + -- Previous error left expansion incomplete. + -- Nothing to do on this call. + + return Empty; + end if; + + Param := + Defining_Identifier + (First (Parameter_Specifications (Parent (Corr)))); + + if Is_Subprogram (Proc) + and then Proc /= Corr + then + -- Protected function or procedure. + + Set_Entity (Rec, Param); + + -- Rec is a reference to an entity which will not be in scope + -- when the call is reanalyzed, and needs no further analysis. + + Set_Analyzed (Rec); + + else + -- Entry or barrier function for entry body. + -- The first parameter of the entry body procedure is a + -- pointer to the object. We create a local variable + -- of the proper type, duplicating what is done to define + -- _object later on. + + declare + Decls : List_Id; + Obj_Ptr : Entity_Id := Make_Defining_Identifier + (Loc, New_Internal_Name ('T')); + begin + Decls := New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Obj_Ptr, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To + (Corresponding_Record_Type (Scop), Loc)))); + + Insert_Actions (N, Decls); + Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N))); + + Rec := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Obj_Ptr, + New_Occurrence_Of (Param, Loc))); + + -- Analyze new actual. Other actuals in calls are already + -- analyzed and the list of actuals is not renalyzed after + -- rewriting. + + Set_Parent (Rec, N); + Analyze (Rec); + end; + end if; + + return Rec; + end Expand_Protected_Object_Reference; + + -------------------------------------- + -- Expand_Protected_Subprogram_Call -- + -------------------------------------- + + procedure Expand_Protected_Subprogram_Call + (N : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id) + is + Rec : Node_Id; + + begin + -- If the protected object is not an enclosing scope, this is + -- an inter-object function call. Inter-object procedure + -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call. + -- The call is intra-object only if the subprogram being + -- called is in the protected body being compiled, and if the + -- protected object in the call is statically the enclosing type. + -- The object may be an component of some other data structure, + -- in which case this must be handled as an inter-object call. + + if not In_Open_Scopes (Scop) + or else not Is_Entity_Name (Name (N)) + then + if Nkind (Name (N)) = N_Selected_Component then + Rec := Prefix (Name (N)); + + else + pragma Assert (Nkind (Name (N)) = N_Indexed_Component); + Rec := Prefix (Prefix (Name (N))); + end if; + + Build_Protected_Subprogram_Call (N, + Name => New_Occurrence_Of (Subp, Sloc (N)), + Rec => Convert_Concurrent (Rec, Etype (Rec)), + External => True); + + else + Rec := Expand_Protected_Object_Reference (N, Scop); + + if No (Rec) then + return; + end if; + + Build_Protected_Subprogram_Call (N, + Name => Name (N), + Rec => Rec, + External => False); + + end if; + + Analyze (N); + + -- If it is a function call it can appear in elaboration code and + -- the called entity must be frozen here. + + if Ekind (Subp) = E_Function then + Freeze_Expression (Name (N)); + end if; + end Expand_Protected_Subprogram_Call; + + ----------------------- + -- Freeze_Subprogram -- + ----------------------- + + procedure Freeze_Subprogram (N : Node_Id) is + E : constant Entity_Id := Entity (N); + + begin + -- When a primitive is frozen, enter its name in the corresponding + -- dispatch table. If the DTC_Entity field is not set this is an + -- overridden primitive that can be ignored. We suppress the + -- initialization of the dispatch table entry when Java_VM because + -- the dispatching mechanism is handled internally by the JVM. + + if Is_Dispatching_Operation (E) + and then not Is_Abstract (E) + and then Present (DTC_Entity (E)) + and then not Is_CPP_Class (Scope (DTC_Entity (E))) + and then not Java_VM + then + Check_Overriding_Operation (E); + Insert_After (N, Fill_DT_Entry (Sloc (N), E)); + end if; + + -- Mark functions that return by reference. Note that it cannot be + -- part of the normal semantic analysis of the spec since the + -- underlying returned type may not be known yet (for private types) + + declare + Typ : constant Entity_Id := Etype (E); + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + if Is_Return_By_Reference_Type (Typ) then + Set_Returns_By_Ref (E); + + elsif Present (Utyp) and then Controlled_Type (Utyp) then + Set_Returns_By_Ref (E); + end if; + end; + + end Freeze_Subprogram; + +end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads new file mode 100644 index 00000000000..edb633f48b7 --- /dev/null +++ b/gcc/ada/exp_ch6.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 6 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.13 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 6 constructs + +with Types; use Types; + +package Exp_Ch6 is + + procedure Expand_N_Function_Call (N : Node_Id); + procedure Expand_N_Subprogram_Body (N : Node_Id); + procedure Expand_N_Subprogram_Body_Stub (N : Node_Id); + procedure Expand_N_Subprogram_Declaration (N : Node_Id); + procedure Expand_N_Procedure_Call_Statement (N : Node_Id); + + procedure Expand_Call (N : Node_Id); + -- This procedure contains common processing for Expand_N_Function_Call, + -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. + + procedure Freeze_Subprogram (N : Node_Id); + -- generate the appropriate expansions related to Subprogram freeze + -- nodes (e. g. the filling of the corresponding Dispatch Table for + -- Primitive Operations) + +end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb new file mode 100644 index 00000000000..3feba78ecd7 --- /dev/null +++ b/gcc/ada/exp_ch7.adb @@ -0,0 +1,2801 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 7 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.245 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains virtually all expansion mechanisms related to +-- - controlled types +-- - transient scopes + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Hostparm; use Hostparm; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Targparm; use Targparm; +with Sinfo; use Sinfo; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Ch7 is + + -------------------------------- + -- Transient Scope Management -- + -------------------------------- + + -- A transient scope is created when temporary objects are created by the + -- compiler. These temporary objects are allocated on the secondary stack + -- and the transient scope is responsible for finalizing the object when + -- appropriate and reclaiming the memory at the right time. The temporary + -- objects are generally the objects allocated to store the result of a + -- function returning an unconstrained or a tagged value. Expressions + -- needing to be wrapped in a transient scope (functions calls returning + -- unconstrained or tagged values) may appear in 3 different contexts which + -- lead to 3 different kinds of transient scope expansion: + + -- 1. In a simple statement (procedure call, assignment, ...). In + -- this case the instruction is wrapped into a transient block. + -- (See Wrap_Transient_Statement for details) + + -- 2. In an expression of a control structure (test in a IF statement, + -- expression in a CASE statement, ...). + -- (See Wrap_Transient_Expression for details) + + -- 3. In a expression of an object_declaration. No wrapping is possible + -- here, so the finalization actions, if any are done right after the + -- declaration and the secondary stack deallocation is done in the + -- proper enclosing scope (see Wrap_Transient_Declaration for details) + + -- Note about function returning tagged types: It has been decided to + -- always allocate their result in the secondary stack while it is not + -- absolutely mandatory when the tagged type is constrained because the + -- caller knows the size of the returned object and thus could allocate the + -- result in the primary stack. But, allocating them always in the + -- secondary stack simplifies many implementation hassles: + + -- - If it is dispatching function call, the computation of the size of + -- the result is possible but complex from the outside. + + -- - If the returned type is controlled, the assignment of the returned + -- value to the anonymous object involves an Adjust, and we have no + -- easy way to access the anonymous object created by the back-end + + -- - If the returned type is class-wide, this is an unconstrained type + -- anyway + + -- Furthermore, the little loss in efficiency which is the result of this + -- decision is not such a big deal because function returning tagged types + -- are not very much used in real life as opposed to functions returning + -- access to a tagged type + + -------------------------------------------------- + -- Transient Blocks and Finalization Management -- + -------------------------------------------------- + + function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; + -- N is a node wich may generate a transient scope. Loop over the + -- parent pointers of N until it find the appropriate node to + -- wrap. It it returns Empty, it means that no transient scope is + -- needed in this context. + + function Make_Clean + (N : Node_Id; + Clean : Entity_Id; + Mark : Entity_Id; + Flist : Entity_Id; + Is_Task : Boolean; + Is_Master : Boolean; + Is_Protected_Subprogram : Boolean; + Is_Task_Allocation_Block : Boolean; + Is_Asynchronous_Call_Block : Boolean) + return Node_Id; + -- Expand a the clean-up procedure for controlled and/or transient + -- block, and/or task master or task body, or blocks used to + -- implement task allocation or asynchronous entry calls, or + -- procedures used to implement protected procedures. Clean is the + -- entity for such a procedure. Mark is the entity for the secondary + -- stack mark, if empty only controlled block clean-up will be + -- performed. Flist is the entity for the local final list, if empty + -- only transient scope clean-up will be performed. The flags + -- Is_Task and Is_Master control the calls to the corresponding + -- finalization actions for a task body or for an entity that is a + -- task master. + + procedure Set_Node_To_Be_Wrapped (N : Node_Id); + -- Set the field Node_To_Be_Wrapped of the current scope + + procedure Insert_Actions_In_Scope_Around (N : Node_Id); + -- Insert the before-actions kept in the scope stack before N, and the + -- after after-actions, after N which must be a member of a list. + + function Make_Transient_Block + (Loc : Source_Ptr; + Action : Node_Id) + return Node_Id; + -- Create a transient block whose name is Scope, which is also a + -- controlled block if Flist is not empty and whose only code is + -- Action (either a single statement or single declaration). + + type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case); + -- This enumeration type is defined in order to ease sharing code for + -- building finalization procedures for composite types. + + Name_Of : constant array (Final_Primitives) of Name_Id := + (Initialize_Case => Name_Initialize, + Adjust_Case => Name_Adjust, + Finalize_Case => Name_Finalize); + + Deep_Name_Of : constant array (Final_Primitives) of Name_Id := + (Initialize_Case => Name_uDeep_Initialize, + Adjust_Case => Name_uDeep_Adjust, + Finalize_Case => Name_uDeep_Finalize); + + procedure Build_Record_Deep_Procs (Typ : Entity_Id); + -- Build the deep Initialize/Adjust/Finalize for a record Typ with + -- Has_Component_Component set and store them using the TSS mechanism. + + procedure Build_Array_Deep_Procs (Typ : Entity_Id); + -- Build the deep Initialize/Adjust/Finalize for a record Typ with + -- Has_Controlled_Component set and store them using the TSS mechanism. + + function Make_Deep_Proc + (Prim : Final_Primitives; + Typ : Entity_Id; + Stmts : List_Id) + return Node_Id; + -- This function generates the tree for Deep_Initialize, Deep_Adjust + -- or Deep_Finalize procedures according to the first parameter, + -- these procedures operate on the type Typ. The Stmts parameter + -- gives the body of the procedure. + + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) + return List_Id; + -- This function generates the list of statements for implementing + -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures + -- according to the first parameter, these procedures operate on the + -- array type Typ. + + function Make_Deep_Record_Body + (Prim : Final_Primitives; + Typ : Entity_Id) + return List_Id; + -- This function generates the list of statements for implementing + -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures + -- according to the first parameter, these procedures operate on the + -- record type Typ. + + function Convert_View + (Proc : Entity_Id; + Arg : Node_Id; + Ind : Pos := 1) + return Node_Id; + -- Proc is one of the Initialize/Adjust/Finalize operations, and + -- Arg is the argument being passed to it. Ind indicates which + -- formal of procedure Proc we are trying to match. This function + -- will, if necessary, generate an conversion between the partial + -- and full view of Arg to match the type of the formal of Proc, + -- or force a conversion to the class-wide type in the case where + -- the operation is abstract. + + ----------------------------- + -- Finalization Management -- + ----------------------------- + + -- This part describe how Initialization/Adjusment/Finalization procedures + -- are generated and called. Two cases must be considered, types that are + -- Controlled (Is_Controlled flag set) and composite types that contain + -- controlled components (Has_Controlled_Component flag set). In the first + -- case the procedures to call are the user-defined primitive operations + -- Initialize/Adjust/Finalize. In the second case, GNAT generates + -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge of + -- calling the former procedures on the controlled components. + + -- For records with Has_Controlled_Component set, a hidden "controller" + -- component is inserted. This controller component contains its own + -- finalization list on which all controlled components are attached + -- creating an indirection on the upper-level Finalization list. This + -- technique facilitates the management of objects whose number of + -- controlled components changes during execution. This controller + -- component is itself controlled and is attached to the upper-level + -- finalization chain. Its adjust primitive is in charge of calling + -- adjust on the components and adusting the finalization pointer to + -- match their new location (see a-finali.adb) + + -- It is not possible to use a similar technique for arrays that have + -- Has_Controlled_Component set. In this case, deep procedures are + -- generated that call initialize/adjust/finalize + attachment or + -- detachment on the finalization list for all component. + + -- Initialize calls: they are generated for declarations or dynamic + -- allocations of Controlled objects with no initial value. They are + -- always followed by an attachment to the current Finalization + -- Chain. For the dynamic allocation case this the chain attached to + -- the scope of the access type definition otherwise, this is the chain + -- of the current scope. + + -- Adjust Calls: They are generated on 2 occasions: (1) for + -- declarations or dynamic allocations of Controlled objects with an + -- initial value. (2) after an assignment. In the first case they are + -- followed by an attachment to the final chain, in the second case + -- they are not. + + -- Finalization Calls: They are generated on (1) scope exit, (2) + -- assignments, (3) unchecked deallocations. In case (3) they have to + -- be detached from the final chain, in case (2) they must not and in + -- case (1) this is not important since we are exiting the scope + -- anyway. + + -- Here is a simple example of the expansion of a controlled block : + + -- declare + -- X : Controlled ; + -- Y : Controlled := Init; + -- + -- type R is record + -- C : Controlled; + -- end record; + -- W : R; + -- Z : R := (C => X); + -- begin + -- X := Y; + -- W := Z; + -- end; + -- + -- is expanded into + -- + -- declare + -- _L : System.FI.Finalizable_Ptr; + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (_L); + -- Abort_Undefer; + -- end _Clean; + + -- X : Controlled; + -- Initialize (X); + -- Attach_To_Final_List (_L, Finalizable (X), 1); + -- Y : Controlled := Init; + -- Adjust (Y); + -- Attach_To_Final_List (_L, Finalizable (Y), 1); + -- + -- type R is record + -- _C : Record_Controller; + -- C : Controlled; + -- end record; + -- W : R; + -- Deep_Initialize (W, _L, 1); + -- Z : R := (C => X); + -- Deep_Adjust (Z, _L, 1); + + -- begin + -- Finalize (X); + -- X := Y; + -- Adjust (X); + + -- Deep_Finalize (W, False); + -- W := Z; + -- Deep_Adjust (W, _L, 0); + -- at end + -- _Clean; + -- end; + + function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean; + -- Return True if Flist_Ref refers to a global final list, either + -- the object GLobal_Final_List which is used to attach standalone + -- objects, or any of the list controllers associated with library + -- level access to controlled objects + + ---------------------------- + -- Build_Array_Deep_Procs -- + ---------------------------- + + procedure Build_Array_Deep_Procs (Typ : Entity_Id) is + begin + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Initialize_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); + + if not Is_Return_By_Reference_Type (Typ) then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Adjust_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); + end if; + + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Finalize_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); + end Build_Array_Deep_Procs; + + ----------------------------- + -- Build_Controlling_Procs -- + ----------------------------- + + procedure Build_Controlling_Procs (Typ : Entity_Id) is + begin + if Is_Array_Type (Typ) then + Build_Array_Deep_Procs (Typ); + + else pragma Assert (Is_Record_Type (Typ)); + Build_Record_Deep_Procs (Typ); + end if; + end Build_Controlling_Procs; + + ---------------------- + -- Build_Final_List -- + ---------------------- + + procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + Set_Associated_Final_Chain (Typ, + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Typ), 'L'))); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => + Associated_Final_Chain (Typ), + Object_Definition => + New_Reference_To + (RTE (RE_List_Controller), Loc))); + end Build_Final_List; + + ----------------------------- + -- Build_Record_Deep_Procs -- + ----------------------------- + + procedure Build_Record_Deep_Procs (Typ : Entity_Id) is + begin + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Initialize_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); + + if not Is_Return_By_Reference_Type (Typ) then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Adjust_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); + end if; + + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Finalize_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); + end Build_Record_Deep_Procs; + + --------------------- + -- Controlled_Type -- + --------------------- + + function Controlled_Type (T : Entity_Id) return Boolean is + begin + -- Class-wide types are considered controlled because they may contain + -- an extension that has controlled components + + return (Is_Class_Wide_Type (T) + and then not No_Run_Time + and then not In_Finalization_Root (T)) + or else Is_Controlled (T) + or else Has_Controlled_Component (T) + or else (Is_Concurrent_Type (T) + and then Present (Corresponding_Record_Type (T)) + and then Controlled_Type (Corresponding_Record_Type (T))); + end Controlled_Type; + + -------------------------- + -- Controller_Component -- + -------------------------- + + function Controller_Component (Typ : Entity_Id) return Entity_Id is + T : Entity_Id := Base_Type (Typ); + Comp : Entity_Id; + Comp_Scop : Entity_Id; + Res : Entity_Id := Empty; + Res_Scop : Entity_Id := Empty; + + begin + if Is_Class_Wide_Type (T) then + T := Root_Type (T); + end if; + + if Is_Private_Type (T) then + T := Underlying_Type (T); + end if; + + -- Fetch the outermost controller + + Comp := First_Entity (T); + while Present (Comp) loop + if Chars (Comp) = Name_uController then + Comp_Scop := Scope (Original_Record_Component (Comp)); + + -- If this controller is at the outermost level, no need to + -- look for another one + + if Comp_Scop = T then + return Comp; + + -- Otherwise record the outermost one and continue looking + + elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then + Res := Comp; + Res_Scop := Comp_Scop; + end if; + end if; + + Next_Entity (Comp); + end loop; + + -- If we fall through the loop, there is no controller component + + return Res; + end Controller_Component; + + ------------------ + -- Convert_View -- + ------------------ + + function Convert_View + (Proc : Entity_Id; + Arg : Node_Id; + Ind : Pos := 1) + return Node_Id + is + Fent : Entity_Id := First_Entity (Proc); + Ftyp : Entity_Id; + Atyp : Entity_Id; + + begin + for J in 2 .. Ind loop + Next_Entity (Fent); + end loop; + + Ftyp := Etype (Fent); + + if Nkind (Arg) = N_Type_Conversion + or else Nkind (Arg) = N_Unchecked_Type_Conversion + then + Atyp := Entity (Subtype_Mark (Arg)); + else + Atyp := Etype (Arg); + end if; + + if Is_Abstract (Proc) and then Is_Tagged_Type (Ftyp) then + return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); + + elsif Ftyp /= Atyp + and then Present (Atyp) + and then + (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) + and then Underlying_Type (Atyp) = Underlying_Type (Ftyp) + then + return Unchecked_Convert_To (Ftyp, Arg); + + -- If the argument is already a conversion, as generated by + -- Make_Init_Call, set the target type to the type of the formal + -- directly, to avoid spurious typing problems. + + elsif (Nkind (Arg) = N_Unchecked_Type_Conversion + or else Nkind (Arg) = N_Type_Conversion) + and then not Is_Class_Wide_Type (Atyp) + then + Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); + Set_Etype (Arg, Ftyp); + return Arg; + + else + return Arg; + end if; + end Convert_View; + + ------------------------------- + -- Establish_Transient_Scope -- + ------------------------------- + + -- This procedure is called each time a transient block has to be inserted + -- that is to say for each call to a function with unconstrained ot tagged + -- result. It creates a new scope on the stack scope in order to enclose + -- all transient variables generated + + procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Wrap_Node : Node_Id; + + Sec_Stk : constant Boolean := + Sec_Stack and not Functions_Return_By_DSP_On_Target; + -- We never need a secondary stack if functions return by DSP + + begin + -- Do not create a transient scope if we are already inside one + + for S in reverse Scope_Stack.First .. Scope_Stack.Last loop + + if Scope_Stack.Table (S).Is_Transient then + if Sec_Stk then + Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity); + end if; + + return; + + -- If we have encountered Standard there are no enclosing + -- transient scopes. + + elsif Scope_Stack.Table (S).Entity = Standard_Standard then + exit; + + end if; + end loop; + + Wrap_Node := Find_Node_To_Be_Wrapped (N); + + -- Case of no wrap node, false alert, no transient scope needed + + if No (Wrap_Node) then + null; + + -- Transient scope is required + + else + New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); + Set_Scope_Is_Transient; + + if Sec_Stk then + Set_Uses_Sec_Stack (Current_Scope); + Disallow_In_No_Run_Time_Mode (N); + end if; + + Set_Etype (Current_Scope, Standard_Void_Type); + Set_Node_To_Be_Wrapped (Wrap_Node); + + if Debug_Flag_W then + Write_Str (" <Transient>"); + Write_Eol; + end if; + end if; + end Establish_Transient_Scope; + + ---------------------------- + -- Expand_Cleanup_Actions -- + ---------------------------- + + procedure Expand_Cleanup_Actions (N : Node_Id) is + Loc : Source_Ptr; + S : constant Entity_Id := + Current_Scope; + Flist : constant Entity_Id := + Finalization_Chain_Entity (S); + Is_Task : constant Boolean := + (Nkind (Original_Node (N)) = N_Task_Body); + Is_Master : constant Boolean := + Nkind (N) /= N_Entry_Body + and then Is_Task_Master (N); + Is_Protected : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + Is_Task_Allocation : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Task_Allocation_Block (N); + Is_Asynchronous_Call : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Asynchronous_Call_Block (N); + + Clean : Entity_Id; + Mark : Entity_Id := Empty; + New_Decls : List_Id := New_List; + Blok : Node_Id; + Wrapped : Boolean; + Chain : Entity_Id := Empty; + Decl : Node_Id; + Old_Poll : Boolean; + + begin + + -- Compute a location that is not directly in the user code in + -- order to avoid to generate confusing debug info. A good + -- approximation is the name of the outer user-defined scope + + declare + S1 : Entity_Id := S; + + begin + while not Comes_From_Source (S1) and then S1 /= Standard_Standard loop + S1 := Scope (S1); + end loop; + + Loc := Sloc (S1); + end; + + -- There are cleanup actions only if the secondary stack needs + -- releasing or some finalizations are needed or in the context + -- of tasking + + if Uses_Sec_Stack (Current_Scope) + and then not Sec_Stack_Needed_For_Return (Current_Scope) + then + null; + elsif No (Flist) + and then not Is_Master + and then not Is_Task + and then not Is_Protected + and then not Is_Task_Allocation + and then not Is_Asynchronous_Call + then + return; + end if; + + -- Set polling off, since we don't need to poll during cleanup + -- actions, and indeed for the cleanup routine, which is executed + -- with aborts deferred, we don't want polling. + + Old_Poll := Polling_Required; + Polling_Required := False; + + -- Make sure we have a declaration list, since we will add to it + + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + -- The task activation call has already been built for task + -- allocation blocks. + + if not Is_Task_Allocation then + Build_Task_Activation_Call (N); + end if; + + if Is_Master then + Establish_Task_Master (N); + end if; + + -- If secondary stack is in use, expand: + -- _Mxx : constant Mark_Id := SS_Mark; + + -- Suppress calls to SS_Mark and SS_Release if Java_VM, + -- since we never use the secondary stack on the JVM. + + if Uses_Sec_Stack (Current_Scope) + and then not Sec_Stack_Needed_For_Return (Current_Scope) + and then not Java_VM + then + Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + Append_To (New_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Mark, + Object_Definition => New_Reference_To (RTE (RE_Mark_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_SS_Mark), Loc)))); + + Set_Uses_Sec_Stack (Current_Scope, False); + end if; + + -- If finalization list is present then expand: + -- Local_Final_List : System.FI.Finalizable_Ptr; + + if Present (Flist) then + Append_To (New_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Flist, + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + end if; + + -- Clean-up procedure definition + + Clean := Make_Defining_Identifier (Loc, Name_uClean); + Set_Suppress_Elaboration_Warnings (Clean); + Append_To (New_Decls, + Make_Clean (N, Clean, Mark, Flist, + Is_Task, + Is_Master, + Is_Protected, + Is_Task_Allocation, + Is_Asynchronous_Call)); + + -- If exception handlers are present, wrap the Sequence of + -- statements in a block because it is not possible to get + -- exception handlers and an AT END call in the same scope. + + if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then + Blok := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok))); + Wrapped := True; + + -- Otherwise we do not wrap + + else + Wrapped := False; + Blok := Empty; + end if; + + -- Don't move the _chain Activation_Chain declaration in task + -- allocation blocks. Task allocation blocks use this object + -- in their cleanup handlers, and gigi complains if it is declared + -- in the sequence of statements of the scope that declares the + -- handler. + + if Is_Task_Allocation then + Chain := Activation_Chain_Entity (N); + Decl := First (Declarations (N)); + + while Nkind (Decl) /= N_Object_Declaration + or else Defining_Identifier (Decl) /= Chain + loop + Next (Decl); + pragma Assert (Present (Decl)); + end loop; + + Remove (Decl); + Prepend_To (New_Decls, Decl); + end if; + + -- Now we move the declarations into the Sequence of statements + -- in order to get them protected by the AT END call. It may seem + -- weird to put declarations in the sequence of statement but in + -- fact nothing forbids that at the tree level. We also set the + -- First_Real_Statement field so that we remember where the real + -- statements (i.e. original statements) begin. Note that if we + -- wrapped the statements, the first real statement is inside the + -- inner block. If the First_Real_Statement is already set (as is + -- the case for subprogram bodies that are expansions of task bodies) + -- then do not reset it, because its declarative part would migrate + -- to the statement part. + + if not Wrapped then + if No (First_Real_Statement (Handled_Statement_Sequence (N))) then + Set_First_Real_Statement (Handled_Statement_Sequence (N), + First (Statements (Handled_Statement_Sequence (N)))); + end if; + + else + Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok); + end if; + + Append_List_To (Declarations (N), + Statements (Handled_Statement_Sequence (N))); + Set_Statements (Handled_Statement_Sequence (N), Declarations (N)); + + -- We need to reset the Sloc of the handled statement sequence to + -- properly reflect the new initial "statement" in the sequence. + + Set_Sloc + (Handled_Statement_Sequence (N), Sloc (First (Declarations (N)))); + + -- The declarations of the _Clean procedure and finalization chain + -- replace the old declarations that have been moved inward + + Set_Declarations (N, New_Decls); + Analyze_Declarations (New_Decls); + + -- The At_End call is attached to the sequence of statements. + + declare + HSS : Node_Id; + + begin + -- If the construct is a protected subprogram, then the call to + -- the corresponding unprotected program appears in a block which + -- is the last statement in the body, and it is this block that + -- must be covered by the At_End handler. + + if Is_Protected then + HSS := Handled_Statement_Sequence + (Last (Statements (Handled_Statement_Sequence (N)))); + else + HSS := Handled_Statement_Sequence (N); + end if; + + Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc)); + Expand_At_End_Handler (HSS, Empty); + end; + + -- Restore saved polling mode + + Polling_Required := Old_Poll; + end Expand_Cleanup_Actions; + + ------------------------------- + -- Expand_Ctrl_Function_Call -- + ------------------------------- + + procedure Expand_Ctrl_Function_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtype : constant Entity_Id := Etype (N); + Utype : constant Entity_Id := Underlying_Type (Rtype); + Ref : Node_Id; + Action : Node_Id; + + Attach_Level : Uint := Uint_1; + Len_Ref : Node_Id := Empty; + + function Last_Array_Component + (Ref : Node_Id; + Typ : Entity_Id) + return Node_Id; + -- Creates a reference to the last component of the array object + -- designated by Ref whose type is Typ. + + function Last_Array_Component + (Ref : Node_Id; + Typ : Entity_Id) + return Node_Id + is + N : Int; + Index_List : List_Id := New_List; + + begin + N := 1; + while N <= Number_Dimensions (Typ) loop + Append_To (Index_List, + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Ref), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, N)))); + + N := N + 1; + end loop; + + return + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr (Ref), + Expressions => Index_List); + end Last_Array_Component; + + -- Start of processing for Expand_Ctrl_Function_Call + + begin + -- Optimization, if the returned value (which is on the sec-stack) + -- is returned again, no need to copy/readjust/finalize, we can just + -- pass the value thru (see Expand_N_Return_Statement), and thus no + -- attachment is needed + + if Nkind (Parent (N)) = N_Return_Statement then + return; + end if; + + -- Resolution is now finished, make sure we don't start analysis again + -- because of the duplication + + Set_Analyzed (N); + Ref := Duplicate_Subexpr (N); + + -- Now we can generate the Attach Call, note that this value is + -- always in the (secondary) stack and thus is attached to a singly + -- linked final list: + -- + -- Resx := F (X)'reference; + -- Attach_To_Final_List (_Lx, Resx.all, 1); + -- or when there are controlled components + -- Attach_To_Final_List (_Lx, Resx._controller, 1); + -- or if it is an array with is_controlled components + -- Attach_To_Final_List (_Lx, Resx (Resx'last), 3); + -- An attach level of 3 means that a whole array is to be + -- attached to the finalization list + -- or if it is an array with has_controlled components + -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3); + + if Has_Controlled_Component (Rtype) then + declare + T1 : Entity_Id := Rtype; + T2 : Entity_Id := Utype; + + begin + if Is_Array_Type (T2) then + Len_Ref := + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Unchecked_Convert_To (T2, Ref)), + Attribute_Name => Name_Length); + end if; + + while Is_Array_Type (T2) loop + if T1 /= T2 then + Ref := Unchecked_Convert_To (T2, Ref); + end if; + Ref := Last_Array_Component (Ref, T2); + Attach_Level := Uint_3; + T1 := Component_Type (T2); + T2 := Underlying_Type (T1); + end loop; + + if Has_Controlled_Component (T2) then + if T1 /= T2 then + Ref := Unchecked_Convert_To (T2, Ref); + end if; + Ref := + Make_Selected_Component (Loc, + Prefix => Ref, + Selector_Name => Make_Identifier (Loc, Name_uController)); + end if; + end; + + -- Here we know that 'Ref' has a controller so we may as well + -- attach it directly + + Action := + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => Find_Final_List (Current_Scope), + With_Attach => Make_Integer_Literal (Loc, Attach_Level)); + + else + -- Here, we have a controlled type that does not seem to have + -- controlled components but it could be a class wide type whose + -- further derivations have controlled components. So we don't know + -- if the object itself needs to be attached or if it + -- has a record controller. We need to call a runtime function + -- (Deep_Tag_Attach) which knows what to do thanks to the + -- RC_Offset in the dispatch table. + + Action := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), + Parameter_Associations => New_List ( + Find_Final_List (Current_Scope), + + Make_Attribute_Reference (Loc, + Prefix => Ref, + Attribute_Name => Name_Address), + + Make_Integer_Literal (Loc, Attach_Level))); + end if; + + if Present (Len_Ref) then + Action := + Make_Implicit_If_Statement (N, + Condition => Make_Op_Gt (Loc, + Left_Opnd => Len_Ref, + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List (Action)); + end if; + + Insert_Action (N, Action); + end Expand_Ctrl_Function_Call; + + --------------------------- + -- Expand_N_Package_Body -- + --------------------------- + + -- Add call to Activate_Tasks if body is an activator (actual + -- processing is in chapter 9). + + -- Generate subprogram descriptor for elaboration routine + + -- ENcode entity names in package body + + procedure Expand_N_Package_Body (N : Node_Id) is + Ent : Entity_Id := Corresponding_Spec (N); + + begin + -- This is done only for non-generic packages + + if Ekind (Ent) = E_Package then + New_Scope (Corresponding_Spec (N)); + Build_Task_Activation_Call (N); + Pop_Scope; + end if; + + Set_Elaboration_Flag (N, Corresponding_Spec (N)); + + -- Generate a subprogram descriptor for the elaboration routine of + -- a package body if the package body has no pending instantiations + -- and it has generated at least one exception handler + + if Present (Handler_Records (Body_Entity (Ent))) + and then Is_Compilation_Unit (Ent) + and then not Delay_Subprogram_Descriptors (Body_Entity (Ent)) + then + Generate_Subprogram_Descriptor_For_Package + (N, Body_Entity (Ent)); + end if; + + Set_In_Package_Body (Ent, False); + + -- Set to encode entity names in package body before gigi is called + + Qualify_Entity_Names (N); + end Expand_N_Package_Body; + + ---------------------------------- + -- Expand_N_Package_Declaration -- + ---------------------------------- + + -- Add call to Activate_Tasks if there are tasks declared and the + -- package has no body. Note that in Ada83, this may result in + -- premature activation of some tasks, given that we cannot tell + -- whether a body will eventually appear. + + procedure Expand_N_Package_Declaration (N : Node_Id) is + begin + if Nkind (Parent (N)) = N_Compilation_Unit + and then not Body_Required (Parent (N)) + and then not Unit_Requires_Body (Defining_Entity (N)) + and then Present (Activation_Chain_Entity (N)) + then + New_Scope (Defining_Entity (N)); + Build_Task_Activation_Call (N); + Pop_Scope; + end if; + + -- Note: it is not necessary to worry about generating a subprogram + -- descriptor, since the only way to get exception handlers into a + -- package spec is to include instantiations, and that would cause + -- generation of subprogram descriptors to be delayed in any case. + + -- Set to encode entity names in package spec before gigi is called + + Qualify_Entity_Names (N); + end Expand_N_Package_Declaration; + + --------------------- + -- Find_Final_List -- + --------------------- + + function Find_Final_List + (E : Entity_Id; + Ref : Node_Id := Empty) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + S : Entity_Id; + Id : Entity_Id; + R : Node_Id; + + begin + -- Case of an internal component. The Final list is the record + -- controller of the enclosing record + + if Present (Ref) then + R := Ref; + loop + case Nkind (R) is + when N_Unchecked_Type_Conversion | N_Type_Conversion => + R := Expression (R); + + when N_Indexed_Component | N_Explicit_Dereference => + R := Prefix (R); + + when N_Selected_Component => + R := Prefix (R); + exit; + + when N_Identifier => + exit; + + when others => + raise Program_Error; + end case; + end loop; + + return + Make_Selected_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => R, + Selector_Name => Make_Identifier (Loc, Name_uController)), + Selector_Name => Make_Identifier (Loc, Name_F)); + + -- Case of a dynamically allocated object. The final list is the + -- corresponding list controller (The next entity in the scope of + -- the access type with the right type) + + elsif Is_Access_Type (E) then + return + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Associated_Final_Chain (Base_Type (E)), Loc), + Selector_Name => Make_Identifier (Loc, Name_F)); + + else + if Is_Dynamic_Scope (E) then + S := E; + else + S := Enclosing_Dynamic_Scope (E); + end if; + + -- When the finalization chain entity is 'Error', it means that + -- there should not be any chain at that level and that the + -- enclosing one should be used + + -- This is a nasty kludge, see ??? note in exp_ch11 + + while Finalization_Chain_Entity (S) = Error loop + S := Enclosing_Dynamic_Scope (S); + end loop; + + if S = Standard_Standard then + return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); + else + if No (Finalization_Chain_Entity (S)) then + + Id := Make_Defining_Identifier (Sloc (S), + New_Internal_Name ('F')); + Set_Finalization_Chain_Entity (S, Id); + + -- Set momentarily some semantics attributes to allow normal + -- analysis of expansions containing references to this chain. + -- Will be fully decorated during the expansion of the scope + -- itself + + Set_Ekind (Id, E_Variable); + Set_Etype (Id, RTE (RE_Finalizable_Ptr)); + end if; + + return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E)); + end if; + end if; + end Find_Final_List; + + ----------------------------- + -- Find_Node_To_Be_Wrapped -- + ----------------------------- + + function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is + P : Node_Id; + The_Parent : Node_Id; + + begin + The_Parent := N; + loop + P := The_Parent; + pragma Assert (P /= Empty); + The_Parent := Parent (P); + + case Nkind (The_Parent) is + + -- Simple statement can be wrapped + + when N_Pragma => + return The_Parent; + + -- Usually assignments are good candidate for wrapping + -- except when they have been generated as part of a + -- controlled aggregate where the wrapping should take + -- place more globally. + + when N_Assignment_Statement => + if No_Ctrl_Actions (The_Parent) then + null; + else + return The_Parent; + end if; + + -- An entry call statement is a special case if it occurs in + -- the context of a Timed_Entry_Call. In this case we wrap + -- the entire timed entry call. + + when N_Entry_Call_Statement | + N_Procedure_Call_Statement => + if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative + and then + Nkind (Parent (Parent (The_Parent))) = N_Timed_Entry_Call + then + return Parent (Parent (The_Parent)); + else + return The_Parent; + end if; + + -- Object declarations are also a boundary for the transient scope + -- even if they are not really wrapped + -- (see Wrap_Transient_Declaration) + + when N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Subtype_Declaration => + return The_Parent; + + -- The expression itself is to be wrapped if its parent is a + -- compound statement or any other statement where the expression + -- is known to be scalar + + when N_Accept_Alternative | + N_Attribute_Definition_Clause | + N_Case_Statement | + N_Code_Statement | + N_Delay_Alternative | + N_Delay_Until_Statement | + N_Delay_Relative_Statement | + N_Discriminant_Association | + N_Elsif_Part | + N_Entry_Body_Formal_Part | + N_Exit_Statement | + N_If_Statement | + N_Iteration_Scheme | + N_Terminate_Alternative => + return P; + + when N_Attribute_Reference => + + if Is_Procedure_Attribute_Name + (Attribute_Name (The_Parent)) + then + return The_Parent; + end if; + + -- ??? No scheme yet for "for I in Expression'Range loop" + -- ??? the current scheme for Expression wrapping doesn't apply + -- ??? because a RANGE is NOT an expression. Tricky problem... + -- ??? while this problem is not solved we have a potential for + -- ??? leak and unfinalized intermediate objects here. + + when N_Loop_Parameter_Specification => + return Empty; + + -- The following nodes contains "dummy calls" which don't + -- need to be wrapped. + + when N_Parameter_Specification | + N_Discriminant_Specification | + N_Component_Declaration => + return Empty; + + -- The return statement is not to be wrapped when the function + -- itself needs wrapping at the outer-level + + when N_Return_Statement => + if Requires_Transient_Scope (Return_Type (The_Parent)) then + return Empty; + else + return The_Parent; + end if; + + -- If we leave a scope without having been able to find a node to + -- wrap, something is going wrong but this can happen in error + -- situation that are not detected yet (such as a dynamic string + -- in a pragma export) + + when N_Subprogram_Body | + N_Package_Declaration | + N_Package_Body | + N_Block_Statement => + return Empty; + + -- otherwise continue the search + + when others => + null; + end case; + end loop; + end Find_Node_To_Be_Wrapped; + + ---------------------- + -- Global_Flist_Ref -- + ---------------------- + + function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean is + Flist : Entity_Id; + + begin + -- Look for the Global_Final_List + + if Is_Entity_Name (Flist_Ref) then + Flist := Entity (Flist_Ref); + + -- Look for the final list associated with an access to controlled + + elsif Nkind (Flist_Ref) = N_Selected_Component + and then Is_Entity_Name (Prefix (Flist_Ref)) + then + Flist := Entity (Prefix (Flist_Ref)); + else + return False; + end if; + + return Present (Flist) + and then Present (Scope (Flist)) + and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard; + end Global_Flist_Ref; + + ---------------------------------- + -- Has_New_Controlled_Component -- + ---------------------------------- + + function Has_New_Controlled_Component (E : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + if not Is_Tagged_Type (E) then + return Has_Controlled_Component (E); + elsif not Is_Derived_Type (E) then + return Has_Controlled_Component (E); + end if; + + Comp := First_Component (E); + while Present (Comp) loop + + if Chars (Comp) = Name_uParent then + null; + + elsif Scope (Original_Record_Component (Comp)) = E + and then Controlled_Type (Etype (Comp)) + then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_New_Controlled_Component; + + -------------------------- + -- In_Finalization_Root -- + -------------------------- + + -- It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but + -- the purpose of this function is to avoid a circular call to Rtsfind + -- which would been caused by such a test. + + function In_Finalization_Root (E : Entity_Id) return Boolean is + S : constant Entity_Id := Scope (E); + + begin + return Chars (Scope (S)) = Name_System + and then Chars (S) = Name_Finalization_Root + and then Scope (Scope (S)) = Standard_Standard; + end In_Finalization_Root; + + ------------------------------------ + -- Insert_Actions_In_Scope_Around -- + ------------------------------------ + + procedure Insert_Actions_In_Scope_Around (N : Node_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + if Present (SE.Actions_To_Be_Wrapped_Before) then + Insert_List_Before (N, SE.Actions_To_Be_Wrapped_Before); + SE.Actions_To_Be_Wrapped_Before := No_List; + end if; + + if Present (SE.Actions_To_Be_Wrapped_After) then + Insert_List_After (N, SE.Actions_To_Be_Wrapped_After); + SE.Actions_To_Be_Wrapped_After := No_List; + end if; + end Insert_Actions_In_Scope_Around; + + ----------------------- + -- Make_Adjust_Call -- + ----------------------- + + function Make_Adjust_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Res : constant List_Id := New_List; + Utyp : Entity_Id; + Proc : Entity_Id; + Cref : Node_Id := Ref; + Cref2 : Node_Id; + Attach : Node_Id := With_Attach; + + begin + if Is_Class_Wide_Type (Typ) then + Utyp := Underlying_Type (Base_Type (Root_Type (Typ))); + else + Utyp := Underlying_Type (Base_Type (Typ)); + end if; + + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views + + if Is_Untagged_Derivation (Typ) then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + Cref := Unchecked_Convert_To (Utyp, Cref); + Set_Assignment_OK (Cref); + -- To prevent problems with UC see 1.156 RH ??? + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- We do not need to attach to one of the Global Final Lists + -- the objects whose type is Finalize_Storage_Only + + if Finalize_Storage_Only (Typ) + and then (Global_Flist_Ref (Flist_Ref) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) + = Standard_True) + then + Attach := Make_Integer_Literal (Loc, 0); + end if; + + -- Generate: + -- Deep_Adjust (Flist_Ref, Ref, With_Attach); + + if Has_Controlled_Component (Utyp) + or else Is_Class_Wide_Type (Typ) + then + if Is_Tagged_Type (Utyp) then + Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Adjust_Case)); + + else + Proc := TSS (Utyp, Deep_Name_Of (Adjust_Case)); + end if; + + Cref := Convert_View (Proc, Cref, 2); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Flist_Ref, Cref, Attach))); + + -- Generate: + -- if With_Attach then + -- Attach_To_Final_List (Ref, Flist_Ref); + -- end if; + -- Adjust (Ref); + + else -- Is_Controlled (Utyp) + + Proc := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); + Cref := Convert_View (Proc, Cref); + Cref2 := New_Copy_Tree (Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List (Cref2))); + + Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach)); + + -- Treat this as a reference to Adjust if the Adjust routine + -- comes from source. The call is not explicit, but it is near + -- enough, and we won't typically get explicit adjust calls. + + if Comes_From_Source (Proc) then + Generate_Reference (Proc, Ref); + end if; + end if; + + return Res; + end Make_Adjust_Call; + + ---------------------- + -- Make_Attach_Call -- + ---------------------- + + -- Generate: + -- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link) + + function Make_Attach_Call + (Obj_Ref : Node_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Obj_Ref); + + begin + -- Optimization: If the number of links is statically '0', don't + -- call the attach_proc. + + if Nkind (With_Attach) = N_Integer_Literal + and then Intval (With_Attach) = Uint_0 + then + return Make_Null_Statement (Loc); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc), + Parameter_Associations => New_List ( + Flist_Ref, + OK_Convert_To (RTE (RE_Finalizable), Obj_Ref), + With_Attach)); + end Make_Attach_Call; + + ---------------- + -- Make_Clean -- + ---------------- + + function Make_Clean + (N : Node_Id; + Clean : Entity_Id; + Mark : Entity_Id; + Flist : Entity_Id; + Is_Task : Boolean; + Is_Master : Boolean; + Is_Protected_Subprogram : Boolean; + Is_Task_Allocation_Block : Boolean; + Is_Asynchronous_Call_Block : Boolean) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Clean); + + Stmt : List_Id := New_List; + Sbody : Node_Id; + Spec : Node_Id; + Name : Node_Id; + Param : Node_Id; + Unlock : Node_Id; + Param_Type : Entity_Id; + Pid : Entity_Id := Empty; + Cancel_Param : Entity_Id; + + begin + if Is_Task then + if Restricted_Profile then + Append_To + (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); + else + Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task)); + end if; + + elsif Is_Master then + if Restrictions (No_Task_Hierarchy) = False then + Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master)); + end if; + + elsif Is_Protected_Subprogram then + + -- Add statements to the cleanup handler of the (ordinary) + -- subprogram expanded to implement a protected subprogram, + -- unlocking the protected object parameter and undeferring abortion. + -- If this is a protected procedure, and the object contains + -- entries, this also calls the entry service routine. + + -- NOTE: This cleanup handler references _object, a parameter + -- to the procedure. + + -- Find the _object parameter representing the protected object. + + Spec := Parent (Corresponding_Spec (N)); + + Param := First (Parameter_Specifications (Spec)); + loop + Param_Type := Etype (Parameter_Type (Param)); + + if Ekind (Param_Type) = E_Record_Type then + Pid := Corresponding_Concurrent_Type (Param_Type); + end if; + + exit when not Present (Param) or else Present (Pid); + Next (Param); + end loop; + + pragma Assert (Present (Param)); + + -- If the associated protected object declares entries, + -- a protected procedure has to service entry queues. + -- In this case, add + + -- Service_Entries (_object._object'Access); + + -- _object is the record used to implement the protected object. + -- It is a parameter to the protected subprogram. + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Has_Entries (Pid) + then + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Pid) > 1 + then + Name := New_Reference_To (RTE (RE_Service_Entries), Loc); + else + Name := New_Reference_To (RTE (RE_Service_Entry), Loc); + end if; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To ( + Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + end if; + + -- Unlock (_object._object'Access); + + -- _object is the record used to implement the protected object. + -- It is a parameter to the protected subprogram. + + -- If the protected object is controlled (i.e it has entries or + -- needs finalization for interrupt handling), call Unlock_Entries, + -- except if the protected object follows the ravenscar profile, in + -- which case call Unlock_Entry, otherwise call the simplified + -- version, Unlock. + + if Has_Entries (Pid) + or else Has_Interrupt_Handler (Pid) + or else Has_Attach_Handler (Pid) + then + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Pid) > 1 + then + Unlock := New_Reference_To (RTE (RE_Unlock_Entries), Loc); + else + Unlock := New_Reference_To (RTE (RE_Unlock_Entry), Loc); + end if; + + else + Unlock := New_Reference_To (RTE (RE_Unlock), Loc); + end if; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Unlock, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + + if Abort_Allowed then + -- Abort_Undefer; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => Empty_List)); + end if; + + elsif Is_Task_Allocation_Block then + + -- Add a call to Expunge_Unactivated_Tasks to the cleanup + -- handler of a block created for the dynamic allocation of + -- tasks: + + -- Expunge_Unactivated_Tasks (_chain); + + -- where _chain is the list of tasks created by the allocator + -- but not yet activated. This list will be empty unless + -- the block completes abnormally. + + -- This only applies to dynamically allocated tasks; + -- other unactivated tasks are completed by Complete_Task or + -- Complete_Master. + + -- NOTE: This cleanup handler references _chain, a local + -- object. + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Expunge_Unactivated_Tasks), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Activation_Chain_Entity (N), Loc)))); + + elsif Is_Asynchronous_Call_Block then + + -- Add a call to attempt to cancel the asynchronous entry call + -- whenever the block containing the abortable part is exited. + + -- NOTE: This cleanup handler references C, a local object + + -- Get the argument to the Cancel procedure + Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N))); + + -- If it is of type Communication_Block, this must be a + -- protected entry call. + + if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then + + Append_To (Stmt, + + -- if Enqueued (Cancel_Parameter) then + + Make_Implicit_If_Statement (Clean, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Enqueued), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc))), + Then_Statements => New_List ( + + -- Cancel_Protected_Entry_Call (Cancel_Param); + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Cancel_Protected_Entry_Call), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))))); + + -- Asynchronous delay + + elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Cancel_Param, Loc), + Attribute_Name => Name_Unchecked_Access)))); + + -- Task entry call + + else + -- Append call to Cancel_Task_Entry_Call (C); + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Cancel_Task_Entry_Call), + Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))); + + end if; + end if; + + if Present (Flist) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_List), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Flist, Loc)))); + end if; + + if Present (Mark) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_SS_Release), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Mark, Loc)))); + end if; + + Sbody := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Clean), + + Declarations => New_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmt)); + + if Present (Flist) or else Is_Task or else Is_Master then + Wrap_Cleanup_Procedure (Sbody); + end if; + + -- We do not want debug information for _Clean routines, + -- since it just confuses the debugging operation unless + -- we are debugging generated code. + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Clean, True); + end if; + + return Sbody; + end Make_Clean; + + -------------------------- + -- Make_Deep_Array_Body -- + -------------------------- + + -- Array components are initialized and adjusted in the normal order + -- and finalized in the reverse order. Exceptions are handled and + -- Program_Error is re-raise in the Adjust and Finalize case + -- (RM 7.6.1(12)). Generate the following code : + -- + -- procedure Deep_<P> -- with <P> being Initialize or Adjust or Finalize + -- (L : in out Finalizable_Ptr; + -- V : in out Typ) + -- is + -- begin + -- for J1 in Typ'First (1) .. Typ'Last (1) loop + -- ^ reverse ^ -- in the finalization case + -- ... + -- for J2 in Typ'First (n) .. Typ'Last (n) loop + -- Make_<P>_Call (Typ, V (J1, .. , Jn), L, V); + -- end loop; + -- ... + -- end loop; + -- exception -- not in the + -- when others => raise Program_Error; -- Initialize case + -- end Deep_<P>; + + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + + Index_List : constant List_Id := New_List; + -- Stores the list of references to the indexes (one per dimension) + + function One_Component return List_Id; + -- Create one statement to initialize/adjust/finalize one array + -- component, designated by a full set of indices. + + function One_Dimension (N : Int) return List_Id; + -- Create loop to deal with one dimension of the array. The single + -- statement in the body of the loop initializes the inner dimensions if + -- any, or else a single component. + + ------------------- + -- One_Component -- + ------------------- + + function One_Component return List_Id is + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Comp_Ref : constant Node_Id := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Expressions => Index_List); + + begin + -- Set the etype of the component Reference, which is used to + -- determine whether a conversion to a parent type is needed. + + Set_Etype (Comp_Ref, Comp_Typ); + + case Prim is + when Initialize_Case => + return Make_Init_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B)); + + when Adjust_Case => + return Make_Adjust_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B)); + + when Finalize_Case => + return Make_Final_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_B)); + end case; + end One_Component; + + ------------------- + -- One_Dimension -- + ------------------- + + function One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + if N > Number_Dimensions (Typ) then + return One_Component; + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append_To (Index_List, New_Reference_To (Index, Loc)); + + return New_List ( + Make_Implicit_Loop_Statement (Typ, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))), + Reverse_Present => Prim = Finalize_Case)), + Statements => One_Dimension (N + 1))); + end if; + end One_Dimension; + + -- Start of processing for Make_Deep_Array_Body + + begin + return One_Dimension (1); + end Make_Deep_Array_Body; + + -------------------- + -- Make_Deep_Proc -- + -------------------- + + -- Generate: + -- procedure DEEP_<prim> + -- (L : IN OUT Finalizable_Ptr; -- not for Finalize + -- V : IN OUT <typ>; + -- B : IN Short_Short_Integer) is + -- begin + -- <stmts>; + -- exception -- Finalize and Adjust Cases only + -- raise Program_Error; -- idem + -- end DEEP_<prim>; + + function Make_Deep_Proc + (Prim : Final_Primitives; + Typ : Entity_Id; + Stmts : List_Id) + return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Formals : List_Id; + Proc_Name : Entity_Id; + Handler : List_Id := No_List; + Subp_Body : Node_Id; + Type_B : Entity_Id; + + begin + if Prim = Finalize_Case then + Formals := New_List; + Type_B := Standard_Boolean; + + else + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + Type_B := Standard_Short_Short_Integer; + end if; + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), + Parameter_Type => New_Reference_To (Type_B, Loc))); + + if Prim = Finalize_Case or else Prim = Adjust_Case then + Handler := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Program_Error (Loc)))); + end if; + + Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim)); + + Subp_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Name, + Parameter_Specifications => Formals), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts, + Exception_Handlers => Handler)); + + return Proc_Name; + end Make_Deep_Proc; + + --------------------------- + -- Make_Deep_Record_Body -- + --------------------------- + + -- The Deep procedures call the appropriate Controlling proc on the + -- the controller component. In the init case, it also attach the + -- controller to the current finalization list. + + function Make_Deep_Record_Body + (Prim : Final_Primitives; + Typ : Entity_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Controller_Typ : Entity_Id; + Obj_Ref : constant Node_Id := Make_Identifier (Loc, Name_V); + Controller_Ref : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Obj_Ref, + Selector_Name => + Make_Identifier (Loc, Name_uController)); + + begin + if Is_Return_By_Reference_Type (Typ) then + Controller_Typ := RTE (RE_Limited_Record_Controller); + else + Controller_Typ := RTE (RE_Record_Controller); + end if; + + case Prim is + when Initialize_Case => + declare + Res : constant List_Id := New_List; + + begin + Append_List_To (Res, + Make_Init_Call ( + Ref => Controller_Ref, + Typ => Controller_Typ, + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B))); + + -- When the type is also a controlled type by itself, + -- Initialize it and attach it at the end of the internal + -- finalization chain + + if Is_Controlled (Typ) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + + Parameter_Associations => + New_List (New_Copy_Tree (Obj_Ref)))); + + Append_To (Res, Make_Attach_Call ( + Obj_Ref => New_Copy_Tree (Obj_Ref), + Flist_Ref => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Controller_Ref), + Selector_Name => Make_Identifier (Loc, Name_F)), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + + return Res; + end; + + when Adjust_Case => + return + Make_Adjust_Call (Controller_Ref, Controller_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B)); + + when Finalize_Case => + return + Make_Final_Call (Controller_Ref, Controller_Typ, + Make_Identifier (Loc, Name_B)); + end case; + end Make_Deep_Record_Body; + + ---------------------- + -- Make_Final_Call -- + ---------------------- + + function Make_Final_Call + (Ref : Node_Id; + Typ : Entity_Id; + With_Detach : Node_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Res : constant List_Id := New_List; + Cref : Node_Id; + Cref2 : Node_Id; + Proc : Entity_Id; + Utyp : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ) then + Utyp := Root_Type (Typ); + Cref := Ref; + + elsif Is_Concurrent_Type (Typ) then + Utyp := Corresponding_Record_Type (Typ); + Cref := Convert_Concurrent (Ref, Typ); + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Concurrent_Type (Full_View (Typ)) + then + Utyp := Corresponding_Record_Type (Full_View (Typ)); + Cref := Convert_Concurrent (Ref, Full_View (Typ)); + else + Utyp := Typ; + Cref := Ref; + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views + + if Is_Untagged_Derivation (Typ) then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + Cref := Unchecked_Convert_To (Utyp, Cref); + Set_Assignment_OK (Cref); + -- To prevent problems with UC see 1.156 RH ??? + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- Generate: + -- Deep_Finalize (Ref, With_Detach); + + if Has_Controlled_Component (Utyp) + or else Is_Class_Wide_Type (Typ) + then + if Is_Tagged_Type (Utyp) then + Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Finalize_Case)); + else + Proc := TSS (Utyp, Deep_Name_Of (Finalize_Case)); + end if; + + Cref := Convert_View (Proc, Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Cref, With_Detach))); + + -- Generate: + -- if With_Detach then + -- Finalize_One (Ref); + -- else + -- Finalize (Ref); + -- end if; + + else + Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case)); + + if Chars (With_Detach) = Chars (Standard_True) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), Cref)))); + + elsif Chars (With_Detach) = Chars (Standard_False) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Convert_View (Proc, Cref)))); + + else + Cref2 := New_Copy_Tree (Cref); + Append_To (Res, + Make_Implicit_If_Statement (Ref, + Condition => With_Detach, + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), Cref)))), + + Else_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Convert_View (Proc, Cref2)))))); + end if; + end if; + + -- Treat this as a reference to Finalize if the Finalize routine + -- comes from source. The call is not explicit, but it is near + -- enough, and we won't typically get explicit adjust calls. + + if Comes_From_Source (Proc) then + Generate_Reference (Proc, Ref); + end if; + return Res; + end Make_Final_Call; + + -------------------- + -- Make_Init_Call -- + -------------------- + + function Make_Init_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Is_Conc : Boolean; + Res : constant List_Id := New_List; + Proc : Entity_Id; + Utyp : Entity_Id; + Cref : Node_Id; + Cref2 : Node_Id; + Attach : Node_Id := With_Attach; + + begin + if Is_Concurrent_Type (Typ) then + Is_Conc := True; + Utyp := Corresponding_Record_Type (Typ); + Cref := Convert_Concurrent (Ref, Typ); + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Concurrent_Type (Underlying_Type (Typ)) + then + Is_Conc := True; + Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); + Cref := Convert_Concurrent (Ref, Underlying_Type (Typ)); + + else + Is_Conc := False; + Utyp := Typ; + Cref := Ref; + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views + + if Is_Untagged_Derivation (Typ) + and then not Is_Conc + then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + Cref := Unchecked_Convert_To (Utyp, Cref); + Set_Assignment_OK (Cref); + -- To prevent problems with UC see 1.156 RH ??? + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- We do not need to attach to one of the Global Final Lists + -- the objects whose type is Finalize_Storage_Only + + if Finalize_Storage_Only (Typ) + and then (Global_Flist_Ref (Flist_Ref) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) + = Standard_True) + then + Attach := Make_Integer_Literal (Loc, 0); + end if; + + -- Generate: + -- Deep_Initialize (Ref, Flist_Ref); + + if Has_Controlled_Component (Utyp) then + Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); + + Cref := Convert_View (Proc, Cref, 2); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List ( + Node1 => Flist_Ref, + Node2 => Cref, + Node3 => Attach))); + + -- Generate: + -- Attach_To_Final_List (Ref, Flist_Ref); + -- Initialize (Ref); + + else -- Is_Controlled (Utyp) + Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); + Cref := Convert_View (Proc, Cref); + Cref2 := New_Copy_Tree (Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List (Cref2))); + + Append_To (Res, + Make_Attach_Call (Cref, Flist_Ref, Attach)); + + -- Treat this as a reference to Initialize if Initialize routine + -- comes from source. The call is not explicit, but it is near + -- enough, and we won't typically get explicit adjust calls. + + if Comes_From_Source (Proc) then + Generate_Reference (Proc, Ref); + end if; + end if; + + return Res; + end Make_Init_Call; + + -------------------------- + -- Make_Transient_Block -- + -------------------------- + + -- If finalization is involved, this function just wraps the instruction + -- into a block whose name is the transient block entity, and then + -- Expand_Cleanup_Actions (called on the expansion of the handled + -- sequence of statements will do the necessary expansions for + -- cleanups). + + function Make_Transient_Block + (Loc : Source_Ptr; + Action : Node_Id) + return Node_Id + is + Flist : constant Entity_Id := Finalization_Chain_Entity (Current_Scope); + Decls : constant List_Id := New_List; + Instrs : constant List_Id := New_List (Action); + Blk : Node_Id; + + begin + -- Case where only secondary stack use is involved + + if Uses_Sec_Stack (Current_Scope) + and then No (Flist) + and then Nkind (Action) /= N_Return_Statement + then + + declare + S : Entity_Id; + K : Entity_Kind; + begin + S := Scope (Current_Scope); + loop + K := Ekind (S); + + -- At the outer level, no need to release the sec stack + + if S = Standard_Standard then + Set_Uses_Sec_Stack (Current_Scope, False); + exit; + + -- In a function, only release the sec stack if the + -- function does not return on the sec stack otherwise + -- the result may be lost. The caller is responsible for + -- releasing. + + elsif K = E_Function then + Set_Uses_Sec_Stack (Current_Scope, False); + + if not Requires_Transient_Scope (Etype (S)) then + if not Functions_Return_By_DSP_On_Target then + Set_Uses_Sec_Stack (S, True); + Disallow_In_No_Run_Time_Mode (Action); + end if; + end if; + + exit; + + -- In a loop or entry we should install a block encompassing + -- all the construct. For now just release right away. + + elsif K = E_Loop or else K = E_Entry then + exit; + + -- In a procedure or a block, we release on exit of the + -- procedure or block. ??? memory leak can be created by + -- recursive calls. + + elsif K = E_Procedure + or else K = E_Block + then + if not Functions_Return_By_DSP_On_Target then + Set_Uses_Sec_Stack (S, True); + Disallow_In_No_Run_Time_Mode (Action); + end if; + + Set_Uses_Sec_Stack (Current_Scope, False); + exit; + + else + S := Scope (S); + end if; + end loop; + end; + end if; + + -- Insert actions stuck in the transient scopes as well as all + -- freezing nodes needed by those actions + + Insert_Actions_In_Scope_Around (Action); + + declare + Last_Inserted : Node_Id := Prev (Action); + + begin + if Present (Last_Inserted) then + Freeze_All (First_Entity (Current_Scope), Last_Inserted); + end if; + end; + + Blk := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Current_Scope, Loc), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), + Has_Created_Identifier => True); + + -- When the transient scope was established, we pushed the entry for + -- the transient scope onto the scope stack, so that the scope was + -- active for the installation of finalizable entities etc. Now we + -- must remove this entry, since we have constructed a proper block. + + Pop_Scope; + + return Blk; + end Make_Transient_Block; + + ------------------------ + -- Node_To_Be_Wrapped -- + ------------------------ + + function Node_To_Be_Wrapped return Node_Id is + begin + return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; + end Node_To_Be_Wrapped; + + ---------------------------- + -- Set_Node_To_Be_Wrapped -- + ---------------------------- + + procedure Set_Node_To_Be_Wrapped (N : Node_Id) is + begin + Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; + end Set_Node_To_Be_Wrapped; + + ---------------------------------- + -- Store_After_Actions_In_Scope -- + ---------------------------------- + + procedure Store_After_Actions_In_Scope (L : List_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + if Present (SE.Actions_To_Be_Wrapped_After) then + Insert_List_Before_And_Analyze ( + First (SE.Actions_To_Be_Wrapped_After), L); + + else + SE.Actions_To_Be_Wrapped_After := L; + + if Is_List_Member (SE.Node_To_Be_Wrapped) then + Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); + else + Set_Parent (L, SE.Node_To_Be_Wrapped); + end if; + + Analyze_List (L); + end if; + end Store_After_Actions_In_Scope; + + ----------------------------------- + -- Store_Before_Actions_In_Scope -- + ----------------------------------- + + procedure Store_Before_Actions_In_Scope (L : List_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + if Present (SE.Actions_To_Be_Wrapped_Before) then + Insert_List_After_And_Analyze ( + Last (SE.Actions_To_Be_Wrapped_Before), L); + + else + SE.Actions_To_Be_Wrapped_Before := L; + + if Is_List_Member (SE.Node_To_Be_Wrapped) then + Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); + else + Set_Parent (L, SE.Node_To_Be_Wrapped); + end if; + + Analyze_List (L); + end if; + end Store_Before_Actions_In_Scope; + + -------------------------------- + -- Wrap_Transient_Declaration -- + -------------------------------- + + -- If a transient scope has been established during the processing of the + -- Expression of an Object_Declaration, it is not possible to wrap the + -- declaration into a transient block as usual case, otherwise the object + -- would be itself declared in the wrong scope. Therefore, all entities (if + -- any) defined in the transient block are moved to the proper enclosing + -- scope, furthermore, if they are controlled variables they are finalized + -- right after the declaration. The finalization list of the transient + -- scope is defined as a renaming of the enclosing one so during their + -- initialization they will be attached to the proper finalization + -- list. For instance, the following declaration : + + -- X : Typ := F (G (A), G (B)); + + -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) + -- is expanded into : + + -- _local_final_list_1 : Finalizable_Ptr; + -- X : Typ := [ complex Expression-Action ]; + -- Finalize_One(_v1); + -- Finalize_One (_v2); + + procedure Wrap_Transient_Declaration (N : Node_Id) is + S : Entity_Id; + LC : Entity_Id := Empty; + Nodes : List_Id; + Loc : constant Source_Ptr := Sloc (N); + Enclosing_S : Entity_Id; + Uses_SS : Boolean; + Next_N : constant Node_Id := Next (N); + + begin + S := Current_Scope; + Enclosing_S := Scope (S); + + -- Insert Actions kept in the Scope stack + + Insert_Actions_In_Scope_Around (N); + + -- If the declaration is consuming some secondary stack, mark the + -- Enclosing scope appropriately. + + Uses_SS := Uses_Sec_Stack (S); + Pop_Scope; + + -- Create a List controller and rename the final list to be its + -- internal final pointer: + -- Lxxx : Simple_List_Controller; + -- Fxxx : Finalizable_Ptr renames Lxxx.F; + + if Present (Finalization_Chain_Entity (S)) then + LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + + Nodes := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => LC, + Object_Definition => + New_Reference_To (RTE (RE_Simple_List_Controller), Loc)), + + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Finalization_Chain_Entity (S), + Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (LC, Loc), + Selector_Name => Make_Identifier (Loc, Name_F)))); + + -- Put the declaration at the beginning of the declaration part + -- to make sure it will be before all other actions that have been + -- inserted before N. + + Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes); + + -- Generate the Finalization calls by finalizing the list + -- controller right away. It will be re-finalized on scope + -- exit but it doesn't matter. It cannot be done when the + -- call initializes a renaming object though because in this + -- case, the object becomes a pointer to the temporary and thus + -- increases its life span. + + if Nkind (N) = N_Object_Renaming_Declaration + and then Controlled_Type (Etype (Defining_Identifier (N))) + then + null; + + else + Nodes := + Make_Final_Call ( + Ref => New_Reference_To (LC, Loc), + Typ => Etype (LC), + With_Detach => New_Reference_To (Standard_False, Loc)); + if Present (Next_N) then + Insert_List_Before_And_Analyze (Next_N, Nodes); + else + Append_List_To (List_Containing (N), Nodes); + end if; + end if; + end if; + + -- Put the local entities back in the enclosing scope, and set the + -- Is_Public flag appropriately. + + Transfer_Entities (S, Enclosing_S); + + -- Mark the enclosing dynamic scope so that the sec stack will be + -- released upon its exit unless this is a function that returns on + -- the sec stack in which case this will be done by the caller. + + if Uses_SS then + S := Enclosing_Dynamic_Scope (S); + + if Ekind (S) = E_Function + and then Requires_Transient_Scope (Etype (S)) + then + null; + else + Set_Uses_Sec_Stack (S); + Disallow_In_No_Run_Time_Mode (N); + end if; + end if; + end Wrap_Transient_Declaration; + + ------------------------------- + -- Wrap_Transient_Expression -- + ------------------------------- + + -- Insert actions before <Expression>: + + -- (lines marked with <CTRL> are expanded only in presence of Controlled + -- objects needing finalization) + + -- _E : Etyp; + -- declare + -- _M : constant Mark_Id := SS_Mark; + -- Local_Final_List : System.FI.Finalizable_Ptr; <CTRL> + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (Local_Final_List); <CTRL> + -- SS_Release (M); + -- Abort_Undefer; + -- end _Clean; + + -- begin + -- _E := <Expression>; + -- at end + -- _Clean; + -- end; + + -- then expression is replaced by _E + + procedure Wrap_Transient_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Etyp : Entity_Id := Etype (N); + + begin + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Object_Definition => New_Reference_To (Etyp, Loc)), + + Make_Transient_Block (Loc, + Action => + Make_Assignment_Statement (Loc, + Name => New_Reference_To (E, Loc), + Expression => Relocate_Node (N))))); + + Rewrite (N, New_Reference_To (E, Loc)); + Analyze_And_Resolve (N, Etyp); + end Wrap_Transient_Expression; + + ------------------------------ + -- Wrap_Transient_Statement -- + ------------------------------ + + -- Transform <Instruction> into + + -- (lines marked with <CTRL> are expanded only in presence of Controlled + -- objects needing finalization) + + -- declare + -- _M : Mark_Id := SS_Mark; + -- Local_Final_List : System.FI.Finalizable_Ptr ; <CTRL> + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (Local_Final_List); <CTRL> + -- SS_Release (_M); + -- Abort_Undefer; + -- end _Clean; + + -- begin + -- <Instr uction>; + -- at end + -- _Clean; + -- end; + + procedure Wrap_Transient_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + New_Statement : constant Node_Id := Relocate_Node (N); + + begin + Rewrite (N, Make_Transient_Block (Loc, New_Statement)); + + -- With the scope stack back to normal, we can call analyze on the + -- resulting block. At this point, the transient scope is being + -- treated like a perfectly normal scope, so there is nothing + -- special about it. + + -- Note: Wrap_Transient_Statement is called with the node already + -- analyzed (i.e. Analyzed (N) is True). This is important, since + -- otherwise we would get a recursive processing of the node when + -- we do this Analyze call. + + Analyze (N); + end Wrap_Transient_Statement; + +end Exp_Ch7; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads new file mode 100644 index 00000000000..aeff51f2b96 --- /dev/null +++ b/gcc/ada/exp_ch7.ads @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 7 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.42 $ +-- -- +-- Copyright (C) 1992-2000 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 Types; use Types; + +package Exp_Ch7 is + + procedure Expand_N_Package_Body (N : Node_Id); + procedure Expand_N_Package_Declaration (N : Node_Id); + + ------------------------------ + -- Finalization Management -- + ------------------------------ + + function In_Finalization_Root (E : Entity_Id) return Boolean; + -- True if current scope is in package System.Finalization_Root. Used + -- to avoid certain expansions that would involve circularity in the + -- Rtsfind mechanism. + + procedure Build_Final_List (N : Node_Id; Typ : Entity_Id); + -- Build finalization list for anonymous access types, and for access + -- types that are frozen before their designated types are known to + -- be controlled. + + procedure Build_Controlling_Procs (Typ : Entity_Id); + -- Typ is a record, and array type having controlled components. + -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize + -- that take care of finalization management at run-time. + + function Controller_Component (Typ : Entity_Id) return Entity_Id; + -- Returns the entity of the component whose name is 'Name_uController' + + function Controlled_Type (T : Entity_Id) return Boolean; + -- True if T potentially needs finalization actions + + function Find_Final_List + (E : Entity_Id; + Ref : Node_Id := Empty) + return Node_Id; + -- E is an entity representing a controlled object, a controlled type + -- or a scope. If Ref is not empty, it is a reference to a controlled + -- record, the closest Final list is in the controller component of + -- the record containing Ref otherwise this function returns a + -- reference to the final list attached to the closest dynamic scope + -- (that can be E itself) creating this final list if necessary. + + function Has_New_Controlled_Component (E : Entity_Id) return Boolean; + -- E is a type entity. Give the same resul as Has_Controlled_Component + -- except for tagged extensions where the result is True only if the + -- latest extension contains a controlled component. + + function Make_Attach_Call + (Obj_Ref : Node_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) + return Node_Id; + -- Attach the referenced object to the referenced Final Chain + -- 'Flist_Ref' With_Attach is an expression of type Short_Short_Integer + -- which can be either '0' to signify no attachment, '1' for + -- attachement to a simply linked list or '2' for attachement to a + -- doubly linked list. + + function Make_Init_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) + return List_Id; + -- Ref is an expression (with no-side effect and is not required to + -- have been previously analyzed) that references the object to be + -- initialized. Typ is the expected type of Ref, which is a controlled + -- type (Is_Controlled) or a type with controlled components + -- (Has_Controlled). 'Dynamic_Case' controls the way the object is + -- attached which is different whether the object is dynamically + -- allocated or not. + -- + -- This function will generate the appropriate calls to make + -- sure that the objects referenced by Ref are initialized. The + -- generate code is quite different depending on the fact the type + -- IS_Controlled or HAS_Controlled but this is not the problem of the + -- caller, the details are in the body. + + function Make_Adjust_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) + return List_Id; + -- Ref is an expression (with no-side effect and is not required to + -- have been previously analyzed) that references the object to be + -- adjusted. Typ is the expected type of Ref, which is a controlled + -- type (Is_Controlled) or a type with controlled components + -- (Has_Controlled). + -- + -- This function will generate the appropriate calls to make + -- sure that the objects referenced by Ref are adjusted. The generated + -- code is quite different depending on the fact the type IS_Controlled + -- or HAS_Controlled but this is not the problem of the caller, the + -- details are in the body. If the parameter With_Attach is set to + -- True, the finalizable objects involved are attached to the proper + -- finalization chain. The objects must be attached when the adjust + -- takes place after an initialization expression but not when it takes + -- place after a regular assignment. + -- + -- The description of With_Attach is completely obsolete ??? + + function Make_Final_Call + (Ref : Node_Id; + Typ : Entity_Id; + With_Detach : Node_Id) + return List_Id; + -- Ref is an expression (with no-side effect and is not required to + -- have been previously analyzed) that references the object + -- to be Finalized. Typ is the expected type of Ref, which is a + -- controlled type (Is_Controlled) or a type with controlled + -- components (Has_Controlled). + -- + -- This function will generate the appropriate calls to make + -- sure that the objects referenced by Ref are finalized. The generated + -- code is quite different depending on the fact the type IS_Controlled + -- or HAS_Controlled but this is not the problem of the caller, the + -- details are in the body. If the parameter With_Detach is set to + -- True, the finalizable objects involved are detached from the proper + -- finalization chain. The objects must be detached when finalizing an + -- unchecked deallocated object but not when finalizing the target of + -- an assignment, it is not necessary either on scope exit. + + procedure Expand_Ctrl_Function_Call (N : Node_Id); + -- Expand a call to a function returning a controlled value. That is to + -- say attach the result of the call to the current finalization list, + -- which is the one of the transient scope created for such constructs. + + -------------------------------- + -- Transient Scope Management -- + -------------------------------- + + procedure Expand_Cleanup_Actions (N : Node_Id); + -- Expand the necessary stuff into a scope to enable finalization of local + -- objects and deallocation of transient data when exiting the scope. N is + -- a "scope node" that is to say one of the following: N_Block_Statement, + -- N_Subprogram_Body, N_Task_Body, N_Entry_Body. + + procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean); + -- Push a new transient scope on the scope stack. N is the node responsible + -- for the need of a transient scope. If Sec_Stack is True then the + -- secondary stack is brought in, otherwise it isn't. + + function Node_To_Be_Wrapped return Node_Id; + -- return the node to be wrapped if the current scope is transient. + + procedure Store_Before_Actions_In_Scope (L : List_Id); + -- Append the list L of actions to the end of the before-actions store + -- in the top of the scope stack + + procedure Store_After_Actions_In_Scope (L : List_Id); + -- Append the list L of actions to the beginning of the after-actions + -- store in the top of the scope stack + + procedure Wrap_Transient_Declaration (N : Node_Id); + -- N is an object declaration. Expand the finalization calls after the + -- declaration and make the outer scope beeing the transient one. + + procedure Wrap_Transient_Expression (N : Node_Id); + -- N is a sub-expression. Expand a transient block around an expression + + procedure Wrap_Transient_Statement (N : Node_Id); + -- N is a statement. Expand a transient block around an instruction + +end Exp_Ch7; diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb new file mode 100644 index 00000000000..54b113300e3 --- /dev/null +++ b/gcc/ada/exp_ch8.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 8 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1992-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 Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sinfo; use Sinfo; +with Stand; use Stand; + +package body Exp_Ch8 is + + --------------------------------------------- + -- Expand_N_Exception_Renaming_Declaration -- + --------------------------------------------- + + procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + + begin + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end Expand_N_Exception_Renaming_Declaration; + + ------------------------------------------ + -- Expand_N_Object_Renaming_Declaration -- + ------------------------------------------ + + -- Most object renaming cases can be done by just capturing the address + -- of the renamed object. The cases in which this is not true are when + -- this address is not computable, since it involves extraction of a + -- packed array element, or of a record component to which a component + -- clause applies (that can specify an arbitrary bit boundary). + + -- In these two cases, we pre-evaluate the renaming expression, by + -- extracting and freezing the values of any subscripts, and then we + -- set the flag Is_Renaming_Of_Object which means that any reference + -- to the object will be handled by macro substitution in the front + -- end, and the back end will know to ignore the renaming declaration. + + -- The other special processing required is for the case of renaming + -- of an object of a class wide type, where it is necessary to build + -- the appropriate subtype for the renamed object. + -- More comments needed for this para ??? + + procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is + Nam : Node_Id := Name (N); + T : Entity_Id; + Decl : Node_Id; + + procedure Evaluate_Name (Fname : Node_Id); + -- A recursive procedure used to freeze a name in the sense described + -- above, i.e. any variable references or function calls are removed. + -- Of course the outer level variable reference must not be removed. + -- For example in A(J,F(K)), A is left as is, but J and F(K) are + -- evaluated and removed. + + function Evaluation_Required (Nam : Node_Id) return Boolean; + -- Determines whether it is necessary to do static name evaluation + -- for renaming of Nam. It is considered necessary if evaluating the + -- name involves indexing a packed array, or extracting a component + -- of a record to which a component clause applies. Note that we are + -- only interested in these operations if they occur as part of the + -- name itself, subscripts are just values that are computed as part + -- of the evaluation, so their form is unimportant. + + ------------------- + -- Evaluate_Name -- + ------------------- + + procedure Evaluate_Name (Fname : Node_Id) is + K : constant Node_Kind := Nkind (Fname); + E : Node_Id; + + begin + -- For an explicit dereference, we simply force the evaluation + -- of the name expression. The dereference provides a value that + -- is the address for the renamed object, and it is precisely + -- this value that we want to preserve. + + if K = N_Explicit_Dereference then + Force_Evaluation (Prefix (Fname)); + + -- For a selected component, we simply evaluate the prefix + + elsif K = N_Selected_Component then + Evaluate_Name (Prefix (Fname)); + + -- For an indexed component, or an attribute reference, we evaluate + -- the prefix, which is itself a name, recursively, and then force + -- the evaluation of all the subscripts (or attribute expressions). + + elsif K = N_Indexed_Component + or else K = N_Attribute_Reference + then + Evaluate_Name (Prefix (Fname)); + + E := First (Expressions (Fname)); + while Present (E) loop + Force_Evaluation (E); + + if Original_Node (E) /= E then + Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); + end if; + + Next (E); + end loop; + + -- For a slice, we evaluate the prefix, as for the indexed component + -- case and then, if there is a range present, either directly or + -- as the constraint of a discrete subtype indication, we evaluate + -- the two bounds of this range. + + elsif K = N_Slice then + Evaluate_Name (Prefix (Fname)); + + declare + DR : constant Node_Id := Discrete_Range (Fname); + Constr : Node_Id; + Rexpr : Node_Id; + + begin + if Nkind (DR) = N_Range then + Force_Evaluation (Low_Bound (DR)); + Force_Evaluation (High_Bound (DR)); + + elsif Nkind (DR) = N_Subtype_Indication then + Constr := Constraint (DR); + + if Nkind (Constr) = N_Range_Constraint then + Rexpr := Range_Expression (Constr); + + Force_Evaluation (Low_Bound (Rexpr)); + Force_Evaluation (High_Bound (Rexpr)); + end if; + end if; + end; + + -- For a type conversion, the expression of the conversion must be + -- the name of an object, and we simply need to evaluate this name. + + elsif K = N_Type_Conversion then + Evaluate_Name (Expression (Fname)); + + -- For a function call, we evaluate the call. + + elsif K = N_Function_Call then + Force_Evaluation (Fname); + + -- The remaining cases are direct name, operator symbol and + -- character literal. In all these cases, we do nothing, since + -- we want to reevaluate each time the renamed object is used. + + else + return; + end if; + end Evaluate_Name; + + ------------------------- + -- Evaluation_Required -- + ------------------------- + + function Evaluation_Required (Nam : Node_Id) return Boolean is + begin + if Nkind (Nam) = N_Indexed_Component + or else Nkind (Nam) = N_Slice + then + if Is_Packed (Etype (Prefix (Nam))) then + return True; + else + return Evaluation_Required (Prefix (Nam)); + end if; + + elsif Nkind (Nam) = N_Selected_Component then + if Present (Component_Clause (Entity (Selector_Name (Nam)))) then + return True; + else + return Evaluation_Required (Prefix (Nam)); + end if; + + else + return False; + end if; + end Evaluation_Required; + + -- Start of processing for Expand_N_Object_Renaming_Declaration + + begin + -- Perform name evaluation if required + + if Evaluation_Required (Nam) then + Evaluate_Name (Nam); + Set_Is_Renaming_Of_Object (Defining_Identifier (N)); + end if; + + -- Deal with construction of subtype in class-wide case + + T := Etype (Defining_Identifier (N)); + + if Is_Class_Wide_Type (T) then + Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N)); + Find_Type (Subtype_Mark (N)); + Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N))); + end if; + + -- Create renaming entry for debug information + + Decl := Debug_Renaming_Declaration (N); + + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end Expand_N_Object_Renaming_Declaration; + + ------------------------------------------- + -- Expand_N_Package_Renaming_Declaration -- + ------------------------------------------- + + procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + + begin + if Present (Decl) then + + -- If we are in a compilation unit, then this is an outer + -- level declaration, and must have a scope of Standard + + if Nkind (Parent (N)) = N_Compilation_Unit then + declare + Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); + + begin + New_Scope (Standard_Standard); + + if No (Actions (Aux)) then + Set_Actions (Aux, New_List (Decl)); + else + Append (Decl, Actions (Aux)); + end if; + + Analyze (Decl); + Pop_Scope; + end; + + -- Otherwise, just insert after the package declaration + + else + Insert_Action (N, Decl); + end if; + end if; + end Expand_N_Package_Renaming_Declaration; + +end Exp_Ch8; diff --git a/gcc/ada/exp_ch8.ads b/gcc/ada/exp_ch8.ads new file mode 100644 index 00000000000..806d0dd0b93 --- /dev/null +++ b/gcc/ada/exp_ch8.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 8 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 8 constructs + +with Types; use Types; + +package Exp_Ch8 is + procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id); + procedure Expand_N_Object_Renaming_Declaration (N : Node_Id); + procedure Expand_N_Package_Renaming_Declaration (N : Node_Id); +end Exp_Ch8; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb new file mode 100644 index 00000000000..31b5d124e63 --- /dev/null +++ b/gcc/ada/exp_ch9.adb @@ -0,0 +1,8543 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 9 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.438 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch11; use Exp_Ch11; +with Exp_Ch6; use Exp_Ch6; +with Exp_Dbug; use Exp_Dbug; +with Exp_Smem; use Exp_Smem; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Hostparm; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch11; use Sem_Ch11; +with Sem_Elab; use Sem_Elab; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Types; use Types; +with Uintp; use Uintp; +with Opt; + +package body Exp_Ch9 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Actual_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Tsk : Entity_Id) + return Node_Id; + -- Compute the index position for an entry call. Tsk is the target + -- task. If the bounds of some entry family depend on discriminants, + -- the expression computed by this function uses the discriminants + -- of the target task. + + function Index_Constant_Declaration + (N : Node_Id; + Index_Id : Entity_Id; + Prot : Entity_Id) + return List_Id; + -- For an entry family and its barrier function, we define a local entity + -- that maps the index in the call into the entry index into the object: + -- + -- I : constant Index_Type := Index_Type'Val ( + -- E - <<index of first family member>> + + -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First))); + + procedure Add_Object_Pointer + (Decls : List_Id; + Pid : Entity_Id; + Loc : Source_Ptr); + -- Prepend an object pointer declaration to the declaration list + -- Decls. This object pointer is initialized to a type conversion + -- of the System.Address pointer passed to entry barrier functions + -- and entry body procedures. + + function Array_Type (E : Entity_Id; Trec : Node_Id) return Entity_Id; + -- Find the array type associated with an entry family in the + -- associated record for the task type. + + function Build_Accept_Body (Astat : Node_Id) return Node_Id; + -- Transform accept statement into a block with added exception handler. + -- Used both for simple accept statements and for accept alternatives in + -- select statements. Astat is the accept statement. + + function Build_Barrier_Function + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) + return Node_Id; + -- Build the function body returning the value of the barrier expression + -- for the specified entry body. + + function Build_Barrier_Function_Specification + (Def_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id; + -- Build a specification for a function implementing + -- the protected entry barrier of the specified entry body. + + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Node_Id; + Loc : Source_Ptr) + return Node_Id; + -- Common to tasks and protected types. Copy discriminant specifications, + -- build record declaration. N is the type declaration, Ctyp is the + -- concurrent entity (task type or protected type). + + function Build_Entry_Count_Expression + (Concurrent_Type : Node_Id; + Component_List : List_Id; + Loc : Source_Ptr) + return Node_Id; + -- Compute number of entries for concurrent object. This is a count of + -- simple entries, followed by an expression that computes the length + -- of the range of each entry family. A single array with that size is + -- allocated for each concurrent object of the type. + + function Build_Find_Body_Index + (Typ : Entity_Id) + return Node_Id; + -- Build the function that translates the entry index in the call + -- (which depends on the size of entry families) into an index into the + -- Entry_Bodies_Array, to determine the body and barrier function used + -- in a protected entry call. A pointer to this function appears in every + -- protected object. + + function Build_Find_Body_Index_Spec + (Typ : Entity_Id) + return Node_Id; + -- Build subprogram declaration for previous one. + + function Build_Protected_Entry + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) + return Node_Id; + -- Build the procedure implementing the statement sequence of + -- the specified entry body. + + function Build_Protected_Entry_Specification + (Def_Id : Entity_Id; + Ent_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id; + -- Build a specification for a procedure implementing + -- the statement sequence of the specified entry body. + -- Add attributes associating it with the entry defining identifier + -- Ent_Id. + + function Build_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) + return Node_Id; + -- This function is used to construct the protected version of a protected + -- subprogram. Its statement sequence first defers abortion, then locks + -- the associated protected object, and then enters a block that contains + -- a call to the unprotected version of the subprogram (for details, see + -- Build_Unprotected_Subprogram_Body). This block statement requires + -- a cleanup handler that unlocks the object in all cases. + -- (see Exp_Ch7.Expand_Cleanup_Actions). + + function Build_Protected_Spec + (N : Node_Id; + Obj_Type : Entity_Id; + Unprotected : Boolean := False; + Ident : Entity_Id) + return List_Id; + -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ + -- Subprogram_Type. Builds signature of protected subprogram, adding the + -- formal that corresponds to the object itself. For an access to protected + -- subprogram, there is no object type to specify, so the additional + -- parameter has type Address and mode In. An indirect call through such + -- a pointer converts the address to a reference to the actual object. + -- The object is a limited record and therefore a by_reference type. + + function Build_Selected_Name + (Prefix, Selector : Name_Id; + Append_Char : Character := ' ') + return Name_Id; + -- Build a name in the form of Prefix__Selector, with an optional + -- character appended. This is used for internal subprograms generated + -- for operations of protected types, including barrier functions. In + -- order to simplify the work of the debugger, the prefix includes the + -- characters PT. + + procedure Build_Simple_Entry_Call + (N : Node_Id; + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id); + -- Some comments here would be useful ??? + + function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; + -- This routine constructs a specification for the procedure that we will + -- build for the task body for task type T. The spec has the form: + -- + -- procedure tnameB (_Task : access tnameV); + -- + -- where name is the character name taken from the task type entity that + -- is passed as the argument to the procedure, and tnameV is the task + -- value type that is associated with the task type. + + function Build_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) + return Node_Id; + -- This routine constructs the unprotected version of a protected + -- subprogram body, which is contains all of the code in the + -- original, unexpanded body. This is the version of the protected + -- subprogram that is called from all protected operations on the same + -- object, including the protected version of the same subprogram. + + procedure Collect_Entry_Families + (Loc : Source_Ptr; + Cdecls : List_Id; + Current_Node : in out Node_Id; + Conctyp : Entity_Id); + -- For each entry family in a concurrent type, create an anonymous array + -- type of the right size, and add a component to the corresponding_record. + + function Family_Offset + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id) + return Node_Id; + -- Compute (Hi - Lo) for two entry family indices. Hi is the index in + -- an accept statement, or the upper bound in the discrete subtype of + -- an entry declaration. Lo is the corresponding lower bound. Ttyp is + -- the concurrent type of the entry. + + function Family_Size + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id) + return Node_Id; + -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in + -- a family, and handle properly the superflat case. This is equivalent + -- to the use of 'Length on the index type, but must use Family_Offset + -- to handle properly the case of bounds that depend on discriminants. + + procedure Extract_Entry + (N : Node_Id; + Concval : out Node_Id; + Ename : out Node_Id; + Index : out Node_Id); + -- Given an entry call, returns the associated concurrent object, + -- the entry name, and the entry family index. + + function Find_Task_Or_Protected_Pragma + (T : Node_Id; + P : Name_Id) + return Node_Id; + -- Searches the task or protected definition T for the first occurrence + -- of the pragma whose name is given by P. The caller has ensured that + -- the pragma is present in the task definition. A special case is that + -- when P is Name_uPriority, the call will also find Interrupt_Priority. + -- ??? Should be implemented with the rep item chain mechanism. + + procedure Update_Prival_Subtypes (N : Node_Id); + -- The actual subtypes of the privals will differ from the type of the + -- private declaration in the original protected type, if the protected + -- type has discriminants or if the prival has constrained components. + -- This is because the privals are generated out of sequence w.r.t. the + -- analysis of a protected body. After generating the bodies for protected + -- operations, we set correctly the type of all references to privals, by + -- means of a recursive tree traversal, which is heavy-handed but + -- correct. + + ----------------------------- + -- Actual_Index_Expression -- + ----------------------------- + + function Actual_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Tsk : Entity_Id) + return Node_Id + is + Expr : Node_Id; + Num : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Prev : Entity_Id; + S : Node_Id; + Ttyp : Entity_Id := Etype (Tsk); + + -------------------------- + -- Actual_Family_Offset -- + -------------------------- + + function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; + -- Compute difference between bounds of entry family. + + function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- Replace a reference to a discriminant with a selected component + -- denoting the discriminant of the target task. + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is + Typ : Entity_Id := Etype (Bound); + B : Node_Id; + + begin + if not Is_Entity_Name (Bound) + or else Ekind (Entity (Bound)) /= E_Discriminant + then + if Nkind (Bound) = N_Attribute_Reference then + return Bound; + else + B := New_Copy_Tree (Bound); + end if; + + else + B := + Make_Selected_Component (Sloc, + Prefix => New_Copy_Tree (Tsk), + Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); + + Analyze_And_Resolve (B, Typ); + end if; + + return + Make_Attribute_Reference (Sloc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Etype (Bound), Sloc), + Expressions => New_List (B)); + end Actual_Discriminant_Ref; + + begin + return + Make_Op_Subtract (Sloc, + Left_Opnd => Actual_Discriminant_Ref (Hi), + Right_Opnd => Actual_Discriminant_Ref (Lo)); + end Actual_Family_Offset; + + begin + -- The queues of entries and entry families appear in textual + -- order in the associated record. The entry index is computed as + -- the sum of the number of queues for all entries that precede the + -- designated one, to which is added the index expression, if this + -- expression denotes a member of a family. + + -- The following is a place holder for the count of simple entries. + + Num := Make_Integer_Literal (Sloc, 1); + + -- We construct an expression which is a series of addition + -- operations. See comments in Entry_Index_Expression, which is + -- identical in structure. + + if Present (Index) then + S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Num, + + Right_Opnd => + Actual_Family_Offset ( + Make_Attribute_Reference (Sloc, + Attribute_Name => Name_Pos, + Prefix => New_Reference_To (Base_Type (S), Sloc), + Expressions => New_List (Relocate_Node (Index))), + Type_Low_Bound (S))); + else + Expr := Num; + end if; + + -- Now add lengths of preceding entries and entry families. + + Prev := First_Entity (Ttyp); + + while Chars (Prev) /= Chars (Ent) + or else (Ekind (Prev) /= Ekind (Ent)) + or else not Sem_Ch6.Type_Conformant (Ent, Prev) + loop + if Ekind (Prev) = E_Entry then + Set_Intval (Num, Intval (Num) + 1); + + elsif Ekind (Prev) = E_Entry_Family then + S := + Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); + Lo := Type_Low_Bound (S); + Hi := Type_High_Bound (S); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Expr, + Right_Opnd => + Make_Op_Add (Sloc, + Left_Opnd => + Actual_Family_Offset (Hi, Lo), + Right_Opnd => + Make_Integer_Literal (Sloc, 1))); + + -- Other components are anonymous types to be ignored. + + else + null; + end if; + + Next_Entity (Prev); + end loop; + + return Expr; + end Actual_Index_Expression; + + ---------------------------------- + -- Add_Discriminal_Declarations -- + ---------------------------------- + + procedure Add_Discriminal_Declarations + (Decls : List_Id; + Typ : Entity_Id; + Name : Name_Id; + Loc : Source_Ptr) + is + D : Entity_Id; + + begin + if Has_Discriminants (Typ) then + D := First_Discriminant (Typ); + + while Present (D) loop + + Prepend_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Discriminal (D), + Subtype_Mark => New_Reference_To (Etype (D), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name), + Selector_Name => Make_Identifier (Loc, Chars (D))))); + + Next_Discriminant (D); + end loop; + end if; + end Add_Discriminal_Declarations; + + ------------------------ + -- Add_Object_Pointer -- + ------------------------ + + procedure Add_Object_Pointer + (Decls : List_Id; + Pid : Entity_Id; + Loc : Source_Ptr) + is + Obj_Ptr : Node_Id; + + begin + -- Prepend the declaration of _object. This must be first in the + -- declaration list, since it is used by the discriminal and + -- prival declarations. + -- ??? An attempt to make this a renaming was unsuccessful. + -- + -- type poVP is access poV; + -- _object : poVP := poVP!O; + + Obj_Ptr := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Chars (Corresponding_Record_Type (Pid)), 'P')); + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Object_Definition => New_Reference_To (Obj_Ptr, Loc), + Expression => + Unchecked_Convert_To (Obj_Ptr, + Make_Identifier (Loc, Name_uO)))); + + Prepend_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Obj_Ptr, + Type_Definition => Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Corresponding_Record_Type (Pid), Loc)))); + + end Add_Object_Pointer; + + ------------------------------ + -- Add_Private_Declarations -- + ------------------------------ + + procedure Add_Private_Declarations + (Decls : List_Id; + Typ : Entity_Id; + Name : Name_Id; + Loc : Source_Ptr) + is + P : Node_Id; + Pdef : Entity_Id; + Def : Node_Id := Protected_Definition (Parent (Typ)); + Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ)); + + begin + pragma Assert (Nkind (Def) = N_Protected_Definition); + + if Present (Private_Declarations (Def)) then + P := First (Private_Declarations (Def)); + + while Present (P) loop + if Nkind (P) = N_Component_Declaration then + Pdef := Defining_Identifier (P); + Prepend_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Prival (Pdef), + Subtype_Mark => New_Reference_To (Etype (Pdef), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name), + Selector_Name => Make_Identifier (Loc, Chars (Pdef))))); + end if; + Next (P); + end loop; + end if; + + -- One more "prival" for the object itself, with the right protection + -- type. + + declare + Protection_Type : RE_Id; + begin + if Has_Attach_Handler (Typ) then + if Restricted_Profile then + Protection_Type := RE_Protection_Entry; + else + Protection_Type := RE_Static_Interrupt_Protection; + end if; + + elsif Has_Interrupt_Handler (Typ) then + Protection_Type := RE_Dynamic_Interrupt_Protection; + + elsif Has_Entries (Typ) then + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Typ) > 1 + then + Protection_Type := RE_Protection_Entries; + else + Protection_Type := RE_Protection_Entry; + end if; + + else + Protection_Type := RE_Protection; + end if; + + Prepend_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Object_Ref (Body_Ent), + Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name), + Selector_Name => Make_Identifier (Loc, Name_uObject)))); + end; + + end Add_Private_Declarations; + + ---------------- + -- Array_Type -- + ---------------- + + function Array_Type (E : Entity_Id; Trec : Node_Id) return Entity_Id is + Arr : Entity_Id := First_Component (Trec); + + begin + while Present (Arr) loop + exit when Ekind (Arr) = E_Component + and then Is_Array_Type (Etype (Arr)) + and then Chars (Arr) = Chars (E); + + Next_Component (Arr); + end loop; + + -- This used to return Arr itself, but this caused problems + -- when used in expanding a protected type, possibly because + -- the record of which it is a component is not frozen yet. + -- I am going to try the type instead. This may pose visibility + -- problems. ??? + + return Etype (Arr); + end Array_Type; + + ----------------------- + -- Build_Accept_Body -- + ----------------------- + + function Build_Accept_Body (Astat : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Astat); + Stats : constant Node_Id := Handled_Statement_Sequence (Astat); + New_S : Node_Id; + Hand : Node_Id; + Call : Node_Id; + Ohandle : Node_Id; + + begin + -- At the end of the statement sequence, Complete_Rendezvous is called. + -- A label skipping the Complete_Rendezvous, and all other + -- accept processing, has already been added for the expansion + -- of requeue statements. + + Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous); + Insert_Before (Last (Statements (Stats)), Call); + Analyze (Call); + + -- If exception handlers are present, then append Complete_Rendezvous + -- calls to the handlers, and construct the required outer block. + + if Present (Exception_Handlers (Stats)) then + Hand := First (Exception_Handlers (Stats)); + + while Present (Hand) loop + Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous); + Append (Call, Statements (Hand)); + Analyze (Call); + Next (Hand); + end loop; + + New_S := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Stats))); + + else + New_S := Stats; + end if; + + -- At this stage we know that the new statement sequence does not + -- have an exception handler part, so we supply one to call + -- Exceptional_Complete_Rendezvous. This handler is + + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + + -- We handle Abort_Signal to make sure that we properly catch the abort + -- case and wake up the caller. + + Ohandle := Make_Others_Choice (Loc); + Set_All_Others (Ohandle); + + Set_Exception_Handlers (New_S, + New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List (Ohandle), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Exceptional_Complete_Rendezvous), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Get_GNAT_Exception), Loc)))))))); + + Set_Parent (New_S, Astat); -- temp parent for Analyze call + Analyze_Exception_Handlers (Exception_Handlers (New_S)); + Expand_Exception_Handlers (New_S); + + -- Exceptional_Complete_Rendezvous must be called with abort + -- still deferred, which is the case for a "when all others" handler. + + return New_S; + + end Build_Accept_Body; + + ----------------------------------- + -- Build_Activation_Chain_Entity -- + ----------------------------------- + + procedure Build_Activation_Chain_Entity (N : Node_Id) is + P : Node_Id; + B : Node_Id; + Decls : List_Id; + + begin + -- Loop to find enclosing construct containing activation chain variable + + P := Parent (N); + + while Nkind (P) /= N_Subprogram_Body + and then Nkind (P) /= N_Package_Declaration + and then Nkind (P) /= N_Package_Body + and then Nkind (P) /= N_Block_Statement + and then Nkind (P) /= N_Task_Body + loop + P := Parent (P); + end loop; + + -- If we are in a package body, the activation chain variable is + -- allocated in the corresponding spec. First, we save the package + -- body node because we enter the new entity in its Declarations list. + + B := P; + + if Nkind (P) = N_Package_Body then + P := Unit_Declaration_Node (Corresponding_Spec (P)); + Decls := Declarations (B); + + elsif Nkind (P) = N_Package_Declaration then + Decls := Visible_Declarations (Specification (B)); + + else + Decls := Declarations (B); + end if; + + -- If activation chain entity not already declared, declare it + + if No (Activation_Chain_Entity (P)) then + Set_Activation_Chain_Entity + (P, Make_Defining_Identifier (Sloc (N), Name_uChain)); + + Prepend_To (Decls, + Make_Object_Declaration (Sloc (P), + Defining_Identifier => Activation_Chain_Entity (P), + Aliased_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Activation_Chain), Sloc (P)))); + + Analyze (First (Decls)); + end if; + + end Build_Activation_Chain_Entity; + + ---------------------------- + -- Build_Barrier_Function -- + ---------------------------- + + function Build_Barrier_Function + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); + Index_Spec : constant Node_Id := Entry_Index_Specification + (Ent_Formals); + Bdef : Entity_Id; + Bspec : Node_Id; + Op_Decls : List_Id := New_List; + + begin + Bdef := + Make_Defining_Identifier (Loc, Chars (Barrier_Function (Ent))); + Bspec := Build_Barrier_Function_Specification (Bdef, Loc); + + -- <object pointer declaration> + -- <discriminant renamings> + -- <private object renamings> + -- Add discriminal and private renamings. These names have + -- already been used to expand references to discriminants + -- and private data. + + Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc); + Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc); + Add_Object_Pointer (Op_Decls, Pid, Loc); + + -- If this is the barrier for an entry family, the entry index is + -- visible in the body of the barrier. Create a local variable that + -- converts the entry index (which is the last formal of the barrier + -- function) into the appropriate offset into the entry array. The + -- entry index constant must be set, as for the entry body, so that + -- local references to the entry index are correctly replaced with + -- the local variable. This parallels what is done for entry bodies. + + if Present (Index_Spec) then + declare + Index_Id : constant Entity_Id := Defining_Identifier (Index_Spec); + Index_Con : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + begin + Set_Entry_Index_Constant (Index_Id, Index_Con); + Append_List_To (Op_Decls, + Index_Constant_Declaration (N, Index_Id, Pid)); + end; + end if; + + -- Note: the condition in the barrier function needs to be properly + -- processed for the C/Fortran boolean possibility, but this happens + -- automatically since the return statement does this normalization. + + return + Make_Subprogram_Body (Loc, + Specification => Bspec, + Declarations => Op_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => Condition (Ent_Formals))))); + end Build_Barrier_Function; + + ------------------------------------------ + -- Build_Barrier_Function_Specification -- + ------------------------------------------ + + function Build_Barrier_Function_Specification + (Def_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id + is + begin + return Make_Function_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), + Parameter_Type => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), + + Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)); + end Build_Barrier_Function_Specification; + + -------------------------- + -- Build_Call_With_Task -- + -------------------------- + + function Build_Call_With_Task + (N : Node_Id; + E : Entity_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + begin + return + Make_Function_Call (Loc, + Name => New_Reference_To (E, Loc), + Parameter_Associations => New_List (Concurrent_Ref (N))); + end Build_Call_With_Task; + + -------------------------------- + -- Build_Corresponding_Record -- + -------------------------------- + + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Entity_Id; + Loc : Source_Ptr) + return Node_Id + is + Rec_Ent : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_External_Name (Chars (Ctyp), 'V')); + Disc : Entity_Id; + Dlist : List_Id; + New_Disc : Entity_Id; + Cdecls : List_Id; + + begin + Set_Corresponding_Record_Type (Ctyp, Rec_Ent); + Set_Ekind (Rec_Ent, E_Record_Type); + Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); + Set_Is_Concurrent_Record_Type (Rec_Ent, True); + Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); + Set_Girder_Constraint (Rec_Ent, No_Elist); + Cdecls := New_List; + + -- Use discriminals to create list of discriminants for record, and + -- create new discriminals for use in default expressions, etc. It is + -- worth noting that a task discriminant gives rise to 5 entities; + + -- a) The original discriminant. + -- b) The discriminal for use in the task. + -- c) The discriminant of the corresponding record. + -- d) The discriminal for the init_proc of the corresponding record. + -- e) The local variable that renames the discriminant in the procedure + -- for the task body. + + -- In fact the discriminals b) are used in the renaming declarations + -- for e). See details in einfo (Handling of Discriminants). + + if Present (Discriminant_Specifications (N)) then + Dlist := New_List; + Disc := First_Discriminant (Ctyp); + + while Present (Disc) loop + New_Disc := CR_Discriminant (Disc); + + Append_To (Dlist, + Make_Discriminant_Specification (Loc, + Defining_Identifier => New_Disc, + Discriminant_Type => + New_Occurrence_Of (Etype (Disc), Loc), + Expression => + New_Copy (Discriminant_Default_Value (Disc)))); + + Next_Discriminant (Disc); + end loop; + + else + Dlist := No_List; + end if; + + -- Now we can construct the record type declaration. Note that this + -- record is limited, reflecting the underlying limitedness of the + -- task or protected object that it represents, and ensuring for + -- example that it is properly passed by reference. + + return + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Rec_Ent, + Discriminant_Specifications => Dlist, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Cdecls), + Limited_Present => True)); + end Build_Corresponding_Record; + + ---------------------------------- + -- Build_Entry_Count_Expression -- + ---------------------------------- + + function Build_Entry_Count_Expression + (Concurrent_Type : Node_Id; + Component_List : List_Id; + Loc : Source_Ptr) + return Node_Id + is + Eindx : Nat; + Ent : Entity_Id; + Ecount : Node_Id; + Comp : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Typ : Entity_Id; + + begin + Ent := First_Entity (Concurrent_Type); + Eindx := 0; + + -- Count number of non-family entries + + while Present (Ent) loop + if Ekind (Ent) = E_Entry then + Eindx := Eindx + 1; + end if; + + Next_Entity (Ent); + end loop; + + Ecount := Make_Integer_Literal (Loc, Eindx); + + -- Loop through entry families building the addition nodes + + Ent := First_Entity (Concurrent_Type); + Comp := First (Component_List); + + while Present (Ent) loop + if Ekind (Ent) = E_Entry_Family then + while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop + Next (Comp); + end loop; + + Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); + Hi := Type_High_Bound (Typ); + Lo := Type_Low_Bound (Typ); + + Ecount := + Make_Op_Add (Loc, + Left_Opnd => Ecount, + Right_Opnd => Family_Size (Loc, Hi, Lo, Concurrent_Type)); + end if; + + Next_Entity (Ent); + end loop; + + return Ecount; + end Build_Entry_Count_Expression; + + --------------------------- + -- Build_Find_Body_Index -- + --------------------------- + + function Build_Find_Body_Index + (Typ : Entity_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Ent : Entity_Id; + E_Typ : Entity_Id; + Has_F : Boolean := False; + Index : Nat; + If_St : Node_Id := Empty; + Lo : Node_Id; + Hi : Node_Id; + Decls : List_Id := New_List; + Ret : Node_Id; + Spec : Node_Id; + Siz : Node_Id := Empty; + + procedure Add_If_Clause (Expr : Node_Id); + -- Add test for range of current entry. + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- If a bound of an entry is given by a discriminant, retrieve the + -- actual value of the discriminant from the enclosing object. + + ------------------- + -- Add_If_Clause -- + ------------------- + + procedure Add_If_Clause (Expr : Node_Id) is + Cond : Node_Id; + Stats : constant List_Id := + New_List ( + Make_Return_Statement (Loc, + Expression => Make_Integer_Literal (Loc, Index + 1))); + + begin + -- Index for current entry body. + + Index := Index + 1; + + -- Compute total length of entry queues so far. + + if No (Siz) then + Siz := Expr; + else + Siz := + Make_Op_Add (Loc, + Left_Opnd => Siz, + Right_Opnd => Expr); + end if; + + Cond := + Make_Op_Le (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uE), + Right_Opnd => Siz); + + -- Map entry queue indices in the range of the current family + -- into the current index, that designates the entry body. + + if No (If_St) then + If_St := + Make_Implicit_If_Statement (Typ, + Condition => Cond, + Then_Statements => Stats, + Elsif_Parts => New_List); + + Ret := If_St; + + else + Append ( + Make_Elsif_Part (Loc, + Condition => Cond, + Then_Statements => Stats), + Elsif_Parts (If_St)); + end if; + + end Add_If_Clause; + + ------------------------------ + -- Convert_Discriminant_Ref -- + ------------------------------ + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is + B : Node_Id; + + begin + if Is_Entity_Name (Bound) + and then Ekind (Entity (Bound)) = E_Discriminant + then + B := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Typ), + Make_Explicit_Dereference (Loc, + Make_Identifier (Loc, Name_uObject))), + Selector_Name => Make_Identifier (Loc, Chars (Bound))); + Set_Etype (B, Etype (Entity (Bound))); + else + B := New_Copy_Tree (Bound); + end if; + + return B; + end Convert_Discriminant_Ref; + + -- Start of processing for Build_Find_Body_Index + + begin + Spec := Build_Find_Body_Index_Spec (Typ); + + Ent := First_Entity (Typ); + + while Present (Ent) loop + + if Ekind (Ent) = E_Entry_Family then + Has_F := True; + exit; + end if; + + Next_Entity (Ent); + end loop; + + if not Has_F then + + -- If the protected type has no entry families, there is a one-one + -- correspondence between entry queue and entry body. + + Ret := + Make_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_uE)); + + else + -- Suppose entries e1, e2, ... have size l1, l2, ... we generate + -- the following: + -- + -- if E <= l1 then return 1; + -- elsif E <= l1 + l2 then return 2; + -- ... + + Index := 0; + Siz := Empty; + Ent := First_Entity (Typ); + + Add_Object_Pointer (Decls, Typ, Loc); + + while Present (Ent) loop + + if Ekind (Ent) = E_Entry then + Add_If_Clause (Make_Integer_Literal (Loc, 1)); + + elsif Ekind (Ent) = E_Entry_Family then + + E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); + Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); + Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); + Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ)); + end if; + + Next_Entity (Ent); + end loop; + + if Index = 1 then + Decls := New_List; + Ret := + Make_Return_Statement (Loc, + Expression => Make_Integer_Literal (Loc, 1)); + + elsif Nkind (Ret) = N_If_Statement then + + -- Ranges are in increasing order, so last one doesn't need a + -- guard. + + declare + Nod : constant Node_Id := Last (Elsif_Parts (Ret)); + + begin + Remove (Nod); + Set_Else_Statements (Ret, Then_Statements (Nod)); + end; + end if; + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Ret))); + + end Build_Find_Body_Index; + + -------------------------------- + -- Build_Find_Body_Index_Spec -- + -------------------------------- + + function Build_Find_Body_Index_Spec + (Typ : Entity_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'F')); + Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); + Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); + + begin + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Parm1, + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Parm2, + Parameter_Type => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), + Subtype_Mark => New_Occurrence_Of ( + RTE (RE_Protected_Entry_Index), Loc)); + + end Build_Find_Body_Index_Spec; + + ------------------------- + -- Build_Master_Entity -- + ------------------------- + + procedure Build_Master_Entity (E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + P : Node_Id; + Decl : Node_Id; + + begin + -- Nothing to do if we already built a master entity for this scope + -- or if there is no task hierarchy. + + if Has_Master_Entity (Scope (E)) + or else Restrictions (No_Task_Hierarchy) + then + return; + end if; + + -- Otherwise first build the master entity + -- _Master : constant Master_Id := Current_Master.all; + -- and insert it just before the current declaration + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); + + P := Parent (E); + Insert_Before (P, Decl); + Analyze (Decl); + Set_Has_Master_Entity (Scope (E)); + + -- Now mark the containing scope as a task master + + while Nkind (P) /= N_Compilation_Unit loop + P := Parent (P); + + -- If we fall off the top, we are at the outer level, and the + -- environment task is our effective master, so nothing to mark. + + if Nkind (P) = N_Task_Body + or else Nkind (P) = N_Block_Statement + or else Nkind (P) = N_Subprogram_Body + then + Set_Is_Task_Master (P, True); + return; + + elsif Nkind (Parent (P)) = N_Subunit then + P := Corresponding_Stub (Parent (P)); + end if; + end loop; + end Build_Master_Entity; + + --------------------------- + -- Build_Protected_Entry -- + --------------------------- + + function Build_Protected_Entry + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Edef : Entity_Id; + Espec : Node_Id; + Op_Decls : List_Id := New_List; + Op_Stats : List_Id; + Ohandle : Node_Id; + Complete : Node_Id; + + begin + Edef := + Make_Defining_Identifier (Loc, + Chars => Chars (Protected_Body_Subprogram (Ent))); + Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc); + + -- <object pointer declaration> + -- Add object pointer declaration. This is needed by the + -- discriminal and prival renamings, which should already + -- have been inserted into the declaration list. + + Add_Object_Pointer (Op_Decls, Pid, Loc); + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Pid) > 1 + then + Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc); + else + Complete := + New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc); + end if; + + Op_Stats := New_List ( + Make_Block_Statement (Loc, + Declarations => Declarations (N), + Handled_Statement_Sequence => + Handled_Statement_Sequence (N)), + + Make_Procedure_Call_Statement (Loc, + Name => Complete, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uObject), + + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + + if Restrictions (No_Exception_Handlers) then + return + Make_Subprogram_Body (Loc, + Specification => Espec, + Declarations => Op_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Op_Stats)); + + else + Ohandle := Make_Others_Choice (Loc); + Set_All_Others (Ohandle); + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Pid) > 1 + then + Complete := + New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc); + + else + Complete := New_Reference_To ( + RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Espec, + Declarations => Op_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Op_Stats, + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List (Ohandle), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => Complete, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uObject), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access), + + Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Get_GNAT_Exception), Loc))))))))); + end if; + end Build_Protected_Entry; + + ----------------------------------------- + -- Build_Protected_Entry_Specification -- + ----------------------------------------- + + function Build_Protected_Entry_Specification + (Def_Id : Entity_Id; + Ent_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id + is + P : Entity_Id; + + begin + P := Make_Defining_Identifier (Loc, Name_uP); + + if Present (Ent_Id) then + Append_Elmt (P, Accept_Address (Ent_Id)); + end if; + + return Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => P, + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), + Parameter_Type => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)))); + end Build_Protected_Entry_Specification; + + -------------------------- + -- Build_Protected_Spec -- + -------------------------- + + function Build_Protected_Spec + (N : Node_Id; + Obj_Type : Entity_Id; + Unprotected : Boolean := False; + Ident : Entity_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Formal : Entity_Id; + New_Plist : List_Id; + New_Param : Node_Id; + + begin + New_Plist := New_List; + Formal := First_Formal (Ident); + + while Present (Formal) loop + New_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc)); + + if Unprotected then + Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); + end if; + + Append (New_Param, New_Plist); + Next_Formal (Formal); + end loop; + + -- If the subprogram is a procedure and the context is not an access + -- to protected subprogram, the parameter is in-out. Otherwise it is + -- an in parameter. + + Prepend_To (New_Plist, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + In_Present => True, + Out_Present => + (Etype (Ident) = Standard_Void_Type + and then not Is_RTE (Obj_Type, RE_Address)), + Parameter_Type => New_Reference_To (Obj_Type, Loc))); + + return New_Plist; + end Build_Protected_Spec; + + --------------------------------------- + -- Build_Protected_Sub_Specification -- + --------------------------------------- + + function Build_Protected_Sub_Specification + (N : Node_Id; + Prottyp : Entity_Id; + Unprotected : Boolean := False) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Protnm : constant Name_Id := Chars (Prottyp); + Ident : Entity_Id; + Nam : Name_Id; + New_Plist : List_Id; + Append_Char : Character; + New_Spec : Node_Id; + + begin + if Ekind + (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body + then + Decl := Unit_Declaration_Node (Corresponding_Spec (N)); + else + Decl := N; + end if; + + Ident := Defining_Unit_Name (Specification (Decl)); + Nam := Chars (Ident); + + New_Plist := Build_Protected_Spec + (Decl, Corresponding_Record_Type (Prottyp), + Unprotected, Ident); + + if Unprotected then + Append_Char := 'N'; + else + Append_Char := 'P'; + end if; + + if Nkind (Specification (Decl)) = N_Procedure_Specification then + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Build_Selected_Name (Protnm, Nam, Append_Char)), + Parameter_Specifications => New_Plist); + + else + New_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Build_Selected_Name (Protnm, Nam, Append_Char)), + Parameter_Specifications => New_Plist, + Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl)))); + Set_Return_Present (Defining_Unit_Name (New_Spec)); + return New_Spec; + end if; + end Build_Protected_Sub_Specification; + + ------------------------------------- + -- Build_Protected_Subprogram_Body -- + ------------------------------------- + + function Build_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Op_Spec : Node_Id; + Op_Def : Entity_Id; + Sub_Name : Name_Id; + P_Op_Spec : Node_Id; + Uactuals : List_Id; + Pformal : Node_Id; + Unprot_Call : Node_Id; + Sub_Body : Node_Id; + Lock_Name : Node_Id; + Lock_Stmt : Node_Id; + Unlock_Name : Node_Id; + Unlock_Stmt : Node_Id; + Service_Name : Node_Id; + Service_Stmt : Node_Id; + R : Node_Id; + Return_Stmt : Node_Id := Empty; + Pre_Stmts : List_Id := No_List; + -- Initializations to avoid spurious warnings from GCC3. + Stmts : List_Id; + Object_Parm : Node_Id; + Exc_Safe : Boolean; + + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; + -- Tell whether a given subprogram cannot raise an exception + + ----------------------- + -- Is_Exception_Safe -- + ----------------------- + + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is + + function Has_Side_Effect (N : Node_Id) return Boolean; + -- Return True whenever encountering a subprogram call or a + -- raise statement of any kind in the sequence of statements N + + --------------------- + -- Has_Side_Effect -- + --------------------- + + -- What is this doing buried two levels down in exp_ch9. It + -- seems like a generally useful function, and indeed there + -- may be code duplication going on here ??? + + function Has_Side_Effect (N : Node_Id) return Boolean is + Stmt : Node_Id := N; + Expr : Node_Id; + + function Is_Call_Or_Raise (N : Node_Id) return Boolean; + -- Indicate whether N is a subprogram call or a raise statement + + function Is_Call_Or_Raise (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Procedure_Call_Statement + or else Nkind (N) = N_Function_Call + or else Nkind (N) = N_Raise_Statement + or else Nkind (N) = N_Raise_Constraint_Error + or else Nkind (N) = N_Raise_Program_Error + or else Nkind (N) = N_Raise_Storage_Error; + end Is_Call_Or_Raise; + + -- Start of processing for Has_Side_Effect + + begin + while Present (Stmt) loop + if Is_Call_Or_Raise (Stmt) then + return True; + end if; + + -- An object declaration can also contain a function call + -- or a raise statement + + if Nkind (Stmt) = N_Object_Declaration then + Expr := Expression (Stmt); + + if Present (Expr) and then Is_Call_Or_Raise (Expr) then + return True; + end if; + end if; + + Next (Stmt); + end loop; + + return False; + end Has_Side_Effect; + + -- Start of processing for Is_Exception_Safe + + begin + -- If the checks handled by the back end are not disabled, we cannot + -- ensure that no exception will be raised. + + if not Access_Checks_Suppressed (Empty) + or else not Discriminant_Checks_Suppressed (Empty) + or else not Range_Checks_Suppressed (Empty) + or else not Index_Checks_Suppressed (Empty) + or else Opt.Stack_Checking_Enabled + then + return False; + end if; + + if Has_Side_Effect (First (Declarations (Subprogram))) + or else + Has_Side_Effect ( + First (Statements (Handled_Statement_Sequence (Subprogram)))) + then + return False; + else + return True; + end if; + end Is_Exception_Safe; + + -- Start of processing for Build_Protected_Subprogram_Body + + begin + Op_Spec := Specification (N); + Op_Def := Defining_Unit_Name (Op_Spec); + Exc_Safe := Is_Exception_Safe (N); + + Sub_Name := Chars (Defining_Unit_Name (Specification (N))); + + P_Op_Spec := + Build_Protected_Sub_Specification (N, + Pid, Unprotected => False); + + -- Build a list of the formal parameters of the protected + -- version of the subprogram to use as the actual parameters + -- of the unprotected version. + + Uactuals := New_List; + Pformal := First (Parameter_Specifications (P_Op_Spec)); + + while Present (Pformal) loop + Append ( + Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))), + Uactuals); + Next (Pformal); + end loop; + + -- Make a call to the unprotected version of the subprogram + -- built above for use by the protected version built below. + + if Nkind (Op_Spec) = N_Function_Specification then + if Exc_Safe then + R := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Unprot_Call := + Make_Object_Declaration (Loc, + Defining_Identifier => R, + Constant_Present => True, + Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)), + Expression => + Make_Function_Call (Loc, + Name => Make_Identifier (Loc, + Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + Return_Stmt := Make_Return_Statement (Loc, + Expression => New_Reference_To (R, Loc)); + + else + Unprot_Call := Make_Return_Statement (Loc, + Expression => Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, + Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + end if; + + else + Unprot_Call := Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, + Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals); + end if; + + -- Wrap call in block that will be covered by an at_end handler. + + if not Exc_Safe then + Unprot_Call := Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Unprot_Call))); + end if; + + -- Make the protected subprogram body. This locks the protected + -- object and calls the unprotected version of the subprogram. + + -- If the protected object is controlled (i.e it has entries or + -- needs finalization for interrupt handling), call Lock_Entries, + -- except if the protected object follows the Ravenscar profile, in + -- which case call Lock_Entry, otherwise call the simplified version, + -- Lock. + + if Has_Entries (Pid) + or else Has_Interrupt_Handler (Pid) + or else Has_Attach_Handler (Pid) + then + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Pid) > 1 + then + Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc); + Unlock_Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); + Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc); + + else + Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc); + Unlock_Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); + Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc); + end if; + + else + Lock_Name := New_Reference_To (RTE (RE_Lock), Loc); + Unlock_Name := New_Reference_To (RTE (RE_Unlock), Loc); + Service_Name := Empty; + end if; + + Object_Parm := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uObject), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access); + + Lock_Stmt := Make_Procedure_Call_Statement (Loc, + Name => Lock_Name, + Parameter_Associations => New_List (Object_Parm)); + + if Abort_Allowed then + Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Defer), Loc), + Parameter_Associations => Empty_List), + Lock_Stmt); + + else + Stmts := New_List (Lock_Stmt); + end if; + + if not Exc_Safe then + Append (Unprot_Call, Stmts); + else + if Nkind (Op_Spec) = N_Function_Specification then + Pre_Stmts := Stmts; + Stmts := Empty_List; + else + Append (Unprot_Call, Stmts); + end if; + + if Service_Name /= Empty then + Service_Stmt := Make_Procedure_Call_Statement (Loc, + Name => Service_Name, + Parameter_Associations => + New_List (New_Copy_Tree (Object_Parm))); + Append (Service_Stmt, Stmts); + end if; + + Unlock_Stmt := + Make_Procedure_Call_Statement (Loc, + Name => Unlock_Name, + Parameter_Associations => New_List ( + New_Copy_Tree (Object_Parm))); + Append (Unlock_Stmt, Stmts); + + if Abort_Allowed then + Append ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => Empty_List), + Stmts); + end if; + + if Nkind (Op_Spec) = N_Function_Specification then + Append (Return_Stmt, Stmts); + Append (Make_Block_Statement (Loc, + Declarations => New_List (Unprot_Call), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)), Pre_Stmts); + Stmts := Pre_Stmts; + end if; + end if; + + Sub_Body := + Make_Subprogram_Body (Loc, + Declarations => Empty_List, + Specification => P_Op_Spec, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); + + if not Exc_Safe then + Set_Is_Protected_Subprogram_Body (Sub_Body); + end if; + + return Sub_Body; + end Build_Protected_Subprogram_Body; + + ------------------------------------- + -- Build_Protected_Subprogram_Call -- + ------------------------------------- + + procedure Build_Protected_Subprogram_Call + (N : Node_Id; + Name : Node_Id; + Rec : Node_Id; + External : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (N); + Sub : Entity_Id := Entity (Name); + New_Sub : Node_Id; + Params : List_Id; + + begin + if External then + New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); + else + New_Sub := + New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); + end if; + + if Present (Parameter_Associations (N)) then + Params := New_Copy_List_Tree (Parameter_Associations (N)); + else + Params := New_List; + end if; + + Prepend (Rec, Params); + + if Ekind (Sub) = E_Procedure then + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Sub, + Parameter_Associations => Params)); + + else + pragma Assert (Ekind (Sub) = E_Function); + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Sub, + Parameter_Associations => Params)); + end if; + + if External + and then Nkind (Rec) = N_Unchecked_Type_Conversion + and then Is_Entity_Name (Expression (Rec)) + and then Is_Shared_Passive (Entity (Expression (Rec))) + then + Add_Shared_Var_Lock_Procs (N); + end if; + + end Build_Protected_Subprogram_Call; + + ------------------------- + -- Build_Selected_Name -- + ------------------------- + + function Build_Selected_Name + (Prefix, Selector : Name_Id; + Append_Char : Character := ' ') + return Name_Id + is + Select_Buffer : String (1 .. Hostparm.Max_Name_Length); + Select_Len : Natural; + + begin + Get_Name_String (Selector); + Select_Len := Name_Len; + Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); + Get_Name_String (Prefix); + + -- If scope is anonymous type, discard suffix to recover name of + -- single protected object. Otherwise use protected type name. + + if Name_Buffer (Name_Len) = 'T' then + Name_Len := Name_Len - 1; + end if; + + Name_Buffer (Name_Len + 1) := 'P'; + Name_Buffer (Name_Len + 2) := 'T'; + Name_Buffer (Name_Len + 3) := '_'; + Name_Buffer (Name_Len + 4) := '_'; + + Name_Len := Name_Len + 4; + for J in 1 .. Select_Len loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Select_Buffer (J); + end loop; + + if Append_Char /= ' ' then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Append_Char; + end if; + + return Name_Find; + end Build_Selected_Name; + + ----------------------------- + -- Build_Simple_Entry_Call -- + ----------------------------- + + -- A task entry call is converted to a call to Call_Simple + + -- declare + -- P : parms := (parm, parm, parm); + -- begin + -- Call_Simple (acceptor-task, entry-index, P'Address); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- Here Pnn is an aggregate of the type constructed for the entry to hold + -- the parameters, and the constructed aggregate value contains either the + -- parameters or, in the case of non-elementary types, references to these + -- parameters. Then the address of this aggregate is passed to the runtime + -- routine, along with the task id value and the task entry index value. + -- Pnn is only required if parameters are present. + + -- The assignments after the call are present only in the case of in-out + -- or out parameters for elementary types, and are used to assign back the + -- resulting values of such parameters. + + -- Note: the reason that we insert a block here is that in the context + -- of selects, conditional entry calls etc. the entry call statement + -- appears on its own, not as an element of a list. + + -- A protected entry call is converted to a Protected_Entry_Call: + + -- declare + -- P : E1_Params := (param, param, param); + -- Pnn : Boolean; + -- Bnn : Communications_Block; + + -- declare + -- P : E1_Params := (param, param, param); + -- Bnn : Communications_Block; + + -- begin + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => <entry index>; + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call; + -- Block => Bnn); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + procedure Build_Simple_Entry_Call + (N : Node_Id; + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id) + is + begin + Expand_Call (N); + + -- Convert entry call to Call_Simple call + + declare + Loc : constant Source_Ptr := Sloc (N); + Parms : constant List_Id := Parameter_Associations (N); + Pdecl : Node_Id; + Xdecl : Node_Id; + Decls : List_Id; + Conctyp : Node_Id; + Ent : Entity_Id; + Ent_Acc : Entity_Id; + P : Entity_Id; + X : Entity_Id; + Plist : List_Id; + Parm1 : Node_Id; + Parm2 : Node_Id; + Parm3 : Node_Id; + Call : Node_Id; + Actual : Node_Id; + Formal : Node_Id; + N_Node : Node_Id; + N_Var : Node_Id; + Stats : List_Id := New_List; + Comm_Name : Entity_Id; + + begin + -- Simple entry and entry family cases merge here + + Ent := Entity (Ename); + Ent_Acc := Entry_Parameters_Type (Ent); + Conctyp := Etype (Concval); + + -- If prefix is an access type, dereference to obtain the task type + + if Is_Access_Type (Conctyp) then + Conctyp := Designated_Type (Conctyp); + end if; + + -- Special case for protected subprogram calls. + + if Is_Protected_Type (Conctyp) + and then Is_Subprogram (Entity (Ename)) + then + Build_Protected_Subprogram_Call + (N, Ename, Convert_Concurrent (Concval, Conctyp)); + Analyze (N); + return; + end if; + + -- First parameter is the Task_Id value from the task value or the + -- Object from the protected object value, obtained by selecting + -- the _Task_Id or _Object from the result of doing an unchecked + -- conversion to convert the value to the corresponding record type. + + Parm1 := Concurrent_Ref (Concval); + + -- Second parameter is the entry index, computed by the routine + -- provided for this purpose. The value of this expression is + -- assigned to an intermediate variable to assure that any entry + -- family index expressions are evaluated before the entry + -- parameters. + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else not Is_Protected_Type (Conctyp) + or else Number_Entries (Conctyp) > 1 + then + X := Make_Defining_Identifier (Loc, Name_uX); + + Xdecl := + Make_Object_Declaration (Loc, + Defining_Identifier => X, + Object_Definition => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Actual_Index_Expression ( + Loc, Entity (Ename), Index, Concval)); + + Decls := New_List (Xdecl); + Parm2 := New_Reference_To (X, Loc); + + else + Xdecl := Empty; + Decls := New_List; + Parm2 := Empty; + end if; + + -- The third parameter is the packaged parameters. If there are + -- none, then it is just the null address, since nothing is passed + + if No (Parms) then + Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc); + P := Empty; + + -- Case of parameters present, where third argument is the address + -- of a packaged record containing the required parameter values. + + else + -- First build a list of parameter values, which are + -- references to objects of the parameter types. + + Plist := New_List; + + Actual := First_Actual (N); + Formal := First_Formal (Ent); + + while Present (Actual) loop + + -- If it is a by_copy_type, copy it to a new variable. The + -- packaged record has a field that points to this variable. + + if Is_By_Copy_Type (Etype (Actual)) then + N_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('I')), + Aliased_Present => True, + Object_Definition => + New_Reference_To (Etype (Formal), Loc)); + + -- We have to make an assignment statement separate for + -- the case of limited type. We can not assign it unless + -- the Assignment_OK flag is set first. + + if Ekind (Formal) /= E_Out_Parameter then + N_Var := + New_Reference_To (Defining_Identifier (N_Node), Loc); + Set_Assignment_OK (N_Var); + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => N_Var, + Expression => Relocate_Node (Actual))); + end if; + + Append (N_Node, Decls); + + Append_To (Plist, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + New_Reference_To (Defining_Identifier (N_Node), Loc))); + else + Append_To (Plist, + Make_Reference (Loc, Prefix => Relocate_Node (Actual))); + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + -- Now build the declaration of parameters initialized with the + -- aggregate containing this constructed parameter list. + + P := Make_Defining_Identifier (Loc, Name_uP); + + Pdecl := + Make_Object_Declaration (Loc, + Defining_Identifier => P, + Object_Definition => + New_Reference_To (Designated_Type (Ent_Acc), Loc), + Expression => + Make_Aggregate (Loc, Expressions => Plist)); + + Parm3 := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Reference_To (P, Loc)); + + Append (Pdecl, Decls); + end if; + + -- Now we can create the call, case of protected type + + if Is_Protected_Type (Conctyp) then + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Conctyp) > 1 + then + -- Change the type of the index declaration + + Set_Object_Definition (Xdecl, + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)); + + -- Some additional declarations for protected entry calls + + if No (Decls) then + Decls := New_List; + end if; + + -- Bnn : Communications_Block; + + Comm_Name := + Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Comm_Name, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Some additional statements for protected entry calls + + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => <entry index>; + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call; + -- Block => Bnn); + + Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => Parm1), + Parm2, + Parm3, + New_Reference_To (RTE (RE_Simple_Call), Loc), + New_Occurrence_Of (Comm_Name, Loc))); + + else + -- Protected_Single_Entry_Call ( + -- Object => po._object'Access, + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call); + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Protected_Single_Entry_Call), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => Parm1), + Parm3, + New_Reference_To (RTE (RE_Simple_Call), Loc))); + end if; + + -- Case of task type + + else + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Call_Simple), Loc), + Parameter_Associations => New_List (Parm1, Parm2, Parm3)); + + end if; + + Append_To (Stats, Call); + + -- If there are out or in/out parameters by copy + -- add assignment statements for the result values. + + if Present (Parms) then + Actual := First_Actual (N); + Formal := First_Formal (Ent); + + Set_Assignment_OK (Actual); + while Present (Actual) loop + if Is_By_Copy_Type (Etype (Actual)) + and then Ekind (Formal) /= E_In_Parameter + then + N_Node := + Make_Assignment_Statement (Loc, + Name => New_Copy (Actual), + Expression => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => New_Reference_To (P, Loc), + Selector_Name => + Make_Identifier (Loc, Chars (Formal))))); + + -- In all cases (including limited private types) we + -- want the assignment to be valid. + + Set_Assignment_OK (Name (N_Node)); + + -- If the call is the triggering alternative in an + -- asynchronous select, or the entry_call alternative + -- of a conditional entry call, the assignments for in-out + -- parameters are incorporated into the statement list + -- that follows, so that there are executed only if the + -- entry call succeeds. + + if (Nkind (Parent (N)) = N_Triggering_Alternative + and then N = Triggering_Statement (Parent (N))) + or else + (Nkind (Parent (N)) = N_Entry_Call_Alternative + and then N = Entry_Call_Statement (Parent (N))) + then + if No (Statements (Parent (N))) then + Set_Statements (Parent (N), New_List); + end if; + + Prepend (N_Node, Statements (Parent (N))); + + else + Insert_After (Call, N_Node); + end if; + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + end if; + + -- Finally, create block and analyze it + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats))); + + Analyze (N); + end; + + end Build_Simple_Entry_Call; + + -------------------------------- + -- Build_Task_Activation_Call -- + -------------------------------- + + procedure Build_Task_Activation_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Chain : Entity_Id; + Call : Node_Id; + Name : Node_Id; + P : Node_Id; + + begin + -- Get the activation chain entity. Except in the case of a package + -- body, this is in the node that was passed. For a package body, we + -- have to find the corresponding package declaration node. + + if Nkind (N) = N_Package_Body then + P := Corresponding_Spec (N); + + loop + P := Parent (P); + exit when Nkind (P) = N_Package_Declaration; + end loop; + + Chain := Activation_Chain_Entity (P); + + else + Chain := Activation_Chain_Entity (N); + end if; + + if Present (Chain) then + if Restricted_Profile then + Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc); + else + Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc); + end if; + + Call := + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => + New_List (Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Chain, Loc), + Attribute_Name => Name_Unchecked_Access))); + + if Nkind (N) = N_Package_Declaration then + if Present (Corresponding_Body (N)) then + null; + + elsif Present (Private_Declarations (Specification (N))) then + Append (Call, Private_Declarations (Specification (N))); + + else + Append (Call, Visible_Declarations (Specification (N))); + end if; + + else + if Present (Handled_Statement_Sequence (N)) then + + -- The call goes at the start of the statement sequence, but + -- after the start of exception range label if one is present. + + declare + Stm : Node_Id; + + begin + Stm := First (Statements (Handled_Statement_Sequence (N))); + + if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then + Next (Stm); + end if; + + Insert_Before (Stm, Call); + end; + + else + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call))); + end if; + end if; + + Analyze (Call); + Check_Task_Activation (N); + end if; + + end Build_Task_Activation_Call; + + ------------------------------- + -- Build_Task_Allocate_Block -- + ------------------------------- + + procedure Build_Task_Allocate_Block + (Actions : List_Id; + N : Node_Id; + Args : List_Id) + is + T : constant Entity_Id := Entity (Expression (N)); + Init : constant Entity_Id := Base_Init_Proc (T); + Loc : constant Source_Ptr := Sloc (N); + + Chain : Entity_Id := Make_Defining_Identifier (Loc, Name_uChain); + Blkent : Entity_Id; + Block : Node_Id; + + begin + Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blkent, Loc), + Declarations => New_List ( + + -- _Chain : Activation_Chain; + + Make_Object_Declaration (Loc, + Defining_Identifier => Chain, + Aliased_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Activation_Chain), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + + Statements => New_List ( + + -- Init (Args); + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Init, Loc), + Parameter_Associations => Args), + + -- Activate_Tasks (_Chain); + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Chain, Loc), + Attribute_Name => Name_Unchecked_Access))))), + + Has_Created_Identifier => True, + Is_Task_Allocation_Block => True); + + Append_To (Actions, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blkent, + Label_Construct => Block)); + + Append_To (Actions, Block); + + Set_Activation_Chain_Entity (Block, Chain); + + end Build_Task_Allocate_Block; + + ----------------------------------- + -- Build_Task_Proc_Specification -- + ----------------------------------- + + function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (T); + Nam : constant Name_Id := Chars (T); + Tdec : constant Node_Id := Declaration_Node (T); + Ent : Entity_Id; + + begin + Ent := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Nam, 'B')); + Set_Is_Internal (Ent); + + -- Associate the procedure with the task, if this is the declaration + -- (and not the body) of the procedure. + + if No (Task_Body_Procedure (Tdec)) then + Set_Task_Body_Procedure (Tdec, Ent); + end if; + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Ent, + Parameter_Specifications => + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To + (Corresponding_Record_Type (T), Loc))))); + + end Build_Task_Proc_Specification; + + --------------------------------------- + -- Build_Unprotected_Subprogram_Body -- + --------------------------------------- + + function Build_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Sub_Name : Name_Id; + N_Op_Spec : Node_Id; + Op_Decls : List_Id; + + begin + -- Make an unprotected version of the subprogram for use + -- within the same object, with a new name and an additional + -- parameter representing the object. + + Op_Decls := Declarations (N); + Sub_Name := Chars (Defining_Unit_Name (Specification (N))); + + N_Op_Spec := + Build_Protected_Sub_Specification + (N, Pid, Unprotected => True); + + return + Make_Subprogram_Body (Loc, + Specification => N_Op_Spec, + Declarations => Op_Decls, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N)); + + end Build_Unprotected_Subprogram_Body; + + ---------------------------- + -- Collect_Entry_Families -- + ---------------------------- + + procedure Collect_Entry_Families + (Loc : Source_Ptr; + Cdecls : List_Id; + Current_Node : in out Node_Id; + Conctyp : Entity_Id) + is + Efam : Entity_Id; + Efam_Decl : Node_Id; + Efam_Type : Entity_Id; + + begin + Efam := First_Entity (Conctyp); + + while Present (Efam) loop + + if Ekind (Efam) = E_Entry_Family then + Efam_Type := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('F')); + + Efam_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Efam_Type, + Type_Definition => + Make_Unconstrained_Array_Definition (Loc, + Subtype_Marks => (New_List ( + New_Occurrence_Of ( + Base_Type + (Etype (Discrete_Subtype_Definition + (Parent (Efam)))), Loc))), + + Subtype_Indication => + New_Reference_To (Standard_Character, Loc))); + + Insert_After (Current_Node, Efam_Decl); + Current_Node := Efam_Decl; + Analyze (Efam_Decl); + + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Efam)), + + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Efam_Type, Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + New_Occurrence_Of + (Etype (Discrete_Subtype_Definition + (Parent (Efam))), Loc)))))); + end if; + + Next_Entity (Efam); + end loop; + end Collect_Entry_Families; + + -------------------- + -- Concurrent_Ref -- + -------------------- + + -- The expression returned for a reference to a concurrent + -- object has the form: + + -- taskV!(name)._Task_Id + + -- for a task, and + + -- objectV!(name)._Object + + -- for a protected object. + + -- For the case of an access to a concurrent object, + -- there is an extra explicit dereference: + + -- taskV!(name.all)._Task_Id + -- objectV!(name.all)._Object + + -- here taskV and objectV are the types for the associated records, which + -- contain the required _Task_Id and _Object fields for tasks and + -- protected objects, respectively. + + -- For the case of a task type name, the expression is + + -- Self; + + -- i.e. a call to the Self function which returns precisely this Task_Id + + -- For the case of a protected type name, the expression is + + -- objectR + + -- which is a renaming of the _object field of the current object + -- object record, passed into protected operations as a parameter. + + function Concurrent_Ref (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Ntyp : constant Entity_Id := Etype (N); + Dtyp : Entity_Id; + Sel : Name_Id; + + function Is_Current_Task (T : Entity_Id) return Boolean; + -- Check whether the reference is to the immediately enclosing task + -- type, or to an outer one (rare but legal). + + --------------------- + -- Is_Current_Task -- + --------------------- + + function Is_Current_Task (T : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + Scop := Current_Scope; + while Present (Scop) + and then Scop /= Standard_Standard + loop + + if Scop = T then + return True; + + elsif Is_Task_Type (Scop) then + return False; + + -- If this is a procedure nested within the task type, we must + -- assume that it can be called from an inner task, and therefore + -- cannot treat it as a local reference. + + elsif Is_Overloadable (Scop) + and then In_Open_Scopes (T) + then + return False; + + else + Scop := Scope (Scop); + end if; + end loop; + + -- We know that we are within the task body, so should have + -- found it in scope. + + raise Program_Error; + end Is_Current_Task; + + -- Start of processing for Concurrent_Ref + + begin + if Is_Access_Type (Ntyp) then + Dtyp := Designated_Type (Ntyp); + + if Is_Protected_Type (Dtyp) then + Sel := Name_uObject; + else + Sel := Name_uTask_Id; + end if; + + return + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), + Make_Explicit_Dereference (Loc, N)), + Selector_Name => Make_Identifier (Loc, Sel)); + + elsif Is_Entity_Name (N) + and then Is_Concurrent_Type (Entity (N)) + then + if Is_Task_Type (Entity (N)) then + + if Is_Current_Task (Entity (N)) then + return + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Self), Loc)); + + else + declare + Decl : Node_Id; + T_Self : constant Entity_Id + := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + T_Body : constant Node_Id + := Parent (Corresponding_Body (Parent (Entity (N)))); + + begin + Decl := Make_Object_Declaration (Loc, + Defining_Identifier => T_Self, + Object_Definition => + New_Occurrence_Of (RTE (RO_ST_Task_ID), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Self), Loc))); + Prepend (Decl, Declarations (T_Body)); + Analyze (Decl); + Set_Scope (T_Self, Entity (N)); + return New_Occurrence_Of (T_Self, Loc); + end; + end if; + + else + pragma Assert (Is_Protected_Type (Entity (N))); + return + New_Reference_To ( + Object_Ref (Corresponding_Body (Parent (Base_Type (Ntyp)))), + Loc); + end if; + + else + pragma Assert (Is_Concurrent_Type (Ntyp)); + + if Is_Protected_Type (Ntyp) then + Sel := Name_uObject; + else + Sel := Name_uTask_Id; + end if; + + return + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), + New_Copy_Tree (N)), + Selector_Name => Make_Identifier (Loc, Sel)); + end if; + end Concurrent_Ref; + + ------------------------ + -- Convert_Concurrent -- + ------------------------ + + function Convert_Concurrent + (N : Node_Id; + Typ : Entity_Id) + return Node_Id + is + begin + if not Is_Concurrent_Type (Typ) then + return N; + else + return + Unchecked_Convert_To (Corresponding_Record_Type (Typ), + New_Copy_Tree (N)); + end if; + end Convert_Concurrent; + + ---------------------------- + -- Entry_Index_Expression -- + ---------------------------- + + function Entry_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Ttyp : Entity_Id) + return Node_Id + is + Expr : Node_Id; + Num : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Prev : Entity_Id; + S : Node_Id; + + begin + -- The queues of entries and entry families appear in textual + -- order in the associated record. The entry index is computed as + -- the sum of the number of queues for all entries that precede the + -- designated one, to which is added the index expression, if this + -- expression denotes a member of a family. + + -- The following is a place holder for the count of simple entries. + + Num := Make_Integer_Literal (Sloc, 1); + + -- We construct an expression which is a series of addition + -- operations. The first operand is the number of single entries that + -- precede this one, the second operand is the index value relative + -- to the start of the referenced family, and the remaining operands + -- are the lengths of the entry families that precede this entry, i.e. + -- the constructed expression is: + + -- number_simple_entries + + -- (s'pos (index-value) - s'pos (family'first)) + 1 + + -- family'length + ... + + -- where index-value is the given index value, and s is the index + -- subtype (we have to use pos because the subtype might be an + -- enumeration type preventing direct subtraction). + -- Note that the task entry array is one-indexed. + + -- The upper bound of the entry family may be a discriminant, so we + -- retrieve the lower bound explicitly to compute offset, rather than + -- using the index subtype which may mention a discriminant. + + if Present (Index) then + S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Num, + + Right_Opnd => + Family_Offset ( + Sloc, + Make_Attribute_Reference (Sloc, + Attribute_Name => Name_Pos, + Prefix => New_Reference_To (Base_Type (S), Sloc), + Expressions => New_List (Relocate_Node (Index))), + Type_Low_Bound (S), + Ttyp)); + else + Expr := Num; + end if; + + -- Now add lengths of preceding entries and entry families. + + Prev := First_Entity (Ttyp); + + while Chars (Prev) /= Chars (Ent) + or else (Ekind (Prev) /= Ekind (Ent)) + or else not Sem_Ch6.Type_Conformant (Ent, Prev) + loop + if Ekind (Prev) = E_Entry then + Set_Intval (Num, Intval (Num) + 1); + + elsif Ekind (Prev) = E_Entry_Family then + S := + Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); + Lo := Type_Low_Bound (S); + Hi := Type_High_Bound (S); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Expr, + Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp)); + + -- Other components are anonymous types to be ignored. + + else + null; + end if; + + Next_Entity (Prev); + end loop; + + return Expr; + end Entry_Index_Expression; + + --------------------------- + -- Establish_Task_Master -- + --------------------------- + + procedure Establish_Task_Master (N : Node_Id) is + Call : Node_Id; + + begin + if Restrictions (No_Task_Hierarchy) = False then + Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); + Prepend_To (Declarations (N), Call); + Analyze (Call); + end if; + end Establish_Task_Master; + + -------------------------------- + -- Expand_Accept_Declarations -- + -------------------------------- + + -- Part of the expansion of an accept statement involves the creation of + -- a declaration that can be referenced from the statement sequence of + -- the accept: + + -- Ann : Address; + + -- This declaration is inserted immediately before the accept statement + -- and it is important that it be inserted before the statements of the + -- statement sequence are analyzed. Thus it would be too late to create + -- this declaration in the Expand_N_Accept_Statement routine, which is + -- why there is a separate procedure to be called directly from Sem_Ch9. + + -- Ann is used to hold the address of the record containing the parameters + -- (see Expand_N_Entry_Call for more details on how this record is built). + -- References to the parameters do an unchecked conversion of this address + -- to a pointer to the required record type, and then access the field that + -- holds the value of the required parameter. The entity for the address + -- variable is held as the top stack element (i.e. the last element) of the + -- Accept_Address stack in the corresponding entry entity, and this element + -- must be set in place before the statements are processed. + + -- The above description applies to the case of a stand alone accept + -- statement, i.e. one not appearing as part of a select alternative. + + -- For the case of an accept that appears as part of a select alternative + -- of a selective accept, we must still create the declaration right away, + -- since Ann is needed immediately, but there is an important difference: + + -- The declaration is inserted before the selective accept, not before + -- the accept statement (which is not part of a list anyway, and so would + -- not accommodate inserted declarations) + + -- We only need one address variable for the entire selective accept. So + -- the Ann declaration is created only for the first accept alternative, + -- and subsequent accept alternatives reference the same Ann variable. + + -- We can distinguish the two cases by seeing whether the accept statement + -- is part of a list. If not, then it must be in an accept alternative. + + -- To expand the requeue statement, a label is provided at the end of + -- the accept statement or alternative of which it is a part, so that + -- the statement can be skipped after the requeue is complete. + -- This label is created here rather than during the expansion of the + -- accept statement, because it will be needed by any requeue + -- statements within the accept, which are expanded before the + -- accept. + + procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ann : Entity_Id := Empty; + Adecl : Node_Id; + Lab_Id : Node_Id; + Lab : Node_Id; + Ldecl : Node_Id; + Ldecl2 : Node_Id; + + begin + if Expander_Active then + + -- If we have no handled statement sequence, then build a dummy + -- sequence consisting of a null statement. This is only done if + -- pragma FIFO_Within_Priorities is specified. The issue here is + -- that even a null accept body has an effect on the called task + -- in terms of its position in the queue, so we cannot optimize + -- the context switch away. However, if FIFO_Within_Priorities + -- is not active, the optimization is legitimate, since we can + -- say that our dispatching policy (i.e. the default dispatching + -- policy) reorders the queue to be the same as just before the + -- call. In the absence of a specified dispatching policy, we are + -- allowed to modify queue orders for a given priority at will! + + if Opt.Task_Dispatching_Policy = 'F' and then + not Present (Handled_Statement_Sequence (N)) + then + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + -- Create and declare two labels to be placed at the end of the + -- accept statement. The first label is used to allow requeues to + -- skip the remainder of entry processing. The second label is + -- used to skip the remainder of entry processing if the rendezvous + -- completes in the middle of the accept body. + + if Present (Handled_Statement_Sequence (N)) then + Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); + Set_Entity (Lab_Id, + Make_Defining_Identifier (Loc, Chars (Lab_Id))); + Lab := Make_Label (Loc, Lab_Id); + Ldecl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Lab_Id), + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + + Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); + Set_Entity (Lab_Id, + Make_Defining_Identifier (Loc, Chars (Lab_Id))); + Lab := Make_Label (Loc, Lab_Id); + Ldecl2 := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Lab_Id), + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + + else + Ldecl := Empty; + Ldecl2 := Empty; + end if; + + -- Case of stand alone accept statement + + if Is_List_Member (N) then + + if Present (Handled_Statement_Sequence (N)) then + Ann := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + + Adecl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ann, + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc)); + + Insert_Before (N, Adecl); + Analyze (Adecl); + + Insert_Before (N, Ldecl); + Analyze (Ldecl); + + Insert_Before (N, Ldecl2); + Analyze (Ldecl2); + end if; + + -- Case of accept statement which is in an accept alternative + + else + declare + Acc_Alt : constant Node_Id := Parent (N); + Sel_Acc : constant Node_Id := Parent (Acc_Alt); + Alt : Node_Id; + + begin + pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); + pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); + + -- ??? Consider a single label for select statements. + + if Present (Handled_Statement_Sequence (N)) then + Prepend (Ldecl2, + Statements (Handled_Statement_Sequence (N))); + Analyze (Ldecl2); + + Prepend (Ldecl, + Statements (Handled_Statement_Sequence (N))); + Analyze (Ldecl); + end if; + + -- Find first accept alternative of the selective accept. A + -- valid selective accept must have at least one accept in it. + + Alt := First (Select_Alternatives (Sel_Acc)); + + while Nkind (Alt) /= N_Accept_Alternative loop + Next (Alt); + end loop; + + -- If we are the first accept statement, then we have to + -- create the Ann variable, as for the stand alone case, + -- except that it is inserted before the selective accept. + -- Similarly, a label for requeue expansion must be + -- declared. + + if N = Accept_Statement (Alt) then + Ann := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Adecl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ann, + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc)); + + Insert_Before (Sel_Acc, Adecl); + Analyze (Adecl); + + -- If we are not the first accept statement, then find the + -- Ann variable allocated by the first accept and use it. + + else + Ann := + Node (Last_Elmt (Accept_Address + (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); + end if; + end; + end if; + + -- Merge here with Ann either created or referenced, and Adecl + -- pointing to the corresponding declaration. Remaining processing + -- is the same for the two cases. + + if Present (Ann) then + Append_Elmt (Ann, Accept_Address (Ent)); + end if; + end if; + end Expand_Accept_Declarations; + + --------------------------------------------- + -- Expand_Access_Protected_Subprogram_Type -- + --------------------------------------------- + + procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Comps : List_Id; + T : constant Entity_Id := Defining_Identifier (N); + D_T : constant Entity_Id := Designated_Type (T); + D_T2 : constant Entity_Id := Make_Defining_Identifier + (Loc, New_Internal_Name ('D')); + E_T : constant Entity_Id := Make_Defining_Identifier + (Loc, New_Internal_Name ('E')); + P_List : constant List_Id := Build_Protected_Spec + (N, RTE (RE_Address), False, D_T); + Decl1 : Node_Id; + Decl2 : Node_Id; + Def1 : Node_Id; + + begin + -- Create access to protected subprogram with full signature. + + if Nkind (Type_Definition (N)) = N_Access_Function_Definition then + Def1 := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => P_List, + Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N)))); + + else + Def1 := + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => P_List); + end if; + + Decl1 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => D_T2, + Type_Definition => Def1); + + Insert_After (N, Decl1); + + -- Create Equivalent_Type, a record with two components for an + -- an access to object an an access to subprogram. + + Comps := New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('P')), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Subtype_Indication => + New_Occurrence_Of (D_T2, Loc))); + + Decl2 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => E_T, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Comps))); + + Insert_After (Decl1, Decl2); + Set_Equivalent_Type (T, E_T); + + end Expand_Access_Protected_Subprogram_Type; + + -------------------------- + -- Expand_Entry_Barrier -- + -------------------------- + + procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Func : Node_Id; + B_F : Node_Id; + Prot : constant Entity_Id := Scope (Ent); + Spec_Decl : Node_Id := Parent (Prot); + Body_Decl : Node_Id; + Cond : Node_Id := Condition (Entry_Body_Formal_Part (N)); + + begin + -- The body of the entry barrier must be analyzed in the context of + -- the protected object, but its scope is external to it, just as any + -- other unprotected version of a protected operation. The specification + -- has been produced when the protected type declaration was elaborated. + -- We build the body, insert it in the enclosing scope, but analyze it + -- in the current context. A more uniform approach would be to treat a + -- barrier just as a protected function, and discard the protected + -- version of it because it is never called. + + if Expander_Active then + B_F := Build_Barrier_Function (N, Ent, Prot); + Func := Barrier_Function (Ent); + Set_Corresponding_Spec (B_F, Func); + + Body_Decl := Parent (Corresponding_Body (Spec_Decl)); + + if Nkind (Parent (Body_Decl)) = N_Subunit then + Body_Decl := Corresponding_Stub (Parent (Body_Decl)); + end if; + + Insert_Before_And_Analyze (Body_Decl, B_F); + + Update_Prival_Subtypes (B_F); + + Set_Privals (Spec_Decl, N, Loc); + Set_Discriminals (Spec_Decl, N, Loc); + Set_Scope (Func, Scope (Prot)); + else + Analyze (Cond); + end if; + + -- The Ravenscar profile restricts barriers to simple variables + -- declared within the protected object. We also allow Boolean + -- constants, since these appear in several published examples + -- and are also allowed by the Aonix compiler. + + -- Note that after analysis variables in this context will be + -- replaced by the corresponding prival, that is to say a renaming + -- of a selected component of the form _Object.Var. If expansion is + -- disabled, as within a generic, we check that the entity appears in + -- the current scope. + + if Is_Entity_Name (Cond) then + + if Entity (Cond) = Standard_False + or else + Entity (Cond) = Standard_True + then + return; + + elsif not Expander_Active + and then Scope (Entity (Cond)) = Current_Scope + then + return; + + elsif Present (Renamed_Object (Entity (Cond))) + and then + Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component + and then + Chars (Prefix (Renamed_Object (Entity (Cond)))) = Name_uObject + then + return; + end if; + end if; + + -- It is not a boolean variable or literal, so check the restriction + + Check_Restriction (Boolean_Entry_Barriers, Cond); + end Expand_Entry_Barrier; + + ------------------------------------ + -- Expand_Entry_Body_Declarations -- + ------------------------------------ + + procedure Expand_Entry_Body_Declarations (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Index_Spec : Node_Id; + + begin + if Expander_Active then + + -- Expand entry bodies corresponding to entry families + -- by assigning a placeholder for the constant that will + -- be used to expand references to the entry index parameter. + + Index_Spec := + Entry_Index_Specification (Entry_Body_Formal_Part (N)); + + if Present (Index_Spec) then + Set_Entry_Index_Constant ( + Defining_Identifier (Index_Spec), + Make_Defining_Identifier (Loc, New_Internal_Name ('I'))); + end if; + + end if; + end Expand_Entry_Body_Declarations; + + ------------------------------ + -- Expand_N_Abort_Statement -- + ------------------------------ + + -- Expand abort T1, T2, .. Tn; into: + -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) + + procedure Expand_N_Abort_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Tlist : constant List_Id := Names (N); + Count : Nat; + Aggr : Node_Id; + Tasknm : Node_Id; + + begin + Aggr := Make_Aggregate (Loc, Component_Associations => New_List); + Count := 0; + + Tasknm := First (Tlist); + + while Present (Tasknm) loop + Count := Count + 1; + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Count)), + Expression => Concurrent_Ref (Tasknm))); + Next (Tasknm); + end loop; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc), + Parameter_Associations => New_List ( + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc), + Expression => Aggr)))); + + Analyze (N); + + end Expand_N_Abort_Statement; + + ------------------------------- + -- Expand_N_Accept_Statement -- + ------------------------------- + + -- This procedure handles expansion of accept statements that stand + -- alone, i.e. they are not part of an accept alternative. The expansion + -- of accept statement in accept alternatives is handled by the routines + -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The + -- following description applies only to stand alone accept statements. + + -- If there is no handled statement sequence, or only null statements, + -- then this is called a trivial accept, and the expansion is: + + -- Accept_Trivial (entry-index) + + -- If there is a handled statement sequence, then the expansion is: + + -- Ann : Address; + -- {Lnn : Label} + + -- begin + -- begin + -- Accept_Call (entry-index, Ann); + -- <statement sequence from N_Accept_Statement node> + -- Complete_Rendezvous; + -- <<Lnn>> + -- + -- exception + -- when ... => + -- <exception handler from N_Accept_Statement node> + -- Complete_Rendezvous; + -- when ... => + -- <exception handler from N_Accept_Statement node> + -- Complete_Rendezvous; + -- ... + -- end; + + -- exception + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + -- end; + + -- The first three declarations were already inserted ahead of the + -- accept statement by the Expand_Accept_Declarations procedure, which + -- was called directly from the semantics during analysis of the accept. + -- statement, before analyzing its contained statements. + + -- The declarations from the N_Accept_Statement, as noted in Sinfo, come + -- from possible expansion activity (the original source of course does + -- not have any declarations associated with the accept statement, since + -- an accept statement has no declarative part). In particular, if the + -- expander is active, the first such declaration is the declaration of + -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). + -- + -- The two blocks are merged into a single block if the inner block has + -- no exception handlers, but otherwise two blocks are required, since + -- exceptions might be raised in the exception handlers of the inner + -- block, and Exceptional_Complete_Rendezvous must be called. + + procedure Expand_N_Accept_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stats : constant Node_Id := Handled_Statement_Sequence (N); + Ename : constant Node_Id := Entry_Direct_Name (N); + Eindx : constant Node_Id := Entry_Index (N); + Eent : constant Entity_Id := Entity (Ename); + Acstack : constant Elist_Id := Accept_Address (Eent); + Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); + Ttyp : constant Entity_Id := Etype (Scope (Eent)); + Call : Node_Id; + Block : Node_Id; + + function Null_Statements (Stats : List_Id) return Boolean; + -- Check for null statement sequence (i.e a list of labels and + -- null statements) + + function Null_Statements (Stats : List_Id) return Boolean is + Stmt : Node_Id; + + begin + Stmt := First (Stats); + while Nkind (Stmt) /= N_Empty + and then (Nkind (Stmt) = N_Null_Statement + or else + Nkind (Stmt) = N_Label) + loop + Next (Stmt); + end loop; + + return Nkind (Stmt) = N_Empty; + end Null_Statements; + + -- Start of processing for Expand_N_Accept_Statement + + begin + -- If accept statement is not part of a list, then its parent must be + -- an accept alternative, and, as described above, we do not do any + -- expansion for such accept statements at this level. + + if not Is_List_Member (N) then + pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); + return; + + -- Trivial accept case (no statement sequence, or null statements). + -- If the accept statement has declarations, then just insert them + -- before the procedure call. + + -- We avoid this optimization when FIFO_Within_Priorities is active, + -- since it is not correct according to annex D semantics. The problem + -- is that the call is required to reorder the acceptors position on + -- its ready queue, even though there is nothing to be done. However, + -- if no policy is specified, then we decide that our dispatching + -- policy always reorders the queue right after the RV to look the + -- way they were just before the RV. Since we are allowed to freely + -- reorder same-priority queues (this is part of what dispatching + -- policies are all about), the optimization is legitimate. + + elsif Opt.Task_Dispatching_Policy /= 'F' + and then (No (Stats) or else Null_Statements (Statements (Stats))) + then + if Present (Declarations (N)) then + Insert_Actions (N, Declarations (N)); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc), + Parameter_Associations => New_List ( + Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); + + Analyze (N); + + -- Discard Entry_Address that was created for it, so it will not be + -- emitted if this accept statement is in the statement part of a + -- delay alternative. + + if Present (Stats) then + Remove_Last_Elmt (Acstack); + end if; + + -- Case of statement sequence present + + else + -- Construct the block, using the declarations from the accept + -- statement if any to initialize the declarations of the block. + + Block := + Make_Block_Statement (Loc, + Declarations => Declarations (N), + Handled_Statement_Sequence => Build_Accept_Body (N)); + + -- Prepend call to Accept_Call to main statement sequence + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Accept_Call), Loc), + Parameter_Associations => New_List ( + Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), + New_Reference_To (Ann, Loc))); + + Prepend (Call, Statements (Stats)); + Analyze (Call); + + -- Replace the accept statement by the new block + + Rewrite (N, Block); + Analyze (N); + + -- Last step is to unstack the Accept_Address value + + Remove_Last_Elmt (Acstack); + end if; + + end Expand_N_Accept_Statement; + + ---------------------------------- + -- Expand_N_Asynchronous_Select -- + ---------------------------------- + + -- This procedure assumes that the trigger statement is an entry + -- call. A delay alternative should already have been expanded + -- into an entry call to the appropriate delay object Wait entry. + + -- If the trigger is a task entry call, the select is implemented + -- with Task_Entry_Call: + + -- declare + -- B : Boolean; + -- C : Boolean; + -- P : parms := (parm, parm, parm); + -- + -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions. + -- + -- procedure _clean is + -- begin + -- ... + -- Cancel_Task_Entry_Call (C); + -- ... + -- end _clean; + -- begin + -- Abort_Defer; + -- Task_Entry_Call + -- (acceptor-task, + -- entry-index, + -- P'Address, + -- Asynchronous_Call, + -- B); + -- begin + -- begin + -- Abort_Undefer; + -- abortable-part + -- at end + -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + -- parm := P.param; + -- parm := P.param; + -- ... + -- if not C then + -- triggered-statements + -- end if; + -- end; + + -- Note that Build_Simple_Entry_Call is used to expand the entry + -- of the asynchronous entry call (by the + -- Expand_N_Entry_Call_Statement procedure) as follows: + + -- declare + -- P : parms := (parm, parm, parm); + -- begin + -- Call_Simple (acceptor-task, entry-index, P'Address); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- so the task at hand is to convert the latter expansion into the former + + -- If the trigger is a protected entry call, the select is + -- implemented with Protected_Entry_Call: + + -- declare + -- P : E1_Params := (param, param, param); + -- Bnn : Communications_Block; + -- begin + -- declare + -- + -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions. + -- + -- procedure _clean is + -- begin + -- ... + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- ... + -- end _clean; + -- begin + -- begin + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => <entry index>; + -- Uninterpreted_Data => P'Address; + -- Mode => Asynchronous_Call; + -- Block => Bnn); + -- if Enqueued (Bnn) then + -- <abortable part> + -- end if; + -- at end + -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. + -- end; + -- exception + -- when Abort_Signal => + -- Abort_Undefer; + -- null; + -- end; + -- if not Cancelled (Bnn) then + -- triggered statements + -- end if; + -- end; + + -- Build_Simple_Entry_Call is used to expand the all to a simple + -- protected entry call: + + -- declare + -- P : E1_Params := (param, param, param); + -- Bnn : Communications_Block; + + -- begin + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => <entry index>; + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call; + -- Block => Bnn); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- The job is to convert this to the asynchronous form. + + -- If the trigger is a delay statement, it will have been expanded + -- into a call to one of the GNARL delay procedures. This routine + -- will convert this into a protected entry call on a delay object + -- and then continue processing as for a protected entry call trigger. + -- This requires declaring a Delay_Block object and adding a pointer + -- to this object to the parameter list of the delay procedure to form + -- the parameter list of the entry call. This object is used by + -- the runtime to queue the delay request. + + -- For a description of the use of P and the assignments after the + -- call, see Expand_N_Entry_Call_Statement. + + procedure Expand_N_Asynchronous_Select (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Trig : constant Node_Id := Triggering_Alternative (N); + Abrt : constant Node_Id := Abortable_Part (N); + Tstats : constant List_Id := Statements (Trig); + + Ecall : Node_Id; + Astats : List_Id := Statements (Abrt); + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id; + Hdle : List_Id; + Decls : List_Id; + Decl : Node_Id; + Parms : List_Id; + Parm : Node_Id; + Call : Node_Id; + Stmts : List_Id; + Enqueue_Call : Node_Id; + Stmt : Node_Id; + B : Entity_Id; + Pdef : Entity_Id; + Dblock_Ent : Entity_Id; + N_Orig : Node_Id; + Abortable_Block : Node_Id; + Cancel_Param : Entity_Id; + Blkent : Entity_Id; + Target_Undefer : RE_Id; + Undefer_Args : List_Id := No_List; + + begin + Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ecall := Triggering_Statement (Trig); + + -- The arguments in the call may require dynamic allocation, and the + -- call statement may have been transformed into a block. The block + -- may contain additional declarations for internal entities, and the + -- original call is found by sequential search. + + if Nkind (Ecall) = N_Block_Statement then + Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); + + while Nkind (Ecall) /= N_Procedure_Call_Statement + and then Nkind (Ecall) /= N_Entry_Call_Statement + loop + Next (Ecall); + end loop; + end if; + + -- If a delay was used as a trigger, it will have been expanded + -- into a procedure call. Convert it to the appropriate sequence of + -- statements, similar to what is done for a task entry call. + -- Note that this currently supports only Duration, Real_Time.Time, + -- and Calendar.Time. + + if Nkind (Ecall) = N_Procedure_Call_Statement then + + -- Add a Delay_Block object to the parameter list of the + -- delay procedure to form the parameter list of the Wait + -- entry call. + + Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + + Pdef := Entity (Name (Ecall)); + + if Is_RTE (Pdef, RO_CA_Delay_For) then + Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc); + + elsif Is_RTE (Pdef, RO_CA_Delay_Until) then + Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc); + + else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); + Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc); + end if; + + Append_To (Parameter_Associations (Ecall), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Dblock_Ent, Loc), + Attribute_Name => Name_Unchecked_Access)); + + -- Create the inner block to protect the abortable part. + + Hdle := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); + + Prepend_To (Astats, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + + Abortable_Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blkent, Loc), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Astats), + Has_Created_Identifier => True, + Is_Asynchronous_Call_Block => True); + + -- Append call to if Enqueue (When, DB'Unchecked_Access) then + + Rewrite (Ecall, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => Enqueue_Call, + Parameter_Associations => Parameter_Associations (Ecall)), + Then_Statements => + New_List (Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blkent, + Label_Construct => Abortable_Block), + Abortable_Block), + Exception_Handlers => Hdle))))); + + Stmts := New_List (Ecall); + + -- Construct statement sequence for new block + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Timed_Out), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Dblock_Ent, Loc), + Attribute_Name => Name_Unchecked_Access))), + Then_Statements => Tstats)); + + -- The result is the new block + + Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Dblock_Ent, + Aliased_Present => True, + Object_Definition => New_Reference_To ( + RTE (RE_Delay_Block), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + return; + + else + N_Orig := N; + end if; + + Extract_Entry (Ecall, Concval, Ename, Index); + Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); + + Stmts := Statements (Handled_Statement_Sequence (Ecall)); + Decls := Declarations (Ecall); + + if Is_Protected_Type (Etype (Concval)) then + + -- Get the declarations of the block expanded from the entry call + + Decl := First (Decls); + while Present (Decl) + and then (Nkind (Decl) /= N_Object_Declaration + or else not Is_RTE + (Etype (Object_Definition (Decl)), RE_Communication_Block)) + loop + Next (Decl); + end loop; + + pragma Assert (Present (Decl)); + Cancel_Param := Defining_Identifier (Decl); + + -- Change the mode of the Protected_Entry_Call call. + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => <entry index>; + -- Uninterpreted_Data => P'Address; + -- Mode => Asynchronous_Call; + -- Block => Bnn); + + Stmt := First (Stmts); + + -- Skip assignments to temporaries created for in-out parameters. + -- This makes unwarranted assumptions about the shape of the expanded + -- tree for the call, and should be cleaned up ??? + + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + Call := Stmt; + + Parm := First (Parameter_Associations (Call)); + while Present (Parm) + and then not Is_RTE (Etype (Parm), RE_Call_Modes) + loop + Next (Parm); + end loop; + + pragma Assert (Present (Parm)); + Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); + Analyze (Parm); + + -- Append an if statement to execute the abortable part. + -- if Enqueued (Bnn) then + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Enqueued), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc))), + Then_Statements => Astats)); + + Abortable_Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blkent, Loc), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts), + Has_Created_Identifier => True, + Is_Asynchronous_Call_Block => True); + + -- For the JVM call Update_Exception instead of Abort_Undefer. + -- See 4jexcept.ads for an explanation. + + if Hostparm.Java_VM then + Target_Undefer := RE_Update_Exception; + Undefer_Args := + New_List (Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Current_Target_Exception), Loc))); + else + Target_Undefer := RE_Abort_Undefer; + end if; + + Stmts := New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blkent, + Label_Construct => Abortable_Block), + Abortable_Block), + + -- exception + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + + -- when Abort_Signal => + -- Abort_Undefer.all; + + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (Target_Undefer), Loc), + Parameter_Associations => Undefer_Args)))))), + + -- if not Cancelled (Bnn) then + -- triggered statements + -- end if; + + Make_Implicit_If_Statement (N, + Condition => Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Cancel_Param, Loc)))), + Then_Statements => Tstats)); + + -- Asynchronous task entry call + + else + if No (Decls) then + Decls := New_List; + end if; + + B := Make_Defining_Identifier (Loc, Name_uB); + + -- Insert declaration of B in declarations of existing block + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + + Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); + + -- Insert declaration of C in declarations of existing block + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Cancel_Param, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + + -- Remove and save the call to Call_Simple. + + Stmt := First (Stmts); + + -- Skip assignments to temporaries created for in-out parameters. + -- This makes unwarranted assumptions about the shape of the expanded + -- tree for the call, and should be cleaned up ??? + + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + Call := Stmt; + + -- Create the inner block to protect the abortable part. + + Hdle := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); + + Prepend_To (Astats, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + + Abortable_Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blkent, Loc), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Astats), + Has_Created_Identifier => True, + Is_Asynchronous_Call_Block => True); + + Insert_After (Call, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blkent, + Label_Construct => Abortable_Block), + Abortable_Block), + Exception_Handlers => Hdle))); + + -- Create new call statement + + Parms := Parameter_Associations (Call); + Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); + Append_To (Parms, New_Reference_To (B, Loc)); + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => Parms)); + + -- Construct statement sequence for new block + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Op_Not (Loc, + New_Reference_To (Cancel_Param, Loc)), + Then_Statements => Tstats)); + + -- Protected the call against abortion + + Prepend_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Defer), Loc), + Parameter_Associations => Empty_List)); + end if; + + Set_Entry_Cancel_Parameter (Blkent, Cancel_Param); + + -- The result is the new block + + Rewrite (N_Orig, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N_Orig); + + end Expand_N_Asynchronous_Select; + + ------------------------------------- + -- Expand_N_Conditional_Entry_Call -- + ------------------------------------- + + -- The conditional task entry call is converted to a call to + -- Task_Entry_Call: + + -- declare + -- B : Boolean; + -- P : parms := (parm, parm, parm); + + -- begin + -- Task_Entry_Call + -- (acceptor-task, + -- entry-index, + -- P'Address, + -- Conditional_Call, + -- B); + -- parm := P.param; + -- parm := P.param; + -- ... + -- if B then + -- normal-statements + -- else + -- else-statements + -- end if; + -- end; + + -- For a description of the use of P and the assignments after the + -- call, see Expand_N_Entry_Call_Statement. Note that the entry call + -- of the conditional entry call has already been expanded (by the + -- Expand_N_Entry_Call_Statement procedure) as follows: + + -- declare + -- P : parms := (parm, parm, parm); + -- begin + -- ... info for in-out parameters + -- Call_Simple (acceptor-task, entry-index, P'Address); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- so the task at hand is to convert the latter expansion into the former + + -- The conditional protected entry call is converted to a call to + -- Protected_Entry_Call: + + -- declare + -- P : parms := (parm, parm, parm); + -- Bnn : Communications_Block; + + -- begin + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => <entry index>; + -- Uninterpreted_Data => P'Address; + -- Mode => Conditional_Call; + -- Block => Bnn); + -- parm := P.param; + -- parm := P.param; + -- ... + -- if Cancelled (Bnn) then + -- else-statements + -- else + -- normal-statements + -- end if; + -- end; + + -- As for tasks, the entry call of the conditional entry call has + -- already been expanded (by the Expand_N_Entry_Call_Statement procedure) + -- as follows: + + -- declare + -- P : E1_Params := (param, param, param); + -- Bnn : Communications_Block; + + -- begin + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => <entry index>; + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call; + -- Block => Bnn); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Alt : constant Node_Id := Entry_Call_Alternative (N); + Blk : Node_Id := Entry_Call_Statement (Alt); + Transient_Blk : Node_Id; + + Parms : List_Id; + Parm : Node_Id; + Call : Node_Id; + Stmts : List_Id; + B : Entity_Id; + Decl : Node_Id; + Stmt : Node_Id; + + begin + -- As described above, The entry alternative is transformed into a + -- block that contains the gnulli call, and possibly assignment + -- statments for in-out parameters. The gnulli call may itself be + -- rewritten into a transient block if some unconstrained parameters + -- require it. We need to retrieve the call to complete its parameter + -- list. + + Transient_Blk := + First_Real_Statement (Handled_Statement_Sequence (Blk)); + + if Present (Transient_Blk) + and then + Nkind (Transient_Blk) = N_Block_Statement + then + Blk := Transient_Blk; + end if; + + Stmts := Statements (Handled_Statement_Sequence (Blk)); + + Stmt := First (Stmts); + + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + Call := Stmt; + + Parms := Parameter_Associations (Call); + + if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then + + -- Substitute Conditional_Entry_Call for Simple_Call + -- parameter. + + Parm := First (Parms); + while Present (Parm) + and then not Is_RTE (Etype (Parm), RE_Call_Modes) + loop + Next (Parm); + end loop; + + pragma Assert (Present (Parm)); + Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc)); + + Analyze (Parm); + + -- Find the Communication_Block parameter for the call + -- to the Cancelled function. + + Decl := First (Declarations (Blk)); + while Present (Decl) + and then not + Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block) + loop + Next (Decl); + end loop; + + -- Add an if statement to execute the else part if the call + -- does not succeed (as indicated by the Cancelled predicate). + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Defining_Identifier (Decl), Loc))), + Then_Statements => Else_Statements (N), + Else_Statements => Statements (Alt))); + + else + B := Make_Defining_Identifier (Loc, Name_uB); + + -- Insert declaration of B in declarations of existing block + + if No (Declarations (Blk)) then + Set_Declarations (Blk, New_List); + end if; + + Prepend_To (Declarations (Blk), + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + + -- Create new call statement + + Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc)); + Append_To (Parms, New_Reference_To (B, Loc)); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => Parms)); + + -- Construct statement sequence for new block + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (B, Loc), + Then_Statements => Statements (Alt), + Else_Statements => Else_Statements (N))); + + end if; + + -- The result is the new block + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Declarations (Blk), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + + end Expand_N_Conditional_Entry_Call; + + --------------------------------------- + -- Expand_N_Delay_Relative_Statement -- + --------------------------------------- + + -- Delay statement is implemented as a procedure call to Delay_For + -- defined in Ada.Calendar.Delays in order to reduce the overhead of + -- simple delays imposed by the use of Protected Objects. + + procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc), + Parameter_Associations => New_List (Expression (N)))); + Analyze (N); + end Expand_N_Delay_Relative_Statement; + + ------------------------------------ + -- Expand_N_Delay_Until_Statement -- + ------------------------------------ + + -- Delay Until statement is implemented as a procedure call to + -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. + + procedure Expand_N_Delay_Until_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id; + + begin + if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then + Typ := RTE (RO_CA_Delay_Until); + else + Typ := RTE (RO_RT_Delay_Until); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Typ, Loc), + Parameter_Associations => New_List (Expression (N)))); + + Analyze (N); + end Expand_N_Delay_Until_Statement; + + ------------------------- + -- Expand_N_Entry_Body -- + ------------------------- + + procedure Expand_N_Entry_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Next_Op : Node_Id; + Dec : Node_Id := Parent (Current_Scope); + Ent_Formals : Node_Id := Entry_Body_Formal_Part (N); + Index_Spec : Node_Id := Entry_Index_Specification (Ent_Formals); + + begin + -- Add the renamings for private declarations and discriminants. + + Add_Discriminal_Declarations + (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); + Add_Private_Declarations + (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); + + if Present (Index_Spec) then + Append_List_To (Declarations (N), + Index_Constant_Declaration + (N, Defining_Identifier (Index_Spec), Defining_Identifier (Dec))); + end if; + + -- Associate privals and discriminals with the next protected + -- operation body to be expanded. These are used to expand + -- references to private data objects and discriminants, + -- respectively. + + Next_Op := Next_Protected_Operation (N); + + if Present (Next_Op) then + Set_Privals (Dec, Next_Op, Loc); + Set_Discriminals (Dec, Next_Op, Loc); + end if; + + end Expand_N_Entry_Body; + + ----------------------------------- + -- Expand_N_Entry_Call_Statement -- + ----------------------------------- + + -- An entry call is expanded into GNARLI calls to implement + -- a simple entry call (see Build_Simple_Entry_Call). + + procedure Expand_N_Entry_Call_Statement (N : Node_Id) is + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id; + + begin + -- If this entry call is part of an asynchronous select, don't + -- expand it here; it will be expanded with the select statement. + -- Don't expand timed entry calls either, as they are translated + -- into asynchronous entry calls. + + -- ??? This whole approach is questionable; it may be better + -- to go back to allowing the expansion to take place and then + -- attempting to fix it up in Expand_N_Asynchronous_Select. + -- The tricky part is figuring out whether the expanded + -- call is on a task or protected entry. + + if (Nkind (Parent (N)) /= N_Triggering_Alternative + or else N /= Triggering_Statement (Parent (N))) + and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative + or else N /= Entry_Call_Statement (Parent (N)) + or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) + then + Extract_Entry (N, Concval, Ename, Index); + Build_Simple_Entry_Call (N, Concval, Ename, Index); + end if; + + end Expand_N_Entry_Call_Statement; + + -------------------------------- + -- Expand_N_Entry_Declaration -- + -------------------------------- + + -- If there are parameters, then first, each of the formals is marked + -- by setting Is_Entry_Formal. Next a record type is built which is + -- used to hold the parameter values. The name of this record type is + -- entryP where entry is the name of the entry, with an additional + -- corresponding access type called entryPA. The record type has matching + -- components for each formal (the component names are the same as the + -- formal names). For elementary types, the component type matches the + -- formal type. For composite types, an access type is declared (with + -- the name formalA) which designates the formal type, and the type of + -- the component is this access type. Finally the Entry_Component of + -- each formal is set to reference the corresponding record component. + + procedure Expand_N_Entry_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Entry_Ent : constant Entity_Id := Defining_Identifier (N); + Components : List_Id; + Formal : Node_Id; + Ftype : Entity_Id; + Last_Decl : Node_Id; + Component : Entity_Id; + Ctype : Entity_Id; + Decl : Node_Id; + Rec_Ent : Entity_Id; + Acc_Ent : Entity_Id; + + begin + Formal := First_Formal (Entry_Ent); + Last_Decl := N; + + -- Most processing is done only if parameters are present + + if Present (Formal) then + Components := New_List; + + -- Loop through formals + + while Present (Formal) loop + Set_Is_Entry_Formal (Formal); + Component := + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); + Set_Entry_Component (Formal, Component); + Set_Entry_Formal (Component, Formal); + Ftype := Etype (Formal); + + -- Declare new access type and then append + + Ctype := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ctype, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Constant_Present => Ekind (Formal) = E_In_Parameter, + Subtype_Indication => New_Reference_To (Ftype, Loc))); + + Insert_After (Last_Decl, Decl); + Last_Decl := Decl; + + Append_To (Components, + Make_Component_Declaration (Loc, + Defining_Identifier => Component, + Subtype_Indication => New_Reference_To (Ctype, Loc))); + + Next_Formal_With_Extras (Formal); + end loop; + + -- Create the Entry_Parameter_Record declaration + + Rec_Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Rec_Ent, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Components))); + + Insert_After (Last_Decl, Decl); + Last_Decl := Decl; + + -- Construct and link in the corresponding access type + + Acc_Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Ent, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Reference_To (Rec_Ent, Loc))); + + Insert_After (Last_Decl, Decl); + Last_Decl := Decl; + + end if; + + end Expand_N_Entry_Declaration; + + ----------------------------- + -- Expand_N_Protected_Body -- + ----------------------------- + + -- Protected bodies are expanded to the completion of the subprograms + -- created for the corresponding protected type. These are a protected + -- and unprotected version of each protected subprogram in the object, + -- a function to calculate each entry barrier, and a procedure to + -- execute the sequence of statements of each protected entry body. + -- For example, for protected type ptype: + + -- function entB + -- (O : System.Address; + -- E : Protected_Entry_Index) + -- return Boolean + -- is + -- <discriminant renamings> + -- <private object renamings> + -- begin + -- return <barrier expression>; + -- end entB; + + -- procedure pprocN (_object : in out poV;...) is + -- <discriminant renamings> + -- <private object renamings> + -- begin + -- <sequence of statements> + -- end pprocN; + + -- procedure pproc (_object : in out poV;...) is + -- procedure _clean is + -- Pn : Boolean; + -- begin + -- ptypeS (_object, Pn); + -- Unlock (_object._object'Access); + -- Abort_Undefer.all; + -- end _clean; + -- begin + -- Abort_Defer.all; + -- Lock (_object._object'Access); + -- pprocN (_object;...); + -- at end + -- _clean; + -- end pproc; + + -- function pfuncN (_object : poV;...) return Return_Type is + -- <discriminant renamings> + -- <private object renamings> + -- begin + -- <sequence of statements> + -- end pfuncN; + + -- function pfunc (_object : poV) return Return_Type is + -- procedure _clean is + -- begin + -- Unlock (_object._object'Access); + -- Abort_Undefer.all; + -- end _clean; + -- begin + -- Abort_Defer.all; + -- Lock (_object._object'Access); + -- return pfuncN (_object); + -- at end + -- _clean; + -- end pfunc; + + -- procedure entE + -- (O : System.Address; + -- P : System.Address; + -- E : Protected_Entry_Index) + -- is + -- <discriminant renamings> + -- <private object renamings> + -- type poVP is access poV; + -- _Object : ptVP := ptVP!(O); + -- begin + -- begin + -- <statement sequence> + -- Complete_Entry_Body (_Object._Object); + -- exception + -- when all others => + -- Exceptional_Complete_Entry_Body ( + -- _Object._Object, Get_GNAT_Exception); + -- end; + -- end entE; + + -- The type poV is the record created for the protected type to hold + -- the state of the protected object. + + procedure Expand_N_Protected_Body (N : Node_Id) is + Pid : constant Entity_Id := Corresponding_Spec (N); + Has_Entries : Boolean := False; + Op_Decl : Node_Id; + Op_Body : Node_Id; + Op_Id : Entity_Id; + New_Op_Body : Node_Id; + Current_Node : Node_Id; + Num_Entries : Natural := 0; + + begin + if Nkind (Parent (N)) = N_Subunit then + + -- This is the proper body corresponding to a stub. The declarations + -- must be inserted at the point of the stub, which is in the decla- + -- rative part of the parent unit. + + Current_Node := Corresponding_Stub (Parent (N)); + + else + Current_Node := N; + end if; + + Op_Body := First (Declarations (N)); + + -- The protected body is replaced with the bodies of its + -- protected operations, and the declarations for internal objects + -- that may have been created for entry family bounds. + + Rewrite (N, Make_Null_Statement (Sloc (N))); + Analyze (N); + + while Present (Op_Body) loop + + case Nkind (Op_Body) is + when N_Subprogram_Declaration => + null; + + when N_Subprogram_Body => + + -- Exclude funtions created to analyze defaults. + + if not Is_Eliminated (Defining_Entity (Op_Body)) then + New_Op_Body := + Build_Unprotected_Subprogram_Body (Op_Body, Pid); + + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + Update_Prival_Subtypes (New_Op_Body); + + -- Build the corresponding protected operation only if + -- this is a visible operation of the type, or if it is + -- an interrupt handler. Otherwise it is only callable + -- from within the object, and the unprotected version + -- is sufficient. + + if Present (Corresponding_Spec (Op_Body)) then + Op_Decl := + Unit_Declaration_Node (Corresponding_Spec (Op_Body)); + + if Nkind (Parent (Op_Decl)) = N_Protected_Definition + and then + (List_Containing (Op_Decl) = + Visible_Declarations (Parent (Op_Decl)) + or else + Is_Interrupt_Handler + (Corresponding_Spec (Op_Body))) + then + New_Op_Body := + Build_Protected_Subprogram_Body ( + Op_Body, Pid, Specification (New_Op_Body)); + + Insert_After (Current_Node, New_Op_Body); + Analyze (New_Op_Body); + end if; + end if; + end if; + + when N_Entry_Body => + Op_Id := Defining_Identifier (Op_Body); + Has_Entries := True; + Num_Entries := Num_Entries + 1; + + New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); + + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + Update_Prival_Subtypes (New_Op_Body); + + when N_Implicit_Label_Declaration => + null; + + when N_Itype_Reference => + Insert_After (Current_Node, New_Copy (Op_Body)); + + when N_Freeze_Entity => + New_Op_Body := New_Copy (Op_Body); + + if Present (Entity (Op_Body)) + and then Freeze_Node (Entity (Op_Body)) = Op_Body + then + Set_Freeze_Node (Entity (Op_Body), New_Op_Body); + end if; + + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + when N_Pragma => + New_Op_Body := New_Copy (Op_Body); + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + when N_Object_Declaration => + pragma Assert (not Comes_From_Source (Op_Body)); + New_Op_Body := New_Copy (Op_Body); + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + when others => + raise Program_Error; + + end case; + + Next (Op_Body); + end loop; + + -- Finally, create the body of the funtion that maps an entry index + -- into the corresponding body index, except when there is no entry, + -- or in a ravenscar-like profile (no abort, no entry queue, 1 entry) + + if Has_Entries + and then (Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Num_Entries > 1) + then + New_Op_Body := Build_Find_Body_Index (Pid); + Insert_After (Current_Node, New_Op_Body); + Analyze (New_Op_Body); + end if; + end Expand_N_Protected_Body; + + ----------------------------------------- + -- Expand_N_Protected_Type_Declaration -- + ----------------------------------------- + + -- First we create a corresponding record type declaration used to + -- represent values of this protected type. + -- The general form of this type declaration is + + -- type poV (discriminants) is record + -- _Object : aliased <kind>Protection + -- [(<entry count> [, <handler count>])]; + -- [entry_family : array (bounds) of Void;] + -- <private data fields> + -- end record; + + -- The discriminants are present only if the corresponding protected + -- type has discriminants, and they exactly mirror the protected type + -- discriminants. The private data fields similarly mirror the + -- private declarations of the protected type. + + -- The Object field is always present. It contains RTS specific data + -- used to control the protected object. It is declared as Aliased + -- so that it can be passed as a pointer to the RTS. This allows the + -- protected record to be referenced within RTS data structures. + -- An appropriate Protection type and discriminant are generated. + + -- The Service field is present for protected objects with entries. It + -- contains sufficient information to allow the entry service procedure + -- for this object to be called when the object is not known till runtime. + + -- One entry_family component is present for each entry family in the + -- task definition (see Expand_N_Task_Type_Declaration). + + -- When a protected object is declared, an instance of the protected type + -- value record is created. The elaboration of this declaration creates + -- the correct bounds for the entry families, and also evaluates the + -- priority expression if needed. The initialization routine for + -- the protected type itself then calls Initialize_Protection with + -- appropriate parameters to initialize the value of the Task_Id field. + -- Install_Handlers may be also called if a pragma Attach_Handler applies. + + -- Note: this record is passed to the subprograms created by the + -- expansion of protected subprograms and entries. It is an in parameter + -- to protected functions and an in out parameter to procedures and + -- entry bodies. The Entity_Id for this created record type is placed + -- in the Corresponding_Record_Type field of the associated protected + -- type entity. + + -- Next we create a procedure specifications for protected subprograms + -- and entry bodies. For each protected subprograms two subprograms are + -- created, an unprotected and a protected version. The unprotected + -- version is called from within other operations of the same protected + -- object. + + -- We also build the call to register the procedure if a pragma + -- Interrupt_Handler applies. + + -- A single subprogram is created to service all entry bodies; it has an + -- additional boolean out parameter indicating that the previous entry + -- call made by the current task was serviced immediately, i.e. not by + -- proxy. The O parameter contains a pointer to a record object of the + -- type described above. An untyped interface is used here to allow this + -- procedure to be called in places where the type of the object to be + -- serviced is not known. This must be done, for example, when a call + -- that may have been requeued is cancelled; the corresponding object + -- must be serviced, but which object that is not known till runtime. + + -- procedure ptypeS + -- (O : System.Address; P : out Boolean); + -- procedure pprocN (_object : in out poV); + -- procedure pproc (_object : in out poV); + -- function pfuncN (_object : poV); + -- function pfunc (_object : poV); + -- ... + + -- Note that this must come after the record type declaration, since + -- the specs refer to this type. + + procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Prottyp : constant Entity_Id := Defining_Identifier (N); + Protnm : constant Name_Id := Chars (Prottyp); + + Pdef : constant Node_Id := Protected_Definition (N); + -- This contains two lists; one for visible and one for private decls + + Rec_Decl : Node_Id; + Cdecls : List_Id; + Discr_Map : Elist_Id := New_Elmt_List; + Priv : Node_Id; + Pent : Entity_Id; + New_Priv : Node_Id; + Comp : Node_Id; + Comp_Id : Entity_Id; + Sub : Node_Id; + Current_Node : Node_Id := N; + Nam : Name_Id; + Bdef : Entity_Id := Empty; -- avoid uninit warning + Edef : Entity_Id := Empty; -- avoid uninit warning + Entries_Aggr : Node_Id; + Body_Id : Entity_Id; + Body_Arr : Node_Id; + E_Count : Int; + Object_Comp : Node_Id; + + procedure Register_Handler; + -- for a protected operation that is an interrupt handler, add the + -- freeze action that will register it as such. + + ---------------------- + -- Register_Handler -- + ---------------------- + + procedure Register_Handler is + + -- All semantic checks already done in Sem_Prag + + Prot_Proc : constant Entity_Id := + Defining_Unit_Name + (Specification (Current_Node)); + + Proc_Address : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prot_Proc, Loc), + Attribute_Name => Name_Address); + + RTS_Call : constant Entity_Id := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Register_Interrupt_Handler), Loc), + Parameter_Associations => + New_List (Proc_Address)); + begin + Append_Freeze_Action (Prot_Proc, RTS_Call); + end Register_Handler; + + -- Start of processing for Expand_N_Protected_Type_Declaration + + begin + if Present (Corresponding_Record_Type (Prottyp)) then + return; + else + Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc); + Cdecls := Component_Items + (Component_List (Type_Definition (Rec_Decl))); + end if; + + Qualify_Entity_Names (N); + + -- If the type has discriminants, their occurrences in the declaration + -- have been replaced by the corresponding discriminals. For components + -- that are constrained by discriminants, their homologues in the + -- corresponding record type must refer to the discriminants of that + -- record, so we must apply a new renaming to subtypes_indications: + + -- protected discriminant => discriminal => record discriminant. + -- This replacement is not applied to default expressions, for which + -- the discriminal is correct. + + if Has_Discriminants (Prottyp) then + declare + Disc : Entity_Id; + Decl : Node_Id; + + begin + Disc := First_Discriminant (Prottyp); + Decl := First (Discriminant_Specifications (Rec_Decl)); + + while Present (Disc) loop + Append_Elmt (Discriminal (Disc), Discr_Map); + Append_Elmt (Defining_Identifier (Decl), Discr_Map); + Next_Discriminant (Disc); + Next (Decl); + end loop; + end; + end if; + + -- Fill in the component declarations. + + -- Add components for entry families. For each entry family, + -- create an anonymous type declaration with the same size, and + -- analyze the type. + + Collect_Entry_Families (Loc, Cdecls, Current_Node, Prottyp); + + -- Prepend the _Object field with the right type to the component + -- list. We need to compute the number of entries, and in some cases + -- the number of Attach_Handler pragmas. + + declare + Ritem : Node_Id; + Num_Attach_Handler : Int := 0; + Protection_Subtype : Node_Id; + Entry_Count_Expr : constant Node_Id := + Build_Entry_Count_Expression + (Prottyp, Cdecls, Loc); + + begin + if Has_Attach_Handler (Prottyp) then + Ritem := First_Rep_Item (Prottyp); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Chars (Ritem) = Name_Attach_Handler + then + Num_Attach_Handler := Num_Attach_Handler + 1; + end if; + + Next_Rep_Item (Ritem); + end loop; + + if Restricted_Profile then + Protection_Subtype := + New_Reference_To (RTE (RE_Protection_Entry), Loc); + + else + Protection_Subtype := + Make_Subtype_Indication + (Sloc => Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Static_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List ( + Entry_Count_Expr, + Make_Integer_Literal (Loc, Num_Attach_Handler)))); + end if; + + elsif Has_Interrupt_Handler (Prottyp) then + Protection_Subtype := + Make_Subtype_Indication ( + Sloc => Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Dynamic_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List (Entry_Count_Expr))); + + elsif Has_Entries (Prottyp) then + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Prottyp) > 1 + then + Protection_Subtype := + Make_Subtype_Indication ( + Sloc => Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Protection_Entries), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List (Entry_Count_Expr))); + + else + Protection_Subtype := + New_Reference_To (RTE (RE_Protection_Entry), Loc); + end if; + + else + Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc); + end if; + + Object_Comp := + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Aliased_Present => True, + Subtype_Indication => Protection_Subtype); + end; + + pragma Assert (Present (Pdef)); + + -- Add private field components. + + if Present (Private_Declarations (Pdef)) then + Priv := First (Private_Declarations (Pdef)); + + while Present (Priv) loop + + if Nkind (Priv) = N_Component_Declaration then + Pent := Defining_Identifier (Priv); + New_Priv := + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Pent), Chars (Pent)), + Subtype_Indication => + New_Copy_Tree (Subtype_Indication (Priv), Discr_Map), + Expression => Expression (Priv)); + + Append_To (Cdecls, New_Priv); + + elsif Nkind (Priv) = N_Subprogram_Declaration then + + -- Make the unprotected version of the subprogram available + -- for expansion of intra object calls. There is need for + -- a protected version only if the subprogram is an interrupt + -- handler, otherwise this operation can only be called from + -- within the body. + + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Priv, Prottyp, Unprotected => True)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Set_Protected_Body_Subprogram + (Defining_Unit_Name (Specification (Priv)), + Defining_Unit_Name (Specification (Sub))); + + Current_Node := Sub; + if Is_Interrupt_Handler + (Defining_Unit_Name (Specification (Priv))) + then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Priv, Prottyp, Unprotected => False)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + Current_Node := Sub; + + if not Restricted_Profile then + Register_Handler; + end if; + end if; + end if; + + Next (Priv); + end loop; + end if; + + -- Put the _Object component after the private component so that it + -- be finalized early as required by 9.4 (20) + + Append_To (Cdecls, Object_Comp); + + Insert_After (Current_Node, Rec_Decl); + Current_Node := Rec_Decl; + + -- Analyze the record declaration immediately after construction, + -- because the initialization procedure is needed for single object + -- declarations before the next entity is analyzed (the freeze call + -- that generates this initialization procedure is found below). + + Analyze (Rec_Decl, Suppress => All_Checks); + + -- Collect pointers to entry bodies and their barriers, to be placed + -- in the Entry_Bodies_Array for the type. For each entry/family we + -- add an expression to the aggregate which is the initial value of + -- this array. The array is declared after all protected subprograms. + + if Has_Entries (Prottyp) then + Entries_Aggr := + Make_Aggregate (Loc, Expressions => New_List); + + else + Entries_Aggr := Empty; + end if; + + -- Build two new procedure specifications for each protected + -- subprogram; one to call from outside the object and one to + -- call from inside. Build a barrier function and an entry + -- body action procedure specification for each protected entry. + -- Initialize the entry body array. + + E_Count := 0; + + Comp := First (Visible_Declarations (Pdef)); + + while Present (Comp) loop + if Nkind (Comp) = N_Subprogram_Declaration then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Comp, Prottyp, Unprotected => True)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Set_Protected_Body_Subprogram + (Defining_Unit_Name (Specification (Comp)), + Defining_Unit_Name (Specification (Sub))); + + -- Make the protected version of the subprogram available + -- for expansion of external calls. + + Current_Node := Sub; + + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Comp, Prottyp, Unprotected => False)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + Current_Node := Sub; + + -- If a pragma Interrupt_Handler applies, build and add + -- a call to Register_Interrupt_Handler to the freezing actions + -- of the protected version (Current_Node) of the subprogram: + -- system.interrupts.register_interrupt_handler + -- (prot_procP'address); + + if not Restricted_Profile + and then Is_Interrupt_Handler + (Defining_Unit_Name (Specification (Comp))) + then + Register_Handler; + end if; + + elsif Nkind (Comp) = N_Entry_Declaration then + E_Count := E_Count + 1; + Comp_Id := Defining_Identifier (Comp); + Set_Privals_Chain (Comp_Id, New_Elmt_List); + Nam := Chars (Comp_Id); + Edef := + Make_Defining_Identifier (Loc, + Build_Selected_Name (Protnm, New_Internal_Name ('E'))); + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Set_Protected_Body_Subprogram ( + Defining_Identifier (Comp), + Defining_Unit_Name (Specification (Sub))); + + Current_Node := Sub; + + Bdef := + Make_Defining_Identifier (Loc, + Build_Selected_Name (Protnm, New_Internal_Name ('B'))); + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Barrier_Function_Specification (Bdef, Loc)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + Set_Protected_Body_Subprogram (Bdef, Bdef); + Set_Barrier_Function (Comp_Id, Bdef); + Set_Scope (Bdef, Scope (Comp_Id)); + Current_Node := Sub; + + -- Collect pointers to the protected subprogram and the barrier + -- of the current entry, for insertion into Entry_Bodies_Array. + + Append ( + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Bdef, Loc), + Attribute_Name => Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Edef, Loc), + Attribute_Name => Name_Unrestricted_Access))), + Expressions (Entries_Aggr)); + + end if; + + Next (Comp); + end loop; + + -- If there are some private entry declarations, expand it as if they + -- were visible entries. + + if Present (Private_Declarations (Pdef)) then + Comp := First (Private_Declarations (Pdef)); + + while Present (Comp) loop + if Nkind (Comp) = N_Entry_Declaration then + E_Count := E_Count + 1; + Comp_Id := Defining_Identifier (Comp); + Set_Privals_Chain (Comp_Id, New_Elmt_List); + Nam := Chars (Comp_Id); + Edef := + Make_Defining_Identifier (Loc, + Build_Selected_Name (Protnm, New_Internal_Name ('E'))); + + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Set_Protected_Body_Subprogram ( + Defining_Identifier (Comp), + Defining_Unit_Name (Specification (Sub))); + + Current_Node := Sub; + + Bdef := + Make_Defining_Identifier (Loc, + Build_Selected_Name (Protnm, New_Internal_Name ('B'))); + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Barrier_Function_Specification (Bdef, Loc)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + Set_Protected_Body_Subprogram (Bdef, Bdef); + Set_Barrier_Function (Comp_Id, Bdef); + Set_Scope (Bdef, Scope (Comp_Id)); + Current_Node := Sub; + + -- Collect pointers to the protected subprogram and the + -- barrier of the current entry, for insertion into + -- Entry_Bodies_Array. + + Append ( + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Bdef, Loc), + Attribute_Name => Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Edef, Loc), + Attribute_Name => Name_Unrestricted_Access))), + Expressions (Entries_Aggr)); + end if; + + Next (Comp); + end loop; + end if; + + -- Emit declaration for Entry_Bodies_Array, now that the addresses of + -- all protected subprograms have been collected. + + if Has_Entries (Prottyp) then + Body_Id := Make_Defining_Identifier (Sloc (Prottyp), + New_External_Name (Chars (Prottyp), 'A')); + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else E_Count > 1 + then + Body_Arr := Make_Object_Declaration (Loc, + Defining_Identifier => Body_Id, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Protected_Entry_Body_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, E_Count))))), + Expression => Entries_Aggr); + + else + Body_Arr := Make_Object_Declaration (Loc, + Defining_Identifier => Body_Id, + Aliased_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Entry_Body), Loc), + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Bdef, Loc), + Attribute_Name => Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Edef, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + end if; + + -- A pointer to this array will be placed in the corresponding + -- record by its initialization procedure, so this needs to be + -- analyzed here. + + Insert_After (Current_Node, Body_Arr); + Current_Node := Body_Arr; + Analyze (Body_Arr); + + Set_Entry_Bodies_Array (Prottyp, Body_Id); + + -- Finally, build the function that maps an entry index into the + -- corresponding body. A pointer to this function is placed in each + -- object of the type. Except for a ravenscar-like profile (no abort, + -- no entry queue, 1 entry) + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else E_Count > 1 + then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => Build_Find_Body_Index_Spec (Prottyp)); + Insert_After (Current_Node, Sub); + Analyze (Sub); + end if; + end if; + end Expand_N_Protected_Type_Declaration; + + -------------------------------- + -- Expand_N_Requeue_Statement -- + -------------------------------- + + -- A requeue statement is expanded into one of four GNARLI operations, + -- depending on the source and destination (task or protected object). + -- In addition, code must be generated to jump around the remainder of + -- processing for the original entry and, if the destination is a + -- (different) protected object, to attempt to service it. + -- The following illustrates the various cases: + + -- procedure entE + -- (O : System.Address; + -- P : System.Address; + -- E : Protected_Entry_Index) + -- is + -- <discriminant renamings> + -- <private object renamings> + -- type poVP is access poV; + -- _Object : ptVP := ptVP!(O); + -- + -- begin + -- begin + -- <start of statement sequence for entry> + -- + -- -- Requeue from one protected entry body to another protected + -- -- entry. + -- + -- Requeue_Protected_Entry ( + -- _object._object'Access, + -- new._object'Access, + -- E, + -- Abort_Present); + -- return; + -- + -- <some more of the statement sequence for entry> + -- + -- -- Requeue from an entry body to a task entry. + -- + -- Requeue_Protected_To_Task_Entry ( + -- New._task_id, + -- E, + -- Abort_Present); + -- return; + -- + -- <rest of statement sequence for entry> + -- Complete_Entry_Body (_Object._Object); + -- + -- exception + -- when all others => + -- Exceptional_Complete_Entry_Body ( + -- _Object._Object, Get_GNAT_Exception); + -- end; + -- end entE; + + -- Requeue of a task entry call to a task entry. + -- + -- Accept_Call (E, Ann); + -- <start of statement sequence for accept statement> + -- Requeue_Task_Entry (New._task_id, E, Abort_Present); + -- goto Lnn; + -- <rest of statement sequence for accept statement> + -- <<Lnn>> + -- Complete_Rendezvous; + -- exception + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + + -- Requeue of a task entry call to a protected entry. + -- + -- Accept_Call (E, Ann); + -- <start of statement sequence for accept statement> + -- Requeue_Task_To_Protected_Entry ( + -- new._object'Access, + -- E, + -- Abort_Present); + -- newS (new, Pnn); + -- goto Lnn; + -- <rest of statement sequence for accept statement> + -- <<Lnn>> + -- Complete_Rendezvous; + -- exception + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + + -- Further details on these expansions can be found in + -- Expand_N_Protected_Body and Expand_N_Accept_Statement. + + procedure Expand_N_Requeue_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Acc_Stat : Node_Id; + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id; + Conctyp : Entity_Id; + Oldtyp : Entity_Id; + Lab_Node : Node_Id; + Rcall : Node_Id; + Abortable : Node_Id; + Skip_Stat : Node_Id; + Self_Param : Node_Id; + New_Param : Node_Id; + Params : List_Id; + RTS_Call : Entity_Id; + + begin + if Abort_Present (N) then + Abortable := New_Occurrence_Of (Standard_True, Loc); + else + Abortable := New_Occurrence_Of (Standard_False, Loc); + end if; + + -- Set up the target object. + + Extract_Entry (N, Concval, Ename, Index); + Conctyp := Etype (Concval); + New_Param := Concurrent_Ref (Concval); + + -- The target entry index and abortable flag are the same for all cases. + + Params := New_List ( + Entry_Index_Expression (Loc, Entity (Ename), Index, Conctyp), + Abortable); + + -- Determine proper GNARLI call and required additional parameters + -- Loop to find nearest enclosing task type or protected type + + Oldtyp := Current_Scope; + loop + if Is_Task_Type (Oldtyp) then + if Is_Task_Type (Conctyp) then + RTS_Call := RTE (RE_Requeue_Task_Entry); + + else + pragma Assert (Is_Protected_Type (Conctyp)); + RTS_Call := RTE (RE_Requeue_Task_To_Protected_Entry); + New_Param := + Make_Attribute_Reference (Loc, + Prefix => New_Param, + Attribute_Name => Name_Unchecked_Access); + end if; + + Prepend (New_Param, Params); + exit; + + elsif Is_Protected_Type (Oldtyp) then + Self_Param := + Make_Attribute_Reference (Loc, + Prefix => Concurrent_Ref (New_Occurrence_Of (Oldtyp, Loc)), + Attribute_Name => Name_Unchecked_Access); + + if Is_Task_Type (Conctyp) then + RTS_Call := RTE (RE_Requeue_Protected_To_Task_Entry); + + else + pragma Assert (Is_Protected_Type (Conctyp)); + RTS_Call := RTE (RE_Requeue_Protected_Entry); + New_Param := + Make_Attribute_Reference (Loc, + Prefix => New_Param, + Attribute_Name => Name_Unchecked_Access); + end if; + + Prepend (New_Param, Params); + Prepend (Self_Param, Params); + exit; + + -- If neither task type or protected type, must be in some + -- inner enclosing block, so move on out + + else + Oldtyp := Scope (Oldtyp); + end if; + end loop; + + -- Create the GNARLI call. + + Rcall := Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTS_Call, Loc), + Parameter_Associations => Params); + + Rewrite (N, Rcall); + Analyze (N); + + if Is_Protected_Type (Oldtyp) then + + -- Build the return statement to skip the rest of the entry body + + Skip_Stat := Make_Return_Statement (Loc); + + else + -- If the requeue is within a task, find the end label of the + -- enclosing accept statement. + + Acc_Stat := Parent (N); + while Nkind (Acc_Stat) /= N_Accept_Statement loop + Acc_Stat := Parent (Acc_Stat); + end loop; + + -- The last statement is the second label, used for completing the + -- rendezvous the usual way. + -- The label we are looking for is right before it. + + Lab_Node := + Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat)))); + + pragma Assert (Nkind (Lab_Node) = N_Label); + + -- Build the goto statement to skip the rest of the accept + -- statement. + + Skip_Stat := + Make_Goto_Statement (Loc, + Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc)); + end if; + + Set_Analyzed (Skip_Stat); + + Insert_After (N, Skip_Stat); + + end Expand_N_Requeue_Statement; + + ------------------------------- + -- Expand_N_Selective_Accept -- + ------------------------------- + + procedure Expand_N_Selective_Accept (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Alts : constant List_Id := Select_Alternatives (N); + + Accept_Case : List_Id; + Accept_List : List_Id := New_List; + + Alt : Node_Id; + Alt_List : List_Id := New_List; + Alt_Stats : List_Id; + Ann : Entity_Id := Empty; + + Block : Node_Id; + Check_Guard : Boolean := True; + Decls : List_Id := New_List; + Stats : List_Id := New_List; + + Body_List : List_Id := New_List; + Trailing_List : List_Id := New_List; + + Choices : List_Id; + Else_Present : Boolean := False; + Terminate_Alt : Node_Id := Empty; + Select_Mode : Node_Id; + + Delay_Case : List_Id; + Delay_Count : Integer := 0; + Delay_Val : Entity_Id; + Delay_Index : Entity_Id; + Delay_Min : Entity_Id; + Delay_Num : Int := 1; + Delay_Alt_List : List_Id := New_List; + Delay_List : List_Id := New_List; + D : Entity_Id; + M : Entity_Id; + + First_Delay : Boolean := True; + Guard_Open : Entity_Id; + + End_Lab : Node_Id; + Index : Int := 1; + Lab : Node_Id; + Num_Alts : Int; + Num_Accept : Nat := 0; + Proc : Node_Id; + Q : Node_Id; + Time_Type : Entity_Id; + X : Node_Id; + Select_Call : Node_Id; + + Qnam : constant Entity_Id := + Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); + + Xnam : constant Entity_Id := + Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Accept_Or_Raise return List_Id; + -- For the rare case where delay alternatives all have guards, and + -- all of them are closed, it is still possible that there were open + -- accept alternatives with no callers. We must reexamine the + -- Accept_List, and execute a selective wait with no else if some + -- accept is open. If none, we raise program_error. + + procedure Add_Accept (Alt : Node_Id); + -- Process a single accept statement in a select alternative. Build + -- procedure for body of accept, and add entry to dispatch table with + -- expression for guard, in preparation for call to run time select. + + function Make_And_Declare_Label (Num : Int) return Node_Id; + -- Manufacture a label using Num as a serial number and declare it. + -- The declaration is appended to Decls. The label marks the trailing + -- statements of an accept or delay alternative. + + function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; + -- Build call to Selective_Wait runtime routine. + + procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); + -- Add code to compare value of delay with previous values, and + -- generate case entry for trailing statements. + + procedure Process_Accept_Alternative + (Alt : Node_Id; + Index : Int; + Proc : Node_Id); + -- Add code to call corresponding procedure, and branch to + -- trailing statements, if any. + + --------------------- + -- Accept_Or_Raise -- + --------------------- + + function Accept_Or_Raise return List_Id is + Cond : Node_Id; + Stats : List_Id; + J : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('J')); + + begin + -- We generate the following: + + -- for J in q'range loop + -- if q(J).S /=null_task_entry then + -- selective_wait (simple_mode,...); + -- done := True; + -- exit; + -- end if; + -- end loop; + -- + -- if no rendez_vous then + -- raise program_error; + -- end if; + + -- Note that the code needs to know that the selector name + -- in an Accept_Alternative is named S. + + Cond := Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Qnam, Loc), + Expressions => New_List (New_Reference_To (J, Loc))), + Selector_Name => Make_Identifier (Loc, Name_S)), + Right_Opnd => + New_Reference_To (RTE (RE_Null_Task_Entry), Loc)); + + Stats := New_List ( + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => J, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Qnam, Loc), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, 1))))), + + Statements => New_List ( + Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Select_Call ( + New_Reference_To (RTE (RE_Simple_Mode), Loc)), + Make_Exit_Statement (Loc)))))); + + Append_To (Stats, + Make_Raise_Program_Error (Loc, + Condition => Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (Xnam, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_No_Rendezvous), Loc)))); + + return Stats; + end Accept_Or_Raise; + + ---------------- + -- Add_Accept -- + ---------------- + + procedure Add_Accept (Alt : Node_Id) is + Acc_Stm : constant Node_Id := Accept_Statement (Alt); + Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); + Eent : constant Entity_Id := Entity (Ename); + Index : constant Node_Id := Entry_Index (Acc_Stm); + Null_Body : Node_Id; + Proc_Body : Node_Id; + PB_Ent : Entity_Id; + Expr : Node_Id; + Call : Node_Id; + + begin + if No (Ann) then + Ann := Node (Last_Elmt (Accept_Address (Eent))); + end if; + + if Present (Condition (Alt)) then + Expr := + Make_Conditional_Expression (Loc, New_List ( + Condition (Alt), + Entry_Index_Expression (Loc, Eent, Index, Scope (Eent)), + New_Reference_To (RTE (RE_Null_Task_Entry), Loc))); + else + Expr := + Entry_Index_Expression + (Loc, Eent, Index, Scope (Eent)); + end if; + + if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then + Null_Body := New_Reference_To (Standard_False, Loc); + + if Abort_Allowed then + Call := Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)); + Insert_Before (First (Statements (Handled_Statement_Sequence ( + Accept_Statement (Alt)))), Call); + Analyze (Call); + end if; + + PB_Ent := + Make_Defining_Identifier (Sloc (Ename), + New_External_Name (Chars (Ename), 'A', Num_Accept)); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => PB_Ent), + Declarations => Declarations (Acc_Stm), + Handled_Statement_Sequence => + Build_Accept_Body (Accept_Statement (Alt))); + + -- During the analysis of the body of the accept statement, any + -- zero cost exception handler records were collected in the + -- Accept_Handler_Records field of the N_Accept_Alternative + -- node. This is where we move them to where they belong, + -- namely the newly created procedure. + + Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); + Append (Proc_Body, Body_List); + + else + Null_Body := New_Reference_To (Standard_True, Loc); + + -- if accept statement has declarations, insert above, given + -- that we are not creating a body for the accept. + + if Present (Declarations (Acc_Stm)) then + Insert_Actions (N, Declarations (Acc_Stm)); + end if; + end if; + + Append_To (Accept_List, + Make_Aggregate (Loc, Expressions => New_List (Null_Body, Expr))); + + Num_Accept := Num_Accept + 1; + + end Add_Accept; + + ---------------------------- + -- Make_And_Declare_Label -- + ---------------------------- + + function Make_And_Declare_Label (Num : Int) return Node_Id is + Lab_Id : Node_Id; + + begin + Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); + Lab := + Make_Label (Loc, Lab_Id); + + Append_To (Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Lab_Id)), + Label_Construct => Lab)); + + return Lab; + end Make_And_Declare_Label; + + ---------------------- + -- Make_Select_Call -- + ---------------------- + + function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is + Params : List_Id := New_List; + + begin + Append ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Qnam, Loc), + Attribute_Name => Name_Unchecked_Access), + Params); + Append (Select_Mode, Params); + Append (New_Reference_To (Ann, Loc), Params); + Append (New_Reference_To (Xnam, Loc), Params); + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Selective_Wait), Loc), + Parameter_Associations => Params); + end Make_Select_Call; + + -------------------------------- + -- Process_Accept_Alternative -- + -------------------------------- + + procedure Process_Accept_Alternative + (Alt : Node_Id; + Index : Int; + Proc : Node_Id) + is + Choices : List_Id := No_List; + Alt_Stats : List_Id; + + begin + Adjust_Condition (Condition (Alt)); + Alt_Stats := No_List; + + if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then + Choices := New_List ( + Make_Integer_Literal (Loc, Index)); + + Alt_Stats := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Defining_Unit_Name (Specification (Proc)), Loc))); + end if; + + if Statements (Alt) /= Empty_List then + + if No (Alt_Stats) then + + -- Accept with no body, followed by trailing statements. + + Choices := New_List ( + Make_Integer_Literal (Loc, Index)); + + Alt_Stats := New_List; + end if; + + -- After the call, if any, branch to to trailing statements. + -- We create a label for each, as well as the corresponding + -- label declaration. + + Lab := Make_And_Declare_Label (Index); + Append_To (Alt_Stats, + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (Lab)))); + + Append (Lab, Trailing_List); + Append_List (Statements (Alt), Trailing_List); + Append_To (Trailing_List, + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + end if; + + if Present (Alt_Stats) then + + -- Procedure call. and/or trailing statements + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choices, + Statements => Alt_Stats)); + end if; + end Process_Accept_Alternative; + + ------------------------------- + -- Process_Delay_Alternative -- + ------------------------------- + + procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is + Choices : List_Id; + Cond : Node_Id; + Delay_Alt : List_Id; + + begin + -- Deal with C/Fortran boolean as delay condition + + Adjust_Condition (Condition (Alt)); + + -- Determine the smallest specified delay. + -- for each delay alternative generate: + + -- if guard-expression then + -- Delay_Val := delay-expression; + -- Guard_Open := True; + -- if Delay_Val < Delay_Min then + -- Delay_Min := Delay_Val; + -- Delay_Index := Index; + -- end if; + -- end if; + + -- The enclosing if-statement is omitted if there is no guard. + + if Delay_Count = 1 + or else First_Delay + then + First_Delay := False; + + Delay_Alt := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Min, Loc), + Expression => Expression (Delay_Statement (Alt)))); + + if Delay_Count > 1 then + Append_To (Delay_Alt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Index, Loc), + Expression => Make_Integer_Literal (Loc, Index))); + end if; + + else + Delay_Alt := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Val, Loc), + Expression => Expression (Delay_Statement (Alt)))); + + if Time_Type = Standard_Duration then + Cond := + Make_Op_Lt (Loc, + Left_Opnd => New_Reference_To (Delay_Val, Loc), + Right_Opnd => New_Reference_To (Delay_Min, Loc)); + + else + -- The scope of the time type must define a comparison + -- operator. The scope itself may not be visible, so we + -- construct a node with entity information to insure that + -- semantic analysis can find the proper operator. + + Cond := + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Reference_To (Scope (Time_Type), Loc), + Selector_Name => + Make_Operator_Symbol (Loc, + Chars => Name_Op_Lt, + Strval => No_String)), + Parameter_Associations => + New_List ( + New_Reference_To (Delay_Val, Loc), + New_Reference_To (Delay_Min, Loc))); + + Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); + end if; + + Append_To (Delay_Alt, + Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Min, Loc), + Expression => New_Reference_To (Delay_Val, Loc)), + + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Index, Loc), + Expression => Make_Integer_Literal (Loc, Index))))); + end if; + + if Check_Guard then + Append_To (Delay_Alt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Guard_Open, Loc), + Expression => New_Reference_To (Standard_True, Loc))); + end if; + + if Present (Condition (Alt)) then + Delay_Alt := New_List ( + Make_Implicit_If_Statement (N, + Condition => Condition (Alt), + Then_Statements => Delay_Alt)); + end if; + + Append_List (Delay_Alt, Delay_List); + + -- If the delay alternative has a statement part, add a + -- choice to the case statements for delays. + + if Present (Statements (Alt)) then + + if Delay_Count = 1 then + Append_List (Statements (Alt), Delay_Alt_List); + + else + Choices := New_List ( + Make_Integer_Literal (Loc, Index)); + + Append_To (Delay_Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choices, + Statements => Statements (Alt))); + end if; + + elsif Delay_Count = 1 then + + -- If the single delay has no trailing statements, add a branch + -- to the exit label to the selective wait. + + Delay_Alt_List := New_List ( + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + + end if; + end Process_Delay_Alternative; + + -- Start of processing for Expand_N_Selective_Accept + + begin + -- First insert some declarations before the select. The first is: + + -- Ann : Address + + -- This variable holds the parameters passed to the accept body. This + -- declaration has already been inserted by the time we get here by + -- a call to Expand_Accept_Declarations made from the semantics when + -- processing the first accept statement contained in the select. We + -- can find this entity as Accept_Address (E), where E is any of the + -- entries references by contained accept statements. + + -- The first step is to scan the list of Selective_Accept_Statements + -- to find this entity, and also count the number of accepts, and + -- determine if terminated, delay or else is present: + + Num_Alts := 0; + + Alt := First (Alts); + while Present (Alt) loop + + if Nkind (Alt) = N_Accept_Alternative then + Add_Accept (Alt); + + elsif Nkind (Alt) = N_Delay_Alternative then + Delay_Count := Delay_Count + 1; + + -- If the delays are relative delays, the delay expressions have + -- type Standard_Duration. Otherwise they must have some time type + -- recognized by GNAT. + + if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then + Time_Type := Standard_Duration; + else + Time_Type := Etype (Expression (Delay_Statement (Alt))); + + if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) + or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) + then + null; + else + Error_Msg_NE ( + "& is not a time type ('R'M 9.6(6))", + Expression (Delay_Statement (Alt)), Time_Type); + Time_Type := Standard_Duration; + Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); + end if; + end if; + + if No (Condition (Alt)) then + + -- This guard will always be open. + + Check_Guard := False; + end if; + + elsif Nkind (Alt) = N_Terminate_Alternative then + Adjust_Condition (Condition (Alt)); + Terminate_Alt := Alt; + end if; + + Num_Alts := Num_Alts + 1; + Next (Alt); + end loop; + + Else_Present := Present (Else_Statements (N)); + + -- At the same time (see procedure Add_Accept) we build the accept list: + + -- Qnn : Accept_List (1 .. num-select) := ( + -- (null-body, entry-index), + -- (null-body, entry-index), + -- .. + -- (null_body, entry-index)); + + -- In the above declaration, null-body is True if the corresponding + -- accept has no body, and false otherwise. The entry is either the + -- entry index expression if there is no guard, or if a guard is + -- present, then a conditional expression of the form: + + -- (if guard then entry-index else Null_Task_Entry) + + -- If a guard is statically known to be false, the entry can simply + -- be omitted from the accept list. + + Q := + Make_Object_Declaration (Loc, + Defining_Identifier => Qnam, + Object_Definition => + New_Reference_To (RTE (RE_Accept_List), Loc), + Aliased_Present => True, + + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Accept_List), Loc), + Expression => + Make_Aggregate (Loc, Expressions => Accept_List))); + + Append (Q, Decls); + + -- Then we declare the variable that holds the index for the accept + -- that will be selected for service: + + -- Xnn : Select_Index; + + X := + Make_Object_Declaration (Loc, + Defining_Identifier => Xnam, + Object_Definition => + New_Reference_To (RTE (RE_Select_Index), Loc), + Expression => + New_Reference_To (RTE (RE_No_Rendezvous), Loc)); + + Append (X, Decls); + + -- After this follow procedure declarations for each accept body. + + -- procedure Pnn is + -- begin + -- ... + -- end; + + -- where the ... are statements from the corresponding procedure body. + -- No parameters are involved, since the parameters are passed via Ann + -- and the parameter references have already been expanded to be direct + -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, + -- any embedded tasking statements (which would normally be illegal in + -- procedures, have been converted to calls to the tasking runtime so + -- there is no problem in putting them into procedures. + + -- The original accept statement has been expanded into a block in + -- the same fashion as for simple accepts (see Build_Accept_Body). + + -- Note: we don't really need to build these procedures for the case + -- where no delay statement is present, but it is just as easy to + -- build them unconditionally, and not significantly inefficient, + -- since if they are short they will be inlined anyway. + + -- The procedure declarations have been assembled in Body_List. + + -- If delays are present, we must compute the required delay. + -- We first generate the declarations: + + -- Delay_Index : Boolean := 0; + -- Delay_Min : Some_Time_Type.Time; + -- Delay_Val : Some_Time_Type.Time; + + -- Delay_Index will be set to the index of the minimum delay, i.e. the + -- active delay that is actually chosen as the basis for the possible + -- delay if an immediate rendez-vous is not possible. + -- In the most common case there is a single delay statement, and this + -- is handled specially. + + if Delay_Count > 0 then + + -- Generate the required declarations + + Delay_Val := + Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); + Delay_Index := + Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); + Delay_Min := + Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Delay_Val, + Object_Definition => New_Reference_To (Time_Type, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Delay_Index, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Delay_Min, + Object_Definition => New_Reference_To (Time_Type, Loc), + Expression => + Unchecked_Convert_To (Time_Type, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Underlying_Type (Time_Type), Loc), + Attribute_Name => Name_Last)))); + + -- Create Duration and Delay_Mode objects used for passing a delay + -- value to RTS + + D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + + declare + Discr : Entity_Id; + + begin + -- Note that these values are defined in s-osprim.ads and must + -- be kept in sync: + -- + -- Relative : constant := 0; + -- Absolute_Calendar : constant := 1; + -- Absolute_RT : constant := 2; + + if Time_Type = Standard_Duration then + Discr := Make_Integer_Literal (Loc, 0); + + elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then + Discr := Make_Integer_Literal (Loc, 1); + + else + pragma Assert + (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); + Discr := Make_Integer_Literal (Loc, 2); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => D, + Object_Definition => + New_Reference_To (Standard_Duration, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => M, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => Discr)); + end; + + if Check_Guard then + Guard_Open := + Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Guard_Open, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc))); + end if; + + -- Delay_Count is zero, don't need M and D set (suppress warning) + + else + M := Empty; + D := Empty; + end if; + + if Present (Terminate_Alt) then + + -- If the terminate alternative guard is False, use + -- Simple_Mode; otherwise use Terminate_Mode. + + if Present (Condition (Terminate_Alt)) then + Select_Mode := Make_Conditional_Expression (Loc, + New_List (Condition (Terminate_Alt), + New_Reference_To (RTE (RE_Terminate_Mode), Loc), + New_Reference_To (RTE (RE_Simple_Mode), Loc))); + else + Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc); + end if; + + elsif Else_Present or Delay_Count > 0 then + Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc); + + else + Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc); + end if; + + Select_Call := Make_Select_Call (Select_Mode); + Append (Select_Call, Stats); + + -- Now generate code to act on the result. There is an entry + -- in this case for each accept statement with a non-null body, + -- followed by a branch to the statements that follow the Accept. + -- In the absence of delay alternatives, we generate: + + -- case X is + -- when No_Rendezvous => -- omitted if simple mode + -- goto Lab0; + + -- when 1 => + -- P1n; + -- goto Lab1; + + -- when 2 => + -- P2n; + -- goto Lab2; + + -- when others => + -- goto Exit; + -- end case; + -- + -- Lab0: Else_Statements; + -- goto exit; + + -- Lab1: Trailing_Statements1; + -- goto Exit; + -- + -- Lab2: Trailing_Statements2; + -- goto Exit; + -- ... + -- Exit: + + -- Generate label for common exit. + + End_Lab := Make_And_Declare_Label (Num_Alts + 1); + + -- First entry is the default case, when no rendezvous is possible. + + Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc)); + + if Else_Present then + + -- If no rendezvous is possible, the else part is executed. + + Lab := Make_And_Declare_Label (0); + Alt_Stats := New_List ( + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (Lab)))); + + Append (Lab, Trailing_List); + Append_List (Else_Statements (N), Trailing_List); + Append_To (Trailing_List, + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + else + Alt_Stats := New_List ( + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + end if; + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choices, + Statements => Alt_Stats)); + + -- We make use of the fact that Accept_Index is an integer type, + -- and generate successive literals for entries for each accept. + -- Only those for which there is a body or trailing statements are + -- given a case entry. + + Alt := First (Select_Alternatives (N)); + Proc := First (Body_List); + + while Present (Alt) loop + + if Nkind (Alt) = N_Accept_Alternative then + Process_Accept_Alternative (Alt, Index, Proc); + Index := Index + 1; + + if Present + (Handled_Statement_Sequence (Accept_Statement (Alt))) + then + Next (Proc); + end if; + + elsif Nkind (Alt) = N_Delay_Alternative then + Process_Delay_Alternative (Alt, Delay_Num); + Delay_Num := Delay_Num + 1; + end if; + + Next (Alt); + end loop; + + -- An others choice is always added to the main case, as well + -- as the delay case (to satisfy the compiler). + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))))); + + Accept_Case := New_List ( + Make_Case_Statement (Loc, + Expression => New_Reference_To (Xnam, Loc), + Alternatives => Alt_List)); + + Append_List (Trailing_List, Accept_Case); + Append (End_Lab, Accept_Case); + Append_List (Body_List, Decls); + + -- Construct case statement for trailing statements of delay + -- alternatives, if there are several of them. + + if Delay_Count > 1 then + Append_To (Delay_Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Null_Statement (Loc)))); + + Delay_Case := New_List ( + Make_Case_Statement (Loc, + Expression => New_Reference_To (Delay_Index, Loc), + Alternatives => Delay_Alt_List)); + else + Delay_Case := Delay_Alt_List; + end if; + + -- If there are no delay alternatives, we append the case statement + -- to the statement list. + + if Delay_Count = 0 then + Append_List (Accept_Case, Stats); + + -- Delay alternatives present + + else + -- If delay alternatives are present we generate: + + -- find minimum delay. + -- DX := minimum delay; + -- M := <delay mode>; + -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, + -- DX, MX, X); + -- + -- if X = No_Rendezvous then + -- case statement for delay statements. + -- else + -- case statement for accept alternatives. + -- end if; + + declare + Cases : Node_Id; + Stmt : Node_Id; + Parms : List_Id; + Parm : Node_Id; + Conv : Node_Id; + + begin + -- The type of the delay expression is known to be legal + + if Time_Type = Standard_Duration then + Conv := New_Reference_To (Delay_Min, Loc); + + elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then + Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_CA_To_Duration), Loc), + New_List (New_Reference_To (Delay_Min, Loc))); + + else + pragma Assert + (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); + + Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_RT_To_Duration), Loc), + New_List (New_Reference_To (Delay_Min, Loc))); + end if; + + Stmt := Make_Assignment_Statement (Loc, + Name => New_Reference_To (D, Loc), + Expression => Conv); + + -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) + + Parms := Parameter_Associations (Select_Call); + Parm := First (Parms); + + while Present (Parm) + and then Parm /= Select_Mode + loop + Next (Parm); + end loop; + + pragma Assert (Present (Parm)); + Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc)); + Analyze (Parm); + + -- Prepare two new parameters of Duration and Delay_Mode type + -- which represent the value and the mode of the minimum delay. + + Next (Parm); + Insert_After (Parm, New_Reference_To (M, Loc)); + Insert_After (Parm, New_Reference_To (D, Loc)); + + -- Create a call to RTS. + + Rewrite (Select_Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc), + Parameter_Associations => Parms)); + + -- This new call should follow the calculation of the + -- minimum delay. + + Insert_List_Before (Select_Call, Delay_List); + + if Check_Guard then + Stmt := + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (Guard_Open, Loc), + Then_Statements => + New_List (New_Copy_Tree (Stmt), + New_Copy_Tree (Select_Call)), + Else_Statements => Accept_Or_Raise); + Rewrite (Select_Call, Stmt); + else + Insert_Before (Select_Call, Stmt); + end if; + + Cases := + Make_Implicit_If_Statement (N, + Condition => Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (Xnam, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_No_Rendezvous), Loc)), + + Then_Statements => Delay_Case, + Else_Statements => Accept_Case); + + Append (Cases, Stats); + end; + end if; + + -- Replace accept statement with appropriate block + + Block := + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats)); + + Rewrite (N, Block); + Analyze (N); + + -- Note: have to worry more about abort deferral in above code ??? + + -- Final step is to unstack the Accept_Address entries for all accept + -- statements appearing in accept alternatives in the select statement + + Alt := First (Alts); + while Present (Alt) loop + if Nkind (Alt) = N_Accept_Alternative then + Remove_Last_Elmt (Accept_Address + (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); + end if; + + Next (Alt); + end loop; + + end Expand_N_Selective_Accept; + + -------------------------------------- + -- Expand_N_Single_Task_Declaration -- + -------------------------------------- + + -- Single task declarations should never be present after semantic + -- analysis, since we expect them to be replaced by a declaration of + -- an anonymous task type, followed by a declaration of the task + -- object. We include this routine to make sure that is happening! + + procedure Expand_N_Single_Task_Declaration (N : Node_Id) is + begin + raise Program_Error; + end Expand_N_Single_Task_Declaration; + + ------------------------ + -- Expand_N_Task_Body -- + ------------------------ + + -- Given a task body + + -- task body tname is + -- <declarations> + -- begin + -- <statements> + -- end x; + + -- This expansion routine converts it into a procedure and sets the + -- elaboration flag for the procedure to true, to represent the fact + -- that the task body is now elaborated: + + -- procedure tnameB (_Task : access tnameV) is + -- discriminal : dtype renames _Task.discriminant; + -- + -- procedure _clean is + -- begin + -- Abort_Defer.all; + -- Complete_Task; + -- Abort_Undefer.all; + -- return; + -- end _clean; + -- begin + -- Abort_Undefer.all; + -- <declarations> + -- System.Task_Stages.Complete_Activation; + -- <statements> + -- at end + -- _clean; + -- end tnameB; + + -- tnameE := True; + + -- In addition, if the task body is an activator, then a call to + -- activate tasks is added at the start of the statements, before + -- the call to Complete_Activation, and if in addition the task is + -- a master then it must be established as a master. These calls are + -- inserted and analyzed in Expand_Cleanup_Actions, when the + -- Handled_Sequence_Of_Statements is expanded. + + -- There is one discriminal declaration line generated for each + -- discriminant that is present to provide an easy reference point + -- for discriminant references inside the body (see Exp_Ch2.Expand_Name). + + -- Note on relationship to GNARLI definition. In the GNARLI definition, + -- task body procedures have a profile (Arg : System.Address). That is + -- needed because GNARLI has to use the same access-to-subprogram type + -- for all task types. We depend here on knowing that in GNAT, passing + -- an address argument by value is identical to passing a record value + -- by access (in either case a single pointer is passed), so even though + -- this procedure has the wrong profile. In fact it's all OK, since the + -- callings sequence is identical. + + procedure Expand_N_Task_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ttyp : constant Entity_Id := Corresponding_Spec (N); + Call : Node_Id; + New_N : Node_Id; + + begin + Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc); + + -- Add a call to Abort_Undefer at the very beginning of the task + -- body since this body is called with abort still deferred. + + if Abort_Allowed then + Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); + Insert_Before + (First (Statements (Handled_Statement_Sequence (N))), Call); + Analyze (Call); + end if; + + -- The statement part has already been protected with an at_end and + -- cleanup actions. The call to Complete_Activation must be placed + -- at the head of the sequence of statements of that block. The + -- declarations have been merged in this sequence of statements but + -- the first real statement is accessible from the First_Real_Statement + -- field (which was set for exactly this purpose). + + if Restricted_Profile then + Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); + else + Call := Build_Runtime_Call (Loc, RE_Complete_Activation); + end if; + + Insert_Before + (First_Real_Statement (Handled_Statement_Sequence (N)), Call); + Analyze (Call); + + New_N := + Make_Subprogram_Body (Loc, + Specification => Build_Task_Proc_Specification (Ttyp), + Declarations => Declarations (N), + Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + + -- If the task contains generic instantiations, cleanup actions + -- are delayed until after instantiation. Transfer the activation + -- chain to the subprogram, to insure that the activation call is + -- properly generated. It the task body contains inner tasks, indicate + -- that the subprogram is a task master. + + if Delay_Cleanups (Ttyp) then + Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); + Set_Is_Task_Master (New_N, Is_Task_Master (N)); + end if; + + Rewrite (N, New_N); + Analyze (N); + + -- Set elaboration flag immediately after task body. If the body + -- is a subunit, the flag is set in the declarative part that + -- contains the stub. + + if Nkind (Parent (N)) /= N_Subunit then + Insert_After (N, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), + Expression => New_Reference_To (Standard_True, Loc))); + end if; + end Expand_N_Task_Body; + + ------------------------------------ + -- Expand_N_Task_Type_Declaration -- + ------------------------------------ + + -- We have several things to do. First we must create a Boolean flag used + -- to mark if the body is elaborated yet. This variable gets set to True + -- when the body of the task is elaborated (we can't rely on the normal + -- ABE mechanism for the task body, since we need to pass an access to + -- this elaboration boolean to the runtime routines). + + -- taskE : aliased Boolean := False; + + -- Next a variable is declared to hold the task stack size (either + -- the default : Unspecified_Size, or a value that is set by a pragma + -- Storage_Size). If the value of the pragma Storage_Size is static, then + -- the variable is initialized with this value: + + -- taskZ : Size_Type := Unspecified_Size; + -- or + -- taskZ : Size_Type := Size_Type (size_expression); + + -- Next we create a corresponding record type declaration used to represent + -- values of this task. The general form of this type declaration is + + -- type taskV (discriminants) is record + -- _Task_Id : Task_Id; + -- entry_family : array (bounds) of Void; + -- _Priority : Integer := priority_expression; + -- _Size : Size_Type := Size_Type (size_expression); + -- _Task_Info : Task_Info_Type := task_info_expression; + -- _Task_Name : Task_Image_Type := new String'(task_name_expression); + -- end record; + + -- The discriminants are present only if the corresponding task type has + -- discriminants, and they exactly mirror the task type discriminants. + + -- The Id field is always present. It contains the Task_Id value, as + -- set by the call to Create_Task. Note that although the task is + -- limited, the task value record type is not limited, so there is no + -- problem in passing this field as an out parameter to Create_Task. + + -- One entry_family component is present for each entry family in the + -- task definition. The bounds correspond to the bounds of the entry + -- family (which may depend on discriminants). The element type is + -- void, since we only need the bounds information for determining + -- the entry index. Note that the use of an anonymous array would + -- normally be illegal in this context, but this is a parser check, + -- and the semantics is quite prepared to handle such a case. + + -- The _Size field is present only if a Storage_Size pragma appears in + -- the task definition. The expression captures the argument that was + -- present in the pragma, and is used to override the task stack size + -- otherwise associated with the task type. + + -- The _Priority field is present only if a Priority or Interrupt_Priority + -- pragma appears in the task definition. The expression captures the + -- argument that was present in the pragma, and is used to provide + -- the Size parameter to the call to Create_Task. + + -- The _Task_Info field is present only if a Task_Info pragma appears in + -- the task definition. The expression captures the argument that was + -- present in the pragma, and is used to provide the Task_Image parameter + -- to the call to Create_Task. + + -- The _Task_Name field is present only if a Task_Name pragma appears in + -- the task definition. The expression captures the argument that was + -- present in the pragma, and is used to provide the Task_Id parameter + -- to the call to Create_Task. + + -- When a task is declared, an instance of the task value record is + -- created. The elaboration of this declaration creates the correct + -- bounds for the entry families, and also evaluates the size, priority, + -- and task_Info expressions if needed. The initialization routine for + -- the task type itself then calls Create_Task with appropriate + -- parameters to initialize the value of the Task_Id field. + + -- Note: the address of this record is passed as the "Discriminants" + -- parameter for Create_Task. Since Create_Task merely passes this onto + -- the body procedure, it does not matter that it does not quite match + -- the GNARLI model of what is being passed (the record contains more + -- than just the discriminants, but the discriminants can be found from + -- the record value). + + -- The Entity_Id for this created record type is placed in the + -- Corresponding_Record_Type field of the associated task type entity. + + -- Next we create a procedure specification for the task body procedure: + + -- procedure taskB (_Task : access taskV); + + -- Note that this must come after the record type declaration, since + -- the spec refers to this type. It turns out that the initialization + -- procedure for the value type references the task body spec, but that's + -- fine, since it won't be generated till the freeze point for the type, + -- which is certainly after the task body spec declaration. + + -- Finally, we set the task index value field of the entry attribute in + -- the case of a simple entry. + + procedure Expand_N_Task_Type_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); + Tasknm : constant Name_Id := Chars (Tasktyp); + Taskdef : constant Node_Id := Task_Definition (N); + Proc_Spec : Node_Id; + + Rec_Decl : Node_Id; + Rec_Ent : Entity_Id; + Cdecls : List_Id; + + Elab_Decl : Node_Id; + Size_Decl : Node_Id; + Body_Decl : Node_Id; + + begin + if Present (Corresponding_Record_Type (Tasktyp)) then + return; + + else + Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); + Rec_Ent := Defining_Identifier (Rec_Decl); + Cdecls := Component_Items + (Component_List (Type_Definition (Rec_Decl))); + end if; + + Qualify_Entity_Names (N); + + -- First create the elaboration variable + + Elab_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Tasktyp), + Chars => New_External_Name (Tasknm, 'E')), + Aliased_Present => True, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc)); + Insert_After (N, Elab_Decl); + + -- Next create the declaration of the size variable (tasknmZ) + + Set_Storage_Size_Variable (Tasktyp, + Make_Defining_Identifier (Sloc (Tasktyp), + Chars => New_External_Name (Tasknm, 'Z'))); + + if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then + Is_Static_Expression (Expression (First ( + Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma ( + Taskdef, Name_Storage_Size))))) + then + Size_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Storage_Size_Variable (Tasktyp), + Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc), + Expression => + Convert_To (RTE (RE_Size_Type), + Relocate_Node ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Storage_Size))))))); + + else + Size_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Storage_Size_Variable (Tasktyp), + Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc), + Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc)); + end if; + + Insert_After (Elab_Decl, Size_Decl); + + -- Next build the rest of the corresponding record declaration. + -- This is done last, since the corresponding record initialization + -- procedure will reference the previously created entities. + + -- Fill in the component declarations. First the _Task_Id field: + + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Id), + Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_ID), Loc))); + + -- Add components for entry families + + Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); + + -- Add the _Priority component if a Priority pragma is present + + if Present (Taskdef) and then Has_Priority_Pragma (Taskdef) then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uPriority), + Subtype_Indication => New_Reference_To (Standard_Integer, Loc), + Expression => New_Copy ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Priority))))))); + end if; + + -- Add the _Task_Size component if a Storage_Size pragma is present + + if Present (Taskdef) + and then Has_Storage_Size_Pragma (Taskdef) + then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uSize), + + Subtype_Indication => New_Reference_To (RTE (RE_Size_Type), Loc), + + Expression => + Convert_To (RTE (RE_Size_Type), + Relocate_Node ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Storage_Size)))))))); + end if; + + -- Add the _Task_Info component if a Task_Info pragma is present + + if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Info), + Subtype_Indication => + New_Reference_To (RTE (RE_Task_Info_Type), Loc), + Expression => New_Copy ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Task_Info))))))); + end if; + + -- Add the _Task_Name component if a Task_Name pragma is present + + if Present (Taskdef) and then Has_Task_Name_Pragma (Taskdef) then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Info), + Subtype_Indication => + New_Reference_To (RTE (RE_Task_Image_Type), Loc), + Expression => + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_String, Loc), + Expression => + New_Copy ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Task_Name))))))))); + end if; + + Insert_After (Size_Decl, Rec_Decl); + + -- Analyze the record declaration immediately after construction, + -- because the initialization procedure is needed for single task + -- declarations before the next entity is analyzed. + + Analyze (Rec_Decl); + + -- Create the declaration of the task body procedure + + Proc_Spec := Build_Task_Proc_Specification (Tasktyp); + Body_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Proc_Spec); + + Insert_After (Rec_Decl, Body_Decl); + + -- Now we can freeze the corresponding record. This needs manually + -- freezing, since it is really part of the task type, and the task + -- type is frozen at this stage. We of course need the initialization + -- procedure for this corresponding record type and we won't get it + -- in time if we don't freeze now. + + declare + L : constant List_Id := Freeze_Entity (Rec_Ent, Loc); + + begin + if Is_Non_Empty_List (L) then + Insert_List_After (Body_Decl, L); + end if; + end; + + -- Complete the expansion of access types to the current task + -- type, if any were declared. + + Expand_Previous_Access_Type (N, Tasktyp); + end Expand_N_Task_Type_Declaration; + + ------------------------------- + -- Expand_N_Timed_Entry_Call -- + ------------------------------- + + -- A timed entry call in normal case is not implemented using ATC + -- mechanism anymore for efficiency reason. + + -- select + -- T.E; + -- S1; + -- or + -- Delay D; + -- S2; + -- end select; + + -- is expanded as follow: + + -- 1) When T.E is a task entry_call; + + -- declare + -- B : Boolean; + -- X : Task_Entry_Index := <entry index>; + -- DX : Duration := To_Duration (D); + -- M : Delay_Mode := <discriminant>; + -- P : parms := (parm, parm, parm); + + -- begin + -- Timed_Protected_Entry_Call (<acceptor-task>, X, P'Address, + -- DX, M, B); + -- if B then + -- S1; + -- else + -- S2; + -- end if; + -- end; + + -- 2) When T.E is a protected entry_call; + + -- declare + -- B : Boolean; + -- X : Protected_Entry_Index := <entry index>; + -- DX : Duration := To_Duration (D); + -- M : Delay_Mode := <discriminant>; + -- P : parms := (parm, parm, parm); + + -- begin + -- Timed_Protected_Entry_Call (<object>'unchecked_access, X, + -- P'Address, DX, M, B); + -- if B then + -- S1; + -- else + -- S2; + -- end if; + -- end; + + procedure Expand_N_Timed_Entry_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + E_Call : Node_Id := + Entry_Call_Statement (Entry_Call_Alternative (N)); + E_Stats : constant List_Id := + Statements (Entry_Call_Alternative (N)); + D_Stat : constant Node_Id := + Delay_Statement (Delay_Alternative (N)); + D_Stats : constant List_Id := + Statements (Delay_Alternative (N)); + + Stmts : List_Id; + Stmt : Node_Id; + Parms : List_Id; + Parm : Node_Id; + + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id; + + Decls : List_Id; + Disc : Node_Id; + Conv : Node_Id; + B : Entity_Id; + D : Entity_Id; + Dtyp : Entity_Id; + M : Entity_Id; + + Call : Node_Id; + Dummy : Node_Id; + + begin + -- The arguments in the call may require dynamic allocation, and the + -- call statement may have been transformed into a block. The block + -- may contain additional declarations for internal entities, and the + -- original call is found by sequential search. + + if Nkind (E_Call) = N_Block_Statement then + E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); + + while Nkind (E_Call) /= N_Procedure_Call_Statement + and then Nkind (E_Call) /= N_Entry_Call_Statement + loop + Next (E_Call); + end loop; + end if; + + -- Build an entry call using Simple_Entry_Call. We will use this as the + -- base for creating appropriate calls. + + Extract_Entry (E_Call, Concval, Ename, Index); + Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); + + Stmts := Statements (Handled_Statement_Sequence (E_Call)); + Decls := Declarations (E_Call); + + if No (Decls) then + Decls := New_List; + end if; + + Dtyp := Base_Type (Etype (Expression (D_Stat))); + + -- Use the type of the delay expression (Calendar or Real_Time) + -- to generate the appropriate conversion. + + if Nkind (D_Stat) = N_Delay_Relative_Statement then + Disc := Make_Integer_Literal (Loc, 0); + Conv := Relocate_Node (Expression (D_Stat)); + + elsif Is_RTE (Dtyp, RO_CA_Time) then + Disc := Make_Integer_Literal (Loc, 1); + Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_CA_To_Duration), Loc), + New_List (New_Copy (Expression (D_Stat)))); + + else pragma Assert (Is_RTE (Dtyp, RO_RT_Time)); + Disc := Make_Integer_Literal (Loc, 2); + Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_RT_To_Duration), Loc), + New_List (New_Copy (Expression (D_Stat)))); + end if; + + -- Create a Duration and a Delay_Mode object used for passing a delay + -- value + + D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => D, + Object_Definition => New_Reference_To (Standard_Duration, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => M, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => Disc)); + + B := Make_Defining_Identifier (Loc, Name_uB); + + -- Create a boolean object used for a return parameter. + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + + Stmt := First (Stmts); + + -- Skip assignments to temporaries created for in-out parameters. + -- This makes unwarranted assumptions about the shape of the expanded + -- tree for the call, and should be cleaned up ??? + + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + -- Do the assignement at this stage only because the evaluation of the + -- expression must not occur before (see ACVC C97302A). + + Insert_Before (Stmt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (D, Loc), + Expression => Conv)); + + Call := Stmt; + + Parms := Parameter_Associations (Call); + + -- For a protected type, we build a Timed_Protected_Entry_Call + + if Is_Protected_Type (Etype (Concval)) then + + -- Create a new call statement + + Parm := First (Parms); + + while Present (Parm) + and then not Is_RTE (Etype (Parm), RE_Call_Modes) + loop + Next (Parm); + end loop; + + Dummy := Remove_Next (Next (Parm)); + + -- In case some garbage is following the Cancel_Param, remove. + + Dummy := Next (Parm); + + -- Remove the mode of the Protected_Entry_Call call, the + -- Communication_Block of the Protected_Entry_Call call, and add a + -- Duration and a Delay_Mode parameter + + pragma Assert (Present (Parm)); + Rewrite (Parm, New_Reference_To (D, Loc)); + + Rewrite (Dummy, New_Reference_To (M, Loc)); + + -- Add a Boolean flag for successful entry call. + + Append_To (Parms, New_Reference_To (B, Loc)); + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Etype (Concval)) > 1 + then + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), + Parameter_Associations => Parms)); + + else + Parm := First (Parms); + + while Present (Parm) + and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index) + loop + Next (Parm); + end loop; + + Remove (Parm); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Timed_Protected_Single_Entry_Call), Loc), + Parameter_Associations => Parms)); + end if; + + -- For the task case, build a Timed_Task_Entry_Call + + else + -- Create a new call statement + + Append_To (Parms, New_Reference_To (D, Loc)); + Append_To (Parms, New_Reference_To (M, Loc)); + Append_To (Parms, New_Reference_To (B, Loc)); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), + Parameter_Associations => Parms)); + + end if; + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (B, Loc), + Then_Statements => E_Stats, + Else_Statements => D_Stats)); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + + end Expand_N_Timed_Entry_Call; + + ---------------------------------------- + -- Expand_Protected_Body_Declarations -- + ---------------------------------------- + + -- Part of the expansion of a protected body involves the creation of + -- a declaration that can be referenced from the statement sequences of + -- the entry bodies: + + -- A : Address; + + -- This declaration is inserted in the declarations of the service + -- entries procedure for the protected body, and it is important that + -- it be inserted before the statements of the entry body statement + -- sequences are analyzed. Thus it would be too late to create this + -- declaration in the Expand_N_Protected_Body routine, which is why + -- there is a separate procedure to be called directly from Sem_Ch9. + + -- Ann is used to hold the address of the record containing the parameters + -- (see Expand_N_Entry_Call for more details on how this record is built). + -- References to the parameters do an unchecked conversion of this address + -- to a pointer to the required record type, and then access the field that + -- holds the value of the required parameter. The entity for the address + -- variable is held as the top stack element (i.e. the last element) of the + -- Accept_Address stack in the corresponding entry entity, and this element + -- must be set in place before the statements are processed. + + -- No stack is needed for entry bodies, since they cannot be nested, but + -- it is kept for consistency between protected and task entries. The + -- stack will never contain more than one element. There is also only one + -- such variable for a given protected body, but this is placed on the + -- Accept_Address stack of all of the entries, again for consistency. + + -- To expand the requeue statement, a label is provided at the end of + -- the loop in the entry service routine created by the expander (see + -- Expand_N_Protected_Body for details), so that the statement can be + -- skipped after the requeue is complete. This label is created during the + -- expansion of the entry body, which will take place after the expansion + -- of the requeue statements that it contains, so a placeholder defining + -- identifier is associated with the task type here. + + -- Another label is provided following case statement created by the + -- expander. This label is need for implementing return statement from + -- entry body so that a return can be expanded as a goto to this label. + -- This label is created during the expansion of the entry body, which + -- will take place after the expansion of the return statements that it + -- contains. Therefore, just like the label for expanding requeues, we + -- need another placeholder for the label. + + procedure Expand_Protected_Body_Declarations + (N : Node_Id; + Spec_Id : Entity_Id) + is + Op : Node_Id; + + begin + if Expander_Active then + + -- Associate privals with the first subprogram or entry + -- body to be expanded. These are used to expand references + -- to private data objects. + + Op := First_Protected_Operation (Declarations (N)); + + if Present (Op) then + Set_Discriminals (Parent (Spec_Id), Op, Sloc (N)); + Set_Privals (Parent (Spec_Id), Op, Sloc (N)); + end if; + end if; + end Expand_Protected_Body_Declarations; + + ------------------------- + -- External_Subprogram -- + ------------------------- + + function External_Subprogram (E : Entity_Id) return Entity_Id is + Subp : constant Entity_Id := Protected_Body_Subprogram (E); + Decl : constant Node_Id := Unit_Declaration_Node (E); + + begin + -- If the protected operation is defined in the visible part of the + -- protected type, or if it is an interrupt handler, the internal and + -- external subprograms follow each other on the entity chain. If the + -- operation is defined in the private part of the type, there is no + -- need for a separate locking version of the operation, and internal + -- calls use the protected_body_subprogram directly. + + if List_Containing (Decl) = Visible_Declarations (Parent (Decl)) + or else Is_Interrupt_Handler (E) + then + return Next_Entity (Subp); + else + return (Subp); + end if; + end External_Subprogram; + + ------------------- + -- Extract_Entry -- + ------------------- + + procedure Extract_Entry + (N : Node_Id; + Concval : out Node_Id; + Ename : out Node_Id; + Index : out Node_Id) + is + Nam : constant Node_Id := Name (N); + + begin + -- For a simple entry, the name is a selected component, with the + -- prefix being the task value, and the selector being the entry. + + if Nkind (Nam) = N_Selected_Component then + Concval := Prefix (Nam); + Ename := Selector_Name (Nam); + Index := Empty; + + -- For a member of an entry family, the name is an indexed + -- component where the prefix is a selected component, + -- whose prefix in turn is the task value, and whose + -- selector is the entry family. The single expression in + -- the expressions list of the indexed component is the + -- subscript for the family. + + else + pragma Assert (Nkind (Nam) = N_Indexed_Component); + Concval := Prefix (Prefix (Nam)); + Ename := Selector_Name (Prefix (Nam)); + Index := First (Expressions (Nam)); + end if; + + end Extract_Entry; + + ------------------- + -- Family_Offset -- + ------------------- + + function Family_Offset + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id) + return Node_Id + is + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- If one of the bounds is a reference to a discriminant, replace + -- with corresponding discriminal of type. Within the body of a task + -- retrieve the renamed discriminant by simple visibility, using its + -- generated name. Within a protected object, find the original dis- + -- criminant and replace it with the discriminal of the current prot- + -- ected operation. + + ------------------------------ + -- Convert_Discriminant_Ref -- + ------------------------------ + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Bound); + B : Node_Id; + D : Entity_Id; + + begin + if Is_Entity_Name (Bound) + and then Ekind (Entity (Bound)) = E_Discriminant + then + if Is_Task_Type (Ttyp) + and then Has_Completion (Ttyp) + then + B := Make_Identifier (Loc, Chars (Entity (Bound))); + Find_Direct_Name (B); + + elsif Is_Protected_Type (Ttyp) then + D := First_Discriminant (Ttyp); + + while Chars (D) /= Chars (Entity (Bound)) loop + Next_Discriminant (D); + end loop; + + B := New_Reference_To (Discriminal (D), Loc); + + else + B := New_Reference_To (Discriminal (Entity (Bound)), Loc); + end if; + + elsif Nkind (Bound) = N_Attribute_Reference then + return Bound; + + else + B := New_Copy_Tree (Bound); + end if; + + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Etype (Bound), Loc), + Expressions => New_List (B)); + end Convert_Discriminant_Ref; + + -- Start of processing for Family_Offset + + begin + return + Make_Op_Subtract (Loc, + Left_Opnd => Convert_Discriminant_Ref (Hi), + Right_Opnd => Convert_Discriminant_Ref (Lo)); + + end Family_Offset; + + ----------------- + -- Family_Size -- + ----------------- + + function Family_Size + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id) + return Node_Id + is + Ityp : Entity_Id; + + begin + if Is_Task_Type (Ttyp) then + Ityp := RTE (RE_Task_Entry_Index); + else + Ityp := RTE (RE_Protected_Entry_Index); + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ityp, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Family_Offset (Loc, Hi, Lo, Ttyp), + Right_Opnd => + Make_Integer_Literal (Loc, 1)), + Make_Integer_Literal (Loc, 0))); + end Family_Size; + + ----------------------------------- + -- Find_Task_Or_Protected_Pragma -- + ----------------------------------- + + function Find_Task_Or_Protected_Pragma + (T : Node_Id; + P : Name_Id) + return Node_Id + is + N : Node_Id; + + begin + N := First (Visible_Declarations (T)); + + while Present (N) loop + if Nkind (N) = N_Pragma then + if Chars (N) = P then + return N; + + elsif P = Name_Priority + and then Chars (N) = Name_Interrupt_Priority + then + return N; + + else + Next (N); + end if; + + else + Next (N); + end if; + end loop; + + N := First (Private_Declarations (T)); + + while Present (N) loop + if Nkind (N) = N_Pragma then + if Chars (N) = P then + return N; + + elsif P = Name_Priority + and then Chars (N) = Name_Interrupt_Priority + then + return N; + + else + Next (N); + end if; + + else + Next (N); + end if; + end loop; + + raise Program_Error; + end Find_Task_Or_Protected_Pragma; + + ------------------------------- + -- First_Protected_Operation -- + ------------------------------- + + function First_Protected_Operation (D : List_Id) return Node_Id is + First_Op : Node_Id; + + begin + First_Op := First (D); + while Present (First_Op) + and then Nkind (First_Op) /= N_Subprogram_Body + and then Nkind (First_Op) /= N_Entry_Body + loop + Next (First_Op); + end loop; + + return First_Op; + end First_Protected_Operation; + + -------------------------------- + -- Index_Constant_Declaration -- + -------------------------------- + + function Index_Constant_Declaration + (N : Node_Id; + Index_Id : Entity_Id; + Prot : Entity_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Decls : List_Id := New_List; + Index_Con : constant Entity_Id := Entry_Index_Constant (Index_Id); + Index_Typ : Entity_Id; + + Hi : Node_Id := Type_High_Bound (Etype (Index_Id)); + Lo : Node_Id := Type_Low_Bound (Etype (Index_Id)); + + function Replace_Discriminant (Bound : Node_Id) return Node_Id; + -- The bounds of the entry index may depend on discriminants, so + -- each declaration of an entry_index_constant must have its own + -- subtype declaration, using the local renaming of the object discri- + -- minant. + + -------------------------- + -- Replace_Discriminant -- + -------------------------- + + function Replace_Discriminant (Bound : Node_Id) return Node_Id is + begin + if Nkind (Bound) = N_Identifier + and then Ekind (Entity (Bound)) = E_Constant + and then Present (Discriminal_Link (Entity (Bound))) + then + return Make_Identifier (Loc, Chars (Entity (Bound))); + else + return Duplicate_Subexpr (Bound); + end if; + end Replace_Discriminant; + + -- Start of processing for Index_Constant_Declaration + + begin + Set_Discriminal_Link (Index_Con, Index_Id); + + if Is_Entity_Name ( + Original_Node (Discrete_Subtype_Definition (Parent (Index_Id)))) + then + -- Simple case: entry family is given by a subtype mark, and index + -- constant has the same type, no replacement needed. + + Index_Typ := Etype (Index_Id); + + else + Hi := Replace_Discriminant (Hi); + Lo := Replace_Discriminant (Lo); + + Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + Append ( + Make_Subtype_Declaration (Loc, + Defining_Identifier => Index_Typ, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Etype (Index_Id)), Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => Make_Range (Loc, Lo, Hi)))), + Decls); + + end if; + + Append ( + Make_Object_Declaration (Loc, + Defining_Identifier => Index_Con, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Index_Typ, Loc), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Val, + + Expressions => New_List ( + + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uE), + Right_Opnd => + Entry_Index_Expression (Loc, + Defining_Identifier (N), Empty, Prot)), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_First))))))), + Decls); + + return Decls; + end Index_Constant_Declaration; + + -------------------------------- + -- Make_Initialize_Protection -- + -------------------------------- + + function Make_Initialize_Protection + (Protect_Rec : Entity_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Protect_Rec); + P_Arr : Entity_Id; + Pdef : Node_Id; + Pdec : Node_Id; + Ptyp : Node_Id; + Pnam : Name_Id; + Args : List_Id; + L : List_Id := New_List; + + begin + -- We may need two calls to properly initialize the object, one + -- to Initialize_Protection, and possibly one to Install_Handlers + -- if we have a pragma Attach_Handler. + + Ptyp := Corresponding_Concurrent_Type (Protect_Rec); + Pnam := Chars (Ptyp); + + -- Get protected declaration. In the case of a task type declaration, + -- this is simply the parent of the protected type entity. + -- In the single protected object + -- declaration, this parent will be the implicit type, and we can find + -- the corresponding single protected object declaration by + -- searching forward in the declaration list in the tree. + -- ??? I am not sure that the test for N_Single_Protected_Declaration + -- is needed here. Nodes of this type should have been removed + -- during semantic analysis. + + Pdec := Parent (Ptyp); + + while Nkind (Pdec) /= N_Protected_Type_Declaration + and then Nkind (Pdec) /= N_Single_Protected_Declaration + loop + Next (Pdec); + end loop; + + -- Now we can find the object definition from this declaration + + Pdef := Protected_Definition (Pdec); + + -- Build the parameter list for the call. Note that _Init is the name + -- of the formal for the object to be initialized, which is the task + -- value record itself. + + Args := New_List; + + -- Object parameter. This is a pointer to the object of type + -- Protection used by the GNARL to control the protected object. + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)); + + -- Priority parameter. Set to Unspecified_Priority unless there is a + -- priority pragma, in which case we take the value from the pragma, + -- or there is an interrupt pragma and no priority pragma, and we + -- set the ceiling to Interrupt_Priority'Last, an implementation- + -- defined value, see D.3(10). + + if Present (Pdef) + and then Has_Priority_Pragma (Pdef) + then + Append_To (Args, + Duplicate_Subexpr (Expression (First (Pragma_Argument_Associations + (Find_Task_Or_Protected_Pragma (Pdef, Name_Priority)))))); + + elsif Has_Interrupt_Handler (Ptyp) + or else Has_Attach_Handler (Ptyp) + then + -- When no priority is specified but an xx_Handler pragma is, + -- we default to System.Interrupts.Default_Interrupt_Priority, + -- see D.3(10). + + Append_To (Args, + New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc)); + + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); + end if; + + if Has_Entries (Ptyp) + or else Has_Interrupt_Handler (Ptyp) + or else Has_Attach_Handler (Ptyp) + then + -- Compiler_Info parameter. This parameter allows entry body + -- procedures and barrier functions to be called from the runtime. + -- It is a pointer to the record generated by the compiler to + -- represent the protected object. + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address)); + + if Has_Entries (Ptyp) then + -- Entry_Bodies parameter. This is a pointer to an array of + -- pointers to the entry body procedures and barrier functions + -- of the object. If the protected type has no entries this + -- object will not exist; in this case, pass a null. + + P_Arr := Entry_Bodies_Array (Ptyp); + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Arr, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Ptyp) > 1 + then + -- Find index mapping function (clumsy but ok for now). + + while Ekind (P_Arr) /= E_Function loop + Next_Entity (P_Arr); + end loop; + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (P_Arr, Loc), + Attribute_Name => Name_Unrestricted_Access)); + end if; + + else + Append_To (Args, Make_Null (Loc)); + Append_To (Args, Make_Null (Loc)); + end if; + + if Abort_Allowed + or else Restrictions (No_Entry_Queue) = False + or else Number_Entries (Ptyp) > 1 + then + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Initialize_Protection_Entries), Loc), + Parameter_Associations => Args)); + + else + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Initialize_Protection_Entry), Loc), + Parameter_Associations => Args)); + end if; + + else + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc), + Parameter_Associations => Args)); + end if; + + if Has_Attach_Handler (Ptyp) then + + -- We have a list of N Attach_Handler (ProcI, ExprI), + -- and we have to make the following call: + -- Install_Handlers (_object, + -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); + + declare + Args : List_Id := New_List; + Table : List_Id := New_List; + Ritem : Node_Id := First_Rep_Item (Ptyp); + + begin + -- Appends the _object argument + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)); + + -- Build the Attach_Handler table argument + + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Chars (Ritem) = Name_Attach_Handler + then + declare + Handler : Node_Id := + First (Pragma_Argument_Associations (Ritem)); + Interrupt : Node_Id := + Next (Handler); + + begin + Append_To (Table, + Make_Aggregate (Loc, Expressions => New_List ( + Duplicate_Subexpr (Expression (Interrupt)), + Make_Attribute_Reference (Loc, + Prefix => Make_Selected_Component (Loc, + Make_Identifier (Loc, Name_uInit), + Duplicate_Subexpr (Expression (Handler))), + Attribute_Name => Name_Access)))); + end; + end if; + + Next_Rep_Item (Ritem); + end loop; + + -- Appends the table argument we just built. + Append_To (Args, Make_Aggregate (Loc, Table)); + + -- Appends the Install_Handler call to the statements. + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), + Parameter_Associations => Args)); + end; + end if; + + return L; + end Make_Initialize_Protection; + + --------------------------- + -- Make_Task_Create_Call -- + --------------------------- + + function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Task_Rec); + Name : Node_Id; + Tdef : Node_Id; + Tdec : Node_Id; + Ttyp : Node_Id; + Tnam : Name_Id; + Args : List_Id; + Ecount : Node_Id; + + begin + Ttyp := Corresponding_Concurrent_Type (Task_Rec); + Tnam := Chars (Ttyp); + + -- Get task declaration. In the case of a task type declaration, this + -- is simply the parent of the task type entity. In the single task + -- declaration, this parent will be the implicit type, and we can find + -- the corresponding single task declaration by searching forward in + -- the declaration list in the tree. + -- ??? I am not sure that the test for N_Single_Task_Declaration + -- is needed here. Nodes of this type should have been removed + -- during semantic analysis. + + Tdec := Parent (Ttyp); + + while Nkind (Tdec) /= N_Task_Type_Declaration + and then Nkind (Tdec) /= N_Single_Task_Declaration + loop + Next (Tdec); + end loop; + + -- Now we can find the task definition from this declaration + + Tdef := Task_Definition (Tdec); + + -- Build the parameter list for the call. Note that _Init is the name + -- of the formal for the object to be initialized, which is the task + -- value record itself. + + Args := New_List; + + -- Priority parameter. Set to Unspecified_Priority unless there is a + -- priority pragma, in which case we take the value from the pragma. + + if Present (Tdef) + and then Has_Priority_Pragma (Tdef) + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uPriority))); + + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); + end if; + + -- Size parameter. If no Storage_Size pragma is present, then + -- the size is taken from the taskZ variable for the type, which + -- is either Unspecified_Size, or has been reset by the use of + -- a Storage_Size attribute definition clause. If a pragma is + -- present, then the size is taken from the _Size field of the + -- task value record, which was set from the pragma value. + + if Present (Tdef) + and then Has_Storage_Size_Pragma (Tdef) + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uSize))); + + else + Append_To (Args, + New_Reference_To (Storage_Size_Variable (Ttyp), Loc)); + end if; + + -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a + -- Task_Info pragma, in which case we take the value from the pragma. + + if Present (Tdef) + and then Has_Task_Info_Pragma (Tdef) + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); + + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc)); + end if; + + if not Restricted_Profile then + + -- Number of entries. This is an expression of the form: + -- + -- n + _Init.a'Length + _Init.a'B'Length + ... + -- + -- where a,b... are the entry family names for the task definition + + Ecount := Build_Entry_Count_Expression ( + Ttyp, + Component_Items (Component_List ( + Type_Definition (Parent ( + Corresponding_Record_Type (Ttyp))))), + Loc); + Append_To (Args, Ecount); + + -- Master parameter. This is a reference to the _Master parameter of + -- the initialization procedure, except in the case of the pragma + -- Restrictions (No_Task_Hierarchy) where the value is fixed to 3. + -- See comments in System.Tasking.Initialization.Init_RTS for the + -- value 3. + + if Restrictions (No_Task_Hierarchy) = False then + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + else + Append_To (Args, Make_Integer_Literal (Loc, 3)); + end if; + end if; + + -- State parameter. This is a pointer to the task body procedure. The + -- required value is obtained by taking the address of the task body + -- procedure and converting it (with an unchecked conversion) to the + -- type required by the task kernel. For further details, see the + -- description of Expand_Task_Body + + Append_To (Args, + Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Get_Task_Body_Procedure (Ttyp), Loc), + Attribute_Name => Name_Address))); + + -- Discriminants parameter. This is just the address of the task + -- value record itself (which contains the discriminant values + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address)); + + -- Elaborated parameter. This is an access to the elaboration Boolean + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), + Attribute_Name => Name_Unchecked_Access)); + + -- Chain parameter. This is a reference to the _Chain parameter of + -- the initialization procedure. + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + + -- Task name parameter. Take this from the _Task_Info parameter to the + -- init call unless there is a Task_Name pragma, in which case we take + -- the value from the pragma. + + if Present (Tdef) + and then Has_Task_Name_Pragma (Tdef) + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); + + else + Append_To (Args, Make_Identifier (Loc, Name_uTask_Id)); + end if; + + -- Created_Task parameter. This is the _Task_Id field of the task + -- record value + + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); + + if Restricted_Profile then + Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc); + else + Name := New_Reference_To (RTE (RE_Create_Task), Loc); + end if; + + return Make_Procedure_Call_Statement (Loc, + Name => Name, Parameter_Associations => Args); + end Make_Task_Create_Call; + + ------------------------------ + -- Next_Protected_Operation -- + ------------------------------ + + function Next_Protected_Operation (N : Node_Id) return Node_Id is + Next_Op : Node_Id; + + begin + Next_Op := Next (N); + + while Present (Next_Op) + and then Nkind (Next_Op) /= N_Subprogram_Body + and then Nkind (Next_Op) /= N_Entry_Body + loop + Next (Next_Op); + end loop; + + return Next_Op; + end Next_Protected_Operation; + + ---------------------- + -- Set_Discriminals -- + ---------------------- + + procedure Set_Discriminals + (Dec : Node_Id; + Op : Node_Id; + Loc : Source_Ptr) + is + D : Entity_Id; + Pdef : Entity_Id; + D_Minal : Entity_Id; + + begin + pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); + Pdef := Defining_Identifier (Dec); + + if Has_Discriminants (Pdef) then + D := First_Discriminant (Pdef); + + while Present (D) loop + D_Minal := + Make_Defining_Identifier (Sloc (D), + Chars => New_External_Name (Chars (D), 'D')); + + Set_Ekind (D_Minal, E_Constant); + Set_Etype (D_Minal, Etype (D)); + Set_Discriminal (D, D_Minal); + Set_Discriminal_Link (D_Minal, D); + + Next_Discriminant (D); + end loop; + end if; + end Set_Discriminals; + + ----------------- + -- Set_Privals -- + ----------------- + + procedure Set_Privals + (Dec : Node_Id; + Op : Node_Id; + Loc : Source_Ptr) + is + P_Decl : Node_Id; + P_Id : Entity_Id; + Priv : Entity_Id; + Def : Node_Id; + Body_Ent : Entity_Id; + Prec_Decl : constant Node_Id := + Parent (Corresponding_Record_Type + (Defining_Identifier (Dec))); + Prec_Def : constant Entity_Id := Type_Definition (Prec_Decl); + Obj_Decl : Node_Id; + P_Subtype : Entity_Id; + New_Decl : Entity_Id; + Assoc_L : Elist_Id := New_Elmt_List; + Op_Id : Entity_Id; + + begin + pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); + pragma Assert + (Nkind (Op) = N_Subprogram_Body or else Nkind (Op) = N_Entry_Body); + + Def := Protected_Definition (Dec); + + if Present (Private_Declarations (Def)) then + + P_Decl := First (Private_Declarations (Def)); + + while Present (P_Decl) loop + if Nkind (P_Decl) = N_Component_Declaration then + P_Id := Defining_Identifier (P_Decl); + Priv := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (P_Id), 'P')); + + Set_Ekind (Priv, E_Variable); + Set_Etype (Priv, Etype (P_Id)); + Set_Scope (Priv, Scope (P_Id)); + Set_Esize (Priv, Esize (Etype (P_Id))); + Set_Alignment (Priv, Alignment (Etype (P_Id))); + + -- If the type of the component is an itype, we must + -- create a new itype for the corresponding prival in + -- each protected operation, to avoid scoping problems. + -- We create new itypes by copying the tree for the + -- component definition. + + if Is_Itype (Etype (P_Id)) then + Append_Elmt (P_Id, Assoc_L); + Append_Elmt (Priv, Assoc_L); + + if Nkind (Op) = N_Entry_Body then + Op_Id := Defining_Identifier (Op); + else + Op_Id := Defining_Unit_Name (Specification (Op)); + end if; + + New_Decl := New_Copy_Tree (P_Decl, Assoc_L, + New_Scope => Op_Id); + end if; + + Set_Protected_Operation (P_Id, Op); + Set_Prival (P_Id, Priv); + end if; + + Next (P_Decl); + end loop; + end if; + + -- There is one more implicit private declaration: the object + -- itself. A "prival" for this is attached to the protected + -- body defining identifier. + + Body_Ent := Corresponding_Body (Dec); + + Priv := + Make_Defining_Identifier (Sloc (Body_Ent), + Chars => New_External_Name (Chars (Body_Ent), 'R')); + + -- Set the Etype to the implicit subtype of Protection created when + -- the protected type declaration was expanded. This node will not + -- be analyzed until it is used as the defining identifier for the + -- renaming declaration in the protected operation body, and it will + -- be needed in the references expanded before that body is expanded. + -- Since the Protection field is aliased, set Is_Aliased as well. + + Obj_Decl := First (Component_Items (Component_List (Prec_Def))); + while Chars (Defining_Identifier (Obj_Decl)) /= Name_uObject loop + Next (Obj_Decl); + end loop; + + P_Subtype := Etype (Defining_Identifier (Obj_Decl)); + Set_Etype (Priv, P_Subtype); + Set_Is_Aliased (Priv); + Set_Object_Ref (Body_Ent, Priv); + + end Set_Privals; + + ---------------------------- + -- Update_Prival_Subtypes -- + ---------------------------- + + procedure Update_Prival_Subtypes (N : Node_Id) is + + function Process (N : Node_Id) return Traverse_Result; + -- Update the etype of occurrences of privals whose etype does not + -- match the current Etype of the prival entity itself. + + procedure Update_Array_Bounds (E : Entity_Id); + -- Itypes generated for array expressions may depend on the + -- determinants of the protected object, and need to be processed + -- separately because they are not attached to the tree. + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (N) then + declare + E : Entity_Id := Entity (N); + + begin + if Present (E) + and then (Ekind (E) = E_Constant + or else Ekind (E) = E_Variable) + and then Nkind (Parent (E)) = N_Object_Renaming_Declaration + and then not Is_Scalar_Type (Etype (E)) + and then Etype (N) /= Etype (E) + then + Set_Etype (N, Etype (Entity (Original_Node (N)))); + + -- If the prefix has an actual subtype that is different + -- from the nominal one, update the types of the indices, + -- so that the proper constraints are applied. Do not + -- apply this transformation to a packed array, where the + -- index type is computed for a byte array and is different + -- from the source index. + + if Nkind (Parent (N)) = N_Indexed_Component + and then + not Is_Bit_Packed_Array (Etype (Prefix (Parent (N)))) + then + declare + Indx1 : Node_Id; + I_Typ : Node_Id; + + begin + Indx1 := First (Expressions (Parent (N))); + I_Typ := First_Index (Etype (N)); + + while Present (Indx1) and then Present (I_Typ) loop + + if not Is_Entity_Name (Indx1) then + Set_Etype (Indx1, Base_Type (Etype (I_Typ))); + end if; + + Next (Indx1); + Next_Index (I_Typ); + end loop; + end; + end if; + + elsif Present (E) + and then Ekind (E) = E_Constant + and then Present (Discriminal_Link (E)) + then + Set_Etype (N, Etype (E)); + end if; + end; + + return OK; + + elsif Nkind (N) = N_Defining_Identifier + or else Nkind (N) = N_Defining_Operator_Symbol + or else Nkind (N) = N_Defining_Character_Literal + then + return Skip; + + elsif Nkind (N) = N_String_Literal then + -- array type, but bounds are constant. + return OK; + + elsif Nkind (N) = N_Object_Declaration + and then Is_Itype (Etype (Defining_Identifier (N))) + and then Is_Array_Type (Etype (Defining_Identifier (N))) + then + Update_Array_Bounds (Etype (Defining_Identifier (N))); + return OK; + + else + if Nkind (N) in N_Has_Etype + and then Present (Etype (N)) + and then Is_Itype (Etype (N)) then + + if Is_Array_Type (Etype (N)) then + Update_Array_Bounds (Etype (N)); + + elsif Is_Scalar_Type (Etype (N)) then + Update_Prival_Subtypes (Type_Low_Bound (Etype (N))); + Update_Prival_Subtypes (Type_High_Bound (Etype (N))); + end if; + end if; + + return OK; + end if; + end Process; + + ------------------------- + -- Update_Array_Bounds -- + ------------------------- + + procedure Update_Array_Bounds (E : Entity_Id) is + Ind : Node_Id; + + begin + Ind := First_Index (E); + + while Present (Ind) loop + Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind))); + Update_Prival_Subtypes (Type_High_Bound (Etype (Ind))); + Next_Index (Ind); + end loop; + end Update_Array_Bounds; + + procedure Traverse is new Traverse_Proc; + + -- Start of processsing for Update_Prival_Subtypes + + begin + Traverse (N); + end Update_Prival_Subtypes; + +end Exp_Ch9; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads new file mode 100644 index 00000000000..949356fb391 --- /dev/null +++ b/gcc/ada/exp_ch9.ads @@ -0,0 +1,312 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 9 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.56 $ +-- -- +-- Copyright (C) 1992-1999 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 9 constructs + +with Types; use Types; + +package Exp_Ch9 is + + procedure Add_Discriminal_Declarations + (Decls : List_Id; + Typ : Entity_Id; + Name : Name_Id; + Loc : Source_Ptr); + -- This routine is used to add discriminal declarations to task and + -- protected operation bodies. The discriminants are available by normal + -- selection from the concurrent object (whose name is passed as the third + -- parameter). Discriminant references inside the body have already + -- been replaced by references to the corresponding discriminals. The + -- declarations constructed by this procedure hook the references up with + -- the objects: + -- + -- discriminal_name : discr_type renames name.discriminant_name; + -- + -- Obviously we could have expanded the discriminant references in the + -- first place to be the appropriate selection, but this turns out to + -- be hard to do because it would introduce difference in handling of + -- discriminant references depending on their location. + + procedure Add_Private_Declarations + (Decls : List_Id; + Typ : Entity_Id; + Name : Name_Id; + Loc : Source_Ptr); + -- This routine is used to add private declarations to protected bodies. + -- These are analogous to the discriminal declarations added to tasks + -- and protected operations, and consist of a renaming of each private + -- object to a selection from the concurrent object passed as an extra + -- parameter to each such operation: + -- private_name : private_type renames name.private_name; + -- As with discriminals, private references inside the protected + -- subprogram bodies have already been replaced by references to the + -- corresponding privals. + + procedure Build_Activation_Chain_Entity (N : Node_Id); + -- Given a declaration N of an object that is a task, or contains tasks + -- (other than allocators to tasks) this routine ensures that an activation + -- chain has been declared in the appropriate scope, building the required + -- declaration for the chain variable if not. The name of this variable + -- is always _Chain and it is accessed by name. This procedure also adds + -- an appropriate call to Activate_Tasks to activate the tasks for this + -- activation chain. It does not however deal with the call needed in the + -- case of allocators to Expunge_Unactivated_Tasks, this is separately + -- handled in the Expand_Task_Allocator routine. + + function Build_Call_With_Task (N : Node_Id; E : Entity_Id) return Node_Id; + -- N is a node representing the name of a task or an access to a task. + -- The value returned is a call to the function whose name is the entity + -- E (typically a runtime routine entity obtained using RTE) with the + -- Task_Id of the associated task as the parameter. The caller is + -- responsible for analyzing and resolving the resulting tree. + + procedure Build_Master_Entity (E : Entity_Id); + -- Given an entity E for the declaration of an object containing tasks + -- or of a type declaration for an allocator whose designated type is a + -- task or contains tasks, this routine marks the appropriate enclosing + -- context as a master, and also declares a variable called _Master in + -- the current declarative part which captures the value of Current_Master + -- (if not already built by a prior call). We build this object (instead + -- of just calling Current_Master) for two reasons. First it is clearly + -- more efficient to call Current_Master only once for a bunch of tasks + -- in the same declarative part, and second it makes things easier in + -- generating the initialization routines, since they can just reference + -- the object _Master by name, and they will get the proper Current_Master + -- value at the outer level, and copy in the parameter value for the outer + -- initialization call if the call is for a nested component). Note that + -- in the case of nested packages, we only really need to make one such + -- object at the outer level, but it is much easier to generate one per + -- declarative part. + + function Build_Protected_Sub_Specification + (N : Node_Id; + Prottyp : Entity_Id; + Unprotected : Boolean := False) + return Node_Id; + -- Build specification for protected subprogram. This is called when + -- expanding a protected type, and also when expanding the declaration for + -- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is + -- empty, and the first parameter of the signature of the protected op is + -- of type System.Address. + + procedure Build_Protected_Subprogram_Call + (N : Node_Id; + Name : Node_Id; + Rec : Node_Id; + External : Boolean := True); + -- The node N is a subprogram or entry call to a protected subprogram. + -- This procedure rewrites this call with the appropriate expansion. + -- Name is the subprogram, and Rec is the record corresponding to the + -- protected object. External is False if the call is to another + -- protected subprogram within the same object. + + procedure Build_Task_Activation_Call (N : Node_Id); + -- This procedure is called for constructs that can be task activators + -- i.e. task bodies, subprogram bodies, package bodies and blocks. If + -- the construct is a task activator (as indicated by the non-empty + -- setting of Activation_Chain_Entity, either in the construct, or, in + -- the case of a package body, in its associated package spec), then + -- a call to Activate_Tasks with this entity as the single parameter + -- is inserted at the start of the statements of the activator. + + procedure Build_Task_Allocate_Block + (Actions : List_Id; + N : Node_Id; + Args : List_Id); + -- This routine is used in the case of allocators where the designated + -- type is a task or contains tasks. In this case, the normal initialize + -- call is replaced by: + -- + -- blockname : label; + -- blockname : declare + -- _Chain : Activation_Chain; + -- + -- procedure _Expunge is + -- begin + -- Expunge_Unactivated_Tasks (_Chain); + -- end; + -- + -- begin + -- Init (Args); + -- Activate_Tasks (_Chain); + -- at end + -- _Expunge; + -- end; + -- + -- to get the task or tasks created and initialized. The expunge call + -- ensures that any tasks that get created but not activated due to an + -- exception are properly expunged (it has no effect in the normal case) + -- The argument N is the allocator, and Args is the list of arguments + -- for the initialization call, constructed by the caller, which uses + -- the Master_Id of the access type as the _Master parameter, and _Chain + -- (defined above) as the _Chain parameter. + + function Concurrent_Ref (N : Node_Id) return Node_Id; + -- Given the name of a concurrent object (task or protected object), or + -- the name of an access to a concurrent object, this function returns an + -- expression referencing the associated Task_Id or Protection object, + -- respectively. Note that a special case is when the name is a reference + -- to a task type name. This can only happen within a task body, and the + -- meaning is to get the Task_Id for the currently executing task. + + function Convert_Concurrent + (N : Node_Id; + Typ : Entity_Id) + return Node_Id; + -- N is an expression of type Typ. If the type is not a concurrent + -- type then it is returned unchanged. If it is a task or protected + -- reference, Convert_Concurrent creates an unchecked conversion node + -- from this expression to the corresponding concurrent record type + -- value. We need this in any situation where the concurrent type is + -- used, because the actual concurrent object is an object of the + -- corresponding concurrent type, and manipulations on the concurrent + -- object actually manipulate the corresponding object of the record + -- type. + + function Entry_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Ttyp : Entity_Id) + return Node_Id; + -- Returns an expression to compute a task entry index given the name + -- of the entry or entry family. For the case of a task entry family, + -- the Index parameter contains the expression for the subscript. + -- Ttyp is the task type. + + procedure Establish_Task_Master (N : Node_Id); + -- Given a subprogram body, or a block statement, or a task body, this + -- proccedure makes the necessary transformations required of a task + -- master (add Enter_Master call at start, and establish a cleanup + -- routine to make sure Complete_Master is called on exit). + + procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id); + -- Build Equivalent_Type for an Access_to_protected_Subprogram. + + procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id); + -- Expand declarations required for accept statement. See bodies of + -- both Expand_Accept_Declarations and Expand_N_Accept_Statement for + -- full details of the nature and use of these declarations, which + -- are inserted immediately before the accept node N. The second + -- argument is the entity for the corresponding entry. + + procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id); + -- Expand the entry barrier into a function. This is called directly + -- from Analyze_Entry_Body so that the discriminals and privals of the + -- barrier can be attached to the function declaration list, and a new + -- set prepared for the entry body procedure, bedore the entry body + -- statement sequence can be expanded. The resulting function is analyzed + -- now, within the context of the protected object, to resolve calls to + -- other protected functions. + + procedure Expand_Entry_Body_Declarations (N : Node_Id); + -- Expand declarations required for the expansion of the + -- statements of the body. + + procedure Expand_N_Abort_Statement (N : Node_Id); + procedure Expand_N_Accept_Statement (N : Node_Id); + procedure Expand_N_Asynchronous_Select (N : Node_Id); + procedure Expand_N_Conditional_Entry_Call (N : Node_Id); + procedure Expand_N_Delay_Relative_Statement (N : Node_Id); + procedure Expand_N_Delay_Until_Statement (N : Node_Id); + procedure Expand_N_Entry_Body (N : Node_Id); + procedure Expand_N_Entry_Call_Statement (N : Node_Id); + procedure Expand_N_Entry_Declaration (N : Node_Id); + procedure Expand_N_Protected_Body (N : Node_Id); + + procedure Expand_N_Protected_Type_Declaration (N : Node_Id); + -- Expands protected type declarations. This results, among + -- other things, in the declaration of a record type for the + -- representation of protected objects and (if there are entries) + -- in an entry service procedure. The Protection value used by + -- the GNARL to control the object will always be the first + -- field of the record, and the entry service procedure spec + -- (if it exists) will always immediately follow the record + -- declaration. This allows these two nodes to be found from + -- the type using Corresponding_Record, without benefit of + -- of further attributes. + + procedure Expand_N_Requeue_Statement (N : Node_Id); + procedure Expand_N_Selective_Accept (N : Node_Id); + procedure Expand_N_Single_Task_Declaration (N : Node_Id); + procedure Expand_N_Task_Body (N : Node_Id); + procedure Expand_N_Task_Type_Declaration (N : Node_Id); + procedure Expand_N_Timed_Entry_Call (N : Node_Id); + + procedure Expand_Protected_Body_Declarations + (N : Node_Id; + Spec_Id : Entity_Id); + -- Expand declarations required for a protected body. See bodies of + -- both Expand_Protected_Body_Declarations and Expand_N_Protected_Body + -- for full details of the nature and use of these declarations. + -- The second argument is the entity for the corresponding + -- protected type declaration. + + function External_Subprogram (E : Entity_Id) return Entity_Id; + -- return the external version of a protected operation, which locks + -- the object before invoking the internal protected subprogram body. + + function First_Protected_Operation (D : List_Id) return Node_Id; + -- Given the declarations list for a protected body, find the + -- first protected operation body. + + function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id; + -- Given the entity of the record type created for a task type, build + -- the call to Create_Task + + function Make_Initialize_Protection + (Protect_Rec : Entity_Id) + return List_Id; + -- Given the entity of the record type created for a protected type, build + -- a list of statements needed for proper initialization of the object. + + function Next_Protected_Operation (N : Node_Id) return Node_Id; + -- Given a protected operation node (a subprogram or entry body), + -- find the following node in the declarations list. + + procedure Set_Discriminals + (Dec : Node_Id; + Op : Node_Id; + Loc : Source_Ptr); + -- Replace discriminals in a protected type for use by the + -- next protected operation on the type. Each operation needs a + -- new set of discirminals, since it needs a unique renaming of + -- the discriminant fields in the record used to implement the + -- protected type. + + procedure Set_Privals + (Dec : Node_Id; + Op : Node_Id; + Loc : Source_Ptr); + -- Associates a new set of privals (placeholders for later access to + -- private components of protected objects) with the private object + -- declarations of a protected object. These will be used to expand + -- the references to private objects in the next protected + -- subprogram or entry body to be expanded. + +end Exp_Ch9; diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb new file mode 100644 index 00000000000..dbd8c44956d --- /dev/null +++ b/gcc/ada/exp_code.adb @@ -0,0 +1,499 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C O D E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.17 $ +-- -- +-- 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 Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Exp_Code is + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + function Asm_Constraint (Operand_Var : Node_Id) return Node_Id; + -- Common processing for Asm_Input_Constraint and Asm_Output_Constraint. + -- Obtains the constraint argument from the global operand variable + -- Operand_Var, which must be non-Empty. + + function Asm_Operand (Operand_Var : Node_Id) return Node_Id; + -- Common processing for Asm_Input_Value and Asm_Output_Variable. Obtains + -- the value/variable argument from Operand_Var, the global operand + -- variable. Returns Empty if no operand available. + + function Get_String_Node (S : Node_Id) return Node_Id; + -- Given S, a static expression node of type String, returns the + -- string literal node. This is needed to deal with the use of constants + -- for these expressions, which is perfectly permissible. + + procedure Next_Asm_Operand (Operand_Var : in out Node_Id); + -- Common processing for Next_Asm_Input and Next_Asm_Output, updates + -- the value of the global operand variable Operand_Var appropriately. + + procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id); + -- Common processing for Setup_Asm_Inputs and Setup_Asm_Outputs. Arg + -- is the actual parameter from the call, and Operand_Var is the global + -- operand variable to be initialized to the first operand. + + ---------------------- + -- Global Variables -- + ---------------------- + + Current_Input_Operand : Node_Id := Empty; + -- Points to current Asm_Input_Operand attribute reference. Initialized + -- by Setup_Asm_Inputs, updated by Next_Asm_Input, and referenced by + -- Asm_Input_Constraint and Asm_Input_Value. + + Current_Output_Operand : Node_Id := Empty; + -- Points to current Asm_Output_Operand attribute reference. Initialized + -- by Setup_Asm_Outputs, updated by Next_Asm_Output, and referenced by + -- Asm_Output_Constraint and Asm_Output_Variable. + + -------------------- + -- Asm_Constraint -- + -------------------- + + function Asm_Constraint (Operand_Var : Node_Id) return Node_Id is + begin + pragma Assert (Present (Operand_Var)); + return Get_String_Node (First (Expressions (Operand_Var))); + end Asm_Constraint; + + -------------------------- + -- Asm_Input_Constraint -- + -------------------------- + + -- Note: error checking on Asm_Input attribute done in Sem_Attr + + function Asm_Input_Constraint return Node_Id is + begin + return Get_String_Node (Asm_Constraint (Current_Input_Operand)); + end Asm_Input_Constraint; + + --------------------- + -- Asm_Input_Value -- + --------------------- + + -- Note: error checking on Asm_Input attribute done in Sem_Attr + + function Asm_Input_Value return Node_Id is + begin + return Asm_Operand (Current_Input_Operand); + end Asm_Input_Value; + + ----------------- + -- Asm_Operand -- + ----------------- + + function Asm_Operand (Operand_Var : Node_Id) return Node_Id is + begin + if No (Operand_Var) then + return Empty; + else + return Next (First (Expressions (Operand_Var))); + end if; + end Asm_Operand; + + --------------------------- + -- Asm_Output_Constraint -- + --------------------------- + + -- Note: error checking on Asm_Output attribute done in Sem_Attr + + function Asm_Output_Constraint return Node_Id is + begin + return Asm_Constraint (Current_Output_Operand); + end Asm_Output_Constraint; + + ------------------------- + -- Asm_Output_Variable -- + ------------------------- + + -- Note: error checking on Asm_Output attribute done in Sem_Attr + + function Asm_Output_Variable return Node_Id is + begin + return Asm_Operand (Current_Output_Operand); + end Asm_Output_Variable; + + ------------------ + -- Asm_Template -- + ------------------ + + function Asm_Template (N : Node_Id) return Node_Id is + Call : constant Node_Id := Expression (Expression (N)); + Temp : constant Node_Id := First_Actual (Call); + + begin + -- Require static expression for template. We also allow a string + -- literal (this is useful for Ada 83 mode where string expressions + -- are never static). + + if Is_OK_Static_Expression (Temp) + or else (Ada_83 and then Nkind (Temp) = N_String_Literal) + then + return Get_String_Node (Temp); + + else + Error_Msg_N ("asm template argument is not static", Temp); + return Empty; + end if; + end Asm_Template; + + ---------------------- + -- Clobber_Get_Next -- + ---------------------- + + Clobber_Node : Node_Id; + -- String literal node for clobber string. Initialized by Clobber_Setup, + -- and not modified by Clobber_Get_Next. Empty if clobber string was in + -- error (resulting in no clobber arguments being returned). + + Clobber_Ptr : Nat; + -- Pointer to current character of string. Initialized to 1 by the call + -- to Clobber_Setup, and then updated by Clobber_Get_Next. + + function Clobber_Get_Next return Address is + Str : constant String_Id := Strval (Clobber_Node); + Len : constant Nat := String_Length (Str); + C : Character; + + begin + if No (Clobber_Node) then + return Null_Address; + end if; + + -- Skip spaces and commas before next register name + + loop + -- Return null string if no more names + + if Clobber_Ptr > Len then + return Null_Address; + end if; + + C := Get_Character (Get_String_Char (Str, Clobber_Ptr)); + exit when C /= ',' and then C /= ' '; + Clobber_Ptr := Clobber_Ptr + 1; + end loop; + + -- Acquire next register name + + Name_Len := 0; + loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := C; + Clobber_Ptr := Clobber_Ptr + 1; + exit when Clobber_Ptr > Len; + C := Get_Character (Get_String_Char (Str, Clobber_Ptr)); + exit when C = ',' or else C = ' '; + end loop; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return Name_Buffer'Address; + + end Clobber_Get_Next; + + ------------------- + -- Clobber_Setup -- + ------------------- + + procedure Clobber_Setup (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + Clob : constant Node_Id := Next_Actual ( + Next_Actual ( + Next_Actual ( + First_Actual (Call)))); + + begin + if not Is_OK_Static_Expression (Clob) then + Error_Msg_N ("asm clobber argument is not static", Clob); + Clobber_Node := Empty; + + else + Clobber_Node := Get_String_Node (Clob); + Clobber_Ptr := 1; + end if; + end Clobber_Setup; + + --------------------- + -- Expand_Asm_Call -- + --------------------- + + procedure Expand_Asm_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + procedure Check_IO_Operand (N : Node_Id); + -- Check for incorrect input or output operand + + procedure Check_IO_Operand (N : Node_Id) is + Err : Node_Id := N; + + begin + -- The only identifier allows is No_xxput_Operands. Since we + -- know the type is right, it is sufficient to see if the + -- referenced entity is in a runtime routine. + + if Nkind (N) = N_Identifier + and then + Is_Predefined_File_Name (Unit_File_Name + (Get_Source_Unit (Entity (N)))) + then + return; + + -- An attribute reference is fine, again the analysis reasonably + -- guarantees that the attribute must be subtype'Asm_??put. + + elsif Nkind (N) = N_Attribute_Reference then + return; + + -- The only other allowed form is an array aggregate in which + -- all the entries are positional and are attribute references. + + elsif Nkind (N) = N_Aggregate then + if Present (Component_Associations (N)) then + Err := First (Component_Associations (N)); + + elsif Present (Expressions (N)) then + Err := First (Expressions (N)); + while Present (Err) loop + exit when Nkind (Err) /= N_Attribute_Reference; + Next (Err); + end loop; + + if No (Err) then + return; + end if; + end if; + end if; + + -- If we fall through, Err is pointing to the bad node + + Error_Msg_N ("Asm operand has wrong form", Err); + end Check_IO_Operand; + + -- Start of processing for Expand_Asm_Call + + begin + -- Check that the input and output operands have the right + -- form, as required by the documentation of the Asm feature: + + -- OUTPUT_OPERAND_LIST ::= + -- No_Output_Operands + -- | OUTPUT_OPERAND_ATTRIBUTE + -- | (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@}) + + -- OUTPUT_OPERAND_ATTRIBUTE ::= + -- SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME) + + -- INPUT_OPERAND_LIST ::= + -- No_Input_Operands + -- | INPUT_OPERAND_ATTRIBUTE + -- | (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@}) + + -- INPUT_OPERAND_ATTRIBUTE ::= + -- SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION) + + declare + Arg_Output : constant Node_Id := Next_Actual (First_Actual (N)); + Arg_Input : constant Node_Id := Next_Actual (Arg_Output); + + begin + Check_IO_Operand (Arg_Output); + Check_IO_Operand (Arg_Input); + end; + + -- If we have the function call case, we are inside a code statement, + -- and the tree is already in the necessary form for gigi. + + if Nkind (N) = N_Function_Call then + null; + + -- For the procedure case, we convert the call into a code statement + + else + pragma Assert (Nkind (N) = N_Procedure_Call_Statement); + + -- Note: strictly we should change the procedure call to a function + -- call in the qualified expression, but since we are not going to + -- reanalyze (see below), and the interface subprograms in this + -- package don't care, we can leave it as a procedure call. + + Rewrite (N, + Make_Code_Statement (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (RTE (RE_Asm_Insn), Loc), + Expression => Relocate_Node (N)))); + + -- There is no need to reanalyze this node, it is completely analyzed + -- already, at least sufficiently for the purposes of the abstract + -- procedural interface defined in this package. + + Set_Analyzed (N); + end if; + end Expand_Asm_Call; + + --------------------- + -- Get_String_Node -- + --------------------- + + function Get_String_Node (S : Node_Id) return Node_Id is + begin + if Nkind (S) = N_String_Literal then + return S; + + else + pragma Assert (Ekind (Entity (S)) = E_Constant); + return Get_String_Node (Constant_Value (Entity (S))); + end if; + end Get_String_Node; + + --------------------- + -- Is_Asm_Volatile -- + --------------------- + + function Is_Asm_Volatile (N : Node_Id) return Boolean is + Call : constant Node_Id := Expression (Expression (N)); + Vol : constant Node_Id := + Next_Actual ( + Next_Actual ( + Next_Actual ( + Next_Actual ( + First_Actual (Call))))); + + begin + if not Is_OK_Static_Expression (Vol) then + Error_Msg_N ("asm volatile argument is not static", Vol); + return False; + + else + return Is_True (Expr_Value (Vol)); + end if; + end Is_Asm_Volatile; + + -------------------- + -- Next_Asm_Input -- + -------------------- + + procedure Next_Asm_Input is + begin + Next_Asm_Operand (Current_Input_Operand); + end Next_Asm_Input; + + ---------------------- + -- Next_Asm_Operand -- + ---------------------- + + procedure Next_Asm_Operand (Operand_Var : in out Node_Id) is + begin + pragma Assert (Present (Operand_Var)); + + if Nkind (Parent (Operand_Var)) = N_Aggregate then + Operand_Var := Next (Operand_Var); + + else + Operand_Var := Empty; + end if; + end Next_Asm_Operand; + + --------------------- + -- Next_Asm_Output -- + --------------------- + + procedure Next_Asm_Output is + begin + Next_Asm_Operand (Current_Output_Operand); + end Next_Asm_Output; + + ---------------------- + -- Setup_Asm_Inputs -- + ---------------------- + + procedure Setup_Asm_Inputs (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + + begin + Setup_Asm_IO_Args + (Next_Actual (Next_Actual (First_Actual (Call))), + Current_Input_Operand); + end Setup_Asm_Inputs; + + ----------------------- + -- Setup_Asm_IO_Args -- + ----------------------- + + procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id) is + begin + -- Case of single argument + + if Nkind (Arg) = N_Attribute_Reference then + Operand_Var := Arg; + + -- Case of list of arguments + + elsif Nkind (Arg) = N_Aggregate then + if Expressions (Arg) = No_List then + Operand_Var := Empty; + else + Operand_Var := First (Expressions (Arg)); + end if; + + -- Otherwise must be default (no operands) case + + else + Operand_Var := Empty; + end if; + end Setup_Asm_IO_Args; + + ----------------------- + -- Setup_Asm_Outputs -- + ----------------------- + + procedure Setup_Asm_Outputs (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + + begin + Setup_Asm_IO_Args + (Next_Actual (First_Actual (Call)), + Current_Output_Operand); + end Setup_Asm_Outputs; + +end Exp_Code; diff --git a/gcc/ada/exp_code.ads b/gcc/ada/exp_code.ads new file mode 100644 index 00000000000..0043c3c045a --- /dev/null +++ b/gcc/ada/exp_code.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C O D E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1996 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Processing for handling code statements + +with Types; use Types; + +with System; use System; +package Exp_Code is + + procedure Expand_Asm_Call (N : Node_Id); + -- Expands a call to Asm or Asm_Volatile into an equivalent + -- N_Code_Statement node. + + -- The following routines provide an abstract interface to analyze + -- code statements, for use by Gigi processing for code statements. + -- Note that the implementations of these routines must not attempt + -- to expand tables that are frozen on entry to Gigi. + + function Is_Asm_Volatile (N : Node_Id) return Boolean; + -- Given an N_Code_Statement node N, return True in the Asm_Volatile + -- case and False in the Asm case. + + function Asm_Template (N : Node_Id) return Node_Id; + -- Given an N_Code_Statement node N, returns string literal node for + -- template in call + + procedure Clobber_Setup (N : Node_Id); + -- Given an N_Code_Statement node N, setup to process the clobber list + -- with subsequent calls to Clobber_Get_Next. + + function Clobber_Get_Next return System.Address; + -- Can only be called after a previous call to Clobber_Setup. The + -- returned value is a pointer to a null terminated (C format) string + -- for the next register argument. Null_Address is returned when there + -- are no more arguments. + + procedure Setup_Asm_Inputs (N : Node_Id); + -- Given an N_Code_Statement node N, setup to read list of Asm_Input + -- arguments. The protocol is to construct a loop as follows: + -- + -- Setup_Asm_Inputs (N); + -- while Present (Asm_Input_Value) + -- body + -- Next_Asm_Input; + -- end loop; + -- + -- where the loop body calls Asm_Input_Constraint or Asm_Input_Value to + -- obtain the constraint string or input value expression from the current + -- Asm_Input argument. + + function Asm_Input_Constraint return Node_Id; + -- Called within a loop initialized by Setup_Asm_Inputs and controlled + -- by Next_Asm_Input as described above. Returns a string literal node + -- for the constraint component of the current Asm_Input_Parameter, or + -- Empty if there are no more Asm_Input parameters. + + function Asm_Input_Value return Node_Id; + -- Called within a loop initialized by Setup_Asm_Inputs and controlled + -- by Next_Asm_Input as described above. Returns the expression node for + -- the value component of the current Asm_Input parameter, or Empty if + -- there are no more Asm_Input parameters. + + procedure Next_Asm_Input; + -- Step to next Asm_Input parameter. It is an error to call this procedure + -- if there are no more available parameters (which is impossible if the + -- call appears in a loop as in the above example). + + procedure Setup_Asm_Outputs (N : Node_Id); + -- Given an N_Code_Statement node N, setup to read list of Asm_Output + -- arguments. The protocol is to construct a loop as follows: + -- + -- Setup_Asm_Outputs (N); + -- while Present (Asm_Output_Value) + -- body + -- Next_Asm_Output; + -- end loop; + -- + -- where the loop body calls Asm_Output_Constraint or Asm_Output_Variable + -- to obtain the constraint string or output variable name from the current + -- Asm_Output argument. + + function Asm_Output_Constraint return Node_Id; + -- Called within a loop initialized by Setup_Asm_Outputs and controlled + -- by Next_Asm_Output as described above. Returns a string literal node + -- for the constraint component of the current Asm_Output_Parameter, or + -- Empty if there are no more Asm_Output parameters. + + function Asm_Output_Variable return Node_Id; + -- Called within a loop initialized by Setup_Asm_Outputs and controlled + -- by Next_Asm_Output as described above. Returns the expression node for + -- the output variable component of the current Asm_Output parameter, or + -- Empty if there are no more Asm_Output parameters. + + procedure Next_Asm_Output; + -- Step to next Asm_Output parameter. It is an error to call this procedure + -- if there are no more available parameters (which is impossible if the + -- call appears in a loop as in the above example). + +end Exp_Code; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb new file mode 100644 index 00000000000..871b0c56c64 --- /dev/null +++ b/gcc/ada/exp_dbug.adb @@ -0,0 +1,1753 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D B U G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.56 $ +-- -- +-- 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 Alloc; use Alloc; +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Lib; use Lib; +with Hostparm; use Hostparm; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Table; +with Urealp; use Urealp; + +with GNAT.HTable; + +package body Exp_Dbug is + + -- The following table is used to queue up the entities passed as + -- arguments to Qualify_Entity_Names for later processing when + -- Qualify_All_Entity_Names is called. + + package Name_Qualify_Units is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Name_Qualify_Units_Initial, + Table_Increment => Alloc.Name_Qualify_Units_Increment, + Table_Name => "Name_Qualify_Units"); + + -- Define hash table for compressed debug names + + -- This hash table keeps track of qualification prefix strings + -- that have been compressed. The element is the corresponding + -- hash value used in the compressed symbol. + + type Hindex is range 0 .. 4096; + -- Type to define range of headers + + function SHash (S : String_Ptr) return Hindex; + -- Hash function for this table + + function SEq (F1, F2 : String_Ptr) return Boolean; + -- Equality function for this table + + type Elmt is record + W : Word; + S : String_Ptr; + end record; + + No_Elmt : Elmt := (0, null); + + package CDN is new GNAT.HTable.Simple_HTable ( + Header_Num => Hindex, + Element => Elmt, + No_Element => No_Elmt, + Key => String_Ptr, + Hash => SHash, + Equal => SEq); + + -------------------------------- + -- Use of Qualification Flags -- + -------------------------------- + + -- There are two flags used to keep track of qualification of entities + + -- Has_Fully_Qualified_Name + -- Has_Qualified_Name + + -- The difference between these is as follows. Has_Qualified_Name is + -- set to indicate that the name has been qualified as required by the + -- spec of this package. As described there, this may involve the full + -- qualification for the name, but for some entities, notably procedure + -- local variables, this full qualification is not required. + + -- The flag Has_Fully_Qualified_Name is set if indeed the name has been + -- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set, + -- then Has_Qualified_Name is also set, but the other way round is not + -- the case. + + -- Consider the following example: + + -- with ... + -- procedure X is + -- B : Ddd.Ttt; + -- procedure Y is .. + + -- Here B is a procedure local variable, so it does not need fully + -- qualification. The flag Has_Qualified_Name will be set on the + -- first attempt to qualify B, to indicate that the job is done + -- and need not be redone. + + -- But Y is qualified as x__y, since procedures are always fully + -- qualified, so the first time that an attempt is made to qualify + -- the name y, it will be replaced by x__y, and both flags are set. + + -- Why the two flags? Well there are cases where we derive type names + -- from object names. As noted in the spec, type names are always + -- fully qualified. Suppose for example that the backend has to build + -- a padded type for variable B. then it will construct the PAD name + -- from B, but it requires full qualification, so the fully qualified + -- type name will be x__b___PAD. The two flags allow the circuit for + -- building this name to realize efficiently that b needs further + -- qualification. + + ---------------------- + -- Local Procedures -- + ---------------------- + + procedure Add_Uint_To_Buffer (U : Uint); + -- Add image of universal integer to Name_Buffer, updating Name_Len + + procedure Add_Real_To_Buffer (U : Ureal); + -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of + -- the normalized numerator and denominator of the given real value. + + function Bounds_Match_Size (E : Entity_Id) return Boolean; + -- Determine whether the bounds of E match the size of the type. This is + -- used to determine whether encoding is required for a discrete type. + + function CDN_Hash (S : String) return Word; + -- This is the hash function used to compress debug symbols. The string + -- S is the prefix which is a list of qualified names separated by double + -- underscore (no trailing double underscore). The returned value is the + -- hash value used in the compressed names. It is also used for the hash + -- table used to keep track of what prefixes have been compressed so far. + + procedure Compress_Debug_Name (E : Entity_Id); + -- If the name of the entity E is too long, or compression is to be + -- attempted on all names (Compress_Debug_Names set), then an attempt + -- is made to compress the name of the entity. + + function Double_Underscore (S : String; J : Natural) return Boolean; + -- Returns True if J is the start of a double underscore + -- sequence in the string S (defined as two underscores + -- which are preceded and followed by a non-underscore) + + procedure Prepend_String_To_Buffer (S : String); + -- Prepend given string to the contents of the string buffer, updating + -- the value in Name_Len (i.e. string is added at start of buffer). + + procedure Prepend_Uint_To_Buffer (U : Uint); + -- Prepend image of universal integer to Name_Buffer, updating Name_Len + + procedure Put_Hex (W : Word; N : Natural); + -- Output W as 8 hex digits (0-9, a-f) in Name_Buffer (N .. N + 7) + + procedure Qualify_Entity_Name (Ent : Entity_Id); + -- If not already done, replaces the Chars field of the given entity + -- with the appropriate fully qualified name. + + procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean); + -- Given an qualified entity name in Name_Buffer, remove any plain X or + -- X{nb} qualification suffix. The contents of Name_Buffer is not changed + -- but Name_Len may be adjusted on return to remove the suffix. If a + -- suffix is found and stripped, then Suffix_Found is set to True. If + -- no suffix is found, then Suffix_Found is not modified. + + ------------------------ + -- Add_Real_To_Buffer -- + ------------------------ + + procedure Add_Real_To_Buffer (U : Ureal) is + begin + Add_Uint_To_Buffer (Norm_Num (U)); + Add_Str_To_Name_Buffer ("_"); + Add_Uint_To_Buffer (Norm_Den (U)); + end Add_Real_To_Buffer; + + ------------------------ + -- Add_Uint_To_Buffer -- + ------------------------ + + procedure Add_Uint_To_Buffer (U : Uint) is + begin + if U < 0 then + Add_Uint_To_Buffer (-U); + Add_Char_To_Name_Buffer ('m'); + else + UI_Image (U, Decimal); + Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); + end if; + end Add_Uint_To_Buffer; + + ----------------------- + -- Bounds_Match_Size -- + ----------------------- + + function Bounds_Match_Size (E : Entity_Id) return Boolean is + Siz : Uint; + + begin + if not Is_OK_Static_Subtype (E) then + return False; + + elsif Is_Integer_Type (E) + and then Subtypes_Statically_Match (E, Base_Type (E)) + then + return True; + + -- Here we check if the static bounds match the natural size, which + -- is the size passed through with the debugging information. This + -- is the Esize rounded up to 8, 16, 32 or 64 as appropriate. + + else + declare + Umark : constant Uintp.Save_Mark := Uintp.Mark; + Result : Boolean; + + begin + if Esize (E) <= 8 then + Siz := Uint_8; + elsif Esize (E) <= 16 then + Siz := Uint_16; + elsif Esize (E) <= 32 then + Siz := Uint_32; + else + Siz := Uint_64; + end if; + + if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then + Result := + Expr_Rep_Value (Type_Low_Bound (E)) = 0 + and then + 2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1; + + else + Result := + Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0 + and then + 2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1; + end if; + + Release (Umark); + return Result; + end; + end if; + end Bounds_Match_Size; + + -------------- + -- CDN_Hash -- + -------------- + + function CDN_Hash (S : String) return Word is + H : Word; + + function Rotate_Left (Value : Word; Amount : Natural) return Word; + pragma Import (Intrinsic, Rotate_Left); + + begin + H := 0; + for J in S'Range loop + H := Rotate_Left (H, 3) + Character'Pos (S (J)); + end loop; + + return H; + end CDN_Hash; + + ------------------------- + -- Compress_Debug_Name -- + ------------------------- + + procedure Compress_Debug_Name (E : Entity_Id) is + Ptr : Natural; + Sptr : String_Ptr; + Cod : Word; + + begin + if not Compress_Debug_Names + and then Length_Of_Name (Chars (E)) <= Max_Debug_Name_Length + then + return; + end if; + + Get_Name_String (Chars (E)); + + -- Find rightmost double underscore + + Ptr := Name_Len - 2; + loop + exit when Double_Underscore (Name_Buffer, Ptr); + + -- Cannot compress if no double underscore anywhere + + if Ptr < 2 then + return; + end if; + + Ptr := Ptr - 1; + end loop; + + -- At this stage we have + + -- Name_Buffer (1 .. Ptr - 1) string to compress + -- Name_Buffer (Ptr) underscore + -- Name_Buffer (Ptr + 1) underscore + -- Name_Buffer (Ptr + 2 .. Name_Len) simple name to retain + + -- See if we already have an entry for the compression string + + -- No point in compressing if it does not make things shorter + + if Name_Len <= (2 + 8 + 1) + (Name_Len - (Ptr + 1)) then + return; + end if; + + -- Do not compress any reference to entity in internal file + + if Name_Buffer (1 .. 5) = "ada__" + or else + Name_Buffer (1 .. 8) = "system__" + or else + Name_Buffer (1 .. 6) = "gnat__" + or else + Name_Buffer (1 .. 12) = "interfaces__" + or else + (OpenVMS and then Name_Buffer (1 .. 5) = "dec__") + then + return; + end if; + + Sptr := Name_Buffer (1 .. Ptr - 1)'Unrestricted_Access; + Cod := CDN.Get (Sptr).W; + + if Cod = 0 then + Cod := CDN_Hash (Sptr.all); + Sptr := new String'(Sptr.all); + CDN.Set (Sptr, (Cod, Sptr)); + end if; + + Name_Buffer (1) := 'X'; + Name_Buffer (2) := 'C'; + Put_Hex (Cod, 3); + Name_Buffer (11) := '_'; + Name_Buffer (12 .. Name_Len - Ptr + 10) := + Name_Buffer (Ptr + 2 .. Name_Len); + Name_Len := Name_Len - Ptr + 10; + + Set_Chars (E, Name_Enter); + end Compress_Debug_Name; + + -------------------------------- + -- Debug_Renaming_Declaration -- + -------------------------------- + + function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Node_Id := Defining_Entity (N); + Nam : constant Node_Id := Name (N); + Rnm : Name_Id; + Ren : Node_Id; + Lit : Entity_Id; + Typ : Entity_Id; + Res : Node_Id; + Def : Entity_Id; + + function Output_Subscript (N : Node_Id; S : String) return Boolean; + -- Outputs a single subscript value as ?nnn (subscript is compile + -- time known value with value nnn) or as ?e (subscript is local + -- constant with name e), where S supplies the proper string to + -- use for ?. Returns False if the subscript is not of an appropriate + -- type to output in one of these two forms. The result is prepended + -- to the name stored in Name_Buffer. + + ---------------------- + -- Output_Subscript -- + ---------------------- + + function Output_Subscript (N : Node_Id; S : String) return Boolean is + begin + if Compile_Time_Known_Value (N) then + Prepend_Uint_To_Buffer (Expr_Value (N)); + + elsif Nkind (N) = N_Identifier + and then Scope (Entity (N)) = Scope (Ent) + and then Ekind (Entity (N)) = E_Constant + then + Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N)))); + + else + return False; + end if; + + Prepend_String_To_Buffer (S); + return True; + end Output_Subscript; + + -- Start of processing for Debug_Renaming_Declaration + + begin + if not Comes_From_Source (N) then + return Empty; + end if; + + -- Prepare entity name for type declaration + + Get_Name_String (Chars (Ent)); + + case Nkind (N) is + when N_Object_Renaming_Declaration => + Add_Str_To_Name_Buffer ("___XR"); + + when N_Exception_Renaming_Declaration => + Add_Str_To_Name_Buffer ("___XRE"); + + when N_Package_Renaming_Declaration => + Add_Str_To_Name_Buffer ("___XRP"); + + when others => + return Empty; + end case; + + Rnm := Name_Find; + + -- Get renamed entity and compute suffix + + Name_Len := 0; + Ren := Nam; + loop + case Nkind (Ren) is + + when N_Identifier => + exit; + + when N_Expanded_Name => + + -- The entity field for an N_Expanded_Name is on the + -- expanded name node itself, so we are done here too. + + exit; + + when N_Selected_Component => + Prepend_String_To_Buffer + (Get_Name_String (Chars (Selector_Name (Ren)))); + Prepend_String_To_Buffer ("XR"); + Ren := Prefix (Ren); + + when N_Indexed_Component => + declare + X : Node_Id := Last (Expressions (Ren)); + + begin + while Present (X) loop + if not Output_Subscript (X, "XS") then + Set_Materialize_Entity (Ent); + return Empty; + end if; + + Prev (X); + end loop; + end; + + Ren := Prefix (Ren); + + when N_Slice => + + Typ := Etype (First_Index (Etype (Nam))); + + if not Output_Subscript (Type_High_Bound (Typ), "XS") then + Set_Materialize_Entity (Ent); + return Empty; + end if; + + if not Output_Subscript (Type_Low_Bound (Typ), "XL") then + Set_Materialize_Entity (Ent); + return Empty; + end if; + + Ren := Prefix (Ren); + + when N_Explicit_Dereference => + Prepend_String_To_Buffer ("XA"); + Ren := Prefix (Ren); + + -- For now, anything else simply results in no translation + + when others => + Set_Materialize_Entity (Ent); + return Empty; + end case; + end loop; + + Prepend_String_To_Buffer ("___XE"); + + -- For now, the literal name contains only the suffix. The Entity_Id + -- value for the name is used to create a link from this literal name + -- to the renamed entity using the Debug_Renaming_Link field. Then the + -- Qualify_Entity_Name procedure uses this link to create the proper + -- fully qualified name. + + -- The reason we do things this way is that we really need to copy the + -- qualification of the renamed entity, and it is really much easier to + -- do this after the renamed entity has itself been fully qualified. + + Lit := Make_Defining_Identifier (Loc, Chars => Name_Enter); + Set_Debug_Renaming_Link (Lit, Entity (Ren)); + + -- Return the appropriate enumeration type + + Def := Make_Defining_Identifier (Loc, Chars => Rnm); + Res := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Def, + Type_Definition => + Make_Enumeration_Type_Definition (Loc, + Literals => New_List (Lit))); + + Set_Needs_Debug_Info (Def); + Set_Needs_Debug_Info (Lit); + + Set_Discard_Names (Defining_Identifier (Res)); + return Res; + + -- If we get an exception, just figure it is a case that we cannot + -- successfully handle using our current approach, since this is + -- only for debugging, no need to take the compilation with us! + + exception + when others => + return Make_Null_Statement (Loc); + end Debug_Renaming_Declaration; + + ----------------------- + -- Double_Underscore -- + ----------------------- + + function Double_Underscore (S : String; J : Natural) return Boolean is + begin + if J = S'First or else J > S'Last - 2 then + return False; + + else + return S (J) = '_' + and then S (J + 1) = '_' + and then S (J - 1) /= '_' + and then S (J + 2) /= '_'; + end if; + end Double_Underscore; + + ------------------------------ + -- Generate_Auxiliary_Types -- + ------------------------------ + + -- Note: right now there is only one auxiliary type to be generated, + -- namely the enumeration type for the compression sequences if used. + + procedure Generate_Auxiliary_Types is + Loc : constant Source_Ptr := Sloc (Cunit (Current_Sem_Unit)); + E : Elmt; + Code : Entity_Id; + Lit : Entity_Id; + Start : Natural; + Ptr : Natural; + Discard : List_Id; + + Literal_List : List_Id := New_List; + -- Gathers the list of literals for the declaration + + procedure Output_Literal; + -- Adds suffix of form Xnnn to name in Name_Buffer, where nnn is + -- a serial number that is one greater on each call, and then + -- builds an enumeration literal and adds it to the literal list. + + Serial : Nat := 0; + -- Current serial number + + procedure Output_Literal is + begin + Serial := Serial + 1; + Add_Char_To_Name_Buffer ('X'); + Add_Nat_To_Name_Buffer (Serial); + + Lit := + Make_Defining_Identifier (Loc, + Chars => Name_Find); + Set_Has_Qualified_Name (Lit, True); + Append (Lit, Literal_List); + end Output_Literal; + + -- Start of processing for Auxiliary_Types + + begin + E := CDN.Get_First; + if E.S /= null then + while E.S /= null loop + + -- We have E.S a String_Ptr that contains a string of the form: + + -- b__c__d + + -- In E.W is a 32-bit word representing the hash value + + -- Our mission is to construct a type + + -- type XChhhhhhhh is (b,c,d); + + -- where hhhhhhhh is the 8 hex digits of the E.W value. + -- and append this type declaration to the result list + + Name_Buffer (1) := 'X'; + Name_Buffer (2) := 'C'; + Put_Hex (E.W, 3); + Name_Len := 10; + Output_Literal; + + Start := E.S'First; + Ptr := E.S'First; + while Ptr <= E.S'Last loop + if Ptr = E.S'Last + or else Double_Underscore (E.S.all, Ptr + 1) + then + Name_Len := Ptr - Start + 1; + Name_Buffer (1 .. Name_Len) := E.S (Start .. Ptr); + Output_Literal; + Start := Ptr + 3; + Ptr := Start; + else + Ptr := Ptr + 1; + end if; + end loop; + + E := CDN.Get_Next; + end loop; + + Name_Buffer (1) := 'X'; + Name_Buffer (2) := 'C'; + Name_Len := 2; + + Code := + Make_Defining_Identifier (Loc, + Chars => Name_Find); + Set_Has_Qualified_Name (Code, True); + + Insert_Library_Level_Action ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Code, + Type_Definition => + Make_Enumeration_Type_Definition (Loc, + Literals => Literal_List))); + + -- We have to manually freeze this entity, since it is inserted + -- very late on into the tree, and otherwise will not be frozen. + -- No freeze actions are generated, so we can discard the result. + + Discard := Freeze_Entity (Code, Loc); + end if; + end Generate_Auxiliary_Types; + + ---------------------- + -- Get_Encoded_Name -- + ---------------------- + + -- Note: see spec for details on encodings + + procedure Get_Encoded_Name (E : Entity_Id) is + Has_Suffix : Boolean; + + begin + Get_Name_String (Chars (E)); + + -- Nothing to do if we do not have a type + + if not Is_Type (E) + + -- Or if this is an enumeration base type + + or else (Is_Enumeration_Type (E) + and then E = Base_Type (E)) + + -- Or if this is a dummy type for a renaming + + or else Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR" + or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE" + or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP" + + -- For all these cases, just return the name unchanged + + then + Name_Buffer (Name_Len + 1) := ASCII.Nul; + return; + end if; + + Has_Suffix := True; + + -- Fixed-point case + + if Is_Fixed_Point_Type (E) then + Get_External_Name_With_Suffix (E, "XF_"); + Add_Real_To_Buffer (Delta_Value (E)); + + if Small_Value (E) /= Delta_Value (E) then + Add_Str_To_Name_Buffer ("_"); + Add_Real_To_Buffer (Small_Value (E)); + end if; + + -- Vax floating-point case + + elsif Vax_Float (E) then + + if Digits_Value (Base_Type (E)) = 6 then + Get_External_Name_With_Suffix (E, "XFF"); + + elsif Digits_Value (Base_Type (E)) = 9 then + Get_External_Name_With_Suffix (E, "XFF"); + + else + pragma Assert (Digits_Value (Base_Type (E)) = 15); + Get_External_Name_With_Suffix (E, "XFG"); + end if; + + -- Discrete case where bounds do not match size + + elsif Is_Discrete_Type (E) + and then not Bounds_Match_Size (E) + then + if Has_Biased_Representation (E) then + Get_External_Name_With_Suffix (E, "XB"); + else + Get_External_Name_With_Suffix (E, "XD"); + end if; + + declare + Lo : constant Node_Id := Type_Low_Bound (E); + Hi : constant Node_Id := Type_High_Bound (E); + + Lo_Stat : constant Boolean := Is_OK_Static_Expression (Lo); + Hi_Stat : constant Boolean := Is_OK_Static_Expression (Hi); + + Lo_Discr : constant Boolean := + Nkind (Lo) = N_Identifier + and then + Ekind (Entity (Lo)) = E_Discriminant; + + Hi_Discr : constant Boolean := + Nkind (Hi) = N_Identifier + and then + Ekind (Entity (Hi)) = E_Discriminant; + + Lo_Encode : constant Boolean := Lo_Stat or Lo_Discr; + Hi_Encode : constant Boolean := Hi_Stat or Hi_Discr; + + begin + if Lo_Encode or Hi_Encode then + if Lo_Encode then + if Hi_Encode then + Add_Str_To_Name_Buffer ("LU_"); + else + Add_Str_To_Name_Buffer ("L_"); + end if; + else + Add_Str_To_Name_Buffer ("U_"); + end if; + + if Lo_Stat then + Add_Uint_To_Buffer (Expr_Rep_Value (Lo)); + elsif Lo_Discr then + Get_Name_String_And_Append (Chars (Entity (Lo))); + end if; + + if Lo_Encode and Hi_Encode then + Add_Str_To_Name_Buffer ("__"); + end if; + + if Hi_Stat then + Add_Uint_To_Buffer (Expr_Rep_Value (Hi)); + elsif Hi_Discr then + Get_Name_String_And_Append (Chars (Entity (Hi))); + end if; + end if; + end; + + -- For all other cases, the encoded name is the normal type name + + else + Has_Suffix := False; + Get_External_Name (E, Has_Suffix); + end if; + + if Debug_Flag_B and then Has_Suffix then + Write_Str ("**** type "); + Write_Name (Chars (E)); + Write_Str (" is encoded as "); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end if; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + end Get_Encoded_Name; + + ------------------- + -- Get_Entity_Id -- + ------------------- + + function Get_Entity_Id (External_Name : String) return Entity_Id is + begin + return Empty; + end Get_Entity_Id; + + ----------------------- + -- Get_External_Name -- + ----------------------- + + procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) + is + E : Entity_Id := Entity; + Kind : Entity_Kind; + + procedure Get_Qualified_Name_And_Append (Entity : Entity_Id); + -- Appends fully qualified name of given entity to Name_Buffer + + ----------------------------------- + -- Get_Qualified_Name_And_Append -- + ----------------------------------- + + procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is + begin + -- If the entity is a compilation unit, its scope is Standard, + -- there is no outer scope, and the no further qualification + -- is required. + + -- If the front end has already computed a fully qualified name, + -- then it is also the case that no further qualification is + -- required + + if Present (Scope (Scope (Entity))) + and then not Has_Fully_Qualified_Name (Entity) + then + Get_Qualified_Name_And_Append (Scope (Entity)); + Add_Str_To_Name_Buffer ("__"); + end if; + + Get_Name_String_And_Append (Chars (Entity)); + end Get_Qualified_Name_And_Append; + + -- Start of processing for Get_External_Name + + begin + Name_Len := 0; + + -- If this is a child unit, we want the child + + if Nkind (E) = N_Defining_Program_Unit_Name then + E := Defining_Identifier (Entity); + end if; + + Kind := Ekind (E); + + -- Case of interface name being used + + if (Kind = E_Procedure or else + Kind = E_Function or else + Kind = E_Constant or else + Kind = E_Variable or else + Kind = E_Exception) + and then Present (Interface_Name (E)) + and then No (Address_Clause (E)) + and then not Has_Suffix + then + -- The following code needs explanation ??? + + if Convention (E) = Convention_Stdcall + and then Ekind (E) = E_Variable + then + Add_Str_To_Name_Buffer ("_imp__"); + end if; + + Add_String_To_Name_Buffer (Strval (Interface_Name (E))); + + -- All other cases besides the interface name case + + else + -- If this is a library level subprogram (i.e. a subprogram that is a + -- compilation unit other than a subunit), then we prepend _ada_ to + -- ensure distinctions required as described in the spec. + -- Check explicitly for child units, because those are not flagged + -- as Compilation_Units by lib. Should they be ??? + + if Is_Subprogram (E) + and then (Is_Compilation_Unit (E) or Is_Child_Unit (E)) + and then not Has_Suffix + then + Add_Str_To_Name_Buffer ("_ada_"); + end if; + + -- If the entity is a subprogram instance that is not a compilation + -- unit, generate the name of the original Ada entity, which is the + -- one gdb needs. + + if Is_Generic_Instance (E) + and then Is_Subprogram (E) + and then not Is_Compilation_Unit (Scope (E)) + then + E := Related_Instance (Scope (E)); + end if; + + Get_Qualified_Name_And_Append (E); + + if Has_Homonym (E) then + declare + H : Entity_Id := Homonym (E); + Nr : Nat := 1; + + begin + while Present (H) loop + if (Scope (H) = Scope (E)) then + Nr := Nr + 1; + end if; + + H := Homonym (H); + end loop; + + if Nr > 1 then + if No_Dollar_In_Label then + Add_Str_To_Name_Buffer ("__"); + else + Add_Char_To_Name_Buffer ('$'); + end if; + + Add_Nat_To_Name_Buffer (Nr); + end if; + end; + end if; + end if; + + Name_Buffer (Name_Len + 1) := ASCII.Nul; + end Get_External_Name; + + ----------------------------------- + -- Get_External_Name_With_Suffix -- + ----------------------------------- + + procedure Get_External_Name_With_Suffix + (Entity : Entity_Id; + Suffix : String) + is + Has_Suffix : constant Boolean := (Suffix /= ""); + begin + Get_External_Name (Entity, Has_Suffix); + + if Has_Suffix then + Add_Str_To_Name_Buffer ("___"); + Add_Str_To_Name_Buffer (Suffix); + + Name_Buffer (Name_Len + 1) := ASCII.Nul; + end if; + end Get_External_Name_With_Suffix; + + -------------------------- + -- Get_Variant_Encoding -- + -------------------------- + + procedure Get_Variant_Encoding (V : Node_Id) is + Choice : Node_Id; + + procedure Choice_Val (Typ : Character; Choice : Node_Id); + -- Output encoded value for a single choice value. Typ is the key + -- character ('S', 'F', or 'T') that precedes the choice value. + + ---------------- + -- Choice_Val -- + ---------------- + + procedure Choice_Val (Typ : Character; Choice : Node_Id) is + begin + Add_Char_To_Name_Buffer (Typ); + + if Nkind (Choice) = N_Integer_Literal then + Add_Uint_To_Buffer (Intval (Choice)); + + -- Character literal with no entity present (this is the case + -- Standard.Character or Standard.Wide_Character as root type) + + elsif Nkind (Choice) = N_Character_Literal + and then No (Entity (Choice)) + then + Add_Uint_To_Buffer + (UI_From_Int (Int (Char_Literal_Value (Choice)))); + + else + declare + Ent : constant Entity_Id := Entity (Choice); + + begin + if Ekind (Ent) = E_Enumeration_Literal then + Add_Uint_To_Buffer (Enumeration_Rep (Ent)); + + else + pragma Assert (Ekind (Ent) = E_Constant); + Choice_Val (Typ, Constant_Value (Ent)); + end if; + end; + end if; + end Choice_Val; + + -- Start of processing for Get_Variant_Encoding + + begin + Name_Len := 0; + + Choice := First (Discrete_Choices (V)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Add_Char_To_Name_Buffer ('O'); + + elsif Nkind (Choice) = N_Range then + Choice_Val ('R', Low_Bound (Choice)); + Choice_Val ('T', High_Bound (Choice)); + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Choice_Val ('R', Type_Low_Bound (Entity (Choice))); + Choice_Val ('T', Type_High_Bound (Entity (Choice))); + + elsif Nkind (Choice) = N_Subtype_Indication then + declare + Rang : constant Node_Id := + Range_Expression (Constraint (Choice)); + begin + Choice_Val ('R', Low_Bound (Rang)); + Choice_Val ('T', High_Bound (Rang)); + end; + + else + Choice_Val ('S', Choice); + end if; + + Next (Choice); + end loop; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + if Debug_Flag_B then + declare + VP : constant Node_Id := Parent (V); -- Variant_Part + CL : constant Node_Id := Parent (VP); -- Component_List + RD : constant Node_Id := Parent (CL); -- Record_Definition + FT : constant Node_Id := Parent (RD); -- Full_Type_Declaration + + begin + Write_Str ("**** variant for type "); + Write_Name (Chars (Defining_Identifier (FT))); + Write_Str (" is encoded as "); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end; + end if; + end Get_Variant_Encoding; + + --------------------------------- + -- Make_Packed_Array_Type_Name -- + --------------------------------- + + function Make_Packed_Array_Type_Name + (Typ : Entity_Id; + Csize : Uint) + return Name_Id + is + begin + Get_Name_String (Chars (Typ)); + Add_Str_To_Name_Buffer ("___XP"); + Add_Uint_To_Buffer (Csize); + return Name_Find; + end Make_Packed_Array_Type_Name; + + ------------------------------ + -- Prepend_String_To_Buffer -- + ------------------------------ + + procedure Prepend_String_To_Buffer (S : String) is + N : constant Integer := S'Length; + + begin + Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. N) := S; + Name_Len := Name_Len + N; + end Prepend_String_To_Buffer; + + ---------------------------- + -- Prepend_Uint_To_Buffer -- + ---------------------------- + + procedure Prepend_Uint_To_Buffer (U : Uint) is + begin + if U < 0 then + Prepend_String_To_Buffer ("m"); + Prepend_Uint_To_Buffer (-U); + else + UI_Image (U, Decimal); + Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); + end if; + end Prepend_Uint_To_Buffer; + + ------------- + -- Put_Hex -- + ------------- + + procedure Put_Hex (W : Word; N : Natural) is + Hex : constant array (Word range 0 .. 15) of Character := + "0123456789abcdef"; + + Cod : Word; + + begin + Cod := W; + for J in reverse N .. N + 7 loop + Name_Buffer (J) := Hex (Cod and 16#F#); + Cod := Cod / 16; + end loop; + end Put_Hex; + + ------------------------------ + -- Qualify_All_Entity_Names -- + ------------------------------ + + procedure Qualify_All_Entity_Names is + E : Entity_Id; + Ent : Entity_Id; + + begin + for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop + E := Defining_Entity (Name_Qualify_Units.Table (J)); + Qualify_Entity_Name (E); + + Ent := First_Entity (E); + while Present (Ent) loop + Qualify_Entity_Name (Ent); + Next_Entity (Ent); + + -- There are odd cases where Last_Entity (E) = E. This happens + -- in the case of renaming of packages. This test avoids getting + -- stuck in such cases. + + exit when Ent = E; + end loop; + end loop; + + -- Second loop compresses any names that need compressing + + for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop + E := Defining_Entity (Name_Qualify_Units.Table (J)); + Compress_Debug_Name (E); + + Ent := First_Entity (E); + while Present (Ent) loop + Compress_Debug_Name (Ent); + Next_Entity (Ent); + exit when Ent = E; + end loop; + end loop; + end Qualify_All_Entity_Names; + + ------------------------- + -- Qualify_Entity_Name -- + ------------------------- + + procedure Qualify_Entity_Name (Ent : Entity_Id) is + + Full_Qualify_Name : String (1 .. Name_Buffer'Length); + Full_Qualify_Len : Natural := 0; + -- Used to accumulate fully qualified name of subprogram + + procedure Fully_Qualify_Name (E : Entity_Id); + -- Used to qualify a subprogram or type name, where full + -- qualification up to Standard is always used. Name is set + -- in Full_Qualify_Name with the length in Full_Qualify_Len. + -- Note that this routine does not prepend the _ada_ string + -- required for library subprograms (this is done in the back end). + + function Is_BNPE (S : Entity_Id) return Boolean; + -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which + -- is defined to be a package which is immediately nested within a + -- package body. + + function Qualify_Needed (S : Entity_Id) return Boolean; + -- Given a scope, determines if the scope is to be included in the + -- fully qualified name, True if so, False if not. + + procedure Set_BNPE_Suffix (E : Entity_Id); + -- Recursive routine to append the BNPE qualification suffix. Works + -- from right to left with E being the current entity in the list. + -- The result does NOT have the trailing n's and trailing b stripped. + -- The caller must do this required stripping. + + procedure Set_Entity_Name (E : Entity_Id); + -- Internal recursive routine that does most of the work. This routine + -- leaves the result sitting in Name_Buffer and Name_Len. + + BNPE_Suffix_Needed : Boolean := False; + -- Set true if a body-nested package entity suffix is required + + Save_Chars : constant Name_Id := Chars (Ent); + -- Save original name + + ------------------------ + -- Fully_Qualify_Name -- + ------------------------ + + procedure Fully_Qualify_Name (E : Entity_Id) is + Discard : Boolean := False; + + begin + -- If this we are qualifying entities local to a generic + -- instance, use the name of the original instantiation, + -- not that of the anonymous subprogram in the wrapper + -- package, so that gdb doesn't have to know about these. + + if Is_Generic_Instance (E) + and then Is_Subprogram (E) + and then not Comes_From_Source (E) + and then not Is_Compilation_Unit (Scope (E)) + then + Fully_Qualify_Name (Related_Instance (Scope (E))); + return; + end if; + + -- If we reached fully qualified name, then just copy it + + if Has_Fully_Qualified_Name (E) then + Get_Name_String (Chars (E)); + Strip_BNPE_Suffix (Discard); + Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Full_Qualify_Len := Name_Len; + Set_Has_Fully_Qualified_Name (Ent); + + -- Case of non-fully qualified name + + else + if Scope (E) = Standard_Standard then + Set_Has_Fully_Qualified_Name (Ent); + else + Fully_Qualify_Name (Scope (E)); + Full_Qualify_Name (Full_Qualify_Len + 1) := '_'; + Full_Qualify_Name (Full_Qualify_Len + 2) := '_'; + Full_Qualify_Len := Full_Qualify_Len + 2; + end if; + + if Has_Qualified_Name (E) then + Get_Unqualified_Name_String (Chars (E)); + else + Get_Name_String (Chars (E)); + end if; + + Full_Qualify_Name + (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) := + Name_Buffer (1 .. Name_Len); + Full_Qualify_Len := Full_Qualify_Len + Name_Len; + end if; + + if Is_BNPE (E) then + BNPE_Suffix_Needed := True; + end if; + end Fully_Qualify_Name; + + ------------- + -- Is_BNPE -- + ------------- + + function Is_BNPE (S : Entity_Id) return Boolean is + begin + return + Ekind (S) = E_Package + and then Is_Package_Body_Entity (S); + end Is_BNPE; + + -------------------- + -- Qualify_Needed -- + -------------------- + + function Qualify_Needed (S : Entity_Id) return Boolean is + begin + -- If we got all the way to Standard, then we have certainly + -- fully qualified the name, so set the flag appropriately, + -- and then return False, since we are most certainly done! + + if S = Standard_Standard then + Set_Has_Fully_Qualified_Name (Ent, True); + return False; + + -- Otherwise figure out if further qualification is required + + else + return + Is_Subprogram (Ent) + or else + Ekind (Ent) = E_Subprogram_Body + or else + (Ekind (S) /= E_Block + and then not Is_Dynamic_Scope (S)); + end if; + end Qualify_Needed; + + --------------------- + -- Set_BNPE_Suffix -- + --------------------- + + procedure Set_BNPE_Suffix (E : Entity_Id) is + S : constant Entity_Id := Scope (E); + + begin + if Qualify_Needed (S) then + Set_BNPE_Suffix (S); + + if Is_BNPE (E) then + Add_Char_To_Name_Buffer ('b'); + else + Add_Char_To_Name_Buffer ('n'); + end if; + + else + Add_Char_To_Name_Buffer ('X'); + end if; + + end Set_BNPE_Suffix; + + --------------------- + -- Set_Entity_Name -- + --------------------- + + procedure Set_Entity_Name (E : Entity_Id) is + S : constant Entity_Id := Scope (E); + + begin + -- If we reach an already qualified name, just take the encoding + -- except that we strip the package body suffixes, since these + -- will be separately put on later. + + if Has_Qualified_Name (E) then + Get_Name_String_And_Append (Chars (E)); + Strip_BNPE_Suffix (BNPE_Suffix_Needed); + + -- If the top level name we are adding is itself fully + -- qualified, then that means that the name that we are + -- preparing for the Fully_Qualify_Name call will also + -- generate a fully qualified name. + + if Has_Fully_Qualified_Name (E) then + Set_Has_Fully_Qualified_Name (Ent); + end if; + + -- Case where upper level name is not encoded yet + + else + -- Recurse if further qualification required + + if Qualify_Needed (S) then + Set_Entity_Name (S); + Add_Str_To_Name_Buffer ("__"); + end if; + + -- Otherwise get name and note if it is a NPBE + + Get_Name_String_And_Append (Chars (E)); + + if Is_BNPE (E) then + BNPE_Suffix_Needed := True; + end if; + end if; + end Set_Entity_Name; + + -- Start of processing for Qualify_Entity_Name + + begin + if Has_Qualified_Name (Ent) then + return; + + -- Here is where we create the proper link for renaming + + elsif Ekind (Ent) = E_Enumeration_Literal + and then Present (Debug_Renaming_Link (Ent)) + then + Set_Entity_Name (Debug_Renaming_Link (Ent)); + Get_Name_String (Chars (Ent)); + Prepend_String_To_Buffer + (Get_Name_String (Chars (Debug_Renaming_Link (Ent)))); + Set_Chars (Ent, Name_Enter); + Set_Has_Qualified_Name (Ent); + return; + + elsif Is_Subprogram (Ent) + or else Ekind (Ent) = E_Subprogram_Body + or else Is_Type (Ent) + then + Fully_Qualify_Name (Ent); + Name_Len := Full_Qualify_Len; + Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len); + + elsif Qualify_Needed (Scope (Ent)) then + Name_Len := 0; + Set_Entity_Name (Ent); + + else + Set_Has_Qualified_Name (Ent); + return; + end if; + + -- Fall through with a fully qualified name in Name_Buffer/Name_Len + + -- Add body-nested package suffix if required + + if BNPE_Suffix_Needed + and then Ekind (Ent) /= E_Enumeration_Literal + then + Set_BNPE_Suffix (Ent); + + -- Strip trailing n's and last trailing b as required. note that + -- we know there is at least one b, or no suffix would be generated. + + while Name_Buffer (Name_Len) = 'n' loop + Name_Len := Name_Len - 1; + end loop; + + Name_Len := Name_Len - 1; + end if; + + Set_Chars (Ent, Name_Enter); + Set_Has_Qualified_Name (Ent); + + if Debug_Flag_BB then + Write_Str ("*** "); + Write_Name (Save_Chars); + Write_Str (" qualified as "); + Write_Name (Chars (Ent)); + Write_Eol; + end if; + end Qualify_Entity_Name; + + -------------------------- + -- Qualify_Entity_Names -- + -------------------------- + + procedure Qualify_Entity_Names (N : Node_Id) is + begin + Name_Qualify_Units.Append (N); + end Qualify_Entity_Names; + + -------------------------------- + -- Save_Unitname_And_Use_List -- + -------------------------------- + + procedure Save_Unitname_And_Use_List + (Main_Unit_Node : Node_Id; + Main_Kind : Node_Kind) + is + INITIAL_NAME_LENGTH : constant := 1024; + + Item : Node_Id; + Pack_Name : Node_Id; + + Unit_Spec : Node_Id := 0; + Unit_Body : Node_Id := 0; + + Main_Name : String_Id; + -- Fully qualified name of Main Unit + + Unit_Name : String_Id; + -- Name of unit specified in a Use clause + + Spec_Unit_Index : Source_File_Index; + Spec_File_Name : File_Name_Type := No_File; + + Body_Unit_Index : Source_File_Index; + Body_File_Name : File_Name_Type := No_File; + + type String_Ptr is access all String; + + Spec_File_Name_Str : String_Ptr; + Body_File_Name_Str : String_Ptr; + + type Label is record + Label_Name : String_Ptr; + Name_Length : Integer; + Pos : Integer; + end record; + + Spec_Label : Label; + Body_Label : Label; + + procedure Initialize (L : out Label); + -- Initialize label + + procedure Append (L : in out Label; Ch : Character); + -- Append character to label + + procedure Append (L : in out Label; Str : String); + -- Append string to label + + procedure Append_Name (L : in out Label; Unit_Name : String_Id); + -- Append name to label + + function Sufficient_Space + (L : Label; + Unit_Name : String_Id) + return Boolean; + -- Does sufficient space exist to append another name? + + procedure Append (L : in out Label; Str : String) is + begin + L.Label_Name (L.Pos + 1 .. L.Pos + Str'Length) := Str; + L.Pos := L.Pos + Str'Length; + end Append; + + procedure Append (L : in out Label; Ch : Character) is + begin + L.Pos := L.Pos + 1; + L.Label_Name (L.Pos) := Ch; + end Append; + + procedure Append_Name (L : in out Label; Unit_Name : String_Id) is + Char : Char_Code; + Upper_Offset : constant := Character'Pos ('a') - Character'Pos ('A'); + + begin + for J in 1 .. String_Length (Unit_Name) loop + Char := Get_String_Char (Unit_Name, J); + + if Character'Val (Char) = '.' then + Append (L, "__"); + elsif Character'Val (Char) in 'A' .. 'Z' then + Append (L, Character'Val (Char + Upper_Offset)); + elsif Char /= 0 then + Append (L, Character'Val (Char)); + end if; + end loop; + end Append_Name; + + procedure Initialize (L : out Label) is + begin + L.Name_Length := INITIAL_NAME_LENGTH; + L.Pos := 0; + L.Label_Name := new String (1 .. L.Name_Length); + end Initialize; + + function Sufficient_Space + (L : Label; + Unit_Name : String_Id) + return Boolean + is + Len : Integer := Integer (String_Length (Unit_Name)) + 1; + + begin + for J in 1 .. String_Length (Unit_Name) loop + if Character'Val (Get_String_Char (Unit_Name, J)) = '.' then + Len := Len + 1; + end if; + end loop; + + return L.Pos + Len < L.Name_Length; + end Sufficient_Space; + + -- Start of processing for Save_Unitname_And_Use_List + + begin + Initialize (Spec_Label); + Initialize (Body_Label); + + case Main_Kind is + when N_Package_Declaration => + Main_Name := Full_Qualified_Name + (Defining_Unit_Name (Specification (Unit (Main_Unit_Node)))); + Unit_Spec := Main_Unit_Node; + Append (Spec_Label, "_LPS__"); + Append (Body_Label, "_LPB__"); + + when N_Package_Body => + Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node)); + Unit_Body := Main_Unit_Node; + Main_Name := Full_Qualified_Name (Unit_Spec); + Append (Spec_Label, "_LPS__"); + Append (Body_Label, "_LPB__"); + + when N_Subprogram_Body => + Unit_Body := Main_Unit_Node; + + if Present (Corresponding_Spec (Unit (Main_Unit_Node))) then + Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node)); + Main_Name := Full_Qualified_Name + (Corresponding_Spec (Unit (Main_Unit_Node))); + else + Main_Name := Full_Qualified_Name + (Defining_Unit_Name (Specification (Unit (Main_Unit_Node)))); + end if; + + Append (Spec_Label, "_LSS__"); + Append (Body_Label, "_LSB__"); + + when others => + return; + end case; + + Append_Name (Spec_Label, Main_Name); + Append_Name (Body_Label, Main_Name); + + -- If we have a body, process it first + + if Present (Unit_Body) then + + Item := First (Context_Items (Unit_Body)); + + while Present (Item) loop + if Nkind (Item) = N_Use_Package_Clause then + Pack_Name := First (Names (Item)); + while Present (Pack_Name) loop + Unit_Name := Full_Qualified_Name (Entity (Pack_Name)); + + if Sufficient_Space (Body_Label, Unit_Name) then + Append (Body_Label, '$'); + Append_Name (Body_Label, Unit_Name); + end if; + + Pack_Name := Next (Pack_Name); + end loop; + end if; + + Item := Next (Item); + end loop; + end if; + + while Present (Unit_Spec) and then + Nkind (Unit_Spec) /= N_Compilation_Unit + loop + Unit_Spec := Parent (Unit_Spec); + end loop; + + if Present (Unit_Spec) then + + Item := First (Context_Items (Unit_Spec)); + + while Present (Item) loop + if Nkind (Item) = N_Use_Package_Clause then + Pack_Name := First (Names (Item)); + while Present (Pack_Name) loop + Unit_Name := Full_Qualified_Name (Entity (Pack_Name)); + + if Sufficient_Space (Spec_Label, Unit_Name) then + Append (Spec_Label, '$'); + Append_Name (Spec_Label, Unit_Name); + end if; + + if Sufficient_Space (Body_Label, Unit_Name) then + Append (Body_Label, '$'); + Append_Name (Body_Label, Unit_Name); + end if; + + Pack_Name := Next (Pack_Name); + end loop; + end if; + + Item := Next (Item); + end loop; + end if; + + if Present (Unit_Spec) then + Append (Spec_Label, Character'Val (0)); + Spec_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Spec)); + Spec_File_Name := Full_File_Name (Spec_Unit_Index); + Get_Name_String (Spec_File_Name); + Spec_File_Name_Str := new String (1 .. Name_Len + 1); + Spec_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Spec_File_Name_Str (Name_Len + 1) := Character'Val (0); + Spec_Filename := Spec_File_Name_Str (1)'Unrestricted_Access; + Spec_Context_List := + Spec_Label.Label_Name.all (1)'Unrestricted_Access; + end if; + + if Present (Unit_Body) then + Append (Body_Label, Character'Val (0)); + Body_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Body)); + Body_File_Name := Full_File_Name (Body_Unit_Index); + Get_Name_String (Body_File_Name); + Body_File_Name_Str := new String (1 .. Name_Len + 1); + Body_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Body_File_Name_Str (Name_Len + 1) := Character'Val (0); + Body_Filename := Body_File_Name_Str (1)'Unrestricted_Access; + Body_Context_List := + Body_Label.Label_Name.all (1)'Unrestricted_Access; + end if; + + end Save_Unitname_And_Use_List; + + --------- + -- SEq -- + --------- + + function SEq (F1, F2 : String_Ptr) return Boolean is + begin + return F1.all = F2.all; + end SEq; + + ----------- + -- SHash -- + ----------- + + function SHash (S : String_Ptr) return Hindex is + begin + return Hindex + (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length)); + end SHash; + + ----------------------- + -- Strip_BNPE_Suffix -- + ----------------------- + + procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean) is + begin + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = 'X' then + Name_Len := J - 1; + Suffix_Found := True; + exit; + end if; + + exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n'; + end loop; + end Strip_BNPE_Suffix; + +end Exp_Dbug; diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads new file mode 100644 index 00000000000..5351ea71b87 --- /dev/null +++ b/gcc/ada/exp_dbug.ads @@ -0,0 +1,1428 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D B U G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.74 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for generation of special declarations used by the +-- debugger. In accordance with the Dwarf 2.2 specification, certain +-- type names are encoded to provide information to the debugger. + +with Sinfo; use Sinfo; +with Types; use Types; +with Uintp; use Uintp; +with Get_Targ; use Get_Targ; + +package Exp_Dbug is + + ----------------------------------------------------- + -- Encoding and Qualification of Names of Entities -- + ----------------------------------------------------- + + -- This section describes how the names of entities are encoded in + -- the generated debugging information. + + -- An entity in Ada has a name of the form X.Y.Z ... E where X,Y,Z + -- are the enclosing scopes (not including Standard at the start). + + -- The encoding of the name follows this basic qualified naming scheme, + -- where the encoding of individual entity names is as described in + -- Namet (i.e. in particular names present in the original source are + -- folded to all lower case, with upper half and wide characters encoded + -- as described in Namet). Upper case letters are used only for entities + -- generated by the compiler. + + -- There are two cases, global entities, and local entities. In more + -- formal terms, local entities are those which have a dynamic enclosing + -- scope, and global entities are at the library level, except that we + -- always consider procedures to be global entities, even if they are + -- nested (that's because at the debugger level a procedure name refers + -- to the code, and the code is indeed a global entity, including the + -- case of nested procedures.) In addition, we also consider all types + -- to be global entities, even if they are defined within a procedure. + + -- The reason for full treating all type names as global entities is + -- that a number of our type encodings work by having related type + -- names, and we need the full qualification to keep this unique. + + -- For global entities, the encoded name includes all components of the + -- fully expanded name (but omitting Standard at the start). For example, + -- if a library level child package P.Q has an embedded package R, and + -- there is an entity in this embdded package whose name is S, the encoded + -- name will include the components p.q.r.s. + + -- For local entities, the encoded name only includes the components + -- up to the enclosing dynamic scope (other than a block). At run time, + -- such a dynamic scope is a subprogram, and the debugging formats know + -- about local variables of procedures, so it is not necessary to have + -- full qualification for such entities. In particular this means that + -- direct local variables of a procedure are not qualified. + + -- As an example of the local name convention, consider a procedure V.W + -- with a local variable X, and a nested block Y containing an entity + -- Z. The fully qualified names of the entities X and Z are: + + -- V.W.X + -- V.W.Y.Z + + -- but since V.W is a subprogram, the encoded names will end up + -- encoding only + + -- x + -- y.z + + -- The separating dots are translated into double underscores. + + -- Note: there is one exception, which is that on IRIX, for workshop + -- back compatibility, dots are retained as dots. In the rest of this + -- document we assume the double underscore encoding. + + ----------------------------- + -- Handling of Overloading -- + ----------------------------- + + -- The above scheme is incomplete with respect to overloaded + -- subprograms, since overloading can legitimately result in a + -- case of two entities with exactly the same fully qualified names. + -- To distinguish between entries in a set of overloaded subprograms, + -- the encoded names are serialized by adding one of the two suffixes: + + -- $n (dollar sign) + -- __nn (two underscores) + + -- where nn is a serial number (1 for the first overloaded function, + -- 2 for the second, etc.). The former suffix is used when a dollar + -- sign is a valid symbol on the target machine and the latter is + -- used when it is not. No suffix need appear on the encoding of + -- the first overloading of a subprogram. + + -- These names are prefixed by the normal full qualification. So + -- for example, the third instance of the subprogram qrs in package + -- yz would have one of the two names: + + -- yz__qrs$3 + -- yz__qrs__3 + + -- The serial number always appears at the end as shown, even in the + -- case of subprograms nested inside overloaded subprograms, and only + -- when the named subprogram is overloaded. For example, consider + -- the following situation: + + -- package body Yz is + -- procedure Qrs is -- Encoded name is yz__qrs + -- procedure Tuv is ... end; -- Encoded name is yz__qrs__tuv + -- begin ... end Qrs; + + -- procedure Qrs (X: Integer) is -- Encoded name is yz__qrs__2 + -- procedure Tuv is ... end; -- Encoded name is yz__qrs__tuv + -- -- (not yz__qrs__2__tuv). + -- procedure Tuv (X: INTEGER) -- Encoded name is yz__qrs__tuv__2 + -- begin ... end Tuv; + + -- procedure Tuv (X: INTEGER) -- Encoded name is yz__qrs__tuv__3 + -- begin ... end Tuv; + -- begin ... end Qrs; + -- end Yz; + + -- This example also serves to illustrate, a case in which the + -- debugging data are currently ambiguous. The two parameterless + -- versions of Yz.Qrs.Tuv have the same encoded names in the + -- debugging data. However, the actual external symbols (which + -- linkers use to resolve references) will be modified with an + -- an additional suffix so that they do not clash. Thus, there will + -- be cases in which the name of a function shown in the debugging + -- data differs from that function's "official" external name, and + -- in which several different functions have exactly the same name + -- as far as the debugger is concerned. We don't consider this too + -- much of a problem, since the only way the user has of referring + -- to these functions by name is, in fact, Yz.Qrs.Tuv, so that the + -- reference is inherently ambiguous from the user's perspective, + -- regardless of internal encodings (in these cases, the debugger + -- can provide a menu of options to allow the user to disambiguate). + + -------------------- + -- Operator Names -- + -------------------- + + -- The above rules applied to operator names would result in names + -- with quotation marks, which are not typically allowed by assemblers + -- and linkers, and even if allowed would be odd and hard to deal with. + -- To avoid this problem, operator names are encoded as follows: + + -- Oabs abs + -- Oand and + -- Omod mod + -- Onot not + -- Oor or + -- Orem rem + -- Oxor xor + -- Oeq = + -- One /= + -- Olt < + -- Ole <= + -- Ogt > + -- Oge >= + -- Oadd + + -- Osubtract - + -- Oconcat & + -- Omultiply * + -- Odivide / + -- Oexpon ** + + -- These names are prefixed by the normal full qualification, and + -- suffixed by the overloading identification. So for example, the + -- second operator "=" defined in package Extra.Messages would + -- have the name: + + -- extra__messages__Oeq__2 + + ---------------------------------- + -- Resolving Other Name Clashes -- + ---------------------------------- + + -- It might be thought that the above scheme is complete, but in Ada 95, + -- full qualification is insufficient to uniquely identify an entity + -- in the program, even if it is not an overloaded subprogram. There + -- are two possible confusions: + + -- a.b + + -- interpretation 1: entity b in body of package a + -- interpretation 2: child procedure b of package a + + -- a.b.c + + -- interpretation 1: entity c in child package a.b + -- interpretation 2: entity c in nested package b in body of a + + -- It is perfectly valid in both cases for both interpretations to + -- be valid within a single program. This is a bit of a surprise since + -- certainly in Ada 83, full qualification was sufficient, but not in + -- Ada 95. The result is that the above scheme can result in duplicate + -- names. This would not be so bad if the effect were just restricted + -- to debugging information, but in fact in both the above cases, it + -- is possible for both symbols to be external names, and so we have + -- a real problem of name clashes. + + -- To deal with this situation, we provide two additional encoding + -- rules for names + + -- First: all library subprogram names are preceded by the string + -- _ada_ (which causes no duplications, since normal Ada names can + -- never start with an underscore. This not only solves the first + -- case of duplication, but also solves another pragmatic problem + -- which is that otherwise Ada procedures can generate names that + -- clash with existing system function names. Most notably, we can + -- have clashes in the case of procedure Main with the C main that + -- in some systems is always present. + + -- Second, for the case where nested packages declared in package + -- bodies can cause trouble, we add a suffix which shows which + -- entities in the list are body-nested packages, i.e. packages + -- whose spec is within a package body. The rules are as follows, + -- given a list of names in a qualified name name1.name2.... + + -- If none are body-nested package entities, then there is no suffix + + -- If at least one is a body-nested package entity, then the suffix + -- is X followed by a string of b's and n's (b = body-nested package + -- entity, n = not a body-nested package). + + -- There is one element in this string for each entity in the encoded + -- expanded name except the first (the rules are such that the first + -- entity of the encoded expanded name can never be a body-nested' + -- package. Trailing n's are omitted, as is the last b (there must + -- be at least one b, or we would not be generating a suffix at all). + + -- For example, suppose we have + + -- package x is + -- pragma Elaborate_Body; + -- m1 : integer; -- #1 + -- end x; + + -- package body x is + -- package y is m2 : integer; end y; -- #2 + -- package body y is + -- package z is r : integer; end z; -- #3 + -- end; + -- m3 : integer; -- #4 + -- end x; + + -- package x.y is + -- pragma Elaborate_Body; + -- m2 : integer; -- #5 + -- end x.y; + + -- package body x.y is + -- m3 : integer; -- #6 + -- procedure j is -- #7 + -- package k is + -- z : integer; -- #8 + -- end k; + -- begin + -- null; + -- end j; + -- end x.y; + + -- procedure x.m3 is begin null; end; -- #9 + + -- Then the encodings would be: + + -- #1. x__m1 (no BNPE's in sight) + -- #2. x__y__m2X (y is a BNPE) + -- #3. x__y__z__rXb (y is a BNPE, so is z) + -- #4. x__m3 (no BNPE's in sight) + -- #5. x__y__m2 (no BNPE's in sight) + -- #6. x__y__m3 (no BNPE's in signt) + -- #7. x__y__j (no BNPE's in sight) + -- #8. k__z (no BNPE's, only up to procedure) + -- #9 _ada_x__m3 (library level subprogram) + + -- Note that we have instances here of both kind of potential name + -- clashes, and the above examples show how the encodings avoid the + -- clash as follows: + + -- Lines #4 and #9 both refer to the entity x.m3, but #9 is a library + -- level subprogram, so it is preceded by the string _ada_ which acts + -- to distinguish it from the package body entity. + + -- Lines #2 and #5 both refer to the entity x.y.m2, but the first + -- instance is inside the body-nested package y, so there is an X + -- suffix to distinguish it from the child library entity. + + -- Note that enumeration literals never need Xb type suffixes, since + -- they are never referenced using global external names. + + --------------------- + -- Interface Names -- + --------------------- + + -- Note: if an interface name is present, then the external name + -- is taken from the specified interface name. Given the current + -- limitations of the gcc backend, this means that the debugging + -- name is also set to the interface name, but conceptually, it + -- would be possible (and indeed desirable) to have the debugging + -- information still use the Ada name as qualified above, so we + -- still fully qualify the name in the front end. + + ------------------------------------- + -- Encodings Related to Task Types -- + ------------------------------------- + + -- Each task object defined by a single task declaration is associated + -- with a prefix that is used to qualify procedures defined in that + -- task. Given + -- + -- package body P is + -- task body TaskObj is + -- procedure F1 is ... end; + -- begin + -- B; + -- end TaskObj; + -- end P; + -- + -- The name of subprogram TaskObj.F1 is encoded as p__taskobjTK__f1, + -- The body, B, is contained in a subprogram whose name is + -- p__taskobjTKB. + + ------------------------------------------ + -- Encodings Related to Protected Types -- + ------------------------------------------ + + -- Each protected type has an associated record type, that describes + -- the actual layout of the private data. In addition to the private + -- components of the type, the Corresponding_Record_Type includes one + -- component of type Protection, which is the actual lock structure. + -- The run-time size of the protected type is the size of the corres- + -- ponding record. + + -- For a protected type prot, the Corresponding_Record_Type is encoded + -- as protV. + + -- The operations of a protected type are encoded as follows: each + -- operation results in two subprograms, a locking one that is called + -- from outside of the object, and a non-locking one that is used for + -- calls from other operations on the same object. The locking operation + -- simply acquires the lock, and then calls the non-locking version. + -- The names of all of these have a prefix constructed from the name + -- of the name of the type, the string "PT", and a suffix which is P + -- or N, depending on whether this is the protected or non-locking + -- version of the operation. + + -- Given the declaration: + + -- protected type lock is + -- function get return integer; + -- procedure set (x: integer); + -- private + -- value : integer := 0; + -- end lock; + + -- the following operations are created: + + -- lockPT_getN + -- lockPT_getP, + -- lockPT_setN + -- lockPT_setP + + ---------------------------------------------------- + -- Conversion between Entities and External Names -- + ---------------------------------------------------- + + No_Dollar_In_Label : constant Boolean := Get_No_Dollar_In_Label; + -- True iff the target allows dollar signs ("$") in external names + + procedure Get_External_Name + (Entity : Entity_Id; + Has_Suffix : Boolean); + -- Set Name_Buffer and Name_Len to the external name of entity E. + -- The external name is the Interface_Name, if specified, unless + -- the entity has an address clause or a suffix. + -- + -- If the Interface is not present, or not used, the external name + -- is the concatenation of: + -- + -- - the string "_ada_", if the entity is a library subprogram, + -- - the names of any enclosing scopes, each followed by "__", + -- or "X_" if the next entity is a subunit) + -- - the name of the entity + -- - the string "$" (or "__" if target does not allow "$"), followed + -- by homonym number, if the entity is an overloaded subprogram + + procedure Get_External_Name_With_Suffix + (Entity : Entity_Id; + Suffix : String); + -- Set Name_Buffer and Name_Len to the external name of entity E. + -- If Suffix is the empty string the external name is as above, + -- otherwise the external name is the concatenation of: + -- + -- - the string "_ada_", if the entity is a library subprogram, + -- - the names of any enclosing scopes, each followed by "__", + -- or "X_" if the next entity is a subunit) + -- - the name of the entity + -- - the string "$" (or "__" if target does not allow "$"), followed + -- by homonym number, if the entity is an overloaded subprogram + -- - the string "___" followed by Suffix + + function Get_Entity_Id (External_Name : String) return Entity_Id; + -- Find entity in current compilation unit, which has the given + -- External_Name. + + ---------------------------- + -- Debug Name Compression -- + ---------------------------- + + -- The full qualification of names can lead to long names, and this + -- section describes the method used to compress these names. Such + -- compression is attempted if one of the following holds: + + -- The length exceeds a maximum set in hostparm, currently set + -- to 128, but can be changed as needed. + + -- The compiler switch -gnatC is set, setting the Compress_Debug_Names + -- switch in Opt to True. + + -- If either of these conditions holds, name compression is attempted + -- by replacing the qualifying section as follows. + + -- Given a name of the form + + -- a__b__c__d + + -- where a,b,c,d are arbitrary strings not containing a sequence + -- of exactly two underscores, the name is rewritten as: + + -- XC????????_d + + -- where ???????? are 8 hex digits representing a 32-bit checksum + -- value that identifies the sequence of compressed names. In + -- addition a dummy type declaration is generated as shown by + -- the following example. Supposed we have three compression + -- sequences + + -- XC1234abcd corresponding to a__b__c__ prefix + -- XCabcd1234 corresponding to a__b__ prefix + -- XCab1234cd corresponding to a__ prefix + + -- then an enumeration type declaration is generated: + + -- type XC is + -- (XC1234abcdXnn, aXnn, bXnn, cXnn, + -- XCabcd1234Xnn, aXnn, bXnn, + -- XCab1234cdXnn, aXnn); + + -- showing the meaning of each compressed prefix, so the debugger + -- can interpret the exact sequence of names that correspond to the + -- compressed sequence. The Xnn suffixes in the above are simply + -- serial numbers that are guaranteed to be different to ensure + -- that all names are unique, and are otherwise ignored. + + -------------------------------------------- + -- Subprograms for Handling Qualification -- + -------------------------------------------- + + procedure Qualify_Entity_Names (N : Node_Id); + -- Given a node N, that represents a block, subprogram body, or package + -- body or spec, or protected or task type, sets a fully qualified name + -- for the defining entity of given construct, and also sets fully + -- qualified names for all enclosed entities of the construct (using + -- First_Entity/Next_Entity). Note that the actual modifications of the + -- names is postponed till a subsequent call to Qualify_All_Entity_Names. + -- Note: this routine does not deal with prepending _ada_ to library + -- subprogram names. The reason for this is that we only prepend _ada_ + -- to the library entity itself, and not to names built from this name. + + procedure Qualify_All_Entity_Names; + -- When Qualify_Entity_Names is called, no actual name changes are made, + -- i.e. the actual calls to Qualify_Entity_Name are deferred until a call + -- is made to this procedure. The reason for this deferral is that when + -- names are changed semantic processing may be affected. By deferring + -- the changes till just before gigi is called, we avoid any concerns + -- about such effects. Gigi itself does not use the names except for + -- output of names for debugging purposes (which is why we are doing + -- the name changes in the first place. + + -- Note: the routines Get_Unqualified_[Decoded]_Name_String in Namet + -- are useful to remove qualification from a name qualified by the + -- call to Qualify_All_Entity_Names. + + procedure Generate_Auxiliary_Types; + -- The process of qualifying names may result in name compression which + -- requires dummy enumeration types to be generated. This subprogram + -- ensures that these types are appropriately included in the tree. + + -------------------------------- + -- Handling of Numeric Values -- + -------------------------------- + + -- All numeric values here are encoded as strings of decimal digits. + -- Only integer values need to be encoded. A negative value is encoded + -- as the corresponding positive value followed by a lower case m for + -- minus to indicate that the value is negative (e.g. 2m for -2). + + ------------------------- + -- Type Name Encodings -- + ------------------------- + + -- In the following typ is the name of the type as normally encoded by + -- the debugger rules, i.e. a non-qualified name, all in lower case, + -- with standard encoding of upper half and wide characters + + ------------------------ + -- Encapsulated Types -- + ------------------------ + + -- In some cases, the compiler encapsulates a type by wrapping it in + -- a structure. For example, this is used when a size or alignment + -- specification requires a larger type. Consider: + + -- type y is mod 2 ** 64; + -- for y'size use 256; + + -- In this case the compile generates a structure type y___PAD, which + -- has a single field whose name is F. This single field is 64 bits + -- long and contains the actual value. + + -- A similar encapsulation is done for some packed array types, + -- in which case the structure type is y___LJM and the field name + -- is OBJECT. + + -- When the debugger sees an object of a type whose name has a + -- suffix not otherwise mentioned in this specification, the type + -- is a record containing a single field, and the name of that field + -- is all upper-case letters, it should look inside to get the value + -- of the field, and neither the outer structure name, nor the + -- field name should appear when the value is printed. + + ----------------------- + -- Fixed-Point Types -- + ----------------------- + + -- Fixed-point types are encoded using a suffix that indicates the + -- delta and small values. The actual type itself is a normal + -- integer type. + + -- typ___XF_nn_dd + -- typ___XF_nn_dd_nn_dd + + -- The first form is used when small = delta. The value of delta (and + -- small) is given by the rational nn/dd, where nn and dd are decimal + -- integers. + -- + -- The second form is used if the small value is different from the + -- delta. In this case, the first nn/dd rational value is for delta, + -- and the second value is for small. + + ------------------------------ + -- VAX Floating-Point Types -- + ------------------------------ + + -- Vax floating-point types are represented at run time as integer + -- types, which are treated specially by the code generator. Their + -- type names are encoded with the following suffix: + + -- typ___XFF + -- typ___XFD + -- typ___XFG + + -- representing the Vax F Float, D Float, and G Float types. The + -- debugger must treat these specially. In particular, printing + -- these values can be achieved using the debug procedures that + -- are provided in package System.Vax_Float_Operations: + + -- procedure Debug_Output_D (Arg : D); + -- procedure Debug_Output_F (Arg : F); + -- procedure Debug_Output_G (Arg : G); + + -- These three procedures take a Vax floating-point argument, and + -- output a corresponding decimal representation to standard output + -- with no terminating line return. + + -------------------- + -- Discrete Types -- + -------------------- + + -- Discrete types are coded with a suffix indicating the range in + -- the case where one or both of the bounds are discriminants or + -- variable. + + -- Note: at the current time, we also encode static bounds if they + -- do not match the natural machine type bounds, but this may be + -- removed in the future, since it is redundant for most debugging + -- formats. However, we do not ever need XD encoding for enumeration + -- base types, since here it is always clear what the bounds are + -- from the number of enumeration literals, and of course we do + -- not need to encode the dummy XR types generated for renamings. + + -- typ___XD + -- typ___XDL_lowerbound + -- typ___XDU_upperbound + -- typ___XDLU_lowerbound__upperbound + + -- If a discrete type is a natural machine type (i.e. its bounds + -- correspond in a natural manner to its size), then it is left + -- unencoded. The above encoding forms are used when there is a + -- constrained range that does not correspond to the size or that + -- has discriminant references or other non-static bounds. + + -- The first form is used if both bounds are dynamic, in which case + -- two constant objects are present whose names are typ___L and + -- typ___U in the same scope as typ, and the values of these constants + -- indicate the bounds. As far as the debugger is concerned, these + -- are simply variables that can be accessed like any other variables. + -- In the enumeration case, these values correspond to the Enum_Rep + -- values for the lower and upper bounds. + + -- The second form is used if the upper bound is dynamic, but the + -- lower bound is either constant or depends on a discriminant of + -- the record with which the type is associated. The upper bound + -- is stored in a constant object of name typ___U as previously + -- described, but the lower bound is encoded directly into the + -- name as either a decimal integer, or as the discriminant name. + + -- The third form is similarly used if the lower bound is dynamic, + -- but the upper bound is static or a discriminant reference, in + -- which case the lower bound is stored in a constant object of + -- name typ___L, and the upper bound is encoded directly into the + -- name as either a decimal integer, or as the discriminant name. + + -- The fourth form is used if both bounds are discriminant references + -- or static values, with the encoding first for the lower bound, + -- then for the upper bound, as previously described. + + ------------------ + -- Biased Types -- + ------------------ + + -- Only discrete types can be biased, and the fact that they are + -- biased is indicated by a suffix of the form: + + -- typ___XB_lowerbound__upperbound + + -- Here lowerbound and upperbound are decimal integers, with the + -- usual (postfix "m") encoding for negative numbers. Biased + -- types are only possible where the bounds are static, and the + -- values are represented as unsigned offsets from the lower + -- bound given. For example: + + -- type Q is range 10 .. 15; + -- for Q'size use 3; + + -- The size clause will force values of type Q in memory to be + -- stored in biased form (e.g. 11 will be represented by the + -- bit pattern 001). + + ---------------------------------------------- + -- Record Types with Variable-Length Fields -- + ---------------------------------------------- + + -- The debugging formats do not fully support these types, and indeed + -- some formats simply generate no useful information at all for such + -- types. In order to provide information for the debugger, gigi creates + -- a parallel type in the same scope with one of the names + + -- type___XVE + -- type___XVU + + -- The former name is used for a record and the latter for the union + -- that is made for a variant record (see below) if that union has + -- variable size. These encodings suffix any other encodings that + -- might be suffixed to the type name. + + -- The idea here is to provide all the needed information to interpret + -- objects of the original type in the form of a "fixed up" type, which + -- is representable using the normal debugging information. + + -- There are three cases to be dealt with. First, some fields may have + -- variable positions because they appear after variable-length fields. + -- To deal with this, we encode *all* the field bit positions of the + -- special ___XV type in a non-standard manner. + + -- The idea is to encode not the position, but rather information + -- that allows computing the position of a field from the position + -- of the previous field. The algorithm for computing the actual + -- positions of all fields and the length of the record is as + -- follows. In this description, let P represent the current + -- bit position in the record. + + -- 1. Initialize P to 0. + + -- 2. For each field in the record, + + -- 2a. If an alignment is given (see below), then round P + -- up, if needed, to the next multiple of that alignment. + + -- 2b. If a bit position is given, then increment P by that + -- amount (that is, treat it as an offset from the end of the + -- preceding record). + + -- 2c. Assign P as the actual position of the field. + + -- 2d. Compute the length, L, of the represented field (see below) + -- and compute P'=P+L. Unless the field represents a variant part + -- (see below and also Variant Record Encoding), set P to P'. + + -- The alignment, if present, is encoded in the field name of the + -- record, which has a suffix: + + -- fieldname___XVAnn + + -- where the nn after the XVA indicates the alignment value in storage + -- units. This encoding is present only if an alignment is present. + + -- The size of the record described by an XVE-encoded type (in bits) + -- is generally the maximum value attained by P' in step 2d above, + -- rounded up according to the record's alignment. + + -- Second, the variable-length fields themselves are represented by + -- replacing the type by a special access type. The designated type + -- of this access type is the original variable-length type, and the + -- fact that this field has been transformed in this way is signalled + -- by encoding the field name as: + + -- field___XVL + + -- where field is the original field name. If a field is both + -- variable-length and also needs an alignment encoding, then the + -- encodings are combined using: + + -- field___XVLnn + + -- Note: the reason that we change the type is so that the resulting + -- type has no variable-length fields. At least some of the formats + -- used for debugging information simply cannot tolerate variable- + -- length fields, so the encoded information would get lost. + + -- Third, in the case of a variant record, the special union + -- that contains the variants is replaced by a normal C union. + -- In this case, the positions are all zero. + + -- As an example of this encoding, consider the declarations: + + -- type Q is array (1 .. V1) of Float; -- alignment 4 + -- type R is array (1 .. V2) of Long_Float; -- alignment 8 + + -- type X is record + -- A : Character; + -- B : Float; + -- C : String (1 .. V3); + -- D : Float; + -- E : Q; + -- F : R; + -- G : Float; + -- end record; + + -- The encoded type looks like: + + -- type anonymousQ is access Q; + -- type anonymousR is access R; + + -- type X___XVE is record + -- A : Character; -- position contains 0 + -- B : Float; -- position contains 24 + -- C___XVL : access String (1 .. V3); -- position contains 0 + -- D___XVA4 : Float; -- position contains 0 + -- E___XVL4 : anonymousQ; -- position contains 0 + -- F___XVL8 : anonymousR; -- position contains 0 + -- G : Float; -- position contains 0 + -- end record; + + -- Any bit sizes recorded for fields other than dynamic fields and + -- variants are honored as for ordinary records. + + -- Notes: + + -- 1) The B field could also have been encoded by using a position + -- of zero, and an alignment of 4, but in such a case, the coding by + -- position is preferred (since it takes up less space). We have used + -- the (illegal) notation access xxx as field types in the example + -- above. + + -- 2) The E field does not actually need the alignment indication + -- but this may not be detected in this case by the conversion + -- routines. + + -- All discriminants always appear before any variable-length + -- fields that depend on them. So they can be located independent + -- of the variable-length field, using the standard procedure for + -- computing positions described above. + + -- The size of the ___XVE or ___XVU record or union is set to the + -- alignment (in bytes) of the original object so that the debugger + -- can calculate the size of the original type. + + -- 3) Our conventions do not cover all XVE-encoded records in which + -- some, but not all, fields have representation clauses. Such + -- records may, therefore, be displayed incorrectly by debuggers. + -- This situation is not common. + + ----------------------- + -- Base Record Types -- + ----------------------- + + -- Under certain circumstances, debuggers need two descriptions + -- of a record type, one that gives the actual details of the + -- base type's structure (as described elsewhere in these + -- comments) and one that may be used to obtain information + -- about the particular subtype and the size of the objects + -- being typed. In such cases the compiler will substitute a + -- type whose name is typically compiler-generated and + -- irrelevant except as a key for obtaining the actual type. + -- Specifically, if this name is x, then we produce a record + -- type named x___XVS consisting of one field. The name of + -- this field is that of the actual type being encoded, which + -- we'll call y (the type of this single field is arbitrary). + -- Both x and y may have corresponding ___XVE types. + + -- The size of the objects typed as x should be obtained from + -- the structure of x (and x___XVE, if applicable) as for + -- ordinary types unless there is a variable named x___XVZ, which, + -- if present, will hold the the size (in bits) of x. + + -- The type x will either be a subtype of y (see also Subtypes + -- of Variant Records, below) or will contain no fields at + -- all. The layout, types, and positions of these fields will + -- be accurate, if present. (Currently, however, the GDB + -- debugger makes no use of x except to determine its size). + + -- Among other uses, XVS types are sometimes used to encode + -- unconstrained types. For example, given + -- + -- subtype Int is INTEGER range 0..10; + -- type T1 (N: Int := 0) is record + -- F1: String (1 .. N); + -- end record; + -- type AT1 is array (INTEGER range <>) of T1; + -- + -- the element type for AT1 might have a type defined as if it had + -- been written: + -- + -- type at1___C_PAD is record null; end record; + -- for at1___C_PAD'Size use 16 * 8; + -- + -- and there would also be + -- + -- type at1___C_PAD___XVS is record t1: Integer; end record; + -- type t1 is ... + -- + -- Had the subtype Int been dynamic: + -- + -- subtype Int is INTEGER range 0 .. M; -- M a variable + -- + -- Then the compiler would also generate a declaration whose effect + -- would be + -- + -- at1___C_PAD___XVZ: constant Integer := 32 + M * 8 + padding term; + -- + -- Not all unconstrained types are so encoded; the XVS + -- convention may be unnecessary for unconstrained types of + -- fixed size. However, this encoding is always necessary when + -- a subcomponent type (array element's type or record field's + -- type) is an unconstrained record type some of whose + -- components depend on discriminant values. + + ----------------- + -- Array Types -- + ----------------- + + -- Since there is no way for the debugger to obtain the index subtypes + -- for an array type, we produce a type that has the name of the + -- array type followed by "___XA" and is a record whose field names + -- are the names of the types for the bounds. The types of these + -- fields is an integer type which is meaningless. + + -- To conserve space, we do not produce this type unless one of + -- the index types is either an enumeration type, has a variable + -- upper bound, has a lower bound different from the constant 1, + -- is a biased type, or is wider than "sizetype". + + -- Given the full encoding of these types (see above description for + -- the encoding of discrete types), this means that all necessary + -- information for addressing arrays is available. In some + -- debugging formats, some or all of the bounds information may + -- be available redundantly, particularly in the fixed-point case, + -- but this information can in any case be ignored by the debugger. + + ---------------------------- + -- Note on Implicit Types -- + ---------------------------- + + -- The compiler creates implicit type names in many situations where + -- a type is present semantically, but no specific name is present. + -- For example: + + -- S : Integer range M .. N; + + -- Here the subtype of S is not integer, but rather an anonymous + -- subtype of Integer. Where possible, the compiler generates names + -- for such anonymous types that are related to the type from which + -- the subtype is obtained as follows: + + -- T name suffix + + -- where name is the name from which the subtype is obtained, using + -- lower case letters and underscores, and suffix starts with an upper + -- case letter. For example, the name for the above declaration of S + -- might be: + + -- TintegerS4b + + -- If the debugger is asked to give the type of an entity and the type + -- has the form T name suffix, it is probably appropriate to just use + -- "name" in the response since this is what is meaningful to the + -- programmer. + + ------------------------------------------------- + -- Subprograms for Handling Encoded Type Names -- + ------------------------------------------------- + + procedure Get_Encoded_Name (E : Entity_Id); + -- If the entity is a typename, store the external name of + -- the entity as in Get_External_Name, followed by three underscores + -- plus the type encoding in Name_Buffer with the length in Name_Len, + -- and an ASCII.NUL character stored following the name. + -- Otherwise set Name_Buffer and Name_Len to hold the entity name. + + -------------- + -- Renaming -- + -------------- + + -- Debugging information is generated for exception, object, package, + -- and subprogram renaming (generic renamings are not significant, since + -- generic templates are not relevant at debugging time). + + -- Consider a renaming declaration of the form + + -- x typ renames y; + + -- There is one case in which no special debugging information is required, + -- namely the case of an object renaming where the backend allocates a + -- reference for the renamed variable, and the entity x is this reference. + -- The debugger can handle this case without any special processing or + -- encoding (it won't know it was a renaming, but that does not matter). + + -- All other cases of renaming generate a dummy type definition for + -- an entity whose name is: + + -- x___XR for an object renaming + -- x___XRE for an exception renaming + -- x___XRP for a package renaming + + -- The name is fully qualified in the usual manner, i.e. qualified in + -- the same manner as the entity x would be. + + -- Note: subprogram renamings are not encoded at the present time. + + -- The type is an enumeration type with a single enumeration literal + -- that is an identifier which describes the renamed variable. + + -- For the simple entity case, where y is an entity name, + -- the enumeration is of the form: + + -- (y___XE) + + -- i.e. the enumeration type has a single field, whose name + -- matches the name y, with the XE suffix. The entity for this + -- enumeration literal is fully qualified in the usual manner. + -- All subprogram, exception, and package renamings fall into + -- this category, as well as simple object renamings. + + -- For the object renaming case where y is a selected component or an + -- indexed component, the literal name is suffixed by additional fields + -- that give details of the components. The name starts as above with + -- a y___XE entity indicating the outer level variable. Then a series + -- of selections and indexing operations can be specified as follows: + + -- Indexed component + + -- A series of subscript values appear in sequence, the number + -- corresponds to the number of dimensions of the array. The + -- subscripts have one of the following two forms: + + -- XSnnn + + -- Here nnn is a constant value, encoded as a decimal + -- integer (pos value for enumeration type case). Negative + -- values have a trailing 'm' as usual. + + -- XSe + + -- Here e is the (unqualified) name of a constant entity in + -- the same scope as the renaming which contains the subscript + -- value. + + -- Slice + + -- For the slice case, we have two entries. The first is for + -- the lower bound of the slice, and has the form + + -- XLnnn + -- XLe + + -- Specifies the lower bound, using exactly the same encoding + -- as for an XS subscript as described above. + + -- Then the upper bound appears in the usual XSnnn/XSe form + + -- Selected component + + -- For a selected component, we have a single entry + + -- XRf + + -- Here f is the field name for the selection + + -- For an explicit deference (.all), we have a single entry + + -- XA + + -- As an example, consider the declarations: + + -- package p is + -- type q is record + -- m : string (2 .. 5); + -- end record; + -- + -- type r is array (1 .. 10, 1 .. 20) of q; + -- + -- g : r; + -- + -- z : string renames g (1,5).m(2 ..3) + -- end p; + + -- The generated type definition would appear as + + -- type p__z___XR is + -- (p__g___XEXS1XS5XRmXL2XS3); + -- p__q___XE--------------------outer entity is g + -- XS1-----------------first subscript for g + -- XS5--------------second subscript for g + -- XRm-----------select field m + -- XL2--------lower bound of slice + -- XS3-----upper bound of slice + + function Debug_Renaming_Declaration (N : Node_Id) return Node_Id; + -- The argument N is a renaming declaration. The result is a type + -- declaration as described in the above paragraphs. If not special + -- debug declaration, than Empty is returned. + + --------------------------- + -- Packed Array Encoding -- + --------------------------- + + -- For every packed array, two types are created, and both appear in + -- the debugging output. + + -- The original declared array type is a perfectly normal array type, + -- and its index bounds indicate the original bounds of the array. + + -- The corresponding packed array type, which may be a modular type, or + -- may be an array of bytes type (see Exp_Pakd for full details). This + -- is the type that is actually used in the generated code and for + -- debugging information for all objects of the packed type. + + -- The name of the corresponding packed array type is: + + -- ttt___XPnnn + + -- where + -- ttt is the name of the original declared array + -- nnn is the component size in bits (1-31) + + -- When the debugger sees that an object is of a type that is encoded + -- in this manner, it can use the original type to determine the bounds, + -- and the component size to determine the packing details. + + -- Packed arrays are represented in tightly packed form, with no extra + -- bits between components. This is true even when the component size + -- is not a factor of the storage unit size, so that as a result it is + -- possible for components to cross storage unit boundaries. + + -- The layout in storage is identical, regardless of whether the + -- implementation type is a modular type or an array-of-bytes type. + -- See Exp_Pakd for details of how these implementation types are used, + -- but for the purpose of the debugger, only the starting address of + -- the object in memory is significant. + + -- The following example should show clearly how the packing works in + -- the little-endian and big-endian cases: + + -- type B is range 0 .. 7; + -- for B'Size use 3; + + -- type BA is array (0 .. 5) of B; + -- pragma Pack (BA); + + -- BV : constant BA := (1,2,3,4,5,6); + + -- Little endian case + + -- BV'Address + 2 BV'Address + 1 BV'Address + 0 + -- +-----------------+-----------------+-----------------+ + -- | 0 0 0 0 0 0 1 1 | 0 1 0 1 1 0 0 0 | 1 1 0 1 0 0 0 1 | + -- +-----------------+-----------------+-----------------+ + -- <---------> <-----> <---> <---> <-----> <---> <---> + -- unused bits BV(5) BV(4) BV(3) BV(2) BV(1) BV(0) + -- + -- Big endian case + -- + -- BV'Address + 0 BV'Address + 1 BV'Address + 2 + -- +-----------------+-----------------+-----------------+ + -- | 0 0 1 0 1 0 0 1 | 1 1 0 0 1 0 1 1 | 1 0 0 0 0 0 0 0 | + -- +-----------------+-----------------+-----------------+ + -- <---> <---> <-----> <---> <---> <-----> <---------> + -- BV(0) BV(1) BV(2) BV(3) BV(4) BV(5) unused bits + + ------------------------------------------------------ + -- Subprograms for Handling Packed Array Type Names -- + ------------------------------------------------------ + + function Make_Packed_Array_Type_Name + (Typ : Entity_Id; + Csize : Uint) + return Name_Id; + -- This function is used in Exp_Pakd to create the name that is encoded + -- as described above. The entity Typ provides the name ttt, and the + -- value Csize is the component size that provides the nnn value. + + -------------------------------------- + -- Pointers to Unconstrained Arrays -- + -------------------------------------- + + -- There are two kinds of pointers to arrays. The debugger can tell + -- which format is in use by the form of the type of the pointer. + + -- Fat Pointers + + -- Fat pointers are represented as a struct with two fields. This + -- struct has two distinguished field names: + + -- P_ARRAY is a pointer to the array type. The name of this + -- type is the unconstrained type followed by "___XUA". This + -- array will have bounds which are the discriminants, and + -- hence are unparsable, but will give the number of + -- subscripts and the component type. + + -- P_BOUNDS is a pointer to a struct, the name of whose type is the + -- unconstrained array name followed by "___XUB" and which has + -- fields of the form + + -- LBn (n a decimal integer) lower bound of n'th dimension + -- UBn (n a decimal integer) upper bound of n'th dimension + + -- The bounds may be any integral type. In the case of an + -- enumeration type, Enum_Rep values are used. + + -- The debugging information will sometimes reference an anonymous + -- fat pointer type. Such types are given the name xxx___XUP, where + -- xxx is the name of the designated type. If the debugger is asked + -- to output such a type name, the appropriate form is "access xxx". + + -- Thin Pointers + + -- Thin pointers are represented as a pointer to the ARRAY field of + -- a structure with two fields. The name of the structure type is + -- that of the unconstrained array followed by "___XUT". + + -- The field ARRAY contains the array value. This array field is + -- typically a variable-length array, and consequently the entire + -- record structure will be encoded as previously described, + -- resulting in a type with suffix "___XUT___XVE". + + -- The field BOUNDS is a struct containing the bounds as above. + + -------------------------------------- + -- Tagged Types and Type Extensions -- + -------------------------------------- + + -- A type C derived from a tagged type P has a field named "_parent" + -- of type P that contains its inherited fields. The type of this + -- field is usually P (encoded as usual if it has a dynamic size), + -- but may be a more distant ancestor, if P is a null extension of + -- that type. + + -- The type tag of a tagged type is a field named _tag, of type void*. + -- If the type is derived from another tagged type, its _tag field is + -- found in its _parent field. + + ----------------------------- + -- Variant Record Encoding -- + ----------------------------- + + -- The variant part of a variant record is encoded as a single field + -- in the enclosing record, whose name is: + + -- discrim___XVN + + -- where discrim is the unqualified name of the variant. This field name + -- is built by gigi (not by code in this unit). In the case of an + -- Unchecked_Union record, this discriminant will not appear in the + -- record, and the debugger must proceed accordingly (basically it + -- can treat this case as it would a C union). + + -- The type corresponding to this field has a name that is obtained + -- by concatenating the type name with the above string and is similar + -- to a C union, in which each member of the union corresponds to one + -- variant. However, unlike a C union, the size of the type may be + -- variable even if each of the components are fixed size, since it + -- includes a computation of which variant is present. In that case, + -- it will be encoded as above and a type with the suffix "___XVN___XVU" + -- will be present. + + -- The name of the union member is encoded to indicate the choices, and + -- is a string given by the following grammar: + + -- union_name ::= {choice} | others_choice + -- choice ::= simple_choice | range_choice + -- simple_choice ::= S number + -- range_choice ::= R number T number + -- number ::= {decimal_digit} [m] + -- others_choice ::= O (upper case letter O) + + -- The m in a number indicates a negative value. As an example of this + -- encoding scheme, the choice 1 .. 4 | 7 | -10 would be represented by + + -- R1T4S7S10m + + -- In the case of enumeration values, the values used are the + -- actual representation values in the case where an enumeration type + -- has an enumeration representation spec (i.e. they are values that + -- correspond to the use of the Enum_Rep attribute). + + -- The type of the inner record is given by the name of the union + -- type (as above) concatenated with the above string. Since that + -- type may itself be variable-sized, it may also be encoded as above + -- with a new type with a further suffix of "___XVU". + + -- As an example, consider: + + -- type Var (Disc : Boolean := True) is record + -- M : Integer; + + -- case Disc is + -- when True => + -- R : Integer; + -- S : Integer; + + -- when False => + -- T : Integer; + -- end case; + -- end record; + + -- V1 : Var; + + -- In this case, the type var is represented as a struct with three + -- fields, the first two are "disc" and "m", representing the values + -- of these record components. + + -- The third field is a union of two types, with field names S1 and O. + -- S1 is a struct with fields "r" and "s", and O is a struct with + -- fields "t". + + ------------------------------------------------ + -- Subprograms for Handling Variant Encodings -- + ------------------------------------------------ + + procedure Get_Variant_Encoding (V : Node_Id); + -- This procedure is called by Gigi with V being the variant node. + -- The corresponding encoding string is returned in Name_Buffer with + -- the length of the string in Name_Len, and an ASCII.NUL character + -- stored following the name. + + --------------------------------- + -- Subtypes of Variant Records -- + --------------------------------- + + -- A subtype of a variant record is represented by a type in which the + -- union field from the base type is replaced by one of the possible + -- values. For example, if we have: + + -- type Var (Disc : Boolean := True) is record + -- M : Integer; + + -- case Disc is + -- when True => + -- R : Integer; + -- S : Integer; + + -- when False => + -- T : Integer; + -- end case; + + -- end record; + -- V1 : Var; + -- V2 : Var (True); + -- V3 : Var (False); + + -- Here V2 for example is represented with a subtype whose name is + -- something like TvarS3b, which is a struct with three fields. The + -- first two fields are "disc" and "m" as for the base type, and + -- the third field is S1, which contains the fields "r" and "s". + + -- The debugger should simply ignore structs with names of the form + -- corresponding to variants, and consider the fields inside as + -- belonging to the containing record. + + ------------------------------------------- + -- Character literals in Character Types -- + ------------------------------------------- + + -- Character types are enumeration types at least one of whose + -- enumeration literals is a character literal. Enumeration literals + -- are usually simply represented using their identifier names. In + -- the case where an enumeration literal is a character literal, the + -- name aencoded as described in the following paragraph. + + -- A name QUhh, where each 'h' is a lower-case hexadecimal digit, + -- stands for a character whose Unicode encoding is hh, and + -- QWhhhh likewise stands for a wide character whose encoding + -- is hhhh. The representation values are encoded as for ordinary + -- enumeration literals (and have no necessary relationship to the + -- values encoded in the names). + + -- For example, given the type declaration + + -- type x is (A, 'C', B); + + -- the second enumeration literal would be named QU43 and the + -- value assigned to it would be 1. + + ------------------- + -- Modular Types -- + ------------------- + + -- A type declared + + -- type x is mod N; + + -- Is encoded as a subrange of an unsigned base type with lower bound + -- 0 and upper bound N. That is, there is no name encoding; we only use + -- the standard encodings provided by the debugging format. Thus, + -- we give these types a non-standard interpretation: the standard + -- interpretation of our encoding would not, in general, imply that + -- arithmetic on type x was to be performed modulo N (especially not + -- when N is not a power of 2). + + --------------------- + -- Context Clauses -- + --------------------- + + -- The SGI Workshop debugger requires a very peculiar and nonstandard + -- symbol name containing $ signs to be generated that records the + -- use clauses that are used in a unit. GDB does not use this name, + -- since it takes a different philsophy of universal use visibility, + -- with manual resolution of any ambiguities. + + -- The routines and data in this section are used to prepare this + -- specialized name, whose exact contents are described below. Gigi + -- will output this encoded name only in the SGI case (indeed, not + -- only is it useless on other targets, but hazardous, given the use + -- of the non-standard character $ rejected by many assemblers.) + + -- "Use" clauses are encoded as follows: + + -- _LSS__ prefix for clauses in a subprogram spec + -- _LSB__ prefix for clauses in a subprogram body + -- _LPS__ prefix for clauses in a package spec + -- _LPB__ prefix for clauses in a package body + + -- Following the prefix is the fully qualified filename, followed by + -- '$' separated names of fully qualified units in the "use" clause. + -- If a unit appears in both the spec and the body "use" clause, it + -- will appear once in the _L[SP]S__ encoding and twice in the _L[SP]B__ + -- encoding. The encoding appears as a global symbol in the object file. + + ------------------------------------------------------------------------ + -- Subprograms and Declarations for Handling Context Clause Encodings -- + ------------------------------------------------------------------------ + + procedure Save_Unitname_And_Use_List + (Main_Unit_Node : Node_Id; + Main_Kind : Node_Kind); + -- Creates a string containing the current compilation unit name + -- and a dollar sign delimited list of packages named in a Use_Package + -- clause for the compilation unit. Needed for the SGI debugger. The + -- procedure is called unconditionally to set the variables declared + -- below, then gigi decides whether or not to use the values. + + -- The following variables are used for communication between the front + -- end and the debugging output routines in Gigi. + + type Char_Ptr is access all Character; + pragma Convention (C, Char_Ptr); + -- Character pointers accessed from C + + Spec_Context_List, Body_Context_List : Char_Ptr; + -- List of use package clauses for spec and body, respectively, as + -- built by the call to Save_Unitname_And_Use_List. Used by gigi if + -- these strings are to be output. + + Spec_Filename, Body_Filename : Char_Ptr; + -- Filenames for the spec and body, respectively, as built by the + -- call to Save_Unitname_And_Use_List. Used by gigi if these strings + -- are to be output. + +end Exp_Dbug; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb new file mode 100644 index 00000000000..bdddde4a289 --- /dev/null +++ b/gcc/ada/exp_disp.adb @@ -0,0 +1,1278 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.79 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Itypes; use Itypes; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Disp; use Sem_Disp; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Disp is + + Ada_Actions : constant array (DT_Access_Action) of RE_Id := + (CW_Membership => RE_CW_Membership, + DT_Entry_Size => RE_DT_Entry_Size, + DT_Prologue_Size => RE_DT_Prologue_Size, + Get_Expanded_Name => RE_Get_Expanded_Name, + Get_External_Tag => RE_Get_External_Tag, + Get_Prim_Op_Address => RE_Get_Prim_Op_Address, + Get_RC_Offset => RE_Get_RC_Offset, + Get_Remotely_Callable => RE_Get_Remotely_Callable, + Get_TSD => RE_Get_TSD, + Inherit_DT => RE_Inherit_DT, + Inherit_TSD => RE_Inherit_TSD, + Register_Tag => RE_Register_Tag, + Set_Expanded_Name => RE_Set_Expanded_Name, + Set_External_Tag => RE_Set_External_Tag, + Set_Prim_Op_Address => RE_Set_Prim_Op_Address, + Set_RC_Offset => RE_Set_RC_Offset, + Set_Remotely_Callable => RE_Set_Remotely_Callable, + Set_TSD => RE_Set_TSD, + TSD_Entry_Size => RE_TSD_Entry_Size, + TSD_Prologue_Size => RE_TSD_Prologue_Size); + + CPP_Actions : constant array (DT_Access_Action) of RE_Id := + (CW_Membership => RE_CPP_CW_Membership, + DT_Entry_Size => RE_CPP_DT_Entry_Size, + DT_Prologue_Size => RE_CPP_DT_Prologue_Size, + Get_Expanded_Name => RE_CPP_Get_Expanded_Name, + Get_External_Tag => RE_CPP_Get_External_Tag, + Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address, + Get_RC_Offset => RE_CPP_Get_RC_Offset, + Get_Remotely_Callable => RE_CPP_Get_Remotely_Callable, + Get_TSD => RE_CPP_Get_TSD, + Inherit_DT => RE_CPP_Inherit_DT, + Inherit_TSD => RE_CPP_Inherit_TSD, + Register_Tag => RE_CPP_Register_Tag, + Set_Expanded_Name => RE_CPP_Set_Expanded_Name, + Set_External_Tag => RE_CPP_Set_External_Tag, + Set_Prim_Op_Address => RE_CPP_Set_Prim_Op_Address, + Set_RC_Offset => RE_CPP_Set_RC_Offset, + Set_Remotely_Callable => RE_CPP_Set_Remotely_Callable, + Set_TSD => RE_CPP_Set_TSD, + TSD_Entry_Size => RE_CPP_TSD_Entry_Size, + TSD_Prologue_Size => RE_CPP_TSD_Prologue_Size); + + Action_Is_Proc : constant array (DT_Access_Action) of Boolean := + (CW_Membership => False, + DT_Entry_Size => False, + DT_Prologue_Size => False, + Get_Expanded_Name => False, + Get_External_Tag => False, + Get_Prim_Op_Address => False, + Get_Remotely_Callable => False, + Get_RC_Offset => False, + Get_TSD => False, + Inherit_DT => True, + Inherit_TSD => True, + Register_Tag => True, + Set_Expanded_Name => True, + Set_External_Tag => True, + Set_Prim_Op_Address => True, + Set_RC_Offset => True, + Set_Remotely_Callable => True, + Set_TSD => True, + TSD_Entry_Size => False, + TSD_Prologue_Size => False); + + Action_Nb_Arg : constant array (DT_Access_Action) of Int := + (CW_Membership => 2, + DT_Entry_Size => 0, + DT_Prologue_Size => 0, + Get_Expanded_Name => 1, + Get_External_Tag => 1, + Get_Prim_Op_Address => 2, + Get_RC_Offset => 1, + Get_Remotely_Callable => 1, + Get_TSD => 1, + Inherit_DT => 3, + Inherit_TSD => 2, + Register_Tag => 1, + Set_Expanded_Name => 2, + Set_External_Tag => 2, + Set_Prim_Op_Address => 3, + Set_RC_Offset => 2, + Set_Remotely_Callable => 2, + Set_TSD => 2, + TSD_Entry_Size => 0, + TSD_Prologue_Size => 0); + + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; + -- Check if the type has a private view or if the public view appears + -- in the visible part of a package spec. + + -------------------------- + -- Expand_Dispatch_Call -- + -------------------------- + + procedure Expand_Dispatch_Call (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + Call_Typ : constant Entity_Id := Etype (Call_Node); + + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); + Param_List : constant List_Id := Parameter_Associations (Call_Node); + Subp : Entity_Id := Entity (Name (Call_Node)); + + CW_Typ : Entity_Id; + New_Call : Node_Id; + New_Call_Name : Node_Id; + New_Params : List_Id := No_List; + Param : Node_Id; + Res_Typ : Entity_Id; + Subp_Ptr_Typ : Entity_Id; + Subp_Typ : Entity_Id; + Typ : Entity_Id; + Eq_Prim_Op : Entity_Id := Empty; + + function New_Value (From : Node_Id) return Node_Id; + -- From is the original Expression. New_Value is equivalent to + -- Duplicate_Subexpr with an explicit dereference when From is an + -- access parameter + + function New_Value (From : Node_Id) return Node_Id is + Res : constant Node_Id := Duplicate_Subexpr (From); + + begin + if Is_Access_Type (Etype (From)) then + return Make_Explicit_Dereference (Sloc (From), Res); + else + return Res; + end if; + end New_Value; + + -- Start of processing for Expand_Dispatch_Call + + begin + -- If this is an inherited operation that was overriden, the body + -- that is being called is its alias. + + if Present (Alias (Subp)) + and then Is_Inherited_Operation (Subp) + and then No (DTC_Entity (Subp)) + then + Subp := Alias (Subp); + end if; + + -- Expand_Dispatch is called directly from the semantics, so we need + -- a check to see whether expansion is active before proceeding + + if not Expander_Active then + return; + end if; + + -- Definition of the ClassWide Type and the Tagged type + + if Is_Access_Type (Etype (Ctrl_Arg)) then + CW_Typ := Designated_Type (Etype (Ctrl_Arg)); + else + CW_Typ := Etype (Ctrl_Arg); + end if; + + Typ := Root_Type (CW_Typ); + + if not Is_Limited_Type (Typ) then + Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); + end if; + + if Is_CPP_Class (Root_Type (Typ)) then + + -- Create a new parameter list with the displaced 'this' + + New_Params := New_List; + Param := First_Actual (Call_Node); + while Present (Param) loop + + -- We assume that dispatching through the main dispatch table + -- (referenced by Tag_Component) doesn't require a displacement + -- so the expansion below is only done when dispatching on + -- another vtable pointer, in which case the first argument + -- is expanded into : + + -- typ!(Displaced_This (Address!(Param))) + + if Param = Ctrl_Arg + and then DTC_Entity (Subp) /= Tag_Component (Typ) + then + Append_To (New_Params, + + Unchecked_Convert_To (Etype (Param), + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displaced_This), Loc), + Parameter_Associations => New_List ( + + -- Current_This + + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Address), Loc), + Expression => Relocate_Node (Param)), + + -- Vptr + + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Ctrl_Arg), + Selector_Name => + New_Reference_To (DTC_Entity (Subp), Loc)), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Subp)))))); + + else + Append_To (New_Params, Relocate_Node (Param)); + end if; + + Next_Actual (Param); + end loop; + + elsif Present (Param_List) then + + -- Generate the Tag checks when appropriate + + New_Params := New_List; + + Param := First_Actual (Call_Node); + while Present (Param) loop + + -- No tag check with itself + + if Param = Ctrl_Arg then + Append_To (New_Params, Duplicate_Subexpr (Param)); + + -- No tag check for parameter whose type is neither tagged nor + -- access to tagged (for access parameters) + + elsif No (Find_Controlling_Arg (Param)) then + Append_To (New_Params, Relocate_Node (Param)); + + -- No tag check for function dispatching on result it the + -- Tag given by the context is this one + + elsif Find_Controlling_Arg (Param) = Ctrl_Arg then + Append_To (New_Params, Relocate_Node (Param)); + + -- "=" is the only dispatching operation allowed to get + -- operands with incompatible tags (it just returns false). + -- We use Duplicate_subexpr instead of relocate_node because + -- the value will be duplicated to check the tags. + + elsif Subp = Eq_Prim_Op then + Append_To (New_Params, Duplicate_Subexpr (Param)); + + -- No check in presence of suppress flags + + elsif Tag_Checks_Suppressed (Etype (Param)) + or else (Is_Access_Type (Etype (Param)) + and then Tag_Checks_Suppressed + (Designated_Type (Etype (Param)))) + then + Append_To (New_Params, Relocate_Node (Param)); + + -- Optimization: no tag checks if the parameters are identical + + elsif Is_Entity_Name (Param) + and then Is_Entity_Name (Ctrl_Arg) + and then Entity (Param) = Entity (Ctrl_Arg) + then + Append_To (New_Params, Relocate_Node (Param)); + + -- Now we need to generate the Tag check + + else + -- Generate code for tag equality check + -- Perhaps should have Checks.Apply_Tag_Equality_Check??? + + Insert_Action (Ctrl_Arg, + Make_Implicit_If_Statement (Call_Node, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Ctrl_Arg), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, New_Value (Param)), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc))), + + Then_Statements => + New_List (New_Constraint_Error (Loc)))); + + Append_To (New_Params, Relocate_Node (Param)); + end if; + + Next_Actual (Param); + end loop; + end if; + + -- Generate the appropriate subprogram pointer type + + if Etype (Subp) = Typ then + Res_Typ := CW_Typ; + else + Res_Typ := Etype (Subp); + end if; + + Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); + Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); + Set_Etype (Subp_Typ, Res_Typ); + Init_Size_Align (Subp_Ptr_Typ); + Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + + -- Create a new list of parameters which is a copy of the old formal + -- list including the creation of a new set of matching entities. + + declare + Old_Formal : Entity_Id := First_Formal (Subp); + New_Formal : Entity_Id; + Extra : Entity_Id; + + begin + if Present (Old_Formal) then + New_Formal := New_Copy (Old_Formal); + Set_First_Entity (Subp_Typ, New_Formal); + Param := First_Actual (Call_Node); + + loop + Set_Scope (New_Formal, Subp_Typ); + + -- Change all the controlling argument types to be class-wide + -- to avoid a recursion in dispatching + + if Is_Controlling_Actual (Param) then + Set_Etype (New_Formal, Etype (Param)); + end if; + + if Is_Itype (Etype (New_Formal)) then + Extra := New_Copy (Etype (New_Formal)); + + if Ekind (Extra) = E_Record_Subtype + or else Ekind (Extra) = E_Class_Wide_Subtype + then + Set_Cloned_Subtype (Extra, Etype (New_Formal)); + end if; + + Set_Etype (New_Formal, Extra); + Set_Scope (Etype (New_Formal), Subp_Typ); + end if; + + Extra := New_Formal; + Next_Formal (Old_Formal); + exit when No (Old_Formal); + + Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); + Next_Entity (New_Formal); + Next_Actual (Param); + end loop; + Set_Last_Entity (Subp_Typ, Extra); + + -- Copy extra formals + + New_Formal := First_Entity (Subp_Typ); + while Present (New_Formal) loop + if Present (Extra_Constrained (New_Formal)) then + Set_Extra_Formal (Extra, + New_Copy (Extra_Constrained (New_Formal))); + Extra := Extra_Formal (Extra); + Set_Extra_Constrained (New_Formal, Extra); + + elsif Present (Extra_Accessibility (New_Formal)) then + Set_Extra_Formal (Extra, + New_Copy (Extra_Accessibility (New_Formal))); + Extra := Extra_Formal (Extra); + Set_Extra_Accessibility (New_Formal, Extra); + end if; + + Next_Formal (New_Formal); + end loop; + end if; + end; + + Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); + Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); + + -- Generate: + -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); + + New_Call_Name := + Unchecked_Convert_To (Subp_Ptr_Typ, + Make_DT_Access_Action (Typ, + Action => Get_Prim_Op_Address, + Args => New_List ( + + -- Vptr + + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Ctrl_Arg), + Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Subp))))); + + if Nkind (Call_Node) = N_Function_Call then + New_Call := + Make_Function_Call (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); + + -- if this is a dispatching "=", we must first compare the tags so + -- we generate: x.tag = y.tag and then x = y + + if Subp = Eq_Prim_Op then + + Param := First_Actual (Call_Node); + New_Call := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc))), + + Right_Opnd => New_Call); + end if; + + else + New_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); + end if; + + Rewrite (Call_Node, New_Call); + Analyze_And_Resolve (Call_Node, Call_Typ); + end Expand_Dispatch_Call; + + ------------- + -- Fill_DT -- + ------------- + + function Fill_DT_Entry + (Loc : Source_Ptr; + Prim : Entity_Id) + return Node_Id + is + Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); + DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ); + + begin + return + Make_DT_Access_Action (Typ, + Action => Set_Prim_Op_Address, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + + Make_Integer_Literal (Loc, DT_Position (Prim)), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + end Fill_DT_Entry; + + --------------------------- + -- Get_Remotely_Callable -- + --------------------------- + + function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Obj); + + begin + return Make_DT_Access_Action + (Typ => Etype (Obj), + Action => Get_Remotely_Callable, + Args => New_List ( + Make_Selected_Component (Loc, + Prefix => Obj, + Selector_Name => Make_Identifier (Loc, Name_uTag)))); + end Get_Remotely_Callable; + + ------------- + -- Make_DT -- + ------------- + + function Make_DT (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + + Result : constant List_Id := New_List; + Elab_Code : constant List_Id := New_List; + + Tname : constant Name_Id := Chars (Typ); + Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); + Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); + Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); + Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); + Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); + + DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); + DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); + TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); + Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); + No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); + + I_Depth : Int; + Generalized_Tag : Entity_Id; + Size_Expr_Node : Node_Id; + Old_Tag : Node_Id; + Old_TSD : Node_Id; + + begin + if Is_CPP_Class (Root_Type (Typ)) then + Generalized_Tag := RTE (RE_Vtable_Ptr); + else + Generalized_Tag := RTE (RE_Tag); + end if; + + -- Dispatch table and related entities are allocated statically + + Set_Ekind (DT, E_Variable); + Set_Is_Statically_Allocated (DT); + + Set_Ekind (DT_Ptr, E_Variable); + Set_Is_Statically_Allocated (DT_Ptr); + + Set_Ekind (TSD, E_Variable); + Set_Is_Statically_Allocated (TSD); + + Set_Ekind (Exname, E_Variable); + Set_Is_Statically_Allocated (Exname); + + Set_Ekind (No_Reg, E_Variable); + Set_Is_Statically_Allocated (No_Reg); + + -- Generate code to create the storage for the Dispatch_Table object: + + -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); + -- for DT'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), + Right_Opnd => + Make_Integer_Literal (Loc, + DT_Entry_Count (Tag_Component (Typ))))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Generate code to create the pointer to the dispatch table + + -- DT_Ptr : Tag := Tag!(DT'Address); Ada case + -- or + -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (Generalized_Tag, Loc), + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (DT, Loc), + Attribute_Name => Name_Address)))); + + -- Generate code to define the boolean that controls registration, in + -- order to avoid multiple registrations for tagged types defined in + -- multiple-called scopes + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => No_Reg, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_True, Loc))); + + -- Set Access_Disp_Table field to be the dispatch table pointer + + Set_Access_Disp_Table (Typ, DT_Ptr); + + -- Count ancestors to compute the inheritance depth. For private + -- extensions, always go to the full view in order to compute the real + -- inheritance depth. + + declare + Parent_Type : Entity_Id := Typ; + P : Entity_Id; + + begin + I_Depth := 0; + + loop + P := Etype (Parent_Type); + + if Is_Private_Type (P) then + P := Full_View (Base_Type (P)); + end if; + + exit when P = Parent_Type; + + I_Depth := I_Depth + 1; + Parent_Type := P; + end loop; + end; + + -- Generate code to create the storage for the type specific data object + + -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size); + -- for TSD'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), + Right_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 1), + Right_Opnd => + Make_Integer_Literal (Loc, I_Depth)))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => TSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (TSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Generate code to put the Address of the TSD in the dispatch table + -- Set_TSD (DT_Ptr, TSD); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_TSD, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Address)))); + + if Typ = Etype (Typ) + or else Is_CPP_Class (Etype (Typ)) + then + Old_Tag := + Unchecked_Convert_To (Generalized_Tag, + Make_Integer_Literal (Loc, 0)); + + Old_TSD := + Unchecked_Convert_To (RTE (RE_Address), + Make_Integer_Literal (Loc, 0)); + + else + Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc); + Old_TSD := + Make_DT_Access_Action (Typ, + Action => Get_TSD, + Args => New_List ( + New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc))); + end if; + + -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count (Tag_Component (Etype (Typ))))))); + + -- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_TSD, + Args => New_List ( + Node1 => Old_TSD, + Node2 => New_Reference_To (DT_Ptr, Loc)))); + + -- Generate: Exname : constant String := full_qualified_name (typ); + -- The type itself may be an anonymous parent type, so use the first + -- subtype to have a user-recognizable name. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Full_Qualified_Name (First_Subtype (Typ))))); + + -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Expanded_Name, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + -- for types with no controlled components + -- Generate: Set_RC_Offset (DT_Ptr, 0); + -- for simple types with controlled components + -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position); + -- for complex types with controlled components where the position + -- of the record controller + -- Generate: Set_RC_Offset (DT_Ptr, -1); + + declare + Position : Node_Id; + + begin + if not Has_Controlled_Component (Typ) then + Position := Make_Integer_Literal (Loc, 0); + + elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then + Position := Make_Integer_Literal (Loc, -1); + + else + Position := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Typ, Loc), + Selector_Name => + New_Reference_To (Controller_Component (Typ), Loc)), + Attribute_Name => Name_Position); + + -- This is not proper Ada code to use the attribute component + -- on something else than an object but this is supported by + -- the back end (see comment on the Bit_Component attribute in + -- sem_attr). So we avoid semantic checking here. + + Set_Analyzed (Position); + Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); + Set_Etype (Prefix (Prefix (Position)), Typ); + Set_Etype (Selector_Name (Prefix (Position)), + RTE (RE_Record_Controller)); + Set_Etype (Position, RTE (RE_Storage_Offset)); + + end if; + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_RC_Offset, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Position))); + end; + + -- Generate: Set_Remotely_Callable (DT_Ptr, status); + -- where status is described in E.4 (18) + + declare + Status : Entity_Id; + + begin + if Is_Pure (Typ) + or else Is_Shared_Passive (Typ) + or else + ((Is_Remote_Types (Typ) or else Is_Remote_Call_Interface (Typ)) + and then Original_View_In_Visible_Part (Typ)) + or else not Comes_From_Source (Typ) + then + Status := Standard_True; + else + Status := Standard_False; + end if; + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Remotely_Callable, + Args => New_List ( + New_Occurrence_Of (DT_Ptr, Loc), + New_Occurrence_Of (Status, Loc)))); + end; + + -- Generate: Set_External_Tag (DT_Ptr, exname'Address); + -- Should be the external name not the qualified name??? + + if not Has_External_Tag_Rep_Clause (Typ) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_External_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + -- Generate code to register the Tag in the External_Tag hash + -- table for the pure Ada type only. We skip this in No_Run_Time + -- mode where the External_Tag attribute is not allowed anyway. + + -- Register_Tag (Dt_Ptr); + + if Is_RTE (Generalized_Tag, RE_Tag) + and then not No_Run_Time + then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => + New_List (New_Reference_To (DT_Ptr, Loc)))); + end if; + end if; + + -- Generate: + -- if No_Reg then + -- <elab_code> + -- No_Reg := False; + -- end if; + + Append_To (Elab_Code, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (No_Reg, Loc), + Expression => New_Reference_To (Standard_False, Loc))); + + Append_To (Result, + Make_Implicit_If_Statement (Typ, + Condition => New_Reference_To (No_Reg, Loc), + Then_Statements => Elab_Code)); + + return Result; + end Make_DT; + + --------------------------- + -- Make_DT_Access_Action -- + --------------------------- + + function Make_DT_Access_Action + (Typ : Entity_Id; + Action : DT_Access_Action; + Args : List_Id) + return Node_Id + is + Action_Name : Entity_Id; + Loc : Source_Ptr; + + begin + if Is_CPP_Class (Root_Type (Typ)) then + Action_Name := RTE (CPP_Actions (Action)); + else + Action_Name := RTE (Ada_Actions (Action)); + end if; + + if No (Args) then + + -- This is a constant + + return New_Reference_To (Action_Name, Sloc (Typ)); + end if; + + pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); + + Loc := Sloc (First (Args)); + + if Action_Is_Proc (Action) then + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Action_Name, Loc), + Parameter_Associations => Args); + + else + return + Make_Function_Call (Loc, + Name => New_Reference_To (Action_Name, Loc), + Parameter_Associations => Args); + end if; + end Make_DT_Access_Action; + + ----------------------------------- + -- Original_View_In_Visible_Part -- + ----------------------------------- + + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is + Scop : constant Entity_Id := Scope (Typ); + + begin + -- The scope must be a package + + if Ekind (Scop) /= E_Package + and then Ekind (Scop) /= E_Generic_Package + then + return False; + end if; + + -- A type with a private declaration has a private view declared in + -- the visible part. + + if Has_Private_Declaration (Typ) then + return True; + end if; + + return List_Containing (Parent (Typ)) = + Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); + end Original_View_In_Visible_Part; + + ------------------------- + -- Set_All_DT_Position -- + ------------------------- + + procedure Set_All_DT_Position (Typ : Entity_Id) is + Parent_Typ : constant Entity_Id := Etype (Typ); + Root_Typ : constant Entity_Id := Root_Type (Typ); + First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); + The_Tag : constant Entity_Id := Tag_Component (Typ); + Adjusted : Boolean := False; + Finalized : Boolean := False; + Parent_EC : Int; + Nb_Prim : Int; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + + -- Get Entry_Count of the parent + + if Parent_Typ /= Typ + and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint + then + Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ))); + else + Parent_EC := 0; + end if; + + -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable + -- give a coherent set of information + + if Is_CPP_Class (Root_Typ) then + + -- Compute the number of primitive operations in the main Vtable + -- Set their position: + -- - where it was set if overriden or inherited + -- - after the end of the parent vtable otherwise + + Prim_Elmt := First_Prim; + Nb_Prim := 0; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if not Is_CPP_Class (Typ) then + Set_DTC_Entity (Prim, The_Tag); + + elsif Present (Alias (Prim)) then + Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim))); + Set_DT_Position (Prim, DT_Position (Alias (Prim))); + + elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then + Error_Msg_NE ("is a primitive operation of&," & + " pragma Cpp_Virtual required", Prim, Typ); + end if; + + if DTC_Entity (Prim) = The_Tag then + + -- Get the slot from the parent subprogram if any + + declare + H : Entity_Id := Homonym (Prim); + + begin + while Present (H) loop + if Present (DTC_Entity (H)) + and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ + then + Set_DT_Position (Prim, DT_Position (H)); + exit; + end if; + + H := Homonym (H); + end loop; + end; + + -- Otherwise take the canonical slot after the end of the + -- parent Vtable + + if DT_Position (Prim) = No_Uint then + Nb_Prim := Nb_Prim + 1; + Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim)); + + elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then + Nb_Prim := Nb_Prim + 1; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Check that the declared size of the Vtable is bigger or equal + -- than the number of primitive operations (if bigger it means that + -- some of the c++ virtual functions were not imported, that is + -- allowed) + + if DT_Entry_Count (The_Tag) = No_Uint + or else not Is_CPP_Class (Typ) + then + Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim)); + + elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then + Error_Msg_N ("not enough room in the Vtable for all virtual" + & " functions", The_Tag); + end if; + + -- Check that Positions are not duplicate nor outside the range of + -- the Vtable + + declare + Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag)); + Pos : Int; + Prim_Pos_Table : array (1 .. Size) of Entity_Id := + (others => Empty); + + begin + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if DTC_Entity (Prim) = The_Tag then + Pos := UI_To_Int (DT_Position (Prim)); + + if Pos not in Prim_Pos_Table'Range then + Error_Msg_N + ("position not in range of virtual table", Prim); + + elsif Present (Prim_Pos_Table (Pos)) then + Error_Msg_NE ("cannot be at the same position in the" + & " vtable than&", Prim, Prim_Pos_Table (Pos)); + + else + Prim_Pos_Table (Pos) := Prim; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + + -- For regular Ada tagged types, just set the DT_Position for + -- each primitive operation. Perform some sanity checks to avoid + -- to build completely inconsistant dispatch tables. + + else + + Nb_Prim := 0; + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Nb_Prim := Nb_Prim + 1; + Prim := Node (Prim_Elmt); + Set_DTC_Entity (Prim, The_Tag); + Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); + + if Chars (Prim) = Name_Finalize + and then (Is_Predefined_File_Name + (Unit_File_Name (Current_Sem_Unit)) + or else + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Prim)))) + then + Finalized := True; + end if; + + if Chars (Prim) = Name_Adjust then + Adjusted := True; + end if; + + -- An abstract operation cannot be declared in the private part + -- for a visible abstract type, because it could never be over- + -- ridden. For explicit declarations this is checked at the point + -- of declaration, but for inherited operations it must be done + -- when building the dispatch table. Input is excluded because + -- Limited_Controlled inherits a useless Input stream operation + -- from Root_Controlled, which cannot be overridden. + + if Is_Abstract (Typ) + and then Is_Abstract (Prim) + and then Present (Alias (Prim)) + and then Is_Derived_Type (Typ) + and then In_Private_Part (Current_Scope) + and then List_Containing (Parent (Prim)) + = Private_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) + and then Original_View_In_Visible_Part (Typ) + and then Chars (Prim) /= Name_uInput + then + Error_Msg_NE ("abstract inherited private operation&" + & " must be overriden", Parent (Typ), Prim); + end if; + Next_Elmt (Prim_Elmt); + end loop; + + if Is_Controlled (Typ) then + if not Finalized then + Error_Msg_N + ("controlled type has no explicit Finalize method?", Typ); + + elsif not Adjusted then + Error_Msg_N + ("controlled type has no explicit Adjust method?", Typ); + end if; + end if; + + Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim)); + + -- The derived type must have at least as many components than + -- its parent (for root types, the etype points back to itself + -- and the test should not fail) + + pragma Assert ( + DT_Entry_Count (The_Tag) >= + DT_Entry_Count (Tag_Component (Parent_Typ))); + end if; + end Set_All_DT_Position; + + ----------------------------- + -- Set_Default_Constructor -- + ----------------------------- + + procedure Set_Default_Constructor (Typ : Entity_Id) is + Loc : Source_Ptr; + Init : Entity_Id; + Param : Entity_Id; + Decl : Node_Id; + E : Entity_Id; + + begin + -- Look for the default constructor entity. For now only the + -- default constructor has the flag Is_Constructor. + + E := Next_Entity (Typ); + while Present (E) + and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) + loop + Next_Entity (E); + end loop; + + -- Create the init procedure + + if Present (E) then + Loc := Sloc (E); + Init := Make_Defining_Identifier (Loc, Name_uInit_Proc); + Param := Make_Defining_Identifier (Loc, Name_X); + Decl := + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Init, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Param, + Parameter_Type => New_Reference_To (Typ, Loc))))); + + Set_Init_Proc (Typ, Init); + Set_Is_Imported (Init); + Set_Interface_Name (Init, Interface_Name (E)); + Set_Convention (Init, Convention_C); + Set_Is_Public (Init); + Set_Has_Completion (Init); + + -- if there are no constructors, mark the type as abstract since we + -- won't be able to declare objects of that type. + + else + Set_Is_Abstract (Typ); + end if; + end Set_Default_Constructor; + +end Exp_Disp; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads new file mode 100644 index 00000000000..f5ff995d61b --- /dev/null +++ b/gcc/ada/exp_disp.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S P -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- Copyright (C) 1992-1998 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines involved in tagged types and dynamic +-- dispatching expansion + +with Types; use Types; +package Exp_Disp is + + type DT_Access_Action is + (CW_Membership, + DT_Entry_Size, + DT_Prologue_Size, + Get_Expanded_Name, + Get_External_Tag, + Get_Prim_Op_Address, + Get_RC_Offset, + Get_Remotely_Callable, + Get_TSD, + Inherit_DT, + Inherit_TSD, + Register_Tag, + Set_Expanded_Name, + Set_External_Tag, + Set_Prim_Op_Address, + Set_RC_Offset, + Set_Remotely_Callable, + Set_TSD, + TSD_Entry_Size, + TSD_Prologue_Size); + + + function Fill_DT_Entry + (Loc : Source_Ptr; + Prim : Entity_Id) + return Node_Id; + -- Generate the code necessary to fill the appropriate entry of the + -- dispatch table of Prim's controlling type with Prim's address. + + function Make_DT_Access_Action + (Typ : Entity_Id; + Action : DT_Access_Action; + Args : List_Id) + return Node_Id; + -- Generate a call to one of the Dispatch Table Access Subprograms defined + -- in Ada.Tags or in Interfaces.Cpp + + function Make_DT (Typ : Entity_Id) return List_Id; + -- Expand the declarations for the Dispatch Table (or the Vtable in + -- the case of type whose ancestor is a CPP_Class) + + procedure Set_All_DT_Position (Typ : Entity_Id); + -- Set the DT_Position field for each primitive operation. In the CPP + -- Class case check that no pragma CPP_Virtual is missing and that the + -- DT_Position are coherent + + procedure Expand_Dispatch_Call (Call_Node : Node_Id); + -- Expand the call to the operation through the dispatch table and perform + -- the required tag checks when appropriate. For CPP types the call is + -- done through the Vtable (tag checks are not relevant) + + procedure Set_Default_Constructor (Typ : Entity_Id); + -- Typ is a CPP_Class type. Create the Init procedure of that type to + -- be the default constructor (i.e. the function returning this type, + -- having a pragma CPP_Constructor and no parameter) + + function Get_Remotely_Callable (Obj : Node_Id) return Node_Id; + -- Return an expression that holds True if the object can be transmitted + -- onto another partition according to E.4 (18) + +end Exp_Disp; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb new file mode 100644 index 00000000000..c0d79d12d22 --- /dev/null +++ b/gcc/ada/exp_dist.adb @@ -0,0 +1,3760 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P_ D I S T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.125 $ +-- -- +-- Copyright (C) 1992-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 Elists; use Elists; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with GNAT.HTable; use GNAT.HTable; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Dist; use Sem_Dist; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Uname; use Uname; + +package body Exp_Dist is + + -- The following model has been used to implement distributed objects: + -- given a designated type D and a RACW type R, then a record of the + -- form: + -- type Stub is tagged record + -- [...declaration similar to s-parint.ads RACW_Stub_Type...] + -- end Stub; + -- is built. This type has two properties: + -- + -- 1) Since it has the same structure than RACW_Stub_Type, it can be + -- converted to and from this type to make it suitable for + -- System.Partition_Interface.Get_Unique_Remote_Pointer in order + -- to avoid memory leaks when the same remote object arrive on the + -- same partition by following different pathes + -- + -- 2) It also has the same dispatching table as the designated type D, + -- and thus can be used as an object designated by a value of type + -- R on any partition other than the one on which the object has + -- been created, since only dispatching calls will be performed and + -- the fields themselves will not be used. We call Derive_Subprograms + -- to fake half a derivation to ensure that the subprograms do have + -- the same dispatching table. + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Build_General_Calling_Stubs + (Decls : in List_Id; + Statements : in List_Id; + Target_Partition : in Entity_Id; + RPC_Receiver : in Node_Id; + Subprogram_Id : in Node_Id; + Asynchronous : in Node_Id := Empty; + Is_Known_Asynchronous : in Boolean := False; + Is_Known_Non_Asynchronous : in Boolean := False; + Is_Function : in Boolean; + Spec : in Node_Id; + Object_Type : in Entity_Id := Empty; + Nod : in Node_Id); + -- Build calling stubs for general purpose. The parameters are: + -- Decls : a place to put declarations + -- Statements : a place to put statements + -- Target_Partition : a node containing the target partition that must + -- be a N_Defining_Identifier + -- RPC_Receiver : a node containing the RPC receiver + -- Subprogram_Id : a node containing the subprogram ID + -- Asynchronous : True if an APC must be made instead of an RPC. + -- The value needs not be supplied if one of the + -- Is_Known_... is True. + -- Is_Known_Async... : True if we know that this is asynchronous + -- Is_Known_Non_A... : True if we know that this is not asynchronous + -- Spec : a node with a Parameter_Specifications and + -- a Subtype_Mark if applicable + -- Object_Type : in case of a RACW, parameters of type access to + -- Object_Type will be marshalled using the + -- address of this object (the addr field) rather + -- than using the 'Write on the object itself + -- Nod : used to provide sloc for generated code + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Int; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id; + -- Build the calling stub for a given subprogram with the subprogram ID + -- being Subp_Id. If Stub_Type is given, then the "addr" field of + -- parameters of this type will be marshalled instead of the object + -- itself. It will then be converted into Stub_Type before performing + -- the real call. If Dynamically_Asynchronous is True, then it will be + -- computed at run time whether the call is asynchronous or not. + -- Otherwise, the value of the formal Asynchronous will be used. + -- If Locator is not Empty, it will be used instead of RCI_Cache. If + -- New_Name is given, then it will be used instead of the original name. + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) + return Node_Id; + -- Build the receiving stub for a given subprogram. The subprogram + -- declaration is also built by this procedure, and the value returned + -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is + -- found in the specification, then its address is read from the stream + -- instead of the object itself and converted into an access to + -- class-wide type before doing the real call using any of the RACW type + -- pointing on the designated type. + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; + -- Return an ordered parameter list: unconstrained parameters are put + -- at the beginning of the list and constrained ones are put after. If + -- there are no parameters, an empty list is returned. + + procedure Add_Calling_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id); + -- Add calling stubs to the declarative part + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id); + -- Add receiving stubs to the declarative part + + procedure Add_RAS_Dereference_Attribute (N : in Node_Id); + -- Add a subprogram body for RAS dereference + + procedure Add_RAS_Access_Attribute (N : in Node_Id); + -- Add a subprogram body for RAS Access attribute + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; + -- Return True if nothing prevents the program whose specification is + -- given to be asynchronous (i.e. no out parameter). + + function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id; + function Get_String_Id (Val : String) return String_Id; + -- Ugly functions used to retrieve a package name. Inherited from the + -- old exp_dist.adb and not rewritten yet ??? + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) + return Node_Id; + -- Pack Object (of type Etyp) into Stream. If Etyp is not given, + -- then Etype (Object) will be used if present. If the type is + -- constrained, then 'Write will be used to output the object, + -- If the type is unconstrained, 'Output will be used. + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id; + -- Similar to above, with an arbitrary node instead of an entity + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id; + -- Similar to above, with Stream instead of Stream'Access + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Stub_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id; + -- Build a specification from another one. If Object_Type is not Empty + -- and any access to Object_Type is found, then it is replaced by an + -- access to Stub_Type. If New_Name is given, then it will be used as + -- the name for the newly created spec. + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; + -- Return the scope represented by a given spec + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; + -- Return True if the current parameter needs an extra formal to reflect + -- its constrained status. + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; Stub_Type : Entity_Id) + return Boolean; + -- Return True if the current parameter is a controlling formal argument + -- of type Stub_Type or access to Stub_Type. + + type Stub_Structure is record + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + RPC_Receiver_Stream : Entity_Id; + RPC_Receiver_Result : Entity_Id; + RACW_Type : Entity_Id; + end record; + -- This structure is necessary because of the two phases analysis of + -- a RACW declaration occurring in the same Remote_Types package as the + -- designated type. RACW_Type is any of the RACW types pointing on this + -- designated type, it is used here to save an anonymous type creation + -- for each primitive operation. + + Empty_Stub_Structure : constant Stub_Structure := + (Empty, Empty, Empty, Empty, Empty, Empty); + + type Hash_Index is range 0 .. 50; + function Hash (F : Entity_Id) return Hash_Index; + + package Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Stub_Structure, + No_Element => Empty_Stub_Structure, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW designated type and its stub type + + package Asynchronous_Flags_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Node_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW type and the node holding the value True if + -- the RACW is asynchronous and False otherwise. + + package RCI_Locator_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI package on which All_Calls_Remote applies and + -- the generic instantiation of RCI_Info for this package. + + package RCI_Calling_Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI subprogram and the corresponding calling stubs + + procedure Add_Stub_Type + (Designated_Type : in Entity_Id; + RACW_Type : in Entity_Id; + Decls : in List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + Object_RPC_Receiver : out Entity_Id; + Existing : out Boolean); + -- Add the declaration of the stub type, the access to stub type and the + -- object RPC receiver at the end of Decls. If these already exist, + -- then nothing is added in the tree but the right values are returned + -- anyhow and Existing is set to True. + + procedure Add_RACW_Read_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Declarations : in List_Id); + -- Add Read attribute in Decls for the RACW type. The Read attribute + -- is added right after the RACW_Type declaration while the body is + -- inserted after Declarations. + + procedure Add_RACW_Write_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id); + -- Same thing for the Write attribute + + procedure Add_RACW_Read_Write_Attributes + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id); + -- Add Read and Write attributes declarations and bodies for a given + -- RACW type. The declarations are added just after the declaration + -- of the RACW type itself, while the bodies are inserted at the end + -- of Decls. + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) + return Node_Id; + -- Instantiate the generic package RCI_Info in order to locate the + -- RCI package whose spec is given as argument. + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; + -- Surround a node N by a tag check, as in: + -- begin + -- <N>; + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end; + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Entity_Id) + return Node_Id; + -- Return a function with the following form: + -- function R return Var_Type is + -- begin + -- return Var_Type'Input (S); + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end R; + + ------------------------------------ + -- Local variables and structures -- + ------------------------------------ + + RCI_Cache : Node_Id; + + Output_From_Constrained : constant array (Boolean) of Name_Id := + (False => Name_Output, + True => Name_Write); + -- The attribute to choose depending on the fact that the parameter + -- is constrained or not. There is no such thing as Input_From_Constrained + -- since this require separate mechanisms ('Input is a function while + -- 'Read is a procedure). + + --------------------------------------- + -- Add_Calling_Stubs_To_Declarations -- + --------------------------------------- + + procedure Add_Calling_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id) + is + Current_Subprogram_Number : Int := 0; + Current_Declaration : Node_Id; + + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + RCI_Instantiation : Node_Id; + + Subp_Stubs : Node_Id; + + begin + -- The first thing added is an instantiation of the generic package + -- System.Partition_interface.RCI_Info with the name of the (current) + -- remote package. This will act as an interface with the name server + -- to determine the Partition_ID and the RPC_Receiver for the + -- receiver of this package. + + RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); + RCI_Cache := Defining_Unit_Name (RCI_Instantiation); + + Append_To (Decls, RCI_Instantiation); + Analyze (RCI_Instantiation); + + -- For each subprogram declaration visible in the spec, we do + -- build a body. We also increment a counter to assign a different + -- Subprogram_Id to each subprograms. The receiving stubs processing + -- do use the same mechanism and will thus assign the same Id and + -- do the correct dispatching. + + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); + + while Current_Declaration /= Empty loop + + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + pragma Assert (Current_Subprogram_Number = + Get_Subprogram_Id (Defining_Unit_Name (Specification ( + Current_Declaration)))); + + Subp_Stubs := + Build_Subprogram_Calling_Stubs ( + Vis_Decl => Current_Declaration, + Subp_Id => Current_Subprogram_Number, + Asynchronous => + Nkind (Specification (Current_Declaration)) = + N_Procedure_Specification + and then + Is_Asynchronous (Defining_Unit_Name (Specification + (Current_Declaration)))); + + Append_To (Decls, Subp_Stubs); + Analyze (Subp_Stubs); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + + end Add_Calling_Stubs_To_Declarations; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features (RACW_Type : in Entity_Id) + is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Decls : List_Id := + List_Containing (Declaration_Node (RACW_Type)); + + Same_Scope : constant Boolean := + Scope (Desig) = Scope (RACW_Type); + + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + Existing : Boolean; + + begin + if not Expander_Active then + return; + end if; + + if Same_Scope then + + -- We are declaring a RACW in the same package than its designated + -- type, so the list to use for late declarations must be the + -- private part of the package. We do know that this private part + -- exists since the designated type has to be a private one. + + Decls := Private_Declarations + (Package_Specification_Of_Scope (Current_Scope)); + + elsif Nkind (Parent (Decls)) = N_Package_Specification + and then Present (Private_Declarations (Parent (Decls))) + then + Decls := Private_Declarations (Parent (Decls)); + end if; + + -- If we were unable to find the declarations, that means that the + -- completion of the type was missing. We can safely return and let + -- the error be caught by the semantic analysis. + + if No (Decls) then + return; + end if; + + Add_Stub_Type + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Decls => Decls, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + Existing => Existing); + + Add_RACW_Read_Write_Attributes + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + Declarations => Decls); + + if not Same_Scope and then not Existing then + + -- The RACW has been declared in another scope than the designated + -- type and has not been handled by another RACW in the same + -- package as the first one, so add primitive for the stub type + -- here. + + Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type => Desig, + Insertion_Node => + Parent (Declaration_Node (Object_RPC_Receiver)), + Decls => Decls); + + else + Add_Access_Type_To_Process (E => Desig, A => RACW_Type); + end if; + end Add_RACW_Features; + + ------------------------------------------------- + -- Add_RACW_Primitive_Declarations_And_Bodies -- + ------------------------------------------------- + + procedure Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type : in Entity_Id; + Insertion_Node : in Node_Id; + Decls : in List_Id) + is + -- Set sloc of generated declaration to be that of the + -- insertion node, so the declarations are recognized as + -- belonging to the current package. + + Loc : constant Source_Ptr := Sloc (Insertion_Node); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Current_Insertion_Node : Node_Id := Insertion_Node; + + RPC_Receiver_Declarations : List_Id; + RPC_Receiver_Statements : List_Id; + RPC_Receiver_Case_Alternatives : constant List_Id := New_List; + RPC_Receiver_Subp_Id : Entity_Id; + + Current_Primitive_Elmt : Elmt_Id; + Current_Primitive : Entity_Id; + Current_Primitive_Body : Node_Id; + Current_Primitive_Spec : Node_Id; + Current_Primitive_Decl : Node_Id; + Current_Primitive_Number : Int := 0; + + Current_Primitive_Alias : Node_Id; + + Current_Receiver : Entity_Id; + Current_Receiver_Body : Node_Id; + + RPC_Receiver_Decl : Node_Id; + + Possibly_Asynchronous : Boolean; + + begin + + if not Expander_Active then + return; + end if; + + -- Build callers, receivers for every primitive operations and a RPC + -- receiver for this type. + + if Present (Primitive_Operations (Designated_Type)) then + + Current_Primitive_Elmt := + First_Elmt (Primitive_Operations (Designated_Type)); + + while Current_Primitive_Elmt /= No_Elmt loop + + Current_Primitive := Node (Current_Primitive_Elmt); + + -- Copy the primitive of all the parents, except predefined + -- ones that are not remotely dispatching. + + if Chars (Current_Primitive) /= Name_uSize + and then Chars (Current_Primitive) /= Name_uDeep_Finalize + then + -- The first thing to do is build an up-to-date copy of + -- the spec with all the formals referencing Designated_Type + -- transformed into formals referencing Stub_Type. Since this + -- primitive may have been inherited, go back the alias chain + -- until the real primitive has been found. + + Current_Primitive_Alias := Current_Primitive; + while Present (Alias (Current_Primitive_Alias)) loop + pragma Assert + (Current_Primitive_Alias + /= Alias (Current_Primitive_Alias)); + Current_Primitive_Alias := Alias (Current_Primitive_Alias); + end loop; + + Current_Primitive_Spec := + Copy_Specification (Loc, + Spec => Parent (Current_Primitive_Alias), + Object_Type => Designated_Type, + Stub_Type => Stub_Elements.Stub_Type); + + Current_Primitive_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Current_Primitive_Spec); + + Insert_After (Current_Insertion_Node, Current_Primitive_Decl); + Analyze (Current_Primitive_Decl); + Current_Insertion_Node := Current_Primitive_Decl; + + Possibly_Asynchronous := + Nkind (Current_Primitive_Spec) = N_Procedure_Specification + and then Could_Be_Asynchronous (Current_Primitive_Spec); + + Current_Primitive_Body := + Build_Subprogram_Calling_Stubs + (Vis_Decl => Current_Primitive_Decl, + Subp_Id => Current_Primitive_Number, + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type); + Append_To (Decls, Current_Primitive_Body); + + -- Analyzing the body here would cause the Stub type to be + -- frozen, thus preventing subsequent primitive declarations. + -- For this reason, it will be analyzed later in the + -- regular flow. + + -- Build the receiver stubs + + Current_Receiver_Body := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Primitive_Decl, + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type, + Parent_Primitive => Current_Primitive); + + Current_Receiver := + Defining_Unit_Name (Specification (Current_Receiver_Body)); + + Append_To (Decls, Current_Receiver_Body); + + -- Add a case alternative to the receiver + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Current_Primitive_Number)), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Current_Receiver, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of + (Stub_Elements.RPC_Receiver_Stream, Loc), + New_Occurrence_Of + (Stub_Elements.RPC_Receiver_Result, Loc)))))); + + -- Increment the index of current primitive + + Current_Primitive_Number := Current_Primitive_Number + 1; + end if; + + Next_Elmt (Current_Primitive_Elmt); + end loop; + end if; + + -- Build the case statement and the heart of the subprogram + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + RPC_Receiver_Subp_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + RPC_Receiver_Declarations := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => RPC_Receiver_Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); + + RPC_Receiver_Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc), + New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc)))); + + Append_To (RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), + Alternatives => RPC_Receiver_Case_Alternatives)); + + RPC_Receiver_Decl := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, + Parent (Stub_Elements.Object_RPC_Receiver)), + Declarations => RPC_Receiver_Declarations, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => RPC_Receiver_Statements)); + + Append_To (Decls, RPC_Receiver_Decl); + + -- Do not analyze RPC receiver at this stage since it will otherwise + -- reference subprograms that have not been analyzed yet. It will + -- be analyzed in the regular flow. + + end Add_RACW_Primitive_Declarations_And_Bodies; + + ----------------------------- + -- Add_RACW_Read_Attribute -- + ----------------------------- + + procedure Add_RACW_Read_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Declarations : in List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Proc_Spec : Node_Id; + -- Specification and body of the currently built procedure + + Proc_Body_Spec : Node_Id; + + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Decls : List_Id; + Statements : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + -- Various parts of the procedure + + Procedure_Name : constant Name_Id := + New_Internal_Name ('R'); + Source_Partition : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Source_Receiver : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Source_Address : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Stream_Parameter : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Result : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Stubbed_Result : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Asynchronous_Flag : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Asynchronous_Node : constant Node_Id := + New_Occurrence_Of (Standard_False, Loc); + + begin + -- Declare the asynchronous flag. This flag will be changed to True + -- whenever it is known that the RACW type is asynchronous. Also, the + -- node gets stored since it may be rewritten when we process the + -- asynchronous pragma. + + Append_To (Declarations, + Make_Object_Declaration (Loc, + Defining_Identifier => Asynchronous_Flag, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => Asynchronous_Node)); + + Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node); + + -- Object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Partition, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Receiver, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stubbed_Result, + Object_Definition => + New_Occurrence_Of (Stub_Type_Access, Loc))); + + -- Read the source Partition_ID and RPC_Receiver from incoming stream + + Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Source_Partition, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Source_Receiver, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Source_Address, Loc)))); + + -- If the Address is Null_Address, then return a null object + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Source_Address, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Result, Loc), + Expression => Make_Null (Loc)), + Make_Return_Statement (Loc)))); + + -- If the RACW denotes an object created on the current partition, then + -- Local_Statements will be executed. The real object will be used. + + Local_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Result, Loc), + Expression => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Source_Address, Loc))))); + + -- If the object is located on another partition, then a stub object + -- will be created with all the information needed to rebuild the + -- real object at the other end. + + Remote_Statements := New_List ( + + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Stubbed_Result, Loc), + Expression => + Make_Allocator (Loc, + New_Occurrence_Of (Stub_Type, Loc))), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Expression => + New_Occurrence_Of (Source_Partition, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), + Expression => + New_Occurrence_Of (Source_Receiver, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Source_Address, Loc))); + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), + Expression => + New_Occurrence_Of (Asynchronous_Flag, Loc))); + + Append_To (Remote_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Stubbed_Result, Loc))))); + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Result, Loc), + Expression => Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Stubbed_Result, Loc)))); + + -- Distinguish between the local and remote cases, and execute the + -- appropriate piece of code. + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)), + Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), + Then_Statements => Local_Statements, + Else_Statements => Remote_Statements)); + + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Result, + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Proc_Body_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Stream_Parameter)), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Result)), + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Proc_Body_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Read_Attribute; + + ------------------------------------ + -- Add_RACW_Read_Write_Attributes -- + ------------------------------------ + + procedure Add_RACW_Read_Write_Attributes + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id) + is + begin + Add_RACW_Write_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + Declarations => Declarations); + + Add_RACW_Read_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Declarations => Declarations); + end Add_RACW_Read_Write_Attributes; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Proc_Spec : Node_Id; + + Proc_Body_Spec : Node_Id; + + Body_Node : Node_Id; + + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Statements : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + Null_Statements : List_Id; + + Procedure_Name : constant Name_Id := New_Internal_Name ('R'); + + Stream_Parameter : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + + Object : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + begin + -- Build the code fragment corresponding to the marshalling of a + -- local object. + + Local_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Object, Loc)), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build the code fragment corresponding to the marshalling of + -- a remote object. + + Remote_Statements := New_List ( + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + New_Occurrence_Of (Object, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + New_Occurrence_Of (Object, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + New_Occurrence_Of (Object, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build the code fragment corresponding to the marshalling of a null + -- object. + + Null_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => Make_Integer_Literal (Loc, Uint_0), + Etyp => RTE (RE_Unsigned_64))); + + Statements := New_List ( + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Object, Loc), + Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Object, Loc), + Attribute_Name => Name_Tag), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag)), + Then_Statements => Remote_Statements)), + Else_Statements => Local_Statements)); + + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Object, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc)); + + Proc_Body_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Stream_Parameter)), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Object)), + In_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Proc_Body_Spec, + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Write_Attribute; + + ------------------------------ + -- Add_RAS_Access_Attribute -- + ------------------------------ + + procedure Add_RAS_Access_Attribute (N : in Node_Id) is + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type while Fat_Type points to + -- the record type corresponding to a remote access to subprogram type. + + Proc_Decls : constant List_Id := New_List; + Proc_Statements : constant List_Id := New_List; + + Proc_Spec : Node_Id; + Proc_Body : Node_Id; + + Proc : Node_Id; + + Param : Node_Id; + Package_Name : Node_Id; + Subp_Id : Node_Id; + Asynchronous : Node_Id; + Return_Value : Node_Id; + + Loc : constant Source_Ptr := Sloc (N); + + procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id); + -- Set a field name for the return value + + procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id) + is + begin + Append_To (Proc_Statements, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Return_Value, Loc), + Selector_Name => Make_Identifier (Loc, Field_Name)), + Expression => Value)); + end Set_Field; + + -- Start of processing for Add_RAS_Access_Attribute + + begin + Param := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); + Asynchronous := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + -- Create the object which will be returned of type Fat_Type + + Append_To (Proc_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Value, + Object_Definition => + New_Occurrence_Of (Fat_Type, Loc))); + + -- Initialize the fields of the record type with the appropriate data + + Set_Field (Name_Ras, + OK_Convert_To (RTE (RE_Unsigned_64), New_Occurrence_Of (Param, Loc))); + + Set_Field (Name_Origin, + Unchecked_Convert_To (Standard_Integer, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc))))); + + Set_Field (Name_Receiver, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))); + + Set_Field (Name_Subp_Id, + New_Occurrence_Of (Subp_Id, Loc)); + + Set_Field (Name_Async, + New_Occurrence_Of (Asynchronous, Loc)); + + -- Return the newly created value + + Append_To (Proc_Statements, + Make_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Return_Value, Loc))); + + Proc := Make_Defining_Identifier (Loc, Name_uRAS_Access); + + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Param, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (Standard_Natural, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynchronous, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Subtype_Mark => + New_Occurrence_Of (Fat_Type, Loc)); + + -- Set the kind and return type of the function to prevent ambiguities + -- between Ras_Type and Fat_Type in subsequent analysis. + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc)); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements)); + + Set_TSS (Fat_Type, Proc); + + end Add_RAS_Access_Attribute; + + ----------------------------------- + -- Add_RAS_Dereference_Attribute -- + ----------------------------------- + + procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Type_Def : constant Node_Id := Type_Definition (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + + Proc_Decls : constant List_Id := New_List; + Proc_Statements : constant List_Id := New_List; + + Inner_Decls : constant List_Id := New_List; + Inner_Statements : constant List_Id := New_List; + + Direct_Statements : constant List_Id := New_List; + + Proc : Node_Id; + + Proc_Spec : Node_Id; + Proc_Body : Node_Id; + + Param_Specs : constant List_Id := New_List; + Param_Assoc : constant List_Id := New_List; + + Pointer : Node_Id; + + Converted_Ras : Node_Id; + Target_Partition : Node_Id; + RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id; + + Is_Function : constant Boolean := + Nkind (Type_Def) = N_Access_Function_Definition; + + Spec : constant Node_Id := Type_Def; + + Current_Parameter : Node_Id; + + begin + -- The way to do it is test if the Ras field is non-null and then if + -- the Origin field is equal to the current partition ID (which is in + -- fact Current_Package'Partition_ID). If this is the case, then it + -- is safe to dereference the Ras field directly rather than + -- performing a remote call. + + Pointer := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Target_Partition := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Proc_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Partition_ID), + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin))))); + + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)); + + Subprogram_Id := + Unchecked_Convert_To (RTE (RE_Subprogram_Id), + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Subp_Id))); + + -- A function is never asynchronous. A procedure may or may not be + -- asynchronous depending on whether a pragma Asynchronous applies + -- on it. Since a RAST may point onto various subprograms, this is + -- only known at runtime so both versions (synchronous and asynchronous) + -- must be built every times it is not a function. + + if Is_Function then + Asynchronous := Empty; + + else + Asynchronous := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Async)); + + end if; + + if Present (Parameter_Specifications (Type_Def)) then + Current_Parameter := First (Parameter_Specifications (Type_Def)); + + while Current_Parameter /= Empty loop + Append_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter))), + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Parameter_Type => + New_Occurrence_Of + (Etype (Parameter_Type (Current_Parameter)), Loc), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Append_To (Param_Assoc, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter)))); + + Next (Current_Parameter); + end loop; + end if; + + Proc := Make_Defining_Identifier (Loc, Name_uRAS_Dereference); + + if Is_Function then + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs, + Subtype_Mark => + New_Occurrence_Of ( + Entity (Subtype_Mark (Spec)), Loc)); + + Set_Ekind (Proc, E_Function); + + Set_Etype (Proc, + New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); + + else + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs); + + Set_Ekind (Proc, E_Procedure); + Set_Etype (Proc, Standard_Void_Type); + end if; + + -- Build the calling stubs for the dereference of the RAS + + Build_General_Calling_Stubs + (Decls => Inner_Decls, + Statements => Inner_Statements, + Target_Partition => Target_Partition, + RPC_Receiver => RPC_Receiver, + Subprogram_Id => Subprogram_Id, + Asynchronous => Asynchronous, + Is_Known_Non_Asynchronous => Is_Function, + Is_Function => Is_Function, + Spec => Proc_Spec, + Nod => N); + + Converted_Ras := + Unchecked_Convert_To (Ras_Type, + OK_Convert_To (RTE (RE_Address), + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pointer, Loc), + Selector_Name => Make_Identifier (Loc, Name_Ras)))); + + if Is_Function then + Append_To (Direct_Statements, + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => Converted_Ras), + Parameter_Associations => Param_Assoc))); + + else + Append_To (Direct_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => Converted_Ras), + Parameter_Associations => Param_Assoc)); + end if; + + Prepend_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => Pointer, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (Fat_Type, Loc))); + + Append_To (Proc_Statements, + Make_Implicit_If_Statement (N, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pointer, Loc), + Selector_Name => Make_Identifier (Loc, Name_Ras)), + Right_Opnd => + Make_Integer_Literal (Loc, Uint_0)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Target_Partition, Loc), + Right_Opnd => + Make_Function_Call (Loc, + New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc)))), + + Then_Statements => + Direct_Statements, + + Else_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Inner_Statements))))); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements)); + + Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec)); + + end Add_RAS_Dereference_Attribute; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features (Vis_Decl : Node_Id) is + begin + -- Do not add attributes more than once in any case. This should + -- be replaced by an assert or this comment removed if we decide + -- that this is normal to be called several times ??? + + if Present (TSS (Equivalent_Type (Defining_Identifier + (Vis_Decl)), Name_uRAS_Access)) + then + return; + end if; + + Add_RAS_Dereference_Attribute (Vis_Decl); + Add_RAS_Access_Attribute (Vis_Decl); + end Add_RAST_Features; + + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Stream_Parameter : Node_Id; + Result_Parameter : Node_Id; + + Pkg_RPC_Receiver : Node_Id; + Pkg_RPC_Receiver_Spec : Node_Id; + Pkg_RPC_Receiver_Formals : List_Id; + Pkg_RPC_Receiver_Decls : List_Id; + Pkg_RPC_Receiver_Statements : List_Id; + Pkg_RPC_Receiver_Cases : List_Id := New_List; + Pkg_RPC_Receiver_Body : Node_Id; + -- A Pkg_RPC_Receiver is built to decode the request + + Subp_Id : Node_Id; + -- Subprogram_Id as read from the incoming stream + + Current_Declaration : Node_Id; + Current_Subprogram_Number : Int := 0; + Current_Stubs : Node_Id; + + Actuals : List_Id; + + Dummy_Register_Name : Name_Id; + Dummy_Register_Spec : Node_Id; + Dummy_Register_Decl : Node_Id; + Dummy_Register_Body : Node_Id; + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram + -- will get a Subprogram_Id from the incoming stream + -- and will dispatch the call to the right subprogram + + -- - a receiving stub for any subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream + + -- - a dummy package with an empty spec and a body made of an + -- elaboration part, whose job is to register the receiving + -- part of this RCI package on the name server. This is done + -- by calling System.Partition_Interface.Register_Receiving_Stub + + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Subp_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Pkg_RPC_Receiver := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + -- The parameters of the package RPC receiver are made of two + -- streams, an input one and an output one. + + Pkg_RPC_Receiver_Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + Make_Parameter_Specification (Loc, + Defining_Identifier => Result_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))); + + Pkg_RPC_Receiver_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Pkg_RPC_Receiver, + Parameter_Specifications => Pkg_RPC_Receiver_Formals); + + Pkg_RPC_Receiver_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); + + Pkg_RPC_Receiver_Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Subp_Id, Loc)))); + + -- For each subprogram, the receiving stub will be built and a + -- case statement will be made on the Subprogram_Id to dispatch + -- to the right subprogram. + + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); + + while Current_Declaration /= Empty loop + + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + pragma Assert (Current_Subprogram_Number = + Get_Subprogram_Id (Defining_Unit_Name (Specification ( + Current_Declaration)))); + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => + Nkind (Specification (Current_Declaration)) = + N_Procedure_Specification + and then Is_Asynchronous + (Defining_Unit_Name (Specification + (Current_Declaration)))); + + Append_To (Decls, Current_Stubs); + + Analyze (Current_Stubs); + + Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc)); + + if Nkind (Specification (Current_Declaration)) + = N_Function_Specification + or else + not Is_Asynchronous ( + Defining_Entity (Specification (Current_Declaration))) + then + -- An asynchronous procedure does not want an output parameter + -- since no result and no exception will ever be returned. + + Append_To (Actuals, + New_Occurrence_Of (Result_Parameter, Loc)); + + end if; + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List ( + Make_Integer_Literal (Loc, Current_Subprogram_Number)), + + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Current_Stubs), Loc), + Parameter_Associations => + Actuals)))); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (Subp_Id, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + Pkg_RPC_Receiver_Body := + Make_Subprogram_Body (Loc, + Specification => Pkg_RPC_Receiver_Spec, + Declarations => Pkg_RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Pkg_RPC_Receiver_Statements)); + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Pkg_RPC_Receiver_Body); + + -- Construction of the dummy package used to register the package + -- receiving stubs on the nameserver. + + Dummy_Register_Name := New_Internal_Name ('P'); + + Dummy_Register_Spec := + Make_Package_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Dummy_Register_Name), + Visible_Declarations => No_List, + End_Label => Empty); + + Dummy_Register_Decl := + Make_Package_Declaration (Loc, + Specification => Dummy_Register_Spec); + + Append_To (Decls, + Dummy_Register_Decl); + Analyze (Dummy_Register_Decl); + + Dummy_Register_Body := + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Dummy_Register_Name), + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), + + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Strval => Get_Pkg_Name_String_Id (Pkg_Spec)), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => + Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version)))))); + + Append_To (Decls, Dummy_Register_Body); + Analyze (Dummy_Register_Body); + end Add_Receiving_Stubs_To_Declarations; + + ------------------- + -- Add_Stub_Type -- + ------------------- + + procedure Add_Stub_Type + (Designated_Type : in Entity_Id; + RACW_Type : in Entity_Id; + Decls : in List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + Object_RPC_Receiver : out Entity_Id; + Existing : out Boolean) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + + Stub_Type_Declaration : Node_Id; + Stub_Type_Access_Declaration : Node_Id; + Object_RPC_Receiver_Declaration : Node_Id; + + RPC_Receiver_Stream : Entity_Id; + RPC_Receiver_Result : Entity_Id; + + begin + if Stub_Elements /= Empty_Stub_Structure then + Stub_Type := Stub_Elements.Stub_Type; + Stub_Type_Access := Stub_Elements.Stub_Type_Access; + Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver; + Existing := True; + return; + end if; + + Existing := False; + Stub_Type := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Stub_Type_Access := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Object_RPC_Receiver := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + RPC_Receiver_Stream := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + RPC_Receiver_Result := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Stubs_Table.Set (Designated_Type, + (Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + RPC_Receiver_Stream => RPC_Receiver_Stream, + RPC_Receiver_Result => RPC_Receiver_Result, + RACW_Type => RACW_Type)); + + -- The stub type definition below must match exactly the one in + -- s-parint.ads, since unchecked conversions will be used in + -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer. + + Stub_Type_Declaration := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type, + Type_Definition => + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Origin), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Receiver), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Addr), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)))))); + + Append_To (Decls, Stub_Type_Declaration); + Analyze (Stub_Type_Declaration); + + -- This is in no way a type derivation, but we fake it to make + -- sure that the dispatching table gets built with the corresponding + -- primitive operations at the right place. + + Derive_Subprograms (Parent_Type => Designated_Type, + Derived_Type => Stub_Type); + + Stub_Type_Access_Declaration := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type_Access, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); + + Append_To (Decls, Stub_Type_Access_Declaration); + Analyze (Stub_Type_Access_Declaration); + + Object_RPC_Receiver_Declaration := + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Object_RPC_Receiver, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RPC_Receiver_Stream, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => RPC_Receiver_Result, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Params_Stream_Type), Loc)))))); + + Append_To (Decls, Object_RPC_Receiver_Declaration); + end Add_Stub_Type; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; + RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Stream_Parameter : Node_Id; + -- Name of the stream used to transmit parameters to the remote package + + Result_Parameter : Node_Id; + -- Name of the result parameter (in non-APC cases) which get the + -- result of the remote subprogram. + + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. + + Current_Parameter : Node_Id; + -- Current parameter being handled + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); + + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases. + + Extra_Formal_Statements : constant List_Id := New_List; + -- List of statements for extra formal parameters. It will appear after + -- the regular statements for writing out parameters. + + begin + -- The general form of a calling stub for a given subprogram is: + + -- procedure X (...) is + -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID; + -- Stream, Result : aliased System.RPC.Params_Stream_Type (0); + -- begin + -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver + -- comes from RCI_Cache.Get_RCI_Package_Receiver) + -- Put_Subprogram_Id_In_Stream; + -- Put_Parameters_In_Stream; + -- Do_RPC (Stream, Result); + -- Read_Exception_Occurrence_From_Result; Raise_It; + -- Read_Out_Parameters_And_Function_Return_From_Stream; + -- end X; + + -- There are some variations: Do_APC is called for an asynchronous + -- procedure and the part after the call is completely ommitted + -- as well as the declaration of Result. For a function call, + -- 'Input is always used to read the result even if it is constrained. + + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Stream_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + Exception_Return_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + + else + Result_Parameter := Empty; + Exception_Return_Parameter := Empty; + end if; + + -- Put first the RPC receiver corresponding to the remote package + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + RPC_Receiver))); + + -- Then put the Subprogram_Id of the subprogram we want to call in + -- the stream. + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Subprogram_Id))); + + Current_Parameter := First (Ordered_Parameters_List); + + while Current_Parameter /= Empty loop + + if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then + + -- In the case of a controlling formal argument, we marshall + -- its addr field rather than the local stub. + + Append_To (Statements, + Pack_Node_Into_Stream (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); + + else + declare + Etyp : constant Entity_Id := + Etype (Parameter_Type (Current_Parameter)); + + Constrained : constant Boolean := + Is_Constrained (Etyp) + or else Is_Elementary_Type (Etyp); + + begin + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Output_From_Constrained (Constrained), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc)))); + end if; + end; + end if; + + -- If the current parameter has a dynamic constrained status, + -- then this status is transmitted as well. + -- This should be done for accessibility as well ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) + then + -- In this block, we do not use the extra formal that has been + -- created because it does not exist at the time of expansion + -- when building calling stubs for remote access to subprogram + -- types. We create an extra variable of this type and push it + -- in the stream after the regular parameters. + + declare + Extra_Parameter : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Parameter, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Extra_Parameter, Loc)))); + end; + end if; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list to the statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if not Is_Known_Non_Asynchronous then + + -- Build the call to System.RPC.Do_APC + + Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Apc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access)))); + else + Asynchronous_Statements := No_List; + end if; + + if not Is_Known_Asynchronous then + + -- Build the call to System.RPC.Do_RPC + + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access)))); + + -- Read the exception occurrence from the result stream and + -- reraise it. It does no harm if this is a Null_Occurrence since + -- this does nothing. + + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + + Attribute_Name => + Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + Append_To (Non_Asynchronous_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + if Is_Function then + + -- If this is a function call, then read the value and return + -- it. The return value is written/read using 'Output/'Input. + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Etype (Subtype_Mark (Spec)), Loc), + + Attribute_Name => Name_Input, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access)))))); + + else + -- Loop around parameters and assign out (or in out) parameters. + -- In the case of RACW, controlling arguments cannot possibly + -- have changed since they are remote, so we do not read them + -- from the stream. + + Current_Parameter := + First (Ordered_Parameters_List); + + while Current_Parameter /= Empty loop + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Object_Type + then + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Etype (Parameter_Type (Current_Parameter)), Loc), + + Attribute_Name => Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc)))); + end if; + + Next (Current_Parameter); + end loop; + end if; + end if; + + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); + + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); + + else + pragma Assert (Asynchronous /= Empty); + Prepend_To (Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_True, Loc)))); + Prepend_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_False, Loc)))); + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; + + ----------------------------------- + -- Build_Ordered_Parameters_List -- + ----------------------------------- + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is + Constrained_List : List_Id; + Unconstrained_List : List_Id; + Current_Parameter : Node_Id; + + begin + if not Present (Parameter_Specifications (Spec)) then + return New_List; + end if; + + Constrained_List := New_List; + Unconstrained_List := New_List; + + -- Loop through the parameters and add them to the right list + + Current_Parameter := First (Parameter_Specifications (Spec)); + while Current_Parameter /= Empty loop + + if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition + or else + Is_Constrained (Etype (Parameter_Type (Current_Parameter))) + or else + Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))) + then + Append_To (Constrained_List, New_Copy (Current_Parameter)); + else + Append_To (Unconstrained_List, New_Copy (Current_Parameter)); + end if; + + Next (Current_Parameter); + end loop; + + -- Unconstrained parameters are returned first + + Append_List_To (Unconstrained_List, Constrained_List); + + return Unconstrained_List; + + end Build_Ordered_Parameters_List; + + ---------------------------------- + -- Build_Passive_Partition_Stub -- + ---------------------------------- + + procedure Build_Passive_Partition_Stub (U : Node_Id) is + Pkg_Spec : Node_Id; + L : List_Id; + Reg : Node_Id; + Loc : constant Source_Ptr := Sloc (U); + Dist_OK : Entity_Id; + + begin + -- Verify that the implementation supports distribution, by accessing + -- a type defined in the proper version of system.rpc + + Dist_OK := RTE (RE_Params_Stream_Type); + + -- Use body if present, spec otherwise + + if Nkind (U) = N_Package_Declaration then + Pkg_Spec := Specification (U); + L := Visible_Declarations (Pkg_Spec); + else + Pkg_Spec := Parent (Corresponding_Spec (U)); + L := Declarations (U); + end if; + + Reg := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version))); + Append_To (L, Reg); + Analyze (Reg); + end Build_Passive_Partition_Stub; + + ------------------------------------ + -- Build_Subprogram_Calling_Stubs -- + ------------------------------------ + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Int; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Target_Partition : Node_Id; + -- Contains the name of the target partition + + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + + Subp_Spec : Node_Id; + -- The specification of the body + + Controlling_Parameter : Entity_Id := Empty; + RPC_Receiver : Node_Id; + + Asynchronous_Expr : Node_Id := Empty; + + RCI_Locator : Entity_Id; + + Spec_To_Use : Node_Id; + + procedure Insert_Partition_Check (Parameter : in Node_Id); + -- Check that the parameter has been elaborated on the same partition + -- than the controlling parameter (E.4(19)). + + ---------------------------- + -- Insert_Partition_Check -- + ---------------------------- + + procedure Insert_Partition_Check (Parameter : in Node_Id) is + Parameter_Entity : constant Entity_Id := + Defining_Identifier (Parameter); + Designated_Object : Node_Id; + Condition : Node_Id; + + begin + -- The expression that will be built is of the form: + -- if not (Parameter in Stub_Type and then + -- Parameter.Origin = Controlling.Origin) + -- then + -- raise Constraint_Error; + -- end if; + -- + -- Condition contains the reversed condition. Also, Parameter is + -- dereferenced if it is an access type. We do not check that + -- Parameter is in Stub_Type since such a check has been inserted + -- at the point of call already (a tag check since we have multiple + -- controlling operands). + + if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then + Designated_Object := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Parameter_Entity, Loc)); + else + Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc); + end if; + + Condition := + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Parameter_Entity, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin))); + + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, Right_Opnd => Condition))); + end Insert_Partition_Check; + + -- Start of processing for Build_Subprogram_Calling_Stubs + + begin + Target_Partition := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Subp_Spec := Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); + + if Locator = Empty then + RCI_Locator := RCI_Cache; + Spec_To_Use := Specification (Vis_Decl); + else + RCI_Locator := Locator; + Spec_To_Use := Subp_Spec; + end if; + + -- Find a controlling argument if we have a stub type. Also check + -- if this subprogram can be made asynchronous. + + if Stub_Type /= Empty + and then Present (Parameter_Specifications (Spec_To_Use)) + then + declare + Current_Parameter : Node_Id := + First (Parameter_Specifications + (Spec_To_Use)); + begin + while Current_Parameter /= Empty loop + + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + if Controlling_Parameter = Empty then + Controlling_Parameter := + Defining_Identifier (Current_Parameter); + else + Insert_Partition_Check (Current_Parameter); + end if; + end if; + + Next (Current_Parameter); + end loop; + end; + end if; + + if Stub_Type /= Empty then + pragma Assert (Controlling_Parameter /= Empty); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin)))); + + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)); + + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_Active_Partition_ID))))); + + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); + end if; + + if Dynamically_Asynchronous then + Asynchronous_Expr := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Asynchronous)); + end if; + + Build_General_Calling_Stubs + (Decls => Decls, + Statements => Statements, + Target_Partition => Target_Partition, + RPC_Receiver => RPC_Receiver, + Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id), + Asynchronous => Asynchronous_Expr, + Is_Known_Asynchronous => Asynchronous + and then not Dynamically_Asynchronous, + Is_Known_Non_Asynchronous + => not Asynchronous + and then not Dynamically_Asynchronous, + Is_Function => Nkind (Spec_To_Use) = + N_Function_Specification, + Spec => Spec_To_Use, + Object_Type => Stub_Type, + Nod => Vis_Decl); + + RCI_Calling_Stubs_Table.Set + (Defining_Unit_Name (Specification (Vis_Decl)), + Defining_Unit_Name (Spec_To_Use)); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements)); + end Build_Subprogram_Calling_Stubs; + + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Stream_Parameter : Node_Id; + Result_Parameter : Node_Id; + -- See explanations of those in Build_Subprogram_Calling_Stubs + + Decls : List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. + + Statements : List_Id := New_List; + + Extra_Formal_Statements : List_Id := New_List; + -- Statements concerning extra formal parameters + + After_Statements : List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handler : Node_Id; + Excep_Choice : Entity_Id; + Excep_Code : List_Id; + + Parameter_List : List_Id := New_List; + -- List of parameters to be passed to the subprogram. + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Specification (Vis_Decl)); + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call + + Null_Raise_Statement : Node_Id; + + Dynamic_Async : Entity_Id; + + begin + if RACW_Type /= Empty then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + if Dynamically_Asynchronous then + Dynamic_Async := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + else + Dynamic_Async := Empty; + end if; + + if not Asynchronous or else Dynamically_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + -- The first statement after the subprogram call is a statement to + -- writes a Null_Occurrence into the result stream. + + Null_Raise_Statement := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); + + if Dynamically_Asynchronous then + Null_Raise_Statement := + Make_Implicit_If_Statement (Vis_Decl, + Condition => + Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => New_List (Null_Raise_Statement)); + end if; + + Append_To (After_Statements, Null_Raise_Statement); + + else + Result_Parameter := Empty; + end if; + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + + while Current_Parameter /= Empty loop + + declare + Etyp : Entity_Id; + Constrained : Boolean; + Object : Entity_Id; + Expr : Node_Id := Empty; + + begin + Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Set_Ekind (Object, E_Variable); + + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + -- We have a controlling formal parameter. Read its address + -- rather than a real object. The address is in Unsigned_64 + -- form. + + Etyp := RTE (RE_Unsigned_64); + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + -- If an input parameter is contrained, then its reading is + -- deferred until the beginning of the subprogram body. If + -- it is unconstrained, then an expression is built for + -- the object declaration and the variable is set using + -- 'Input instead of 'Read. + + if Constrained then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Object, Loc)))); + + else + Expr := Input_With_Tag_Check (Loc, + Var_Type => Etyp, + Stream => Stream_Parameter); + Append_To (Decls, Expr); + Expr := Make_Function_Call (Loc, + New_Occurrence_Of (Defining_Unit_Name + (Specification (Expr)), Loc)); + end if; + end if; + + -- If we do not have to output the current parameter, then + -- it can well be flagged as constant. This may allow further + -- optimizations done by the back end. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => + not Constrained and then not Out_Present (Current_Parameter), + Object_Definition => + New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Stub_Type + then + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Object, Loc)))); + end if; + + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))) + then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Formal_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Formal_Entity, Loc)))); + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list at the end of regular statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a variable. + + declare + Etyp : constant Entity_Id := + Etype (Subtype_Mark (Specification (Vis_Decl))); + Result : constant Node_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Result, Loc)))); + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. + + if Dynamically_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dynamic_Async, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Dynamic_Async, Loc)))); + end if; + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + + end if; + + if Asynchronous and then not Dynamically_Asynchronous then + + -- An asynchronous procedure does not want a Result + -- parameter. Also, we put an exception handler with an others + -- clause that does nothing. + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); + + Excep_Handler := + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Null_Statement (Loc))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is copied into the output stream and + -- no other output parameter is written. + + Excep_Choice := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Excep_Code := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Excep_Choice, Loc)))); + + if Dynamically_Asynchronous then + Excep_Code := New_List ( + Make_Implicit_If_Statement (Vis_Decl, + Condition => Make_Op_Not (Loc, + New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => Excep_Code)); + end if; + + Excep_Handler := + Make_Exception_Handler (Loc, + Choice_Parameter => Excep_Choice, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => Excep_Code); + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Result_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements, + Exception_Handlers => New_List (Excep_Handler))); + + end Build_Subprogram_Receiving_Stubs; + + ------------------------ + -- Copy_Specification -- + ------------------------ + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Stub_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id + is + Parameters : List_Id := No_List; + + Current_Parameter : Node_Id; + Current_Type : Node_Id; + + Name_For_New_Spec : Name_Id; + + New_Identifier : Entity_Id; + + begin + if New_Name = No_Name then + Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); + else + Name_For_New_Spec := New_Name; + end if; + + if Present (Parameter_Specifications (Spec)) then + + Parameters := New_List; + Current_Parameter := First (Parameter_Specifications (Spec)); + + while Current_Parameter /= Empty loop + + Current_Type := Parameter_Type (Current_Parameter); + + if Nkind (Current_Type) = N_Access_Definition then + if Object_Type = Empty then + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype ( + Subtype_Mark (Current_Type)), Loc)); + else + pragma Assert + (Root_Type (Etype (Subtype_Mark (Current_Type))) + = Root_Type (Object_Type)); + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); + end if; + + elsif Object_Type /= Empty + and then Etype (Current_Type) = Object_Type + then + Current_Type := New_Occurrence_Of (Stub_Type, Loc); + + else + Current_Type := New_Occurrence_Of (Etype (Current_Type), Loc); + end if; + + New_Identifier := Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (Current_Parameter))); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Identifier, + Parameter_Type => Current_Type, + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Next (Current_Parameter); + end loop; + end if; + + if Nkind (Spec) = N_Function_Specification then + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters, + Subtype_Mark => + New_Occurrence_Of (Etype (Subtype_Mark (Spec)), Loc)); + + else + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters); + end if; + + end Copy_Specification; + + --------------------------- + -- Could_Be_Asynchronous -- + --------------------------- + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is + Current_Parameter : Node_Id; + + begin + if Present (Parameter_Specifications (Spec)) then + Current_Parameter := First (Parameter_Specifications (Spec)); + while Current_Parameter /= Empty loop + if Out_Present (Current_Parameter) then + return False; + end if; + + Next (Current_Parameter); + end loop; + end if; + + return True; + end Could_Be_Asynchronous; + + --------------------------------------------- + -- Expand_All_Calls_Remote_Subprogram_Call -- + --------------------------------------------- + + procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is + Called_Subprogram : constant Entity_Id := Entity (Name (N)); + RCI_Package : constant Entity_Id := Scope (Called_Subprogram); + Loc : constant Source_Ptr := Sloc (N); + RCI_Locator : Node_Id; + RCI_Cache : Entity_Id; + Calling_Stubs : Node_Id; + E_Calling_Stubs : Entity_Id; + + begin + E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); + + if E_Calling_Stubs = Empty then + RCI_Cache := RCI_Locator_Table.Get (RCI_Package); + + if RCI_Cache = Empty then + RCI_Locator := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); + + -- The RCI_Locator package is inserted at the top level in the + -- current unit, and must appear in the proper scope, so that it + -- is not prematurely removed by the GCC back-end. + + declare + Scop : Entity_Id := Cunit_Entity (Current_Sem_Unit); + + begin + if Ekind (Scop) = E_Package_Body then + New_Scope (Spec_Entity (Scop)); + + elsif Ekind (Scop) = E_Subprogram_Body then + New_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); + + else + New_Scope (Scop); + end if; + + Analyze (RCI_Locator); + Pop_Scope; + end; + + RCI_Cache := Defining_Unit_Name (RCI_Locator); + + else + RCI_Locator := Parent (RCI_Cache); + end if; + + Calling_Stubs := Build_Subprogram_Calling_Stubs + (Vis_Decl => Parent (Parent (Called_Subprogram)), + Subp_Id => Get_Subprogram_Id (Called_Subprogram), + Asynchronous => Nkind (N) = N_Procedure_Call_Statement + and then + Is_Asynchronous (Called_Subprogram), + Locator => RCI_Cache, + New_Name => New_Internal_Name ('S')); + Insert_After (RCI_Locator, Calling_Stubs); + Analyze (Calling_Stubs); + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); + end if; + + Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); + end Expand_All_Calls_Remote_Subprogram_Call; + + --------------------------------- + -- Expand_Calling_Stubs_Bodies -- + --------------------------------- + + procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is + Spec : constant Node_Id := Specification (Unit_Node); + Decls : constant List_Id := Visible_Declarations (Spec); + + begin + New_Scope (Scope_Of_Spec (Spec)); + Add_Calling_Stubs_To_Declarations (Specification (Unit_Node), + Decls); + Pop_Scope; + end Expand_Calling_Stubs_Bodies; + + ----------------------------------- + -- Expand_Receiving_Stubs_Bodies -- + ----------------------------------- + + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is + Spec : Node_Id; + Decls : List_Id; + Temp : List_Id; + + begin + if Nkind (Unit_Node) = N_Package_Declaration then + Spec := Specification (Unit_Node); + Decls := Visible_Declarations (Spec); + New_Scope (Scope_Of_Spec (Spec)); + Add_Receiving_Stubs_To_Declarations (Spec, Decls); + + else + Spec := + Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); + Decls := Declarations (Unit_Node); + New_Scope (Scope_Of_Spec (Unit_Node)); + Temp := New_List; + Add_Receiving_Stubs_To_Declarations (Spec, Temp); + Insert_List_Before (First (Decls), Temp); + end if; + + Pop_Scope; + end Expand_Receiving_Stubs_Bodies; + + ---------------------------- + -- Get_Pkg_Name_string_Id -- + ---------------------------- + + function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is + Unit_Name_Id : Unit_Name_Type := Get_Unit_Name (Decl_Node); + + begin + Get_Unit_Name_String (Unit_Name_Id); + + -- Remove seven last character (" (spec)" or " (body)"). + + Name_Len := Name_Len - 7; + pragma Assert (Name_Buffer (Name_Len + 1) = ' '); + + return Get_String_Id (Name_Buffer (1 .. Name_Len)); + end Get_Pkg_Name_String_Id; + + ------------------- + -- Get_String_Id -- + ------------------- + + function Get_String_Id (Val : String) return String_Id is + begin + Start_String; + Store_String_Chars (Val); + return End_String; + end Get_String_Id; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Entity_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + -------------------------- + -- Input_With_Tag_Check -- + -------------------------- + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Entity_Id) + return Node_Id + is + begin + return + Make_Subprogram_Body (Loc, + Specification => Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Tag_Check (Loc, + Make_Return_Statement (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Var_Type, Loc), + Attribute_Name => Name_Input, + Expressions => + New_List (New_Occurrence_Of (Stream, Loc)))))))); + end Input_With_Tag_Check; + + -------------------------------- + -- Is_RACW_Controlling_Formal -- + -------------------------------- + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; + Stub_Type : Entity_Id) + return Boolean + is + Typ : Entity_Id; + + begin + -- If the kind of the parameter is E_Void, then it is not a + -- controlling formal (this can happen in the context of RAS). + + if Ekind (Defining_Identifier (Parameter)) = E_Void then + return False; + end if; + + -- If the parameter is not a controlling formal, then it cannot + -- be possibly a RACW_Controlling_Formal. + + if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then + return False; + end if; + + Typ := Parameter_Type (Parameter); + return (Nkind (Typ) = N_Access_Definition + and then Etype (Subtype_Mark (Typ)) = Stub_Type) + or else Etype (Typ) = Stub_Type; + end Is_RACW_Controlling_Formal; + + -------------------- + -- Make_Tag_Check -- + -------------------- + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is + Occ : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + begin + return Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (N), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Choice_Parameter => Occ, + + Exception_Choices => + New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), + + Statements => + New_List (Make_Procedure_Call_Statement (Loc, + New_Occurrence_Of + (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), + New_List (New_Occurrence_Of (Occ, Loc)))))))); + end Make_Tag_Check; + + ---------------------------- + -- Need_Extra_Constrained -- + ---------------------------- + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is + Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); + + begin + return Out_Present (Parameter) + and then Has_Discriminants (Etyp) + and then not Is_Constrained (Etyp) + and then not Is_Indefinite_Subtype (Etyp); + end Need_Extra_Constrained; + + ------------------------------------ + -- Pack_Entity_Into_Stream_Access -- + ------------------------------------ + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) + return Node_Id + is + Typ : Entity_Id; + + begin + if Etyp /= Empty then + Typ := Etyp; + else + Typ := Etype (Object); + end if; + + return + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream, + Object => New_Occurrence_Of (Object, Loc), + Etyp => Typ); + end Pack_Entity_Into_Stream_Access; + + --------------------------- + -- Pack_Node_Into_Stream -- + --------------------------- + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream, Loc), + Attribute_Name => Name_Access), + Object)); + end Pack_Node_Into_Stream; + + ---------------------------------- + -- Pack_Node_Into_Stream_Access -- + ---------------------------------- + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + New_Occurrence_Of (Stream, Loc), + Object)); + end Pack_Node_Into_Stream_Access; + + ------------------------------- + -- RACW_Type_Is_Asynchronous -- + ------------------------------- + + procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is + N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (N /= Empty); + + begin + Replace (N, New_Occurrence_Of (Standard_True, Sloc (N))); + end RACW_Type_Is_Asynchronous; + + ------------------------- + -- RCI_Package_Locator -- + ------------------------- + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) + return Node_Id + is + Inst : constant Node_Id := + Make_Package_Instantiation (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('R')), + Name => + New_Occurrence_Of (RTE (RE_RCI_Info), Loc), + Generic_Associations => New_List ( + Make_Generic_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_RCI_Name), + Explicit_Generic_Actual_Parameter => + Make_String_Literal (Loc, + Strval => Get_Pkg_Name_String_Id (Package_Spec))))); + + begin + RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec), + Defining_Unit_Name (Inst)); + return Inst; + end RCI_Package_Locator; + + ----------------------------------------------- + -- Remote_Types_Tagged_Full_View_Encountered -- + ----------------------------------------------- + + procedure Remote_Types_Tagged_Full_View_Encountered + (Full_View : in Entity_Id) + is + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Full_View); + + begin + if Stub_Elements /= Empty_Stub_Structure then + Add_RACW_Primitive_Declarations_And_Bodies + (Full_View, + Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)), + List_Containing (Declaration_Node (Full_View))); + end if; + end Remote_Types_Tagged_Full_View_Encountered; + + ------------------- + -- Scope_Of_Spec -- + ------------------- + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is + Unit_Name : Node_Id := Defining_Unit_Name (Spec); + + begin + while Nkind (Unit_Name) /= N_Defining_Identifier loop + Unit_Name := Defining_Identifier (Unit_Name); + end loop; + + return Unit_Name; + end Scope_Of_Spec; + +end Exp_Dist; diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads new file mode 100644 index 00000000000..e66dceccca7 --- /dev/null +++ b/gcc/ada/exp_dist.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ -- +-- -- +-- Copyright (C) 1992-1998 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains utility routines used for the generation of the +-- stubs relevant to the distribution annex. + +with Types; use Types; + +package Exp_Dist is + + procedure Add_RAST_Features (Vis_Decl : in Node_Id); + -- Build and add bodies for dereference and 'Access subprograms for a + -- remote access to subprogram type. Vis_Decl is the declaration node for + -- the RAS type. + + procedure Add_RACW_Features (RACW_Type : in Entity_Id); + -- Add RACW features. If the RACW and the designated type are not in the + -- same scope, then Add_RACW_Primitive_Declarations_And_Bodies is called + -- automatically since we do know the primitive list already. + + procedure Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type : in Entity_Id; + Insertion_Node : in Node_Id; + Decls : in List_Id); + -- Add primitive for the stub type, and the RPC receiver. The declarations + -- are inserted after insertion_Node, while the bodies are appened at the + -- end of Decls. + + procedure Remote_Types_Tagged_Full_View_Encountered + (Full_View : in Entity_Id); + -- When a full view with a private view is encountered in a Remote_Types + -- package and corresponds to a tagged type, then this procedure is called + -- to generate the needed RACW features if it is needed. + + procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id); + -- This subprogram must be called when it is detected that the RACW type + -- is asynchronous. + + procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id); + -- Call the expansion phase for the calling stubs. The code will be added + -- at the end of the compilation unit, which is a package spec. + + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id); + -- Call the expansion phase for the calling stubs. The code will be added + -- at the end of the compilation unit, which may be either a package spec + -- or a package body. + + procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id); + -- Rewrite a call to a subprogram located in a Remote_Call_Interface + -- package on which the pragma All_Calls_Remote applies so that it + -- goes through the PCS. N is either an N_Procedure_Call_Statement + -- or an N_Function_Call node. + + procedure Build_Passive_Partition_Stub (U : Node_Id); + -- Build stub for a shared passive package. U is the analyzed + -- compilation unit for a package declaration. + +end Exp_Dist; diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb new file mode 100644 index 00000000000..656173f47f1 --- /dev/null +++ b/gcc/ada/exp_fixd.adb @@ -0,0 +1,2340 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ F I X D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.54 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_Fixd is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- General note; in this unit, a number of routines are driven by the + -- types (Etype) of their operands. Since we are dealing with unanalyzed + -- expressions as they are constructed, the Etypes would not normally be + -- set, but the construction routines that we use in this unit do in fact + -- set the Etype values correctly. In addition, setting the Etype ensures + -- that the analyzer does not try to redetermine the type when the node + -- is analyzed (which would be wrong, since in the case where we set the + -- Treat_Fixed_As_Integer or Conversion_OK flags, it would think it was + -- still dealing with a normal fixed-point operation and mess it up). + + function Build_Conversion + (N : Node_Id; + Typ : Entity_Id; + Expr : Node_Id; + Rchk : Boolean := False) + return Node_Id; + -- Build an expression that converts the expression Expr to type Typ, + -- taking the source location from Sloc (N). If the conversions involve + -- fixed-point types, then the Conversion_OK flag will be set so that the + -- resulting conversions do not get re-expanded. On return the resulting + -- node has its Etype set. If Rchk is set, then Do_Range_Check is set + -- in the resulting conversion node. + + function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Divide node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands + -- are either both Long_Long_Float, in which case Build_Divide differs + -- from Make_Op_Divide only in that the Etype of the resulting node is + -- set (to Long_Long_Float), or they can be integer types. In this case + -- the integer types need not be the same, and Build_Divide converts + -- the operand with the smaller sized type to match the type of the + -- other operand and sets this as the result type. The Rounded_Result + -- flag of the result in this case is set from the Rounded_Result flag + -- of node N. On return, the resulting node is analyzed, and has its + -- Etype set. + + function Build_Double_Divide + (N : Node_Id; + X, Y, Z : Node_Id) + return Node_Id; + -- Returns a node corresponding to the value X/(Y*Z) using the source + -- location from Sloc (N). The division is rounded if the Rounded_Result + -- flag of N is set. The integer types of X, Y, Z may be different. On + -- return the resulting node is analyzed, and has its Etype set. + + procedure Build_Double_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id); + -- Generates a sequence of code for determining the quotient and remainder + -- of the division X/(Y*Z), using the source location from Sloc (N). + -- Entities of appropriate types are allocated for the quotient and + -- remainder and returned in Qnn and Rnn. The result is rounded if + -- the Rounded_Result flag of N is set. The Etype fields of Qnn and Rnn + -- are appropriately set on return. + + function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Multiply node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands + -- are either both Long_Long_Float, in which case Build_Divide differs + -- from Make_Op_Multiply only in that the Etype of the resulting node is + -- set (to Long_Long_Float), or they can be integer types. In this case + -- the integer types need not be the same, and Build_Multiply chooses + -- a type long enough to hold the product (i.e. twice the size of the + -- longer of the two operand types), and both operands are converted + -- to this type. The Etype of the result is also set to this value. + -- However, the result can never overflow Integer_64, so this is the + -- largest type that is ever generated. On return, the resulting node + -- is analyzed and has its Etype set. + + function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Rem node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands + -- are both integer types, which need not be the same. Build_Rem + -- converts the operand with the smaller sized type to match the type + -- of the other operand and sets this as the result type. The result + -- is never rounded (rem operations cannot be rounded in any case!) + -- On return, the resulting node is analyzed and has its Etype set. + + function Build_Scaled_Divide + (N : Node_Id; + X, Y, Z : Node_Id) + return Node_Id; + -- Returns a node corresponding to the value X*Y/Z using the source + -- location from Sloc (N). The division is rounded if the Rounded_Result + -- flag of N is set. The integer types of X, Y, Z may be different. On + -- return the resulting node is analyzed and has is Etype set. + + procedure Build_Scaled_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id); + -- Generates a sequence of code for determining the quotient and remainder + -- of the division X*Y/Z, using the source location from Sloc (N). Entities + -- of appropriate types are allocated for the quotient and remainder and + -- returned in Qnn and Rrr. The integer types for X, Y, Z may be different. + -- The division is rounded if the Rounded_Result flag of N is set. The + -- Etype fields of Qnn and Rnn are appropriately set on return. + + procedure Do_Divide_Fixed_Fixed (N : Node_Id); + -- Handles expansion of divide for case of two fixed-point operands + -- (neither of them universal), with an integer or fixed-point result. + -- N is the N_Op_Divide node to be expanded. + + procedure Do_Divide_Fixed_Universal (N : Node_Id); + -- Handles expansion of divide for case of a fixed-point operand divided + -- by a universal real operand, with an integer or fixed-point result. N + -- is the N_Op_Divide node to be expanded. + + procedure Do_Divide_Universal_Fixed (N : Node_Id); + -- Handles expansion of divide for case of a universal real operand + -- divided by a fixed-point operand, with an integer or fixed-point + -- result. N is the N_Op_Divide node to be expanded. + + procedure Do_Multiply_Fixed_Fixed (N : Node_Id); + -- Handles expansion of multiply for case of two fixed-point operands + -- (neither of them universal), with an integer or fixed-point result. + -- N is the N_Op_Multiply node to be expanded. + + procedure Do_Multiply_Fixed_Universal (N : Node_Id; Left, Right : Node_Id); + -- Handles expansion of multiply for case of a fixed-point operand + -- multiplied by a universal real operand, with an integer or fixed- + -- point result. N is the N_Op_Multiply node to be expanded, and + -- Left, Right are the operands (which may have been switched). + + procedure Expand_Convert_Fixed_Static (N : Node_Id); + -- This routine is called where the node N is a conversion of a literal + -- or other static expression of a fixed-point type to some other type. + -- In such cases, we simply rewrite the operand as a real literal and + -- reanalyze. This avoids problems which would otherwise result from + -- attempting to build and fold expressions involving constants. + + function Fpt_Value (N : Node_Id) return Node_Id; + -- Given an operand of fixed-point operation, return an expression that + -- represents the corresponding Long_Long_Float value. The expression + -- can be of integer type, floating-point type, or fixed-point type. + -- The expression returned is neither analyzed and resolved. The Etype + -- of the result is properly set (to Long_Long_Float). + + function Integer_Literal (N : Node_Id; V : Uint) return Node_Id; + -- Given a non-negative universal integer value, build a typed integer + -- literal node, using the smallest applicable standard integer type. If + -- the value exceeds 2**63-1, the largest value allowed for perfect result + -- set scaling factors (see RM G.2.3(22)), then Empty is returned. The + -- node N provides the Sloc value for the constructed literal. The Etype + -- of the resulting literal is correctly set, and it is marked as analyzed. + + function Real_Literal (N : Node_Id; V : Ureal) return Node_Id; + -- Build a real literal node from the given value, the Etype of the + -- returned node is set to Long_Long_Float, since all floating-point + -- arithmetic operations that we construct use Long_Long_Float + + function Rounded_Result_Set (N : Node_Id) return Boolean; + -- Returns True if N is a node that contains the Rounded_Result flag + -- and if the flag is true. + + procedure Set_Result (N : Node_Id; Expr : Node_Id; Rchk : Boolean := False); + -- N is the node for the current conversion, division or multiplication + -- operation, and Expr is an expression representing the result. Expr + -- may be of floating-point or integer type. If the operation result + -- is fixed-point, then the value of Expr is in units of small of the + -- result type (i.e. small's have already been dealt with). The result + -- of the call is to replace N by an appropriate conversion to the + -- result type, dealing with rounding for the decimal types case. The + -- node is then analyzed and resolved using the result type. If Rchk + -- is True, then Do_Range_Check is set in the resulting conversion. + + ---------------------- + -- Build_Conversion -- + ---------------------- + + function Build_Conversion + (N : Node_Id; + Typ : Entity_Id; + Expr : Node_Id; + Rchk : Boolean := False) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Result : Node_Id; + Rcheck : Boolean := Rchk; + + begin + -- A special case, if the expression is an integer literal and the + -- target type is an integer type, then just retype the integer + -- literal to the desired target type. Don't do this if we need + -- a range check. + + if Nkind (Expr) = N_Integer_Literal + and then Is_Integer_Type (Typ) + and then not Rchk + then + Result := Expr; + + -- Cases where we end up with a conversion. Note that we do not use the + -- Convert_To abstraction here, since we may be decorating the resulting + -- conversion with Rounded_Result and/or Conversion_OK, so we want the + -- conversion node present, even if it appears to be redundant. + + else + -- Remove inner conversion if both inner and outer conversions are + -- to integer types, since the inner one serves no purpose (except + -- perhaps to set rounding, so we preserve the Rounded_Result flag) + -- and also we preserve the range check flag on the inner operand + + if Is_Integer_Type (Typ) + and then Is_Integer_Type (Etype (Expr)) + and then Nkind (Expr) = N_Type_Conversion + then + Result := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Expression (Expr)); + Set_Rounded_Result (Result, Rounded_Result_Set (Expr)); + Rcheck := Rcheck or Do_Range_Check (Expr); + + -- For all other cases, a simple type conversion will work + + else + Result := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Expr); + end if; + + -- Set Conversion_OK if either result or expression type is a + -- fixed-point type, since from a semantic point of view, we are + -- treating fixed-point values as integers at this stage. + + if Is_Fixed_Point_Type (Typ) + or else Is_Fixed_Point_Type (Etype (Expression (Result))) + then + Set_Conversion_OK (Result); + end if; + + -- Set Do_Range_Check if either it was requested by the caller, + -- or if an eliminated inner conversion had a range check. + + if Rcheck then + Enable_Range_Check (Result); + else + Set_Do_Range_Check (Result, False); + end if; + end if; + + Set_Etype (Result, Typ); + return Result; + + end Build_Conversion; + + ------------------ + -- Build_Divide -- + ------------------ + + function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Base_Type (Etype (L)); + Right_Type : constant Entity_Id := Base_Type (Etype (R)); + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + -- Deal with floating-point case first + + if Is_Floating_Point_Type (Left_Type) then + pragma Assert (Left_Type = Standard_Long_Long_Float); + pragma Assert (Right_Type = Standard_Long_Long_Float); + + Rnode := Make_Op_Divide (Loc, L, R); + Result_Type := Standard_Long_Long_Float; + + -- Integer and fixed-point cases + + else + -- An optimization. If the right operand is the literal 1, then we + -- can just return the left hand operand. Putting the optimization + -- here allows us to omit the check at the call site. + + if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then + return L; + end if; + + -- If left and right types are the same, no conversion needed + + if Left_Type = Right_Type then + Result_Type := Left_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => L, + Right_Opnd => R); + + -- Use left type if it is the larger of the two + + elsif Esize (Left_Type) >= Esize (Right_Type) then + Result_Type := Left_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => L, + Right_Opnd => Build_Conversion (N, Left_Type, R)); + + -- Otherwise right type is larger of the two, us it + + else + Result_Type := Right_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => Build_Conversion (N, Right_Type, L), + Right_Opnd => R); + end if; + end if; + + -- We now have a divide node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + -- The result is rounded if the target of the operation is decimal + -- and Rounded_Result is set, or if the target of the operation + -- is an integer type. + + if Is_Integer_Type (Etype (N)) + or else Rounded_Result_Set (N) + then + Set_Rounded_Result (Rnode); + end if; + + return Rnode; + + end Build_Divide; + + ------------------------- + -- Build_Double_Divide -- + ------------------------- + + function Build_Double_Divide + (N : Node_Id; + X, Y, Z : Node_Id) + return Node_Id + is + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); + Expr : Node_Id; + + begin + if Y_Size > System_Word_Size + or else + Z_Size > System_Word_Size + then + Disallow_In_No_Run_Time_Mode (N); + end if; + + -- If denominator fits in 64 bits, we can build the operations directly + -- without causing any intermediate overflow, so that's what we do! + + if Int'Max (Y_Size, Z_Size) <= 32 then + return + Build_Divide (N, X, Build_Multiply (N, Y, Z)); + + -- Otherwise we use the runtime routine + + -- [Qnn : Interfaces.Integer_64, + -- Rnn : Interfaces.Integer_64; + -- Double_Divide (X, Y, Z, Qnn, Rnn, Round); + -- Qnn] + + else + declare + Loc : constant Source_Ptr := Sloc (N); + Qnn : Entity_Id; + Rnn : Entity_Id; + Code : List_Id; + + begin + Build_Double_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); + Insert_Actions (N, Code); + Expr := New_Occurrence_Of (Qnn, Loc); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (Expr, Etype (Qnn)); + + -- Set result as analyzed (see note at start on build routines) + + return Expr; + end; + end if; + end Build_Double_Divide; + + ------------------------------ + -- Build_Double_Divide_Code -- + ------------------------------ + + -- If the denominator can be computed in 64-bits, we build + + -- [Nnn : constant typ := typ (X); + -- Dnn : constant typ := typ (Y) * typ (Z) + -- Qnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn / Dnn; + + -- If the numerator cannot be computed in 64 bits, we build + + -- [Qnn : typ; + -- Rnn : typ; + -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);] + + procedure Build_Double_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + X_Size : constant Int := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); + + QR_Siz : Int; + QR_Typ : Entity_Id; + + Nnn : Entity_Id; + Dnn : Entity_Id; + + Quo : Node_Id; + Rnd : Entity_Id; + + begin + -- Find type that will allow computation of numerator + + QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size)); + + if QR_Siz <= 16 then + QR_Typ := Standard_Integer_16; + elsif QR_Siz <= 32 then + QR_Typ := Standard_Integer_32; + elsif QR_Siz <= 64 then + QR_Typ := Standard_Integer_64; + + -- For more than 64, bits, we use the 64-bit integer defined in + -- Interfaces, so that it can be handled by the runtime routine + + else + QR_Typ := RTE (RE_Integer_64); + end if; + + -- Define quotient and remainder, and set their Etypes, so + -- that they can be picked up by Build_xxx routines. + + Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + Set_Etype (Qnn, QR_Typ); + Set_Etype (Rnn, QR_Typ); + + -- Case that we can compute the denominator in 64 bits + + if QR_Siz <= 64 then + + -- Create temporaries for numerator and denominator and set Etypes, + -- so that New_Occurrence_Of picks them up for Build_xxx calls. + + Nnn := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); + Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + + Set_Etype (Nnn, QR_Typ); + Set_Etype (Dnn, QR_Typ); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Nnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Build_Conversion (N, QR_Typ, X)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Multiply (N, + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z)))); + + Quo := + Build_Divide (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)); + + Set_Rounded_Result (Quo, Rounded_Result_Set (N)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Quo)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Rem (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)))); + + -- Case where denominator does not fit in 64 bits, so we have to + -- call the runtime routine to compute the quotient and remainder + + else + if Rounded_Result_Set (N) then + Rnd := Standard_True; + else + Rnd := Standard_False; + end if; + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Double_Divide), Loc), + Parameter_Associations => New_List ( + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z), + New_Occurrence_Of (Qnn, Loc), + New_Occurrence_Of (Rnn, Loc), + New_Occurrence_Of (Rnd, Loc)))); + end if; + + end Build_Double_Divide_Code; + + -------------------- + -- Build_Multiply -- + -------------------- + + function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Etype (L); + Right_Type : constant Entity_Id := Etype (R); + Rsize : Int; + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + -- Deal with floating-point case first + + if Is_Floating_Point_Type (Left_Type) then + pragma Assert (Left_Type = Standard_Long_Long_Float); + pragma Assert (Right_Type = Standard_Long_Long_Float); + + Result_Type := Standard_Long_Long_Float; + Rnode := Make_Op_Multiply (Loc, L, R); + + -- Integer and fixed-point cases + + else + -- An optimization. If the right operand is the literal 1, then we + -- can just return the left hand operand. Putting the optimization + -- here allows us to omit the check at the call site. Similarly, if + -- the left operand is the integer 1 we can return the right operand. + + if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then + return L; + elsif Nkind (L) = N_Integer_Literal and then Intval (L) = 1 then + return R; + end if; + + -- Otherwise we use a type that is at least twice the longer + -- of the two sizes. + + Rsize := 2 * Int'Max (UI_To_Int (Esize (Left_Type)), + UI_To_Int (Esize (Right_Type))); + + if Rsize <= 8 then + Result_Type := Standard_Integer_8; + + elsif Rsize <= 16 then + Result_Type := Standard_Integer_16; + + elsif Rsize <= 32 then + Result_Type := Standard_Integer_32; + + else + if Rsize > System_Word_Size then + Disallow_In_No_Run_Time_Mode (N); + end if; + + Result_Type := Standard_Integer_64; + end if; + + Rnode := + Make_Op_Multiply (Loc, + Left_Opnd => Build_Conversion (N, Result_Type, L), + Right_Opnd => Build_Conversion (N, Result_Type, R)); + end if; + + -- We now have a multiply node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + return Rnode; + end Build_Multiply; + + --------------- + -- Build_Rem -- + --------------- + + function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Etype (L); + Right_Type : constant Entity_Id := Etype (R); + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + if Left_Type = Right_Type then + Result_Type := Left_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => L, + Right_Opnd => R); + + -- If left size is larger, we do the remainder operation using the + -- size of the left type (i.e. the larger of the two integer types). + + elsif Esize (Left_Type) >= Esize (Right_Type) then + Result_Type := Left_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => L, + Right_Opnd => Build_Conversion (N, Left_Type, R)); + + -- Similarly, if the right size is larger, we do the remainder + -- operation using the right type. + + else + Result_Type := Right_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => Build_Conversion (N, Right_Type, L), + Right_Opnd => R); + end if; + + -- We now have an N_Op_Rem node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + -- One more check. We did the rem operation using the larger of the + -- two types, which is reasonable. However, in the case where the + -- two types have unequal sizes, it is impossible for the result of + -- a remainder operation to be larger than the smaller of the two + -- types, so we can put a conversion round the result to keep the + -- evolving operation size as small as possible. + + if Esize (Left_Type) >= Esize (Right_Type) then + Rnode := Build_Conversion (N, Right_Type, Rnode); + elsif Esize (Right_Type) >= Esize (Left_Type) then + Rnode := Build_Conversion (N, Left_Type, Rnode); + end if; + + return Rnode; + end Build_Rem; + + ------------------------- + -- Build_Scaled_Divide -- + ------------------------- + + function Build_Scaled_Divide + (N : Node_Id; + X, Y, Z : Node_Id) + return Node_Id + is + X_Size : constant Int := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Expr : Node_Id; + + begin + -- If numerator fits in 64 bits, we can build the operations directly + -- without causing any intermediate overflow, so that's what we do! + + if Int'Max (X_Size, Y_Size) <= 32 then + return + Build_Divide (N, Build_Multiply (N, X, Y), Z); + + -- Otherwise we use the runtime routine + + -- [Qnn : Integer_64, + -- Rnn : Integer_64; + -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round); + -- Qnn] + + else + declare + Loc : constant Source_Ptr := Sloc (N); + Qnn : Entity_Id; + Rnn : Entity_Id; + Code : List_Id; + + begin + Build_Scaled_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); + Insert_Actions (N, Code); + Expr := New_Occurrence_Of (Qnn, Loc); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (Expr, Etype (Qnn)); + return Expr; + end; + end if; + end Build_Scaled_Divide; + + ------------------------------ + -- Build_Scaled_Divide_Code -- + ------------------------------ + + -- If the numerator can be computed in 64-bits, we build + + -- [Nnn : constant typ := typ (X) * typ (Y); + -- Dnn : constant typ := typ (Z) + -- Qnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn / Dnn; + + -- If the numerator cannot be computed in 64 bits, we build + + -- [Qnn : Interfaces.Integer_64; + -- Rnn : Interfaces.Integer_64; + -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);] + + procedure Build_Scaled_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + X_Size : constant Int := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); + + QR_Siz : Int; + QR_Typ : Entity_Id; + + Nnn : Entity_Id; + Dnn : Entity_Id; + + Quo : Node_Id; + Rnd : Entity_Id; + + begin + -- Find type that will allow computation of numerator + + QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size)); + + if QR_Siz <= 16 then + QR_Typ := Standard_Integer_16; + elsif QR_Siz <= 32 then + QR_Typ := Standard_Integer_32; + elsif QR_Siz <= 64 then + QR_Typ := Standard_Integer_64; + + -- For more than 64, bits, we use the 64-bit integer defined in + -- Interfaces, so that it can be handled by the runtime routine + + else + QR_Typ := RTE (RE_Integer_64); + end if; + + -- Define quotient and remainder, and set their Etypes, so + -- that they can be picked up by Build_xxx routines. + + Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + Set_Etype (Qnn, QR_Typ); + Set_Etype (Rnn, QR_Typ); + + -- Case that we can compute the numerator in 64 bits + + if QR_Siz <= 64 then + Nnn := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); + Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + + -- Set Etypes, so that they can be picked up by New_Occurrence_Of + + Set_Etype (Nnn, QR_Typ); + Set_Etype (Dnn, QR_Typ); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Nnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Multiply (N, + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Build_Conversion (N, QR_Typ, Z))); + + Quo := + Build_Divide (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Quo)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Rem (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)))); + + -- Case where numerator does not fit in 64 bits, so we have to + -- call the runtime routine to compute the quotient and remainder + + else + if Rounded_Result_Set (N) then + Rnd := Standard_True; + else + Rnd := Standard_False; + end if; + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Scaled_Divide), Loc), + Parameter_Associations => New_List ( + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z), + New_Occurrence_Of (Qnn, Loc), + New_Occurrence_Of (Rnn, Loc), + New_Occurrence_Of (Rnd, Loc)))); + end if; + + -- Set type of result, for use in caller. + + Set_Etype (Qnn, QR_Typ); + end Build_Scaled_Divide_Code; + + --------------------------- + -- Do_Divide_Fixed_Fixed -- + --------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- (Left_Value * Left_Small) / (Right_Value * Right_Small) + + -- Result_Value = (Left_Value / Right_Value) * + -- (Left_Small / (Right_Small * Result_Small)); + + -- we can do the operation in integer arithmetic if this fraction is an + -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). + -- Otherwise the result is in the close result set and our approach is to + -- use floating-point to compute this close result. + + procedure Do_Divide_Fixed_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Left_Small : constant Ureal := Small_Value (Left_Type); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_Int : Node_Id; + + begin + -- Rounding is required if the result is integral + + if Is_Integer_Type (Result_Type) then + Set_Rounded_Result (N); + end if; + + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Get small ratio + + Frac := Left_Small / (Right_Small * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- If the fraction is an integer, then we get the result by multiplying + -- the left operand by the integer, and then dividing by the right + -- operand (the order is important, if we did the divide first, we + -- would lose precision). + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Right)); + return; + end if; + + -- If the fraction is the reciprocal of an integer, then we get the + -- result by first multiplying the divisor by the integer, and then + -- doing the division with the adjusted divisor. + + -- Note: this is much better than doing two divisions: multiplications + -- are much faster than divisions (and certainly faster than rounded + -- divisions), and we don't get inaccuracies from double rounding. + + elsif Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den); + + if Present (Lit_Int) then + Set_Result (N, Build_Double_Divide (N, Left, Right, Lit_Int)); + return; + end if; + end if; + + -- If we fall through, we use floating-point to compute the result + + Set_Result (N, + Build_Multiply (N, + Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, Frac))); + + end Do_Divide_Fixed_Fixed; + + ------------------------------- + -- Do_Divide_Fixed_Universal -- + ------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = (Left_Value * Left_Small) / Lit_Value; + -- Result_Value = Left_Value * Left_Small /(Lit_Value * Result_Small); + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Right_Small + -- Right_Small = Lit_Value / K + + -- such that the small ratio: + + -- Left_Small + -- ------------------------------ + -- (Lit_Value / K) * Result_Small + + -- Left_Small + -- = ------------------------ * K + -- Lit_Value * Result_Small + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms. + + -- If numerator = 1, then for K = 1, the small ratio is the reciprocal + -- of an integer, and this is clearly the minimum K case, so set K = 1, + -- Right_Small = Lit_Value. + + -- If numerator > 1, then set K to the denominator of the fraction so + -- that the resulting small ratio is an integer (the numerator value). + + procedure Do_Divide_Fixed_Universal (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Type : constant Entity_Id := Etype (Left); + Result_Type : constant Entity_Id := Etype (N); + Left_Small : constant Ureal := Small_Value (Left_Type); + Lit_Value : constant Ureal := Realval (Right); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := Left_Small / (Lit_Value * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is the reciprocal of an integer (K = 1, integer + -- = denominator). If this integer is not too large, this is the case + -- where the result can be obtained by dividing by this integer value. + + if Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den); + + if Present (Lit_Int) then + Set_Result (N, Build_Divide (N, Left, Lit_Int)); + return; + end if; + + -- Case where we choose K to make fraction an integer (K = denominator + -- of fraction, integer = numerator of fraction). If both K and the + -- numerator are small enough, this is the case where the result can + -- be obtained by first multiplying by the integer value and then + -- dividing by K (the order is important, if we divided first, we + -- would lose precision). + + else + Lit_Int := Integer_Literal (N, Frac_Num); + Lit_K := Integer_Literal (N, Frac_Den); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Lit_K)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point multiplication. + + Set_Result (N, + Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); + + end Do_Divide_Fixed_Universal; + + ------------------------------- + -- Do_Divide_Universal_Fixed -- + ------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- Lit_Value / (Right_Value * Right_Small) + -- Result_Value = + -- (Lit_Value / (Right_Small * Result_Small)) / Right_Value + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Left_Small + -- Left_Small = Lit_Value / K + + -- such that the small ratio: + + -- (Lit_Value / K) + -- -------------------------- + -- Right_Small * Result_Small + + -- Lit_Value 1 + -- = -------------------------- * - + -- Right_Small * Result_Small K + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms. + + -- If denominator = 1, then for K = 1, the small ratio is an integer + -- (the numerator) and this is clearly the minimum K case, so set K = 1, + -- and Left_Small = Lit_Value. + + -- If denominator > 1, then set K to the numerator of the fraction so + -- that the resulting small ratio is the reciprocal of an integer (the + -- numerator value). + + procedure Do_Divide_Universal_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Lit_Value : constant Ureal := Realval (Left); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := Lit_Value / (Right_Small * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is an integer (K = 1, integer = numerator). If + -- this integer is not too large, this is the case where the result + -- can be obtained by dividing this integer by the right operand. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) then + Set_Result (N, Build_Divide (N, Lit_Int, Right)); + return; + end if; + + -- Case where we choose K to make the fraction the reciprocal of an + -- integer (K = numerator of fraction, integer = numerator of fraction). + -- If both K and the integer are small enough, this is the case where + -- the result can be obtained by multiplying the right operand by K + -- and then dividing by the integer value. The order of the operations + -- is important (if we divided first, we would lose precision). + + else + Lit_Int := Integer_Literal (N, Frac_Den); + Lit_K := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Double_Divide (N, Lit_K, Right, Lit_Int)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point division. + + Set_Result (N, + Build_Divide (N, Real_Literal (N, Frac), Fpt_Value (Right))); + + end Do_Divide_Universal_Fixed; + + ----------------------------- + -- Do_Multiply_Fixed_Fixed -- + ----------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- (Left_Value * Left_Small) * (Right_Value * Right_Small) + + -- Result_Value = (Left_Value * Right_Value) * + -- (Left_Small * Right_Small) / Result_Small; + + -- we can do the operation in integer arithmetic if this fraction is an + -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). + -- Otherwise the result is in the close result set and our approach is to + -- use floating-point to compute this close result. + + procedure Do_Multiply_Fixed_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Left_Small : constant Ureal := Small_Value (Left_Type); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Get small ratio + + Frac := (Left_Small * Right_Small) / Result_Small; + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- If the fraction is an integer, then we get the result by multiplying + -- the operands, and then multiplying the result by the integer value. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) then + Set_Result (N, + Build_Multiply (N, Build_Multiply (N, Left, Right), + Lit_Int)); + return; + end if; + + -- If the fraction is the reciprocal of an integer, then we get the + -- result by multiplying the operands, and then dividing the result by + -- the integer value. The order of the operations is important, if we + -- divided first, we would lose precision. + + elsif Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den); + + if Present (Lit_Int) then + Set_Result (N, Build_Scaled_Divide (N, Left, Right, Lit_Int)); + return; + end if; + end if; + + -- If we fall through, we use floating-point to compute the result + + Set_Result (N, + Build_Multiply (N, + Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, Frac))); + + end Do_Multiply_Fixed_Fixed; + + --------------------------------- + -- Do_Multiply_Fixed_Universal -- + --------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = (Left_Value * Left_Small) * Lit_Value; + -- Result_Value = Left_Value * (Left_Small * Lit_Value) / Result_Small; + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Right_Small + -- Right_Small = Lit_Value / K + + -- such that the small ratio: + + -- Left_Small * (Lit_Value / K) + -- ---------------------------- + -- Result_Small + + -- Left_Small * Lit_Value 1 + -- = ---------------------- * - + -- Result_Small K + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms. + + -- If denominator = 1, then for K = 1, the small ratio is an + -- integer, and this is clearly the minimum K case, so set + -- K = 1, Right_Small = Lit_Value. + + -- If denominator > 1, then set K to the numerator of the + -- fraction, so that the resulting small ratio is the + -- reciprocal of the integer (the denominator value). + + procedure Do_Multiply_Fixed_Universal + (N : Node_Id; + Left, Right : Node_Id) + is + Left_Type : constant Entity_Id := Etype (Left); + Result_Type : constant Entity_Id := Etype (N); + Left_Small : constant Ureal := Small_Value (Left_Type); + Lit_Value : constant Ureal := Realval (Right); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := (Left_Small * Lit_Value) / Result_Small; + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is an integer (K = 1, integer = numerator). If + -- this integer is not too large, this is the case where the result can + -- be obtained by multiplying by this integer value. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) then + Set_Result (N, Build_Multiply (N, Left, Lit_Int)); + return; + end if; + + -- Case where we choose K to make fraction the reciprocal of an integer + -- (K = numerator of fraction, integer = denominator of fraction). If + -- both K and the denominator are small enough, this is the case where + -- the result can be obtained by first multiplying by K, and then + -- dividing by the integer value. + + else + Lit_Int := Integer_Literal (N, Frac_Den); + Lit_K := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_K, Lit_Int)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point multiplication. + + Set_Result (N, + Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); + + end Do_Multiply_Fixed_Universal; + + --------------------------------- + -- Expand_Convert_Fixed_Static -- + --------------------------------- + + procedure Expand_Convert_Fixed_Static (N : Node_Id) is + begin + Rewrite (N, + Convert_To (Etype (N), + Make_Real_Literal (Sloc (N), Expr_Value_R (Expression (N))))); + Analyze_And_Resolve (N); + end Expand_Convert_Fixed_Static; + + ----------------------------------- + -- Expand_Convert_Fixed_To_Fixed -- + ----------------------------------- + + -- We have: + + -- Result_Value * Result_Small = Source_Value * Source_Small + -- Result_Value = Source_Value * (Source_Small / Result_Small) + + -- If the small ratio (Source_Small / Result_Small) is a sufficiently small + -- integer, then the perfect result set is obtained by a single integer + -- multiplication. + + -- If the small ratio is the reciprocal of a sufficiently small integer, + -- then the perfect result set is obtained by a single integer division. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point. + + procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small_Ratio : Ureal; + Ratio_Num : Uint; + Ratio_Den : Uint; + Lit : Node_Id; + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + Small_Ratio := Small_Value (Source_Type) / Small_Value (Result_Type); + Ratio_Num := Norm_Num (Small_Ratio); + Ratio_Den := Norm_Den (Small_Ratio); + + if Ratio_Den = 1 then + + if Ratio_Num = 1 then + Set_Result (N, Expr); + return; + + else + Lit := Integer_Literal (N, Ratio_Num); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit)); + return; + end if; + end if; + + elsif Ratio_Num = 1 then + Lit := Integer_Literal (N, Ratio_Den); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small ratio not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small_Ratio)), + Rng_Check); + + end Expand_Convert_Fixed_To_Fixed; + + ----------------------------------- + -- Expand_Convert_Fixed_To_Float -- + ----------------------------------- + + -- If the small of the fixed type is 1.0, then we simply convert the + -- integer value directly to the target floating-point type, otherwise + -- we first have to multiply by the small, in Long_Long_Float, and then + -- convert the result to the target floating-point type. + + procedure Expand_Convert_Fixed_To_Float (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small : constant Ureal := Small_Value (Source_Type); + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + if Small = Ureal_1 then + Set_Result (N, Expr); + + else + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small)), + Rng_Check); + end if; + end Expand_Convert_Fixed_To_Float; + + ------------------------------------- + -- Expand_Convert_Fixed_To_Integer -- + ------------------------------------- + + -- We have: + + -- Result_Value = Source_Value * Source_Small + + -- If the small value is a sufficiently small integer, then the perfect + -- result set is obtained by a single integer multiplication. + + -- If the small value is the reciprocal of a sufficiently small integer, + -- then the perfect result set is obtained by a single integer division. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point. + + procedure Expand_Convert_Fixed_To_Integer (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small : constant Ureal := Small_Value (Source_Type); + Small_Num : constant Uint := Norm_Num (Small); + Small_Den : constant Uint := Norm_Den (Small); + Lit : Node_Id; + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + if Small_Den = 1 then + Lit := Integer_Literal (N, Small_Num); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); + return; + end if; + + elsif Small_Num = 1 then + Lit := Integer_Literal (N, Small_Den); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small value not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small)), + Rng_Check); + + end Expand_Convert_Fixed_To_Integer; + + ----------------------------------- + -- Expand_Convert_Float_To_Fixed -- + ----------------------------------- + + -- We have + + -- Result_Value * Result_Small = Operand_Value + + -- so compute: + + -- Result_Value = Operand_Value * (1.0 / Result_Small) + + -- We do the small scaling in floating-point, and we do a multiplication + -- rather than a division, since it is accurate enough for the perfect + -- result cases, and faster. + + procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Small : constant Ureal := Small_Value (Result_Type); + + begin + -- Optimize small = 1, where we can avoid the multiply completely + + if Small = Ureal_1 then + Set_Result (N, Expr, Rng_Check); + + -- Normal case where multiply is required + + else + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Ureal_1 / Small)), + Rng_Check); + end if; + end Expand_Convert_Float_To_Fixed; + + ------------------------------------- + -- Expand_Convert_Integer_To_Fixed -- + ------------------------------------- + + -- We have + + -- Result_Value * Result_Small = Operand_Value + -- Result_Value = Operand_Value / Result_Small + + -- If the small value is a sufficiently small integer, then the perfect + -- result set is obtained by a single integer division. + + -- If the small value is the reciprocal of a sufficiently small integer, + -- the perfect result set is obtained by a single integer multiplication. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point using a multiplication by the reciprocal + -- of the Result_Small. + + procedure Expand_Convert_Integer_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Small : constant Ureal := Small_Value (Result_Type); + Small_Num : constant Uint := Norm_Num (Small); + Small_Den : constant Uint := Norm_Den (Small); + Lit : Node_Id; + + begin + if Small_Den = 1 then + Lit := Integer_Literal (N, Small_Num); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + + elsif Small_Num = 1 then + Lit := Integer_Literal (N, Small_Den); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small value not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Ureal_1 / Small)), + Rng_Check); + + end Expand_Convert_Integer_To_Fixed; + + -------------------------------- + -- Expand_Decimal_Divide_Call -- + -------------------------------- + + -- We have four operands + + -- Dividend + -- Divisor + -- Quotient + -- Remainder + + -- All of which are decimal types, and which thus have associated + -- decimal scales. + + -- Computing the quotient is a similar problem to that faced by the + -- normal fixed-point division, except that it is simpler, because + -- we always have compatible smalls. + + -- Quotient = (Dividend / Divisor) * 10**q + + -- where 10 ** q = Dividend'Small / (Divisor'Small * Quotient'Small) + -- so q = Divisor'Scale + Quotient'Scale - Dividend'Scale + + -- For q >= 0, we compute + + -- Numerator := Dividend * 10 ** q + -- Denominator := Divisor + -- Quotient := Numerator / Denominator + + -- For q < 0, we compute + + -- Numerator := Dividend + -- Denominator := Divisor * 10 ** q + -- Quotient := Numerator / Denominator + + -- Both these divisions are done in truncated mode, and the remainder + -- from these divisions is used to compute the result Remainder. This + -- remainder has the effective scale of the numerator of the division, + + -- For q >= 0, the remainder scale is Dividend'Scale + q + -- For q < 0, the remainder scale is Dividend'Scale + + -- The result Remainder is then computed by a normal truncating decimal + -- conversion from this scale to the scale of the remainder, i.e. by a + -- division or multiplication by the appropriate power of 10. + + procedure Expand_Decimal_Divide_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Dividend : Node_Id := First_Actual (N); + Divisor : Node_Id := Next_Actual (Dividend); + Quotient : Node_Id := Next_Actual (Divisor); + Remainder : Node_Id := Next_Actual (Quotient); + + Dividend_Type : constant Entity_Id := Etype (Dividend); + Divisor_Type : constant Entity_Id := Etype (Divisor); + Quotient_Type : constant Entity_Id := Etype (Quotient); + Remainder_Type : constant Entity_Id := Etype (Remainder); + + Dividend_Scale : constant Uint := Scale_Value (Dividend_Type); + Divisor_Scale : constant Uint := Scale_Value (Divisor_Type); + Quotient_Scale : constant Uint := Scale_Value (Quotient_Type); + Remainder_Scale : constant Uint := Scale_Value (Remainder_Type); + + Q : Uint; + Numerator_Scale : Uint; + Stmts : List_Id; + Qnn : Entity_Id; + Rnn : Entity_Id; + Computed_Remainder : Node_Id; + Adjusted_Remainder : Node_Id; + Scale_Adjust : Uint; + + begin + -- Relocate the operands, since they are now list elements, and we + -- need to reference them separately as operands in the expanded code. + + Dividend := Relocate_Node (Dividend); + Divisor := Relocate_Node (Divisor); + Quotient := Relocate_Node (Quotient); + Remainder := Relocate_Node (Remainder); + + -- Now compute Q, the adjustment scale + + Q := Divisor_Scale + Quotient_Scale - Dividend_Scale; + + -- If Q is non-negative then we need a scaled divide + + if Q >= 0 then + Build_Scaled_Divide_Code + (N, + Dividend, + Integer_Literal (N, Uint_10 ** Q), + Divisor, + Qnn, Rnn, Stmts); + + Numerator_Scale := Dividend_Scale + Q; + + -- If Q is negative, then we need a double divide + + else + Build_Double_Divide_Code + (N, + Dividend, + Divisor, + Integer_Literal (N, Uint_10 ** (-Q)), + Qnn, Rnn, Stmts); + + Numerator_Scale := Dividend_Scale; + end if; + + -- Add statement to set quotient value + + -- Quotient := quotient-type!(Qnn); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Quotient, + Expression => + Unchecked_Convert_To (Quotient_Type, + Build_Conversion (N, Quotient_Type, + New_Occurrence_Of (Qnn, Loc))))); + + -- Now we need to deal with computing and setting the remainder. The + -- scale of the remainder is in Numerator_Scale, and the desired + -- scale is the scale of the given Remainder argument. There are + -- three cases: + + -- Numerator_Scale > Remainder_Scale + + -- in this case, there are extra digits in the computed remainder + -- which must be eliminated by an extra division: + + -- computed-remainder := Numerator rem Denominator + -- scale_adjust = Numerator_Scale - Remainder_Scale + -- adjusted-remainder := computed-remainder / 10 ** scale_adjust + + -- Numerator_Scale = Remainder_Scale + + -- in this case, the we have the remainder we need + + -- computed-remainder := Numerator rem Denominator + -- adjusted-remainder := computed-remainder + + -- Numerator_Scale < Remainder_Scale + + -- in this case, we have insufficient digits in the computed + -- remainder, which must be eliminated by an extra multiply + + -- computed-remainder := Numerator rem Denominator + -- scale_adjust = Remainder_Scale - Numerator_Scale + -- adjusted-remainder := computed-remainder * 10 ** scale_adjust + + -- Finally we assign the adjusted-remainder to the result Remainder + -- with conversions to get the proper fixed-point type representation. + + Computed_Remainder := New_Occurrence_Of (Rnn, Loc); + + if Numerator_Scale > Remainder_Scale then + Scale_Adjust := Numerator_Scale - Remainder_Scale; + Adjusted_Remainder := + Build_Divide + (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); + + elsif Numerator_Scale = Remainder_Scale then + Adjusted_Remainder := Computed_Remainder; + + else -- Numerator_Scale < Remainder_Scale + Scale_Adjust := Remainder_Scale - Numerator_Scale; + Adjusted_Remainder := + Build_Multiply + (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); + end if; + + -- Assignment of remainder result + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Remainder, + Expression => + Unchecked_Convert_To (Remainder_Type, Adjusted_Remainder))); + + -- Final step is to rewrite the call with a block containing the + -- above sequence of constructed statements for the divide operation. + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + + Analyze (N); + + end Expand_Decimal_Divide_Call; + + ----------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Fixed -- + ----------------------------------------------- + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + if Etype (Left) = Universal_Real then + Do_Divide_Universal_Fixed (N); + + elsif Etype (Right) = Universal_Real then + Do_Divide_Fixed_Universal (N); + + else + Do_Divide_Fixed_Fixed (N); + end if; + + end Expand_Divide_Fixed_By_Fixed_Giving_Fixed; + + ----------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Float -- + ----------------------------------------------- + + -- The division is done in long_long_float, and the result is multiplied + -- by the small ratio, which is Small (Right) / Small (Left). Special + -- treatment is required for universal operands, which represent their + -- own value and do not require conversion. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + + begin + -- Case of left operand is universal real, the result we want is: + + -- Left_Value / (Right_Value * Right_Small) + + -- so we compute this as: + + -- (Left_Value / Right_Small) / Right_Value + + if Left_Type = Universal_Real then + Set_Result (N, + Build_Divide (N, + Real_Literal (N, Realval (Left) / Small_Value (Right_Type)), + Fpt_Value (Right))); + + -- Case of right operand is universal real, the result we want is + + -- (Left_Value * Left_Small) / Right_Value + + -- so we compute this as: + + -- Left_Value * (Left_Small / Right_Value) + + -- Note we invert to a multiplication since usually floating-point + -- multiplication is much faster than floating-point division. + + elsif Right_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Left), + Real_Literal (N, Small_Value (Left_Type) / Realval (Right)))); + + -- Both operands are fixed, so the value we want is + + -- (Left_Value * Left_Small) / (Right_Value * Right_Small) + + -- which we compute as: + + -- (Left_Value / Right_Value) * (Left_Small / Right_Small) + + else + Set_Result (N, + Build_Multiply (N, + Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, + Small_Value (Left_Type) / Small_Value (Right_Type)))); + end if; + + end Expand_Divide_Fixed_By_Fixed_Giving_Float; + + ------------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Integer -- + ------------------------------------------------- + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + if Etype (Left) = Universal_Real then + Do_Divide_Universal_Fixed (N); + + elsif Etype (Right) = Universal_Real then + Do_Divide_Fixed_Universal (N); + + else + Do_Divide_Fixed_Fixed (N); + end if; + + end Expand_Divide_Fixed_By_Fixed_Giving_Integer; + + ------------------------------------------------- + -- Expand_Divide_Fixed_By_Integer_Giving_Fixed -- + ------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight divide by the right operand, the small can be ignored. + + procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + Set_Result (N, Build_Divide (N, Left, Right)); + end Expand_Divide_Fixed_By_Integer_Giving_Fixed; + + ------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- + ------------------------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + if Etype (Left) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Right, Left); + + elsif Etype (Right) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Left, Right); + + else + Do_Multiply_Fixed_Fixed (N); + end if; + + end Expand_Multiply_Fixed_By_Fixed_Giving_Fixed; + + ------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Float -- + ------------------------------------------------- + + -- The multiply is done in long_long_float, and the result is multiplied + -- by the adjustment for the smalls which is Small (Right) * Small (Left). + -- Special treatment is required for universal operands. + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + + begin + -- Case of left operand is universal real, the result we want is + + -- Left_Value * (Right_Value * Right_Small) + + -- so we compute this as: + + -- (Left_Value * Right_Small) * Right_Value; + + if Left_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Real_Literal (N, Realval (Left) * Small_Value (Right_Type)), + Fpt_Value (Right))); + + -- Case of right operand is universal real, the result we want is + + -- (Left_Value * Left_Small) * Right_Value + + -- so we compute this as: + + -- Left_Value * (Left_Small * Right_Value) + + elsif Right_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Left), + Real_Literal (N, Small_Value (Left_Type) * Realval (Right)))); + + -- Both operands are fixed, so the value we want is + + -- (Left_Value * Left_Small) * (Right_Value * Right_Small) + + -- which we compute as: + + -- (Left_Value * Right_Value) * (Right_Small * Left_Small) + + else + Set_Result (N, + Build_Multiply (N, + Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, + Small_Value (Right_Type) * Small_Value (Left_Type)))); + end if; + + end Expand_Multiply_Fixed_By_Fixed_Giving_Float; + + --------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Integer -- + --------------------------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + if Etype (Left) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Right, Left); + + elsif Etype (Right) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Left, Right); + + else + Do_Multiply_Fixed_Fixed (N); + end if; + + end Expand_Multiply_Fixed_By_Fixed_Giving_Integer; + + --------------------------------------------------- + -- Expand_Multiply_Fixed_By_Integer_Giving_Fixed -- + --------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight multiply by the right operand, the small can be ignored. + + procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is + begin + Set_Result (N, + Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); + end Expand_Multiply_Fixed_By_Integer_Giving_Fixed; + + --------------------------------------------------- + -- Expand_Multiply_Integer_By_Fixed_Giving_Fixed -- + --------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight multiply by the right operand, the small can be ignored. + + procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id) is + begin + Set_Result (N, + Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); + end Expand_Multiply_Integer_By_Fixed_Giving_Fixed; + + --------------- + -- Fpt_Value -- + --------------- + + function Fpt_Value (N : Node_Id) return Node_Id is + Typ : constant Entity_Id := Etype (N); + + begin + if Is_Integer_Type (Typ) + or else Is_Floating_Point_Type (Typ) + then + return + Build_Conversion + (N, Standard_Long_Long_Float, N); + + -- Fixed-point case, must get integer value first + + else + return + Build_Conversion (N, Standard_Long_Long_Float, N); + end if; + + end Fpt_Value; + + --------------------- + -- Integer_Literal -- + --------------------- + + function Integer_Literal (N : Node_Id; V : Uint) return Node_Id is + T : Entity_Id; + L : Node_Id; + + begin + if V < Uint_2 ** 7 then + T := Standard_Integer_8; + + elsif V < Uint_2 ** 15 then + T := Standard_Integer_16; + + elsif V < Uint_2 ** 31 then + T := Standard_Integer_32; + + elsif V < Uint_2 ** 63 then + T := Standard_Integer_64; + + else + return Empty; + end if; + + L := Make_Integer_Literal (Sloc (N), V); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (L, T); + Set_Is_Static_Expression (L); + + -- We really need to set Analyzed here because we may be creating a + -- very strange beast, namely an integer literal typed as fixed-point + -- and the analyzer won't like that. Probably we should allow the + -- Treat_Fixed_As_Integer flag to appear on integer literal nodes + -- and teach the analyzer how to handle them ??? + + Set_Analyzed (L); + return L; + + end Integer_Literal; + + ------------------ + -- Real_Literal -- + ------------------ + + function Real_Literal (N : Node_Id; V : Ureal) return Node_Id is + L : Node_Id; + + begin + L := Make_Real_Literal (Sloc (N), V); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (L, Standard_Long_Long_Float); + return L; + end Real_Literal; + + ------------------------ + -- Rounded_Result_Set -- + ------------------------ + + function Rounded_Result_Set (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + + begin + if (K = N_Type_Conversion or else + K = N_Op_Divide or else + K = N_Op_Multiply) + and then Rounded_Result (N) + then + return True; + else + return False; + end if; + end Rounded_Result_Set; + + ---------------- + -- Set_Result -- + ---------------- + + procedure Set_Result + (N : Node_Id; + Expr : Node_Id; + Rchk : Boolean := False) + is + Cnode : Node_Id; + + Expr_Type : constant Entity_Id := Etype (Expr); + Result_Type : constant Entity_Id := Etype (N); + + begin + -- No conversion required if types match and no range check + + if Result_Type = Expr_Type and then not Rchk then + Cnode := Expr; + + -- Else perform required conversion + + else + Cnode := Build_Conversion (N, Result_Type, Expr, Rchk); + end if; + + Rewrite (N, Cnode); + Analyze_And_Resolve (N, Result_Type); + + end Set_Result; + +end Exp_Fixd; diff --git a/gcc/ada/exp_fixd.ads b/gcc/ada/exp_fixd.ads new file mode 100644 index 00000000000..45f68df9d06 --- /dev/null +++ b/gcc/ada/exp_fixd.ads @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ F I X D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for fixed-point convert, divide and multiply operations + +with Types; use Types; + +package Exp_Fixd is + + -- General note on universal fixed. In the routines below, a fixed-point + -- type is always a specific fixed-point type or universal real, never + -- universal fixed. Universal fixed only appears as the result type of a + -- division or multplication and in all such cases, the parent node, which + -- must be either a conversion node or a 'Round attribute reference node, + -- has the specific type information. In both cases, the parent node is + -- removed from the tree, and the appropriate routine in this package is + -- called with a multiply or divide node with all types (and also possibly + -- the Rounded_Result flag) set. + + ---------------------------- + -- Fixed-Point Conversion -- + ---------------------------- + + procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id); + -- This routine expands the conversion of one fixed-point type to another, + -- N is the N_Op_Conversion node with the result and expression types (and + -- possibly the Rounded_Result flag) set. + + procedure Expand_Convert_Fixed_To_Float (N : Node_Id); + -- This routine expands the conversion from a fixed-point type to a + -- floating-point type. N is an N_Type_Conversion node with the result + -- and expression types set. + + procedure Expand_Convert_Fixed_To_Integer (N : Node_Id); + -- This routine expands the conversion from a fixed-point type to an + -- integer type. N is an N_Type_Conversion node with the result and + -- operand types set. + + procedure Expand_Convert_Float_To_Fixed (N : Node_Id); + -- This routine expands the conversion from a floating-point type to + -- a fixed-point type. N is an N_Type_Conversion node with the result + -- and operand types (and possibly the Rounded_Result flag) set. + + procedure Expand_Convert_Integer_To_Fixed (N : Node_Id); + -- This routine expands the conversion from an integer type to a + -- fixed-point type. N is an N_Type_Conversion node with the result + -- and operand types (and possibly the Rounded_Result flag) set. + + -------------------------- + -- Fixed-Point Division -- + -------------------------- + + procedure Expand_Decimal_Divide_Call (N : Node_Id); + -- This routine expands a call to the procedure Decimal.Divide. The + -- argument N is the N_Function_Call node. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id); + -- This routine expands the division between fixed-point types, with + -- a fixed-point type result. N is an N_Op_Divide node with operand + -- and result types (and possibly the Rounded_Result flag) set. Either + -- (but not both) of the operands may be universal real. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id); + -- This routine expands the division between two fixed-point types with + -- a floating-point result. N is an N_Op_Divide node with the result + -- and operand types set. Either (but not both) of the operands may be + -- universal real. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id); + -- This routine expands the division between two fixed-point types with + -- an integer type result. N is an N_Op_Divide node with the result and + -- operand types set. Either (but not both) of the operands may be + -- universal real. + + procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id); + -- This routine expands the division between a fixed-point type and + -- standard integer type. The result type is the same fixed-point type + -- as the operand type. N is an N_Op_Divide node with the result and + -- left operand types being the fixed-point type, and the right operand + -- type being standard integer (and possibly Rounded_Result set). + + -------------------------------- + -- Fixed-Point Multiplication -- + -------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id); + -- This routine expands the multiplication between fixed-point types + -- with a fixed-point type result. N is an N_Op_Multiply node with the + -- result and operand types set. Either (but not both) of the operands + -- may be universal real. + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id); + -- This routine expands the multiplication between two fixed-point types + -- with a floating-point result. N is an N_Op_Multiply node with the + -- result and operand types set. Either (but not both) of the operands + -- may be universal real. + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id); + -- This routine expands the multiplication between two fixed-point types + -- with an integer result. N is an N_Op_Multiply node with the result + -- and operand types set. Either (but not both) of the operands may be + -- be universal real. + + procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id); + -- This routine expands the multiplication between a fixed-point type and + -- a standard integer type. The result type is the same fixed-point type + -- as the fixed operand type. N is an N_Op_Multiply node whose result type + -- and left operand types are the fixed-point type, and whose right operand + -- type is always standard integer. + + procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id); + -- This routine expands the multiplication between standard integer and a + -- fixed-point type. The result type is the same fixed-point type as the + -- the fixed operand type. N is an N_Op_Multiply node whose result type + -- and right operand types are the fixed-point type, and whose left operand + -- type is always standard integer. + +end Exp_Fixd; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb new file mode 100644 index 00000000000..296d12daec6 --- /dev/null +++ b/gcc/ada/exp_imgv.adb @@ -0,0 +1,862 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I M G V -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 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 Casing; use Casing; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Res; use Sem_Res; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +package body Exp_Imgv is + + ------------------------------------ + -- Build_Enumeration_Image_Tables -- + ------------------------------------ + + procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (E); + Str : String_Id; + Ind : List_Id; + Lit : Entity_Id; + Nlit : Nat; + Len : Nat; + Estr : Entity_Id; + Eind : Entity_Id; + Ityp : Node_Id; + + begin + -- Nothing to do for other than a root enumeration type + + if E /= Root_Type (E) then + return; + + -- Nothing to do if pragma Discard_Names applies + + elsif Discard_Names (E) then + return; + end if; + + -- Otherwise tables need constructing + + Start_String; + Ind := New_List; + Lit := First_Literal (E); + Len := 1; + Nlit := 0; + + loop + Append_To (Ind, + Make_Integer_Literal (Loc, UI_From_Int (Len))); + + exit when No (Lit); + Nlit := Nlit + 1; + + Get_Unqualified_Decoded_Name_String (Chars (Lit)); + + if Name_Buffer (1) /= ''' then + Set_Casing (All_Upper_Case); + end if; + + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Len := Len + Int (Name_Len); + Next_Literal (Lit); + end loop; + + if Len < Int (2 ** (8 - 1)) then + Ityp := Standard_Integer_8; + elsif Len < Int (2 ** (16 - 1)) then + Ityp := Standard_Integer_16; + else + Ityp := Standard_Integer_32; + end if; + + Str := End_String; + + Estr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'S')); + + Eind := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'I')); + + Set_Lit_Strings (E, Estr); + Set_Lit_Indexes (E, Eind); + + Insert_Actions (N, + New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Estr, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => Str)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Eind, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 0), + High_Bound => Make_Integer_Literal (Loc, Nlit))), + Subtype_Indication => New_Occurrence_Of (Ityp, Loc)), + + Expression => + Make_Aggregate (Loc, + Expressions => Ind))), + Suppress => All_Checks); + + end Build_Enumeration_Image_Tables; + + ---------------------------- + -- Expand_Image_Attribute -- + ---------------------------- + + -- For all non-enumeration types, and for enumeration types declared + -- in packages Standard or System, typ'Image (Val) expands into: + + -- Image_xx (tp (Expr) [, pm]) + + -- The name xx and type conversion tp (Expr) (called tv below) depend on + -- the root type of Expr. The argument pm is an extra type dependent + -- parameter only used in some cases as follows: + + -- For types whose root type is Character + -- xx = Character + -- tv = Character (Expr) + + -- For types whose root type is Boolean + -- xx = Boolean + -- tv = Boolean (Expr) + + -- For signed integer types with size <= Integer'Size + -- xx = Integer + -- tv = Integer (Expr) + + -- For other signed integer types + -- xx = Long_Long_Integer + -- tv = Long_Long_Integer (Expr) + + -- For modular types with modulus <= System.Unsigned_Types.Unsigned + -- xx = Unsigned + -- tv = System.Unsigned_Types.Unsigned (Expr) + + -- For other modular integer types + -- xx = Long_Long_Unsigned + -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr) + + -- For types whose root type is Wide_Character + -- xx = Wide_Character + -- tv = Wide_Character (Expr) + -- pm = Wide_Character_Encoding_Method + + -- For floating-point types + -- xx = Floating_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Digits + + -- For ordinary fixed-point types + -- xx = Ordinary_Fixed_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Aft + + -- For decimal fixed-point types with size = Integer'Size + -- xx = Decimal + -- tv = Integer (Expr) + -- pm = typ'Scale + + -- For decimal fixed-point types with size > Integer'Size + -- xx = Long_Long_Decimal + -- tv = Long_Long_Integer (Expr) + -- pm = typ'Scale + + -- Note: for the decimal fixed-point type cases, the conversion is + -- done literally without scaling (i.e. the actual expression that + -- is generated is Image_xx (tp?(Expr) [, pm]) + + -- For enumeration types other than those declared packages Standard + -- or System, typ'Image (X) expands into: + + -- Image_Enumeration_NN (typ'Pos (X), typS, typI'Address) + + -- where typS and typI are the entities constructed as described in + -- the spec for the procedure Build_Enumeration_Image_Tables and NN + -- is 32/16/8 depending on the element type of Lit_Indexes. + + procedure Expand_Image_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Exprs : constant List_Id := Expressions (N); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Entity (Pref); + Rtyp : constant Entity_Id := Root_Type (Ptyp); + Expr : constant Node_Id := Relocate_Node (First (Exprs)); + Imid : RE_Id; + Tent : Entity_Id; + Arglist : List_Id; + Func : RE_Id; + Ttyp : Entity_Id; + + begin + if Rtyp = Standard_Boolean then + Imid := RE_Image_Boolean; + Tent := Rtyp; + + elsif Rtyp = Standard_Character then + Imid := RE_Image_Character; + Tent := Rtyp; + + elsif Rtyp = Standard_Wide_Character then + Imid := RE_Image_Wide_Character; + Tent := Rtyp; + + elsif Is_Signed_Integer_Type (Rtyp) then + if Esize (Rtyp) <= Esize (Standard_Integer) then + Imid := RE_Image_Integer; + Tent := Standard_Integer; + else + Imid := RE_Image_Long_Long_Integer; + Tent := Standard_Long_Long_Integer; + end if; + + elsif Is_Modular_Integer_Type (Rtyp) then + if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then + Imid := RE_Image_Unsigned; + Tent := RTE (RE_Unsigned); + else + Imid := RE_Image_Long_Long_Unsigned; + Tent := RTE (RE_Long_Long_Unsigned); + end if; + + elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then + Imid := RE_Image_Decimal; + Tent := Standard_Integer; + else + Imid := RE_Image_Long_Long_Decimal; + Tent := Standard_Long_Long_Integer; + end if; + + elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then + Imid := RE_Image_Ordinary_Fixed_Point; + Tent := Standard_Long_Long_Float; + + elsif Is_Floating_Point_Type (Rtyp) then + Imid := RE_Image_Floating_Point; + Tent := Standard_Long_Long_Float; + + -- Only other possibility is user defined enumeration type + + else + if Discard_Names (First_Subtype (Ptyp)) + or else No (Lit_Strings (Root_Type (Ptyp))) + then + -- When pragma Discard_Names applies to the first subtype, + -- then build (Pref'Pos)'Img. + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Pos, + Expressions => New_List (Expr)), + Attribute_Name => + Name_Img)); + Analyze_And_Resolve (N, Standard_String); + + else + -- Here we get the Image of an enumeration type + + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if Ttyp = Standard_Integer_8 then + Func := RE_Image_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + Func := RE_Image_Enumeration_16; + else + Func := RE_Image_Enumeration_32; + end if; + + -- Apply a validity check, since it is a bit drastic to + -- get a completely junk image value for an invalid value. + + if not Expr_Known_Valid (Expr) then + Insert_Valid_Check (Expr); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List (Expr)), + New_Occurrence_Of (Lit_Strings (Rtyp), Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address)))); + + Analyze_And_Resolve (N, Standard_String); + end if; + + return; + end if; + + -- If we fall through, we have one of the cases that is handled by + -- calling one of the System.Img_xx routines. + + Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr))); + + -- For floating-point types, append Digits argument + + if Is_Floating_Point_Type (Rtyp) then + Append_To (Arglist, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Digits)); + + -- For ordinary fixed-point types, append Aft parameter + + elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then + Append_To (Arglist, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Aft)); + + -- For wide character, append encoding method + + elsif Rtyp = Standard_Wide_Character then + Append_To (Arglist, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + + -- For decimal, append Scale and also set to do literal conversion + + elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + Append_To (Arglist, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Scale)); + + Set_Conversion_OK (First (Arglist)); + Set_Etype (First (Arglist), Tent); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Imid), Loc), + Parameter_Associations => Arglist)); + + Analyze_And_Resolve (N, Standard_String); + end Expand_Image_Attribute; + + ---------------------------- + -- Expand_Value_Attribute -- + ---------------------------- + + -- For scalar types derived from Boolean, Character and integer types + -- in package Standard, typ'Value (X) expands into: + + -- btyp (Value_xx (X)) + + -- where btyp is he base type of the prefix, and + + -- For types whose root type is Character + -- xx = Character + + -- For types whose root type is Boolean + -- xx = Boolean + + -- For signed integer types with size <= Integer'Size + -- xx = Integer + + -- For other signed integer types + -- xx = Long_Long_Integer + + -- For modular types with modulus <= System.Unsigned_Types.Unsigned + -- xx = Unsigned + + -- For other modular integer types + -- xx = Long_Long_Unsigned + + -- For floating-point types and ordinary fixed-point types + -- xx = Real + + -- For types derived from Wide_Character, typ'Value (X) expands into + + -- Value_Wide_Character (X, Wide_Character_Encoding_Method) + + -- For decimal types with size <= Integer'Size, typ'Value (X) + -- expands into + + -- btyp?(Value_Decimal (X, typ'Scale)); + + -- For all other decimal types, typ'Value (X) expands into + + -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) + + -- For enumeration types other than those derived from types Boolean, + -- Character, and Wide_Character in Standard, typ'Value (X) expands to: + + -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + + -- where typS and typI and the Lit_Strings and Lit_Indexes entities + -- from T's root type entitym and Num is Enum'Pos (Enum'Last). The + -- Value_Enumeration_NN function will search the tables looking for + -- X and return the position number in the table if found which is + -- used to provide the result of 'Value (using Enum'Val). If the + -- value is not found Constraint_Error is raised. The suffix _NN + -- depends on the element type of typI. + + procedure Expand_Value_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Rtyp : constant Entity_Id := Root_Type (Typ); + Exprs : constant List_Id := Expressions (N); + Vid : RE_Id; + Args : List_Id; + Func : RE_Id; + Ttyp : Entity_Id; + + begin + Args := Exprs; + + if Rtyp = Standard_Character then + Vid := RE_Value_Character; + + elsif Rtyp = Standard_Boolean then + Vid := RE_Value_Boolean; + + elsif Rtyp = Standard_Wide_Character then + Vid := RE_Value_Wide_Character; + Append_To (Args, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + + elsif Rtyp = Base_Type (Standard_Short_Short_Integer) + or else Rtyp = Base_Type (Standard_Short_Integer) + or else Rtyp = Base_Type (Standard_Integer) + then + Vid := RE_Value_Integer; + + elsif Is_Signed_Integer_Type (Rtyp) then + Vid := RE_Value_Long_Long_Integer; + + elsif Is_Modular_Integer_Type (Rtyp) then + if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then + Vid := RE_Value_Unsigned; + else + Vid := RE_Value_Long_Long_Unsigned; + end if; + + elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then + Vid := RE_Value_Decimal; + else + Vid := RE_Value_Long_Long_Decimal; + end if; + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Scale)); + + Rewrite (N, + OK_Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Vid), Loc), + Parameter_Associations => Args))); + + Set_Etype (N, Btyp); + Analyze_And_Resolve (N, Btyp); + return; + + elsif Is_Real_Type (Rtyp) then + Vid := RE_Value_Real; + + -- Only other possibility is user defined enumeration type + + else + pragma Assert (Is_Enumeration_Type (Rtyp)); + + -- Case of pragma Discard_Names, transform the Value + -- attribute to Btyp'Val (Long_Long_Integer'Value (Args)) + + if Discard_Names (First_Subtype (Typ)) + or else No (Lit_Strings (Rtyp)) + then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Btyp, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Long_Long_Integer, Loc), + Attribute_Name => Name_Value, + Expressions => Args)))); + + Analyze_And_Resolve (N, Btyp); + + -- Here for normal case where we have enumeration tables, this + -- is where we build + + -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + + else + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if Ttyp = Standard_Integer_8 then + Func := RE_Value_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + Func := RE_Value_Enumeration_16; + else + Func := RE_Value_Enumeration_32; + end if; + + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Last)))); + + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address)); + + Prepend_To (Args, + New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (Func), Loc), + Parameter_Associations => Args)))); + + Analyze_And_Resolve (N, Btyp); + end if; + + return; + end if; + + -- Fall through for all cases except user defined enumeration type + -- and decimal types, with Vid set to the Id of the entity for the + -- Value routine and Args set to the list of parameters for the call. + + Rewrite (N, + Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Vid), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Btyp); + end Expand_Value_Attribute; + + ---------------------------- + -- Expand_Width_Attribute -- + ---------------------------- + + -- The processing here also handles the case of Wide_Width. With the + -- exceptions noted, the processing is identical + + -- For scalar types derived from Boolean, character and integer types + -- in package Standard. Note that the Width attribute is computed at + -- compile time for all cases except those involving non-static sub- + -- types. For such subtypes, typ'Width and typ'Wide_Width expands into: + + -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) + + -- where + + -- For types whose root type is Character + -- xx = Width_Character (Wide_Width_Character for Wide_Width case) + -- yy = Character + + -- For types whose root type is Boolean + -- xx = Width_Boolean + -- yy = Boolean + + -- For signed integer types + -- xx = Width_Long_Long_Integer + -- yy = Long_Long_Integer + + -- For modular integer types + -- xx = Width_Long_Long_Unsigned + -- yy = Long_Long_Unsigned + + -- For types derived from Wide_Character, typ'Width expands into + + -- Result_Type (Width_Wide_Character ( + -- Wide_Character (typ'First), + -- Wide_Character (typ'Last), + -- Wide_Character_Encoding_Method); + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Wide_Character ( + -- Wide_Character (typ'First), + -- Wide_Character (typ'Last)); + + -- For real types, typ'Width and typ'Wide_Width expand into + + -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if + + -- where btyp is the base type. This looks recursive but it isn't + -- because the base type is always static, and hence the expression + -- in the else is reduced to an integer literal. + + -- For user defined enumeration types, typ'Width expands into + + -- Result_Type (Width_Enumeration_NN + -- (typS, + -- typI'Address, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last))); + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Enumeration_NN + -- (typS, + -- typI, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last)) + -- Wide_Character_Encoding_Method); + + -- where typS and typI are the enumeration image strings and + -- indexes table, as described in Build_Enumeration_Image_Tables. + -- NN is 8/16/32 for depending on the element type for typI. + + procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Etype (Pref); + Rtyp : constant Entity_Id := Root_Type (Ptyp); + XX : RE_Id; + YY : Entity_Id; + Arglist : List_Id; + Ttyp : Entity_Id; + + begin + -- Types derived from Standard.Boolean + + if Rtyp = Standard_Boolean then + XX := RE_Width_Boolean; + YY := Rtyp; + + -- Types derived from Standard.Character + + elsif Rtyp = Standard_Character then + if not Wide then + XX := RE_Width_Character; + else + XX := RE_Wide_Width_Character; + end if; + + YY := Rtyp; + + -- Types derived from Standard.Wide_Character + + elsif Rtyp = Standard_Wide_Character then + if not Wide then + XX := RE_Width_Wide_Character; + else + XX := RE_Wide_Width_Wide_Character; + end if; + + YY := Rtyp; + + -- Signed integer types + + elsif Is_Signed_Integer_Type (Rtyp) then + XX := RE_Width_Long_Long_Integer; + YY := Standard_Long_Long_Integer; + + -- Modular integer types + + elsif Is_Modular_Integer_Type (Rtyp) then + XX := RE_Width_Long_Long_Unsigned; + YY := RTE (RE_Long_Long_Unsigned); + + -- Real types + + elsif Is_Real_Type (Rtyp) then + + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + + Make_Op_Gt (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last)), + + Make_Integer_Literal (Loc, 0), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Base_Type (Ptyp), Loc), + Attribute_Name => Name_Width)))); + + Analyze_And_Resolve (N, Typ); + return; + + -- User defined enumeration types + + else + pragma Assert (Is_Enumeration_Type (Rtyp)); + + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if not Wide then + if Ttyp = Standard_Integer_8 then + XX := RE_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Width_Enumeration_16; + else + XX := RE_Width_Enumeration_32; + end if; + + else + if Ttyp = Standard_Integer_8 then + XX := RE_Wide_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Wide_Width_Enumeration_16; + else + XX := RE_Wide_Width_Enumeration_32; + end if; + end if; + + Arglist := + New_List ( + New_Occurrence_Of (Lit_Strings (Rtyp), Loc), + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First))), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last)))); + + -- For enumeration'Wide_Width, add encoding method parameter + + if Wide then + Append_To (Arglist, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + end if; + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (XX), Loc), + Parameter_Associations => Arglist))); + + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- If we fall through XX and YY are set + + Arglist := New_List ( + Convert_To (YY, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First)), + + Convert_To (YY, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last))); + + -- For Wide_Character'Width, add encoding method parameter + + if Rtyp = Standard_Wide_Character and then Wide then + Append_To (Arglist, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + end if; + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (XX), Loc), + Parameter_Associations => Arglist))); + + Analyze_And_Resolve (N, Typ); + end Expand_Width_Attribute; + +end Exp_Imgv; diff --git a/gcc/ada/exp_imgv.ads b/gcc/ada/exp_imgv.ads new file mode 100644 index 00000000000..e05fec50cd5 --- /dev/null +++ b/gcc/ada/exp_imgv.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I M G V -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for Image, Value and Width attributes. These are the +-- attributes that make use of enumeration type image tables. + +with Types; use Types; + +package Exp_Imgv is + + procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id); + -- Build the enumeration image tables for E, which is an enumeration + -- base type. The node N is the point in the tree where the resulting + -- declarations are to be inserted. + -- + -- The form of the tables generated is as follows: + -- + -- xxxS : string := "chars"; + -- xxxI : array (0 .. N) of Natural_8/16/32 := (1, n, .., n); + -- + -- Here xxxS is a string obtained by concatenating all the names + -- of the enumeration literals in sequence, representing any wide + -- characters according to the current wide character encoding + -- method, and with all letters forced to upper case. + -- + -- The array xxxI is an array of ones origin indexes to the start + -- of each name, with one extra entry at the end, which is the index + -- to the character just past the end of the last literal, i.e. it is + -- the length of xxxS + 1. The element type is the shortest of the + -- possible types that will hold all the values. + -- + -- For example, for the type + -- + -- type x is (hello,'!',goodbye); + -- + -- the generated tables would consist of + -- + -- xxxS : String := "hello'!'goodbye"; + -- xxxI : array (0 .. 3) of Natural_8 := (1, 6, 9, 16); + -- + -- Here Natural_8 is used since 16 < 2**(8-1) + -- + -- If the entity E needs the tables constructing, the necessary + -- declarations are constructed, and the fields Lit_Strings and + -- Lit_Indexes of E are set to point to the corresponding entities. + -- If no tables are needed (E is not a user defined enumeration + -- root type, or pragma Discard_Names is in effect, then the + -- declarations are not constructed, and the fields remain Empty. + + procedure Expand_Image_Attribute (N : Node_Id); + -- This procedure is called from Exp_Attr to expand an occurrence + -- of the attribute Image. + + procedure Expand_Value_Attribute (N : Node_Id); + -- This procedure is called from Exp_Attr to expand an occurrence + -- of the attribute Value. + + procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean); + -- This procedure is called from Exp_Attr to expand an occurrence of + -- the attributes Width (Wide = False) or Wide_Width (Wide = True). + +end Exp_Imgv; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb new file mode 100644 index 00000000000..53be18f7e39 --- /dev/null +++ b/gcc/ada/exp_intr.adb @@ -0,0 +1,755 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I N T R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.76 $ +-- -- +-- Copyright (C) 1992-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 Exp_Ch4; use Exp_Ch4; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Code; use Exp_Code; +with Exp_Fixd; use Exp_Fixd; +with Exp_Util; use Exp_Util; +with Itypes; use Itypes; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_Intr is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Is_Negative (N : Node_Id); + -- Expand a call to the intrinsic Is_Negative function + + procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); + -- Expand a call to Exception_Information/Message/Name. The first + -- parameter, N, is the node for the function call, and Ent is the + -- entity for the corresponding routine in the Ada.Exceptions package. + + procedure Expand_Import_Call (N : Node_Id); + -- Expand a call to Import_Address/Longest_Integer/Value. The parameter + -- N is the node for the function call. + + procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); + -- Expand an intrinsic shift operation, N and E are from the call to + -- Expand_Instrinsic_Call (call node and subprogram spec entity) and + -- K is the kind for the shift node + + procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); + -- Expand a call to an instantiation of Unchecked_Convertion into a node + -- N_Unchecked_Type_Conversion. + + procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id); + -- Expand a call to an instantiation of Unchecked_Deallocation into a node + -- N_Free_Statement and appropriate context. + + procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id); + -- Rewrite the node by the appropriate string or positive constant. + -- Nam can be one of the following: + -- Name_File - expand string that is the name of source file + -- Name_Line - expand integer line number + -- Name_Source_Location - expand string of form file:line + -- Name_Enclosing_Entity - expand string with name of enclosing entity + + --------------------------- + -- Expand_Exception_Call -- + --------------------------- + + -- If the function call is not within an exception handler, then the + -- call is replaced by a null string. Otherwise the appropriate routine + -- in Ada.Exceptions is called passing the choice parameter specification + -- from the enclosing handler. If the enclosing handler lacks a choice + -- parameter, then one is supplied. + + procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is + Loc : constant Source_Ptr := Sloc (N); + P : Node_Id; + E : Entity_Id; + S : String_Id; + + begin + -- Climb up parents to see if we are in exception handler + + P := Parent (N); + loop + -- Case of not in exception handler + + if No (P) then + Start_String; + S := End_String; + Rewrite (N, + Make_String_Literal (Loc, + Strval => S)); + exit; + + -- Case of in exception handler + + elsif Nkind (P) = N_Exception_Handler then + if No (Choice_Parameter (P)) then + + -- If no choice parameter present, then put one there. Note + -- that we do not need to put it on the entity chain, since + -- no one will be referencing it by normal visibility methods. + + E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Set_Choice_Parameter (P, E); + Set_Ekind (E, E_Variable); + Set_Etype (E, RTE (RE_Exception_Occurrence)); + Set_Scope (E, Current_Scope); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Ent), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Choice_Parameter (P), Loc)))); + exit; + + -- Keep climbing! + + else + P := Parent (P); + end if; + end loop; + + Analyze_And_Resolve (N, Standard_String); + end Expand_Exception_Call; + + ------------------------ + -- Expand_Import_Call -- + ------------------------ + + -- The function call must have a static string as its argument. We create + -- a dummy variable which uses this string as the external name in an + -- Import pragma. The result is then obtained as the address of this + -- dummy variable, converted to the appropriate target type. + + procedure Expand_Import_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Entity (Name (N)); + Str : constant Node_Id := First_Actual (N); + Dum : Entity_Id; + + begin + Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Dum, + Object_Definition => + New_Occurrence_Of (Standard_Character, Loc)), + + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Ada)), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Chars (Dum))), + + Make_Pragma_Argument_Association (Loc, + Chars => Name_Link_Name, + Expression => Relocate_Node (Str)))))); + + Rewrite (N, + Unchecked_Convert_To (Etype (Ent), + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => Make_Identifier (Loc, Chars (Dum))))); + + Analyze_And_Resolve (N, Etype (Ent)); + end Expand_Import_Call; + + --------------------------- + -- Expand_Intrinsic_Call -- + --------------------------- + + procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is + Nam : Name_Id; + + begin + -- If the intrinsic subprogram is generic, gets its original name. + + if Present (Parent (E)) + and then Present (Generic_Parent (Parent (E))) + then + Nam := Chars (Generic_Parent (Parent (E))); + else + Nam := Chars (E); + end if; + + if Nam = Name_Asm then + Expand_Asm_Call (N); + + elsif Nam = Name_Divide then + Expand_Decimal_Divide_Call (N); + + elsif Nam = Name_Exception_Information then + Expand_Exception_Call (N, RE_Exception_Information); + + elsif Nam = Name_Exception_Message then + Expand_Exception_Call (N, RE_Exception_Message); + + elsif Nam = Name_Exception_Name then + Expand_Exception_Call (N, RE_Exception_Name_Simple); + + elsif Nam = Name_Import_Address + or else + Nam = Name_Import_Largest_Value + or else + Nam = Name_Import_Value + then + Expand_Import_Call (N); + + elsif Nam = Name_Is_Negative then + Expand_Is_Negative (N); + + elsif Nam = Name_Rotate_Left then + Expand_Shift (N, E, N_Op_Rotate_Left); + + elsif Nam = Name_Rotate_Right then + Expand_Shift (N, E, N_Op_Rotate_Right); + + elsif Nam = Name_Shift_Left then + Expand_Shift (N, E, N_Op_Shift_Left); + + elsif Nam = Name_Shift_Right then + Expand_Shift (N, E, N_Op_Shift_Right); + + elsif Nam = Name_Shift_Right_Arithmetic then + Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); + + elsif Nam = Name_Unchecked_Conversion then + Expand_Unc_Conversion (N, E); + + elsif Nam = Name_Unchecked_Deallocation then + Expand_Unc_Deallocation (N, E); + + elsif Nam = Name_File + or else Nam = Name_Line + or else Nam = Name_Source_Location + or else Nam = Name_Enclosing_Entity + then + Expand_Source_Info (N, E, Nam); + + else + -- Only other possibility is a renaming, in which case we expand + -- the call to the original operation (which must be intrinsic). + + pragma Assert (Present (Alias (E))); + Expand_Intrinsic_Call (N, Alias (E)); + end if; + + end Expand_Intrinsic_Call; + + ------------------------ + -- Expand_Is_Negative -- + ------------------------ + + procedure Expand_Is_Negative (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); + + begin + + -- We replace the function call by the following expression + + -- if Opnd < 0.0 then + -- True + -- else + -- if Opnd > 0.0 then + -- False; + -- else + -- Float_Unsigned!(Float (Opnd)) /= 0 + -- end if; + -- end if; + + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr (Opnd), + Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), + + New_Occurrence_Of (Standard_True, Loc), + + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr (Opnd), + Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), + + New_Occurrence_Of (Standard_False, Loc), + + Make_Op_Ne (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Float_Unsigned), + Convert_To (Standard_Float, + Duplicate_Subexpr (Opnd))), + Right_Opnd => + Make_Integer_Literal (Loc, 0))))))); + + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_Is_Negative; + + ------------------ + -- Expand_Shift -- + ------------------ + + -- This procedure is used to convert a call to a shift function to the + -- corresponding operator node. This conversion is not done by the usual + -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to + -- operator nodes, because shifts are not predefined operators. + + -- As a result, whenever a shift is used in the source program, it will + -- remain as a call until converted by this routine to the operator node + -- form which Gigi is expecting to see. + + -- Note: it is possible for the expander to generate shift operator nodes + -- directly, which will be analyzed in the normal manner by calling Analyze + -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. + + procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := First_Actual (N); + Right : constant Node_Id := Next_Actual (Left); + Ltyp : constant Node_Id := Etype (Left); + Rtyp : constant Node_Id := Etype (Right); + Snode : Node_Id; + + begin + Snode := New_Node (K, Loc); + Set_Left_Opnd (Snode, Relocate_Node (Left)); + Set_Right_Opnd (Snode, Relocate_Node (Right)); + Set_Chars (Snode, Chars (E)); + Set_Etype (Snode, Base_Type (Typ)); + Set_Entity (Snode, E); + + if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) + and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) + then + Set_Shift_Count_OK (Snode, True); + end if; + + -- Do the rewrite. Note that we don't call Analyze and Resolve on + -- this node, because it already got analyzed and resolved when + -- it was a function call! + + Rewrite (N, Snode); + Set_Analyzed (N); + + end Expand_Shift; + + ------------------------ + -- Expand_Source_Info -- + ------------------------ + + procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : Entity_Id; + + begin + -- Integer cases + + if Nam = Name_Line then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); + Analyze_And_Resolve (N, Standard_Positive); + + -- String cases + + else + case Nam is + when Name_File => + Get_Decoded_Name_String + (Reference_Name (Get_Source_File_Index (Loc))); + + when Name_Source_Location => + Build_Location_String (Loc); + + when Name_Enclosing_Entity => + Name_Len := 0; + + Ent := Current_Scope; + + -- Skip enclosing blocks to reach enclosing unit. + + while Present (Ent) loop + exit when Ekind (Ent) /= E_Block + and then Ekind (Ent) /= E_Loop; + Ent := Scope (Ent); + end loop; + + -- Ent now points to the relevant defining entity + + declare + SDef : Source_Ptr := Sloc (Ent); + TDef : Source_Buffer_Ptr; + + begin + TDef := Source_Text (Get_Source_File_Index (SDef)); + Name_Len := 0; + + while TDef (SDef) in '0' .. '9' + or else TDef (SDef) >= 'A' + or else TDef (SDef) = ASCII.ESC + loop + Add_Char_To_Name_Buffer (TDef (SDef)); + SDef := SDef + 1; + end loop; + end; + + when others => + raise Program_Error; + end case; + + Rewrite (N, + Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + Analyze_And_Resolve (N, Standard_String); + end if; + + Set_Is_Static_Expression (N); + end Expand_Source_Info; + + --------------------------- + -- Expand_Unc_Conversion -- + --------------------------- + + procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is + Func : constant Entity_Id := Entity (Name (N)); + Conv : Node_Id; + Ftyp : Entity_Id; + + begin + -- Rewrite as unchecked conversion node. Note that we must convert + -- the operand to the formal type of the input parameter of the + -- function, so that the resulting N_Unchecked_Type_Conversion + -- call indicates the correct types for Gigi. + + -- Right now, we only do this if a scalar type is involved. It is + -- not clear if it is needed in other cases. If we do attempt to + -- do the conversion unconditionally, it crashes 3411-018. To be + -- investigated further ??? + + Conv := Relocate_Node (First_Actual (N)); + Ftyp := Etype (First_Formal (Func)); + + if Is_Scalar_Type (Ftyp) then + Conv := Convert_To (Ftyp, Conv); + Set_Parent (Conv, N); + Analyze_And_Resolve (Conv); + end if; + + -- We do the analysis here, because we do not want the compiler + -- to try to optimize or otherwise reorganize the unchecked + -- conversion node. + + Rewrite (N, Unchecked_Convert_To (Etype (E), Conv)); + Set_Etype (N, Etype (E)); + Set_Analyzed (N); + + if Nkind (N) = N_Unchecked_Type_Conversion then + Expand_N_Unchecked_Type_Conversion (N); + end if; + end Expand_Unc_Conversion; + + ----------------------------- + -- Expand_Unc_Deallocation -- + ----------------------------- + + -- Generate the following Code : + + -- if Arg /= null then + -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types + -- Free (Arg); + -- Arg := Null; + -- end if; + + -- For a task, we also generate a call to Free_Task to ensure that the + -- task itself is freed if it is terminated, ditto for a simple protected + -- object, with a call to Finalize_Protection + + procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Arg : constant Node_Id := First_Actual (N); + Typ : constant Entity_Id := Etype (Arg); + Stmts : constant List_Id := New_List; + Pool : constant Entity_Id := + Associated_Storage_Pool (Underlying_Type (Root_Type (Typ))); + + Desig_T : Entity_Id := Designated_Type (Typ); + Gen_Code : Node_Id; + Free_Node : Node_Id; + Deref : Node_Id; + Free_Arg : Node_Id; + Free_Cod : List_Id; + Blk : Node_Id; + + begin + if Controlled_Type (Desig_T) then + + Deref := Make_Explicit_Dereference (Loc, Duplicate_Subexpr (Arg)); + + -- If the type is tagged, then we must force dispatching on the + -- finalization call because the designated type may not be the + -- actual type of the object + + if Is_Tagged_Type (Desig_T) + and then not Is_Class_Wide_Type (Desig_T) + then + Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); + end if; + + Free_Cod := + Make_Final_Call + (Ref => Deref, + Typ => Desig_T, + With_Detach => New_Reference_To (Standard_True, Loc)); + + if Abort_Allowed then + Prepend_To (Free_Cod, + Build_Runtime_Call (Loc, RE_Abort_Defer)); + + Blk := + Make_Block_Statement (Loc, Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Free_Cod, + At_End_Proc => + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); + + -- We now expand the exception (at end) handler. We set a + -- temporary parent pointer since we have not attached Blk + -- to the tree yet. + + Set_Parent (Blk, N); + Analyze (Blk); + Expand_At_End_Handler + (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); + Append (Blk, Stmts); + + else + Append_List_To (Stmts, Free_Cod); + end if; + end if; + + -- For a task type, call Free_Task before freeing the ATCB. + + if Is_Task_Type (Desig_T) then + + declare + Stat : Node_Id := Prev (N); + Nam1 : Node_Id; + Nam2 : Node_Id; + + begin + -- An Abort followed by a Free will not do what the user + -- expects, because the abort is not immediate. This is worth + -- a friendly warning. + + while Present (Stat) + and then not Comes_From_Source (Original_Node (Stat)) + loop + Prev (Stat); + end loop; + + if Present (Stat) + and then Nkind (Original_Node (Stat)) = N_Abort_Statement + then + Stat := Original_Node (Stat); + Nam1 := First (Names (Stat)); + Nam2 := Original_Node (First (Parameter_Associations (N))); + + if Nkind (Nam1) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Nam1)) + and then Is_Entity_Name (Nam2) + and then Entity (Prefix (Nam1)) = Entity (Nam2) + then + Error_Msg_N ("Abort may take time to complete?", N); + Error_Msg_N ("\deallocation might have no effect?", N); + Error_Msg_N ("\safer to wait for termination.?", N); + end if; + end if; + end; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Free_Task), Loc), + Parameter_Associations => New_List ( + Concurrent_Ref (Duplicate_Subexpr (Arg))))); + end if; + + -- For a protected type with no entries, call Finalize_Protection + -- before freeing the PO. + + if Is_Protected_Type (Desig_T) and then not Has_Entries (Desig_T) then + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc), + Parameter_Associations => New_List ( + Concurrent_Ref (Duplicate_Subexpr (Arg))))); + end if; + + -- Normal processing for non-controlled types + + Free_Arg := Duplicate_Subexpr (Arg); + Free_Node := Make_Free_Statement (Loc, Empty); + Append_To (Stmts, Free_Node); + Set_Storage_Pool (Free_Node, Pool); + + -- Make implicit if statement. We omit this if we are the then part + -- of a test of the form: + + -- if not (Arg = null) then + + -- i.e. if the test is explicit in the source. Arg must be a simple + -- identifier for the purposes of this special test. Note that the + -- use of /= in the source is always transformed into the above form. + + declare + Test_Needed : Boolean := True; + P : constant Node_Id := Parent (N); + C : Node_Id; + + begin + if Nkind (Arg) = N_Identifier + and then Nkind (P) = N_If_Statement + and then First (Then_Statements (P)) = N + then + if Nkind (Condition (P)) = N_Op_Not then + C := Right_Opnd (Condition (P)); + + if Nkind (C) = N_Op_Eq + and then Nkind (Left_Opnd (C)) = N_Identifier + and then Chars (Arg) = Chars (Left_Opnd (C)) + and then Nkind (Right_Opnd (C)) = N_Null + then + Test_Needed := False; + end if; + end if; + end if; + + -- Generate If_Statement if needed + + if Test_Needed then + Gen_Code := + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Arg), + Right_Opnd => Make_Null (Loc)), + Then_Statements => Stmts); + + else + Gen_Code := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end if; + end; + + -- Deal with storage pool + + if Present (Pool) then + + -- Freeing the secondary stack is meaningless + + if Is_RTE (Pool, RE_SS_Pool) then + null; + + else + Set_Procedure_To_Call (Free_Node, + Find_Prim_Op (Etype (Pool), Name_Deallocate)); + + -- If the type is class wide, we generate an implicit type + -- with the right dynamic size, so that the deallocate call + -- gets the right size parameter computed by gigi + + if Is_Class_Wide_Type (Desig_T) then + declare + Acc_Type : constant Entity_Id := + Create_Itype (E_Access_Type, N); + Deref : constant Node_Id := + Make_Explicit_Dereference (Loc, + Duplicate_Subexpr (Arg)); + + begin + Set_Etype (Deref, Typ); + Set_Parent (Deref, Free_Node); + + Set_Etype (Acc_Type, Acc_Type); + Set_Size_Info (Acc_Type, Typ); + Set_Directly_Designated_Type + (Acc_Type, Entity (Make_Subtype_From_Expr + (Deref, Desig_T))); + + Free_Arg := Unchecked_Convert_To (Acc_Type, Free_Arg); + end; + end if; + end if; + end if; + + Set_Expression (Free_Node, Free_Arg); + + declare + Lhs : Node_Id := Duplicate_Subexpr (Arg); + + begin + Set_Assignment_OK (Lhs); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Make_Null (Loc))); + end; + + Rewrite (N, Gen_Code); + Analyze (N); + end Expand_Unc_Deallocation; + +end Exp_Intr; diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads new file mode 100644 index 00000000000..35de9b4b603 --- /dev/null +++ b/gcc/ada/exp_intr.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I N T R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Processing for expanding intrinsic subprogram calls + +with Types; use Types; + +package Exp_Intr is + + procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id); + -- N is either a function call node, or a procedure call statement node + -- where the corresponding subprogram is intrinsic (i.e. was the subject + -- of a Import or Interface pragma specifying the subprogram as intrinsic. + -- The effect is to replace the call with appropriate specialized nodes. + -- The second argument is the entity for the subprogram spec. + +end Exp_Intr; diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb new file mode 100644 index 00000000000..2cc4f255473 --- /dev/null +++ b/gcc/ada/exp_pakd.adb @@ -0,0 +1,2379 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P A K D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.125 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +package body Exp_Pakd is + + --------------------------- + -- Endian Considerations -- + --------------------------- + + -- As described in the specification, bit numbering in a packed array + -- is consistent with bit numbering in a record representation clause, + -- and hence dependent on the endianness of the machine: + + -- For little-endian machines, element zero is at the right hand end + -- (low order end) of a bit field. + + -- For big-endian machines, element zero is at the left hand end + -- (high order end) of a bit field. + + -- The shifts that are used to right justify a field therefore differ + -- in the two cases. For the little-endian case, we can simply use the + -- bit number (i.e. the element number * element size) as the count for + -- a right shift. For the big-endian case, we have to subtract the shift + -- count from an appropriate constant to use in the right shift. We use + -- rotates instead of shifts (which is necessary in the store case to + -- preserve other fields), and we expect that the backend will be able + -- to change the right rotate into a left rotate, avoiding the subtract, + -- if the architecture provides such an instruction. + + ---------------------------------------------- + -- Entity Tables for Packed Access Routines -- + ---------------------------------------------- + + -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call + -- library routines. This table is used to obtain the entity for the + -- proper routine. + + type E_Array is array (Int range 01 .. 63) of RE_Id; + + -- Array of Bits_nn entities. Note that we do not use library routines + -- for the 8-bit and 16-bit cases, but we still fill in the table, using + -- entries from System.Unsigned, because we also use this table for + -- certain special unchecked conversions in the big-endian case. + + Bits_Id : constant E_Array := + (01 => RE_Bits_1, + 02 => RE_Bits_2, + 03 => RE_Bits_03, + 04 => RE_Bits_4, + 05 => RE_Bits_05, + 06 => RE_Bits_06, + 07 => RE_Bits_07, + 08 => RE_Unsigned_8, + 09 => RE_Bits_09, + 10 => RE_Bits_10, + 11 => RE_Bits_11, + 12 => RE_Bits_12, + 13 => RE_Bits_13, + 14 => RE_Bits_14, + 15 => RE_Bits_15, + 16 => RE_Unsigned_16, + 17 => RE_Bits_17, + 18 => RE_Bits_18, + 19 => RE_Bits_19, + 20 => RE_Bits_20, + 21 => RE_Bits_21, + 22 => RE_Bits_22, + 23 => RE_Bits_23, + 24 => RE_Bits_24, + 25 => RE_Bits_25, + 26 => RE_Bits_26, + 27 => RE_Bits_27, + 28 => RE_Bits_28, + 29 => RE_Bits_29, + 30 => RE_Bits_30, + 31 => RE_Bits_31, + 32 => RE_Unsigned_32, + 33 => RE_Bits_33, + 34 => RE_Bits_34, + 35 => RE_Bits_35, + 36 => RE_Bits_36, + 37 => RE_Bits_37, + 38 => RE_Bits_38, + 39 => RE_Bits_39, + 40 => RE_Bits_40, + 41 => RE_Bits_41, + 42 => RE_Bits_42, + 43 => RE_Bits_43, + 44 => RE_Bits_44, + 45 => RE_Bits_45, + 46 => RE_Bits_46, + 47 => RE_Bits_47, + 48 => RE_Bits_48, + 49 => RE_Bits_49, + 50 => RE_Bits_50, + 51 => RE_Bits_51, + 52 => RE_Bits_52, + 53 => RE_Bits_53, + 54 => RE_Bits_54, + 55 => RE_Bits_55, + 56 => RE_Bits_56, + 57 => RE_Bits_57, + 58 => RE_Bits_58, + 59 => RE_Bits_59, + 60 => RE_Bits_60, + 61 => RE_Bits_61, + 62 => RE_Bits_62, + 63 => RE_Bits_63); + + -- Array of Get routine entities. These are used to obtain an element + -- from a packed array. The N'th entry is used to obtain elements from + -- a packed array whose component size is N. RE_Null is used as a null + -- entry, for the cases where a library routine is not used. + + Get_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_Get_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_Get_10, + 11 => RE_Get_11, + 12 => RE_Get_12, + 13 => RE_Get_13, + 14 => RE_Get_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_Get_18, + 19 => RE_Get_19, + 20 => RE_Get_20, + 21 => RE_Get_21, + 22 => RE_Get_22, + 23 => RE_Get_23, + 24 => RE_Get_24, + 25 => RE_Get_25, + 26 => RE_Get_26, + 27 => RE_Get_27, + 28 => RE_Get_28, + 29 => RE_Get_29, + 30 => RE_Get_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_Get_34, + 35 => RE_Get_35, + 36 => RE_Get_36, + 37 => RE_Get_37, + 38 => RE_Get_38, + 39 => RE_Get_39, + 40 => RE_Get_40, + 41 => RE_Get_41, + 42 => RE_Get_42, + 43 => RE_Get_43, + 44 => RE_Get_44, + 45 => RE_Get_45, + 46 => RE_Get_46, + 47 => RE_Get_47, + 48 => RE_Get_48, + 49 => RE_Get_49, + 50 => RE_Get_50, + 51 => RE_Get_51, + 52 => RE_Get_52, + 53 => RE_Get_53, + 54 => RE_Get_54, + 55 => RE_Get_55, + 56 => RE_Get_56, + 57 => RE_Get_57, + 58 => RE_Get_58, + 59 => RE_Get_59, + 60 => RE_Get_60, + 61 => RE_Get_61, + 62 => RE_Get_62, + 63 => RE_Get_63); + + -- Array of Get routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may + -- not be fully aligned. This only affects the even sizes, since for the + -- odd sizes, we do not get any fixed alignment in any case. + + GetU_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_GetU_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_GetU_10, + 11 => RE_Get_11, + 12 => RE_GetU_12, + 13 => RE_Get_13, + 14 => RE_GetU_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_GetU_18, + 19 => RE_Get_19, + 20 => RE_GetU_20, + 21 => RE_Get_21, + 22 => RE_GetU_22, + 23 => RE_Get_23, + 24 => RE_GetU_24, + 25 => RE_Get_25, + 26 => RE_GetU_26, + 27 => RE_Get_27, + 28 => RE_GetU_28, + 29 => RE_Get_29, + 30 => RE_GetU_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_GetU_34, + 35 => RE_Get_35, + 36 => RE_GetU_36, + 37 => RE_Get_37, + 38 => RE_GetU_38, + 39 => RE_Get_39, + 40 => RE_GetU_40, + 41 => RE_Get_41, + 42 => RE_GetU_42, + 43 => RE_Get_43, + 44 => RE_GetU_44, + 45 => RE_Get_45, + 46 => RE_GetU_46, + 47 => RE_Get_47, + 48 => RE_GetU_48, + 49 => RE_Get_49, + 50 => RE_GetU_50, + 51 => RE_Get_51, + 52 => RE_GetU_52, + 53 => RE_Get_53, + 54 => RE_GetU_54, + 55 => RE_Get_55, + 56 => RE_GetU_56, + 57 => RE_Get_57, + 58 => RE_GetU_58, + 59 => RE_Get_59, + 60 => RE_GetU_60, + 61 => RE_Get_61, + 62 => RE_GetU_62, + 63 => RE_Get_63); + + -- Array of Set routine entities. These are used to assign an element + -- of a packed array. The N'th entry is used to assign elements for + -- a packed array whose component size is N. RE_Null is used as a null + -- entry, for the cases where a library routine is not used. + + Set_Id : E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_Set_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_Set_10, + 11 => RE_Set_11, + 12 => RE_Set_12, + 13 => RE_Set_13, + 14 => RE_Set_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_Set_18, + 19 => RE_Set_19, + 20 => RE_Set_20, + 21 => RE_Set_21, + 22 => RE_Set_22, + 23 => RE_Set_23, + 24 => RE_Set_24, + 25 => RE_Set_25, + 26 => RE_Set_26, + 27 => RE_Set_27, + 28 => RE_Set_28, + 29 => RE_Set_29, + 30 => RE_Set_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_Set_34, + 35 => RE_Set_35, + 36 => RE_Set_36, + 37 => RE_Set_37, + 38 => RE_Set_38, + 39 => RE_Set_39, + 40 => RE_Set_40, + 41 => RE_Set_41, + 42 => RE_Set_42, + 43 => RE_Set_43, + 44 => RE_Set_44, + 45 => RE_Set_45, + 46 => RE_Set_46, + 47 => RE_Set_47, + 48 => RE_Set_48, + 49 => RE_Set_49, + 50 => RE_Set_50, + 51 => RE_Set_51, + 52 => RE_Set_52, + 53 => RE_Set_53, + 54 => RE_Set_54, + 55 => RE_Set_55, + 56 => RE_Set_56, + 57 => RE_Set_57, + 58 => RE_Set_58, + 59 => RE_Set_59, + 60 => RE_Set_60, + 61 => RE_Set_61, + 62 => RE_Set_62, + 63 => RE_Set_63); + + -- Array of Set routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may + -- not be fully aligned. This only affects the even sizes, since for the + -- odd sizes, we do not get any fixed alignment in any case. + + SetU_Id : E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_SetU_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_SetU_10, + 11 => RE_Set_11, + 12 => RE_SetU_12, + 13 => RE_Set_13, + 14 => RE_SetU_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_SetU_18, + 19 => RE_Set_19, + 20 => RE_SetU_20, + 21 => RE_Set_21, + 22 => RE_SetU_22, + 23 => RE_Set_23, + 24 => RE_SetU_24, + 25 => RE_Set_25, + 26 => RE_SetU_26, + 27 => RE_Set_27, + 28 => RE_SetU_28, + 29 => RE_Set_29, + 30 => RE_SetU_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_SetU_34, + 35 => RE_Set_35, + 36 => RE_SetU_36, + 37 => RE_Set_37, + 38 => RE_SetU_38, + 39 => RE_Set_39, + 40 => RE_SetU_40, + 41 => RE_Set_41, + 42 => RE_SetU_42, + 43 => RE_Set_43, + 44 => RE_SetU_44, + 45 => RE_Set_45, + 46 => RE_SetU_46, + 47 => RE_Set_47, + 48 => RE_SetU_48, + 49 => RE_Set_49, + 50 => RE_SetU_50, + 51 => RE_Set_51, + 52 => RE_SetU_52, + 53 => RE_Set_53, + 54 => RE_SetU_54, + 55 => RE_Set_55, + 56 => RE_SetU_56, + 57 => RE_Set_57, + 58 => RE_SetU_58, + 59 => RE_Set_59, + 60 => RE_SetU_60, + 61 => RE_Set_61, + 62 => RE_SetU_62, + 63 => RE_Set_63); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Compute_Linear_Subscript + (Atyp : Entity_Id; + N : Node_Id; + Subscr : out Node_Id); + -- Given a constrained array type Atyp, and an indexed component node + -- N referencing an array object of this type, build an expression of + -- type Standard.Integer representing the zero-based linear subscript + -- value. This expression includes any required range checks. + + procedure Convert_To_PAT_Type (Aexp : Node_Id); + -- Given an expression of a packed array type, builds a corresponding + -- expression whose type is the implementation type used to represent + -- the packed array. Aexp is analyzed and resolved on entry and on exit. + + function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id; + -- Build a left shift node, checking for the case of a shift count of zero + + function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id; + -- Build a right shift node, checking for the case of a shift count of zero + + function RJ_Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) + return Node_Id; + -- The packed array code does unchecked conversions which in some cases + -- may involve non-discrete types with differing sizes. The semantics of + -- such conversions is potentially endian dependent, and the effect we + -- want here for such a conversion is to do the conversion in size as + -- though numeric items are involved, and we extend or truncate on the + -- left side. This happens naturally in the little-endian case, but in + -- the big endian case we can get left justification, when what we want + -- is right justification. This routine does the unchecked conversion in + -- a stepwise manner to ensure that it gives the expected result. Hence + -- the name (RJ = Right justified). The parameters Typ and Expr are as + -- for the case of a normal Unchecked_Convert_To call. + + procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id); + -- This routine is called in the Get and Set case for arrays that are + -- packed but not bit-packed, meaning that they have at least one + -- subscript that is of an enumeration type with a non-standard + -- representation. This routine modifies the given node to properly + -- reference the corresponding packed array type. + + procedure Setup_Inline_Packed_Array_Reference + (N : Node_Id; + Atyp : Entity_Id; + Obj : in out Node_Id; + Cmask : out Uint; + Shift : out Node_Id); + -- This procedure performs common processing on the N_Indexed_Component + -- parameter given as N, whose prefix is a reference to a packed array. + -- This is used for the get and set when the component size is 1,2,4 + -- or for other component sizes when the packed array type is a modular + -- type (i.e. the cases that are handled with inline code). + -- + -- On entry: + -- + -- N is the N_Indexed_Component node for the packed array reference + -- + -- Atyp is the constrained array type (the actual subtype has been + -- computed if necessary to obtain the constraints, but this is still + -- the original array type, not the Packed_Array_Type value). + -- + -- Obj is the object which is to be indexed. It is always of type Atyp. + -- + -- On return: + -- + -- Obj is the object containing the desired bit field. It is of type + -- Unsigned or Long_Long_Unsigned, and is either the entire value, + -- for the small static case, or the proper selected byte from the + -- array in the large or dynamic case. This node is analyzed and + -- resolved on return. + -- + -- Shift is a node representing the shift count to be used in the + -- rotate right instruction that positions the field for access. + -- This node is analyzed and resolved on return. + -- + -- Cmask is a mask corresponding to the width of the component field. + -- Its value is 2 ** Csize - 1 (e.g. 2#1111# for component size of 4). + -- + -- Note: in some cases the call to this routine may generate actions + -- (for handling multi-use references and the generation of the packed + -- array type on the fly). Such actions are inserted into the tree + -- directly using Insert_Action. + + ------------------------------ + -- Compute_Linear_Subcsript -- + ------------------------------ + + procedure Compute_Linear_Subscript + (Atyp : Entity_Id; + N : Node_Id; + Subscr : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Oldsub : Node_Id; + Newsub : Node_Id; + Indx : Node_Id; + Styp : Entity_Id; + + begin + Subscr := Empty; + + -- Loop through dimensions + + Indx := First_Index (Atyp); + Oldsub := First (Expressions (N)); + + while Present (Indx) loop + Styp := Etype (Indx); + Newsub := Relocate_Node (Oldsub); + + -- Get expression for the subscript value. First, if Do_Range_Check + -- is set on a subscript, then we must do a range check against the + -- original bounds (not the bounds of the packed array type). We do + -- this by introducing a subtype conversion. + + if Do_Range_Check (Newsub) + and then Etype (Newsub) /= Styp + then + Newsub := Convert_To (Styp, Newsub); + end if; + + -- Now evolve the expression for the subscript. First convert + -- the subscript to be zero based and of an integer type. + + -- Case of integer type, where we just subtract to get lower bound + + if Is_Integer_Type (Styp) then + + -- If length of integer type is smaller than standard integer, + -- then we convert to integer first, then do the subtract + + -- Integer (subscript) - Integer (Styp'First) + + if Esize (Styp) < Esize (Standard_Integer) then + Newsub := + Make_Op_Subtract (Loc, + Left_Opnd => Convert_To (Standard_Integer, Newsub), + Right_Opnd => + Convert_To (Standard_Integer, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_First))); + + -- For larger integer types, subtract first, then convert to + -- integer, this deals with strange long long integer bounds. + + -- Integer (subscript - Styp'First) + + else + Newsub := + Convert_To (Standard_Integer, + Make_Op_Subtract (Loc, + Left_Opnd => Newsub, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_First))); + end if; + + -- For the enumeration case, we have to use 'Pos to get the value + -- to work with before subtracting the lower bound. + + -- Integer (Styp'Pos (subscr)) - Integer (Styp'Pos (Styp'First)); + + -- This is not quite right for bizarre cases where the size of the + -- enumeration type is > Integer'Size bits due to rep clause ??? + + else + pragma Assert (Is_Enumeration_Type (Styp)); + + Newsub := + Make_Op_Subtract (Loc, + Left_Opnd => Convert_To (Standard_Integer, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Newsub))), + + Right_Opnd => + Convert_To (Standard_Integer, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_First))))); + end if; + + Set_Paren_Count (Newsub, 1); + + -- For the first subscript, we just copy that subscript value + + if No (Subscr) then + Subscr := Newsub; + + -- Otherwise, we must multiply what we already have by the current + -- stride and then add in the new value to the evolving subscript. + + else + Subscr := + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => Subscr, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Range_Length, + Prefix => New_Occurrence_Of (Styp, Loc))), + Right_Opnd => Newsub); + end if; + + -- Move to next subscript + + Next_Index (Indx); + Next (Oldsub); + end loop; + end Compute_Linear_Subscript; + + ------------------------- + -- Convert_To_PAT_Type -- + ------------------------- + + -- The PAT is always obtained from the actual subtype + + procedure Convert_To_PAT_Type (Aexp : Entity_Id) is + Act_ST : Entity_Id; + + begin + Convert_To_Actual_Subtype (Aexp); + Act_ST := Underlying_Type (Etype (Aexp)); + Create_Packed_Array_Type (Act_ST); + + -- Just replace the etype with the packed array type. This works + -- because the expression will not be further analyzed, and Gigi + -- considers the two types equivalent in any case. + + Set_Etype (Aexp, Packed_Array_Type (Act_ST)); + end Convert_To_PAT_Type; + + ------------------------------ + -- Create_Packed_Array_Type -- + ------------------------------ + + procedure Create_Packed_Array_Type (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Ctyp : constant Entity_Id := Component_Type (Typ); + Csize : constant Uint := Component_Size (Typ); + + Ancest : Entity_Id; + PB_Type : Entity_Id; + Esiz : Uint; + Decl : Node_Id; + PAT : Entity_Id; + Len_Dim : Node_Id; + Len_Expr : Node_Id; + Len_Bits : Uint; + Bits_U1 : Node_Id; + PAT_High : Node_Id; + Btyp : Entity_Id; + Lit : Node_Id; + + procedure Install_PAT; + -- This procedure is called with Decl set to the declaration for the + -- packed array type. It creates the type and installs it as required. + + procedure Set_PB_Type; + -- Sets PB_Type to Packed_Bytes{1,2,4} as required by the alignment + -- requirements (see documentation in the spec of this package). + + ----------------- + -- Install_PAT -- + ----------------- + + procedure Install_PAT is + Pushed_Scope : Boolean := False; + + begin + -- We do not want to put the declaration we have created in the tree + -- since it is often hard, and sometimes impossible to find a proper + -- place for it (the impossible case arises for a packed array type + -- with bounds depending on the discriminant, a declaration cannot + -- be put inside the record, and the reference to the discriminant + -- cannot be outside the record). + + -- The solution is to analyze the declaration while temporarily + -- attached to the tree at an appropriate point, and then we install + -- the resulting type as an Itype in the packed array type field of + -- the original type, so that no explicit declaration is required. + + -- Note: the packed type is created in the scope of its parent + -- type. There are at least some cases where the current scope + -- is deeper, and so when this is the case, we temporarily reset + -- the scope for the definition. This is clearly safe, since the + -- first use of the packed array type will be the implicit + -- reference from the corresponding unpacked type when it is + -- elaborated. + + if Is_Itype (Typ) then + Set_Parent (Decl, Associated_Node_For_Itype (Typ)); + else + Set_Parent (Decl, Declaration_Node (Typ)); + end if; + + if Scope (Typ) /= Current_Scope then + New_Scope (Scope (Typ)); + Pushed_Scope := True; + end if; + + Set_Is_Itype (PAT, True); + Set_Is_Packed_Array_Type (PAT, True); + Analyze (Decl, Suppress => All_Checks); + + if Pushed_Scope then + Pop_Scope; + end if; + + -- Set Esize and RM_Size to the actual size of the packed object + -- Do not reset RM_Size if already set, as happens in the case + -- of a modular type + + Set_Esize (PAT, Esiz); + + if Unknown_RM_Size (PAT) then + Set_RM_Size (PAT, Esiz); + end if; + + -- Set remaining fields of packed array type + + Init_Alignment (PAT); + Set_Parent (PAT, Empty); + Set_Packed_Array_Type (Typ, PAT); + Set_Associated_Node_For_Itype (PAT, Typ); + + -- We definitely do not want to delay freezing for packed array + -- types. This is of particular importance for the itypes that + -- are generated for record components depending on discriminants + -- where there is no place to put the freeze node. + + Set_Has_Delayed_Freeze (PAT, False); + Set_Has_Delayed_Freeze (Etype (PAT), False); + end Install_PAT; + + ----------------- + -- Set_PB_Type -- + ----------------- + + procedure Set_PB_Type is + begin + -- If the user has specified an explicit alignment for the + -- component, take it into account. + + if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0 + or else Component_Alignment (Typ) = Calign_Storage_Unit + then + PB_Type := RTE (RE_Packed_Bytes1); + + elsif Csize mod 4 /= 0 then + PB_Type := RTE (RE_Packed_Bytes2); + + else + PB_Type := RTE (RE_Packed_Bytes4); + end if; + end Set_PB_Type; + + -- Start of processing for Create_Packed_Array_Type + + begin + -- If we already have a packed array type, nothing to do + + if Present (Packed_Array_Type (Typ)) then + return; + end if; + + -- If our immediate ancestor subtype is constrained, and it already + -- has a packed array type, then just share the same type, since the + -- bounds must be the same. + + if Ekind (Typ) = E_Array_Subtype then + Ancest := Ancestor_Subtype (Typ); + + if Present (Ancest) + and then Is_Constrained (Ancest) + and then Present (Packed_Array_Type (Ancest)) + then + Set_Packed_Array_Type (Typ, Packed_Array_Type (Ancest)); + return; + end if; + end if; + + -- We preset the result type size from the size of the original array + -- type, since this size clearly belongs to the packed array type. The + -- size of the conceptual unpacked type is always set to unknown. + + Esiz := Esize (Typ); + + -- Case of an array where at least one index is of an enumeration + -- type with a non-standard representation, but the component size + -- is not appropriate for bit packing. This is the case where we + -- have Is_Packed set (we would never be in this unit otherwise), + -- but Is_Bit_Packed_Array is false. + + -- Note that if the component size is appropriate for bit packing, + -- then the circuit for the computation of the subscript properly + -- deals with the non-standard enumeration type case by taking the + -- Pos anyway. + + if not Is_Bit_Packed_Array (Typ) then + + -- Here we build a declaration: + + -- type tttP is array (index1, index2, ...) of component_type + + -- where index1, index2, are the index types. These are the same + -- as the index types of the original array, except for the non- + -- standard representation enumeration type case, where we have + -- two subcases. + + -- For the unconstrained array case, we use + + -- Natural range <> + + -- For the constrained case, we use + + -- Natural range Enum_Type'Pos (Enum_Type'First) .. + -- Enum_Type'Pos (Enum_Type'Last); + + PAT := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'P')); + + Set_Packed_Array_Type (Typ, PAT); + + declare + Indexes : List_Id := New_List; + Indx : Node_Id; + Indx_Typ : Entity_Id; + Enum_Case : Boolean; + Typedef : Node_Id; + + begin + Indx := First_Index (Typ); + + while Present (Indx) loop + Indx_Typ := Etype (Indx); + + Enum_Case := Is_Enumeration_Type (Indx_Typ) + and then Has_Non_Standard_Rep (Indx_Typ); + + -- Unconstrained case + + if not Is_Constrained (Typ) then + if Enum_Case then + Indx_Typ := Standard_Natural; + end if; + + Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc)); + + -- Constrained case + + else + if not Enum_Case then + Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc)); + + else + Append_To (Indexes, + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_First))), + + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_Last))))))); + + end if; + end if; + + Next_Index (Indx); + end loop; + + if not Is_Constrained (Typ) then + Typedef := + Make_Unconstrained_Array_Definition (Loc, + Subtype_Marks => Indexes, + Subtype_Indication => + New_Occurrence_Of (Ctyp, Loc)); + + else + Typedef := + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => Indexes, + Subtype_Indication => + New_Occurrence_Of (Ctyp, Loc)); + end if; + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => PAT, + Type_Definition => Typedef); + end; + + Install_PAT; + return; + + -- Case of bit-packing required for unconstrained array. We simply + -- use Packed_Bytes{1,2,4} as appropriate, and we do not need to + -- construct a special packed array type. + + elsif not Is_Constrained (Typ) then + Set_PB_Type; + Set_Packed_Array_Type (Typ, PB_Type); + Set_Is_Packed_Array_Type (Packed_Array_Type (Typ), True); + return; + + -- Remaining code is for the case of bit-packing for constrained array + + -- The name of the packed array subtype is + + -- ttt___Xsss + + -- where sss is the component size in bits and ttt is the name of + -- the parent packed type. + + else + PAT := + Make_Defining_Identifier (Loc, + Chars => Make_Packed_Array_Type_Name (Typ, Csize)); + + Set_Packed_Array_Type (Typ, PAT); + + -- Build an expression for the length of the array in bits. + -- This is the product of the length of each of the dimensions + + declare + J : Nat := 1; + + begin + Len_Expr := Empty; -- suppress junk warning + + loop + Len_Dim := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Typ, Loc), + Expressions => New_List ( + Make_Integer_Literal (Loc, J))); + + if J = 1 then + Len_Expr := Len_Dim; + + else + Len_Expr := + Make_Op_Multiply (Loc, + Left_Opnd => Len_Expr, + Right_Opnd => Len_Dim); + end if; + + J := J + 1; + exit when J > Number_Dimensions (Typ); + end loop; + end; + + -- Temporarily attach the length expression to the tree and analyze + -- and resolve it, so that we can test its value. We assume that the + -- total length fits in type Integer. + + Set_Parent (Len_Expr, Typ); + Analyze_And_Resolve (Len_Expr, Standard_Integer); + + -- Use a modular type if possible. We can do this if we are we + -- have static bounds, and the length is small enough, and the + -- length is not zero. We exclude the zero length case because the + -- size of things is always at least one, and the zero length object + -- would have an anomous size + + if Compile_Time_Known_Value (Len_Expr) then + Len_Bits := Expr_Value (Len_Expr) * Csize; + + -- We normally consider small enough to mean no larger than the + -- value of System_Max_Binary_Modulus_Power, except that in + -- No_Run_Time mode, we use the Word Size on machines for + -- which double length shifts are not generated in line. + + if Len_Bits > 0 + and then + (Len_Bits <= System_Word_Size + or else (Len_Bits <= System_Max_Binary_Modulus_Power + and then (not No_Run_Time + or else + Long_Shifts_Inlined_On_Target))) + then + -- We can use the modular type, it has the form: + + -- subtype tttPn is btyp + -- range 0 .. 2 ** (Esize (Typ) * Csize) - 1; + + -- Here Siz is 1, 2 or 4, as computed above, and btyp is either + -- Unsigned or Long_Long_Unsigned depending on the length. + + if Len_Bits <= Standard_Integer_Size then + Btyp := RTE (RE_Unsigned); + else + Btyp := RTE (RE_Long_Long_Unsigned); + end if; + + Lit := Make_Integer_Literal (Loc, 2 ** Len_Bits - 1); + Set_Print_In_Hex (Lit); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => PAT, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Btyp, Loc), + + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => Lit)))); + + if Esiz = Uint_0 then + Esiz := Len_Bits; + end if; + + Install_PAT; + return; + end if; + end if; + + -- Could not use a modular type, for all other cases, we build + -- a packed array subtype: + + -- subtype tttPn is + -- System.Packed_Bytes{1,2,4} (0 .. (Bits + 7) / 8 - 1); + + -- Bits is the length of the array in bits. + + Set_PB_Type; + + Bits_U1 := + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, Csize), + Right_Opnd => Len_Expr), + + Right_Opnd => + Make_Integer_Literal (Loc, 7)); + + Set_Paren_Count (Bits_U1, 1); + + PAT_High := + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => Bits_U1, + Right_Opnd => Make_Integer_Literal (Loc, 8)), + Right_Opnd => Make_Integer_Literal (Loc, 1)); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => PAT, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (PB_Type, Loc), + Constraint => + + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => PAT_High))))); + + Install_PAT; + end if; + end Create_Packed_Array_Type; + + ----------------------------------- + -- Expand_Bit_Packed_Element_Set -- + ----------------------------------- + + procedure Expand_Bit_Packed_Element_Set (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lhs : constant Node_Id := Name (N); + + Ass_OK : constant Boolean := Assignment_OK (Lhs); + -- Used to preserve assignment OK status when assignment is rewritten + + Rhs : Node_Id := Expression (N); + -- Initially Rhs is the right hand side value, it will be replaced + -- later by an appropriate unchecked conversion for the assignment. + + Obj : Node_Id; + Atyp : Entity_Id; + PAT : Entity_Id; + Ctyp : Entity_Id; + Csiz : Int; + Shift : Node_Id; + Cmask : Uint; + + New_Lhs : Node_Id; + New_Rhs : Node_Id; + + Rhs_Val_Known : Boolean; + Rhs_Val : Uint; + -- If the value of the right hand side as an integer constant is + -- known at compile time, Rhs_Val_Known is set True, and Rhs_Val + -- contains the value. Otherwise Rhs_Val_Known is set False, and + -- the Rhs_Val is undefined. + + begin + pragma Assert (Is_Bit_Packed_Array (Etype (Prefix (Lhs)))); + + Obj := Relocate_Node (Prefix (Lhs)); + Convert_To_Actual_Subtype (Obj); + Atyp := Etype (Obj); + PAT := Packed_Array_Type (Atyp); + Ctyp := Component_Type (Atyp); + Csiz := UI_To_Int (Component_Size (Atyp)); + + -- We convert the right hand side to the proper subtype to ensure + -- that an appropriate range check is made (since the normal range + -- check from assignment will be lost in the transformations). This + -- conversion is analyzed immediately so that subsequent processing + -- can work with an analyzed Rhs (and e.g. look at its Etype) + + Rhs := Convert_To (Ctyp, Rhs); + Set_Parent (Rhs, N); + Analyze_And_Resolve (Rhs, Ctyp); + + -- Case of component size 1,2,4 or any component size for the modular + -- case. These are the cases for which we can inline the code. + + if Csiz = 1 or else Csiz = 2 or else Csiz = 4 + or else (Present (PAT) and then Is_Modular_Integer_Type (PAT)) + then + Setup_Inline_Packed_Array_Reference (Lhs, Atyp, Obj, Cmask, Shift); + + -- The statement to be generated is: + + -- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, shift))) + + -- where mask1 is obtained by shifting Cmask left Shift bits + -- and then complementing the result. + + -- the "and Mask1" is omitted if rhs is constant and all 1 bits + + -- the "or ..." is omitted if rhs is constant and all 0 bits + + -- rhs is converted to the appropriate type. + + -- The result is converted back to the array type, since + -- otherwise we lose knowledge of the packed nature. + + -- Determine if right side is all 0 bits or all 1 bits + + if Compile_Time_Known_Value (Rhs) then + Rhs_Val := Expr_Rep_Value (Rhs); + Rhs_Val_Known := True; + + -- The following test catches the case of an unchecked conversion + -- of an integer literal. This results from optimizing aggregates + -- of packed types. + + elsif Nkind (Rhs) = N_Unchecked_Type_Conversion + and then Compile_Time_Known_Value (Expression (Rhs)) + then + Rhs_Val := Expr_Rep_Value (Expression (Rhs)); + Rhs_Val_Known := True; + + else + Rhs_Val := No_Uint; + Rhs_Val_Known := False; + end if; + + -- Some special checks for the case where the right hand value + -- is known at compile time. Basically we have to take care of + -- the implicit conversion to the subtype of the component object. + + if Rhs_Val_Known then + + -- If we have a biased component type then we must manually do + -- the biasing, since we are taking responsibility in this case + -- for constructing the exact bit pattern to be used. + + if Has_Biased_Representation (Ctyp) then + Rhs_Val := Rhs_Val - Expr_Rep_Value (Type_Low_Bound (Ctyp)); + end if; + + -- For a negative value, we manually convert the twos complement + -- value to a corresponding unsigned value, so that the proper + -- field width is maintained. If we did not do this, we would + -- get too many leading sign bits later on. + + if Rhs_Val < 0 then + Rhs_Val := 2 ** UI_From_Int (Csiz) + Rhs_Val; + end if; + end if; + + New_Lhs := Duplicate_Subexpr (Obj, True); + New_Rhs := Duplicate_Subexpr (Obj); + + -- First we deal with the "and" + + if not Rhs_Val_Known or else Rhs_Val /= Cmask then + declare + Mask1 : Node_Id; + Lit : Node_Id; + + begin + if Compile_Time_Known_Value (Shift) then + Mask1 := + Make_Integer_Literal (Loc, + Modulus (Etype (Obj)) - 1 - + (Cmask * (2 ** Expr_Value (Shift)))); + Set_Print_In_Hex (Mask1); + + else + Lit := Make_Integer_Literal (Loc, Cmask); + Set_Print_In_Hex (Lit); + Mask1 := + Make_Op_Not (Loc, + Right_Opnd => Make_Shift_Left (Lit, Shift)); + end if; + + New_Rhs := + Make_Op_And (Loc, + Left_Opnd => New_Rhs, + Right_Opnd => Mask1); + end; + end if; + + -- Then deal with the "or" + + if not Rhs_Val_Known or else Rhs_Val /= 0 then + declare + Or_Rhs : Node_Id; + + procedure Fixup_Rhs; + -- Adjust Rhs by bias if biased representation for components + -- or remove extraneous high order sign bits if signed. + + procedure Fixup_Rhs is + Etyp : constant Entity_Id := Etype (Rhs); + + begin + -- For biased case, do the required biasing by simply + -- converting to the biased subtype (the conversion + -- will generate the required bias). + + if Has_Biased_Representation (Ctyp) then + Rhs := Convert_To (Ctyp, Rhs); + + -- For a signed integer type that is not biased, generate + -- a conversion to unsigned to strip high order sign bits. + + elsif Is_Signed_Integer_Type (Ctyp) then + Rhs := Unchecked_Convert_To (RTE (Bits_Id (Csiz)), Rhs); + end if; + + -- Set Etype, since it can be referenced before the + -- node is completely analyzed. + + Set_Etype (Rhs, Etyp); + + -- We now need to do an unchecked conversion of the + -- result to the target type, but it is important that + -- this conversion be a right justified conversion and + -- not a left justified conversion. + + Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs); + + end Fixup_Rhs; + + begin + if Rhs_Val_Known + and then Compile_Time_Known_Value (Shift) + then + Or_Rhs := + Make_Integer_Literal (Loc, + Rhs_Val * (2 ** Expr_Value (Shift))); + Set_Print_In_Hex (Or_Rhs); + + else + -- We have to convert the right hand side to Etype (Obj). + -- A special case case arises if what we have now is a Val + -- attribute reference whose expression type is Etype (Obj). + -- This happens for assignments of fields from the same + -- array. In this case we get the required right hand side + -- by simply removing the inner attribute reference. + + if Nkind (Rhs) = N_Attribute_Reference + and then Attribute_Name (Rhs) = Name_Val + and then Etype (First (Expressions (Rhs))) = Etype (Obj) + then + Rhs := Relocate_Node (First (Expressions (Rhs))); + Fixup_Rhs; + + -- If the value of the right hand side is a known integer + -- value, then just replace it by an untyped constant, + -- which will be properly retyped when we analyze and + -- resolve the expression. + + elsif Rhs_Val_Known then + + -- Note that Rhs_Val has already been normalized to + -- be an unsigned value with the proper number of bits. + + Rhs := + Make_Integer_Literal (Loc, Rhs_Val); + + -- Otherwise we need an unchecked conversion + + else + Fixup_Rhs; + end if; + + Or_Rhs := Make_Shift_Left (Rhs, Shift); + end if; + + if Nkind (New_Rhs) = N_Op_And then + Set_Paren_Count (New_Rhs, 1); + end if; + + New_Rhs := + Make_Op_Or (Loc, + Left_Opnd => New_Rhs, + Right_Opnd => Or_Rhs); + end; + end if; + + -- Now do the rewrite + + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Lhs, + Expression => + Unchecked_Convert_To (Etype (New_Lhs), New_Rhs))); + Set_Assignment_OK (Name (N), Ass_OK); + + -- All other component sizes for non-modular case + + else + -- We generate + + -- Set_nn (Arr'address, Subscr, Bits_nn!(Rhs)) + + -- where Subscr is the computed linear subscript. + + declare + Bits_nn : constant Entity_Id := RTE (Bits_Id (Csiz)); + Set_nn : Entity_Id; + Subscr : Node_Id; + Atyp : Entity_Id; + + begin + -- Acquire proper Set entity. We use the aligned or unaligned + -- case as appropriate. + + if Must_Be_Aligned (Obj) then + Set_nn := RTE (Set_Id (Csiz)); + else + Set_nn := RTE (SetU_Id (Csiz)); + end if; + + -- Now generate the set reference + + Obj := Relocate_Node (Prefix (Lhs)); + Convert_To_Actual_Subtype (Obj); + Atyp := Etype (Obj); + Compute_Linear_Subscript (Atyp, Lhs, Subscr); + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Set_nn, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => Obj), + Subscr, + Unchecked_Convert_To (Bits_nn, + Convert_To (Ctyp, Rhs))))); + + end; + end if; + + Analyze (N, Suppress => All_Checks); + end Expand_Bit_Packed_Element_Set; + + ------------------------------------- + -- Expand_Packed_Address_Reference -- + ------------------------------------- + + procedure Expand_Packed_Address_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ploc : Source_Ptr; + Pref : Node_Id; + Expr : Node_Id; + Term : Node_Id; + Atyp : Entity_Id; + Subscr : Node_Id; + + begin + Pref := Prefix (N); + Expr := Empty; + + -- We build up an expression serially that has the form + + -- outer_object'Address + -- + (linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + -- + ...) / Storage_Unit; + + -- Some additional conversions are required to deal with the addition + -- operation, which is not normally visible to generated code. + + loop + Ploc := Sloc (Pref); + + if Nkind (Pref) = N_Indexed_Component then + Convert_To_Actual_Subtype (Prefix (Pref)); + Atyp := Etype (Prefix (Pref)); + Compute_Linear_Subscript (Atyp, Pref, Subscr); + + Term := + Make_Op_Multiply (Ploc, + Left_Opnd => Subscr, + Right_Opnd => + Make_Attribute_Reference (Ploc, + Prefix => New_Occurrence_Of (Atyp, Ploc), + Attribute_Name => Name_Component_Size)); + + elsif Nkind (Pref) = N_Selected_Component then + Term := + Make_Attribute_Reference (Ploc, + Prefix => Selector_Name (Pref), + Attribute_Name => Name_Bit_Position); + + else + exit; + end if; + + Term := Convert_To (RTE (RE_Integer_Address), Term); + + if No (Expr) then + Expr := Term; + + else + Expr := + Make_Op_Add (Ploc, + Left_Opnd => Expr, + Right_Opnd => Term); + end if; + + Pref := Prefix (Pref); + end loop; + + Rewrite (N, + Unchecked_Convert_To (RTE (RE_Address), + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Address)), + + Right_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => Expr, + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit))))); + + Analyze_And_Resolve (N, RTE (RE_Address)); + end Expand_Packed_Address_Reference; + + ------------------------------------ + -- Expand_Packed_Boolean_Operator -- + ------------------------------------ + + -- This routine expands "a op b" for the packed cases + + procedure Expand_Packed_Boolean_Operator (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + L : constant Node_Id := Relocate_Node (Left_Opnd (N)); + R : constant Node_Id := Relocate_Node (Right_Opnd (N)); + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + PAT : Entity_Id; + + begin + Convert_To_Actual_Subtype (L); + Convert_To_Actual_Subtype (R); + + Ensure_Defined (Etype (L), N); + Ensure_Defined (Etype (R), N); + + Apply_Length_Check (R, Etype (L)); + + Ltyp := Etype (L); + Rtyp := Etype (R); + + -- First an odd and silly test. We explicitly check for the XOR + -- case where the component type is True .. True, since this will + -- raise constraint error. A special check is required since CE + -- will not be required other wise (cf Expand_Packed_Not). + + -- No such check is required for AND and OR, since for both these + -- cases False op False = False, and True op True = True. + + if Nkind (N) = N_Op_Xor then + declare + CT : constant Entity_Id := Component_Type (Rtyp); + BT : constant Entity_Id := Base_Type (CT); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_And (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc))), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc)))))); + end; + end if; + + -- Now that that silliness is taken care of, get packed array type + + Convert_To_PAT_Type (L); + Convert_To_PAT_Type (R); + + PAT := Etype (L); + + -- For the modular case, we expand a op b into + + -- rtyp!(pat!(a) op pat!(b)) + + -- where rtyp is the Etype of the left operand. Note that we do not + -- convert to the base type, since this would be unconstrained, and + -- hence not have a corresponding packed array type set. + + if Is_Modular_Integer_Type (PAT) then + declare + P : Node_Id; + + begin + if Nkind (N) = N_Op_And then + P := Make_Op_And (Loc, L, R); + + elsif Nkind (N) = N_Op_Or then + P := Make_Op_Or (Loc, L, R); + + else -- Nkind (N) = N_Op_Xor + P := Make_Op_Xor (Loc, L, R); + end if; + + Rewrite (N, Unchecked_Convert_To (Rtyp, P)); + end; + + -- For the array case, we insert the actions + + -- Result : Ltype; + + -- System.Bitops.Bit_And/Or/Xor + -- (Left'Address, + -- Ltype'Length * Ltype'Component_Size; + -- Right'Address, + -- Rtype'Length * Rtype'Component_Size + -- Result'Address); + + -- where Left and Right are the Packed_Bytes{1,2,4} operands and + -- the second argument and fourth arguments are the lengths of the + -- operands in bits. Then we replace the expression by a reference + -- to Result. + + else + declare + Result_Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + E_Id : RE_Id; + + begin + if Nkind (N) = N_Op_And then + E_Id := RE_Bit_And; + + elsif Nkind (N) = N_Op_Or then + E_Id := RE_Bit_Or; + + else -- Nkind (N) = N_Op_Xor + E_Id := RE_Bit_Xor; + end if; + + Insert_Actions (N, New_List ( + + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Ent, + Object_Definition => New_Occurrence_Of (Ltyp, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (E_Id), Loc), + Parameter_Associations => New_List ( + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => L), + + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Index (Ltyp)), Loc), + Attribute_Name => Name_Range_Length), + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Ltyp))), + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => R), + + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Index (Rtyp)), Loc), + Attribute_Name => Name_Range_Length), + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Rtyp))), + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); + + Rewrite (N, + New_Occurrence_Of (Result_Ent, Loc)); + end; + end if; + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Packed_Boolean_Operator; + + ------------------------------------- + -- Expand_Packed_Element_Reference -- + ------------------------------------- + + procedure Expand_Packed_Element_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Obj : Node_Id; + Atyp : Entity_Id; + PAT : Entity_Id; + Ctyp : Entity_Id; + Csiz : Int; + Shift : Node_Id; + Cmask : Uint; + Lit : Node_Id; + Arg : Node_Id; + + begin + -- If not bit packed, we have the enumeration case, which is easily + -- dealt with (just adjust the subscripts of the indexed component) + + -- Note: this leaves the result as an indexed component, which is + -- still a variable, so can be used in the assignment case, as is + -- required in the enumeration case. + + if not Is_Bit_Packed_Array (Etype (Prefix (N))) then + Setup_Enumeration_Packed_Array_Reference (N); + return; + end if; + + -- Remaining processing is for the bit-packed case. + + Obj := Relocate_Node (Prefix (N)); + Convert_To_Actual_Subtype (Obj); + Atyp := Etype (Obj); + PAT := Packed_Array_Type (Atyp); + Ctyp := Component_Type (Atyp); + Csiz := UI_To_Int (Component_Size (Atyp)); + + -- Case of component size 1,2,4 or any component size for the modular + -- case. These are the cases for which we can inline the code. + + if Csiz = 1 or else Csiz = 2 or else Csiz = 4 + or else (Present (PAT) and then Is_Modular_Integer_Type (PAT)) + then + Setup_Inline_Packed_Array_Reference (N, Atyp, Obj, Cmask, Shift); + Lit := Make_Integer_Literal (Loc, Cmask); + Set_Print_In_Hex (Lit); + + -- We generate a shift right to position the field, followed by a + -- masking operation to extract the bit field, and we finally do an + -- unchecked conversion to convert the result to the required target. + + -- Note that the unchecked conversion automatically deals with the + -- bias if we are dealing with a biased representation. What will + -- happen is that we temporarily generate the biased representation, + -- but almost immediately that will be converted to the original + -- unbiased component type, and the bias will disappear. + + Arg := + Make_Op_And (Loc, + Left_Opnd => Make_Shift_Right (Obj, Shift), + Right_Opnd => Lit); + + Analyze_And_Resolve (Arg); + + Rewrite (N, + RJ_Unchecked_Convert_To (Ctyp, Arg)); + + -- All other component sizes for non-modular case + + else + -- We generate + + -- Component_Type!(Get_nn (Arr'address, Subscr)) + + -- where Subscr is the computed linear subscript. + + declare + Get_nn : Entity_Id; + Subscr : Node_Id; + + begin + -- Acquire proper Get entity. We use the aligned or unaligned + -- case as appropriate. + + if Must_Be_Aligned (Obj) then + Get_nn := RTE (Get_Id (Csiz)); + else + Get_nn := RTE (GetU_Id (Csiz)); + end if; + + -- Now generate the get reference + + Compute_Linear_Subscript (Atyp, N, Subscr); + + Rewrite (N, + Unchecked_Convert_To (Ctyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Get_nn, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => Obj), + Subscr)))); + end; + end if; + + Analyze_And_Resolve (N, Ctyp, Suppress => All_Checks); + + end Expand_Packed_Element_Reference; + + ---------------------- + -- Expand_Packed_Eq -- + ---------------------- + + -- Handles expansion of "=" on packed array types + + procedure Expand_Packed_Eq (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Relocate_Node (Left_Opnd (N)); + R : constant Node_Id := Relocate_Node (Right_Opnd (N)); + + LLexpr : Node_Id; + RLexpr : Node_Id; + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + PAT : Entity_Id; + + begin + Convert_To_Actual_Subtype (L); + Convert_To_Actual_Subtype (R); + Ltyp := Underlying_Type (Etype (L)); + Rtyp := Underlying_Type (Etype (R)); + + Convert_To_PAT_Type (L); + Convert_To_PAT_Type (R); + PAT := Etype (L); + + LLexpr := + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Ltyp, Loc)), + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Ltyp))); + + RLexpr := + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Rtyp, Loc)), + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Rtyp))); + + -- For the modular case, we transform the comparison to: + + -- Ltyp'Length = Rtyp'Length and then PAT!(L) = PAT!(R) + + -- where PAT is the packed array type. This works fine, since in the + -- modular case we guarantee that the unused bits are always zeroes. + -- We do have to compare the lengths because we could be comparing + -- two different subtypes of the same base type. + + if Is_Modular_Integer_Type (PAT) then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => LLexpr, + Right_Opnd => RLexpr), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => L, + Right_Opnd => R))); + + -- For the non-modular case, we call a runtime routine + + -- System.Bit_Ops.Bit_Eq + -- (L'Address, L_Length, R'Address, R_Length) + + -- where PAT is the packed array type, and the lengths are the lengths + -- in bits of the original packed arrays. This routine takes care of + -- not comparing the unused bits in the last byte. + + else + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => L), + + LLexpr, + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => R), + + RLexpr))); + end if; + + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end Expand_Packed_Eq; + + ----------------------- + -- Expand_Packed_Not -- + ----------------------- + + -- Handles expansion of "not" on packed array types + + procedure Expand_Packed_Not (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Opnd : constant Node_Id := Relocate_Node (Right_Opnd (N)); + + Rtyp : Entity_Id; + PAT : Entity_Id; + Lit : Node_Id; + + begin + Convert_To_Actual_Subtype (Opnd); + Rtyp := Etype (Opnd); + + -- First an odd and silly test. We explicitly check for the case + -- where the 'First of the component type is equal to the 'Last of + -- this component type, and if this is the case, we make sure that + -- constraint error is raised. The reason is that the NOT is bound + -- to cause CE in this case, and we will not otherwise catch it. + + -- Believe it or not, this was reported as a bug. Note that nearly + -- always, the test will evaluate statically to False, so the code + -- will be statically removed, and no extra overhead caused. + + declare + CT : constant Entity_Id := Component_Type (Rtyp); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last)))); + end; + + -- Now that that silliness is taken care of, get packed array type + + Convert_To_PAT_Type (Opnd); + PAT := Etype (Opnd); + + -- For the case where the packed array type is a modular type, + -- not A expands simply into: + + -- rtyp!(PAT!(A) xor mask) + + -- where PAT is the packed array type, and mask is a mask of all + -- one bits of length equal to the size of this packed type and + -- rtyp is the actual subtype of the operand + + Lit := Make_Integer_Literal (Loc, 2 ** Esize (PAT) - 1); + Set_Print_In_Hex (Lit); + + if not Is_Array_Type (PAT) then + Rewrite (N, + Unchecked_Convert_To (Rtyp, + Make_Op_Xor (Loc, + Left_Opnd => Opnd, + Right_Opnd => Lit))); + + -- For the array case, we insert the actions + + -- Result : Typ; + + -- System.Bitops.Bit_Not + -- (Opnd'Address, + -- Typ'Length * Typ'Component_Size; + -- Result'Address); + + -- where Opnd is the Packed_Bytes{1,2,4} operand and the second + -- argument is the length of the operand in bits. Then we replace + -- the expression by a reference to Result. + + else + declare + Result_Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + begin + Insert_Actions (N, New_List ( + + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Ent, + Object_Definition => New_Occurrence_Of (Rtyp, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc), + Parameter_Associations => New_List ( + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => Opnd), + + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Index (Rtyp)), Loc), + Attribute_Name => Name_Range_Length), + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Rtyp))), + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); + + Rewrite (N, + New_Occurrence_Of (Result_Ent, Loc)); + end; + end if; + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + + end Expand_Packed_Not; + + ------------------------------------- + -- Involves_Packed_Array_Reference -- + ------------------------------------- + + function Involves_Packed_Array_Reference (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Indexed_Component + and then Is_Bit_Packed_Array (Etype (Prefix (N))) + then + return True; + + elsif Nkind (N) = N_Selected_Component then + return Involves_Packed_Array_Reference (Prefix (N)); + + else + return False; + end if; + end Involves_Packed_Array_Reference; + + --------------------- + -- Make_Shift_Left -- + --------------------- + + function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id is + Nod : Node_Id; + + begin + if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then + return N; + else + Nod := + Make_Op_Shift_Left (Sloc (N), + Left_Opnd => N, + Right_Opnd => S); + Set_Shift_Count_OK (Nod, True); + return Nod; + end if; + end Make_Shift_Left; + + ---------------------- + -- Make_Shift_Right -- + ---------------------- + + function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id is + Nod : Node_Id; + + begin + if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then + return N; + else + Nod := + Make_Op_Shift_Right (Sloc (N), + Left_Opnd => N, + Right_Opnd => S); + Set_Shift_Count_OK (Nod, True); + return Nod; + end if; + end Make_Shift_Right; + + ----------------------------- + -- RJ_Unchecked_Convert_To -- + ----------------------------- + + function RJ_Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) + return Node_Id + is + Source_Typ : constant Entity_Id := Etype (Expr); + Target_Typ : constant Entity_Id := Typ; + + Src : Node_Id := Expr; + + Source_Siz : Nat; + Target_Siz : Nat; + + begin + Source_Siz := UI_To_Int (RM_Size (Source_Typ)); + Target_Siz := UI_To_Int (RM_Size (Target_Typ)); + + -- In the big endian case, if the lengths of the two types differ, + -- then we must worry about possible left justification in the + -- conversion, and avoiding that is what this is all about. + + if Bytes_Big_Endian and then Source_Siz /= Target_Siz then + + -- First step, if the source type is not a discrete type, then we + -- first convert to a modular type of the source length, since + -- otherwise, on a big-endian machine, we get left-justification. + + if not Is_Discrete_Type (Source_Typ) then + Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src); + end if; + + -- Next step. If the target is not a discrete type, then we first + -- convert to a modular type of the target length, since + -- otherwise, on a big-endian machine, we get left-justification. + + if not Is_Discrete_Type (Target_Typ) then + Src := Unchecked_Convert_To (RTE (Bits_Id (Target_Siz)), Src); + end if; + end if; + + -- And now we can do the final conversion to the target type + + return Unchecked_Convert_To (Target_Typ, Src); + end RJ_Unchecked_Convert_To; + + ---------------------------------------------- + -- Setup_Enumeration_Packed_Array_Reference -- + ---------------------------------------------- + + -- All we have to do here is to find the subscripts that correspond + -- to the index positions that have non-standard enumeration types + -- and insert a Pos attribute to get the proper subscript value. + -- Finally the prefix must be uncheck converted to the corresponding + -- packed array type. + + -- Note that the component type is unchanged, so we do not need to + -- fiddle with the types (Gigi always automatically takes the packed + -- array type if it is set, as it will be in this case). + + procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id) is + Pfx : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Etype (N); + Exprs : constant List_Id := Expressions (N); + Expr : Node_Id; + + begin + -- If the array is unconstrained, then we replace the array + -- reference with its actual subtype. This actual subtype will + -- have a packed array type with appropriate bounds. + + if not Is_Constrained (Packed_Array_Type (Etype (Pfx))) then + Convert_To_Actual_Subtype (Pfx); + end if; + + Expr := First (Exprs); + while Present (Expr) loop + declare + Loc : constant Source_Ptr := Sloc (Expr); + Expr_Typ : constant Entity_Id := Etype (Expr); + + begin + if Is_Enumeration_Type (Expr_Typ) + and then Has_Non_Standard_Rep (Expr_Typ) + then + Rewrite (Expr, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Expr_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Relocate_Node (Expr)))); + Analyze_And_Resolve (Expr, Standard_Natural); + end if; + end; + + Next (Expr); + end loop; + + Rewrite (N, + Make_Indexed_Component (Sloc (N), + Prefix => + Unchecked_Convert_To (Packed_Array_Type (Etype (Pfx)), Pfx), + Expressions => Exprs)); + + Analyze_And_Resolve (N, Typ); + + end Setup_Enumeration_Packed_Array_Reference; + + ----------------------------------------- + -- Setup_Inline_Packed_Array_Reference -- + ----------------------------------------- + + procedure Setup_Inline_Packed_Array_Reference + (N : Node_Id; + Atyp : Entity_Id; + Obj : in out Node_Id; + Cmask : out Uint; + Shift : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Ctyp : Entity_Id; + PAT : Entity_Id; + Otyp : Entity_Id; + Csiz : Uint; + Osiz : Uint; + + begin + Ctyp := Component_Type (Atyp); + Csiz := Component_Size (Atyp); + + Convert_To_PAT_Type (Obj); + PAT := Etype (Obj); + + Cmask := 2 ** Csiz - 1; + + if Is_Array_Type (PAT) then + Otyp := Component_Type (PAT); + Osiz := Esize (Otyp); + + else + Otyp := PAT; + + -- In the case where the PAT is a modular type, we want the actual + -- size in bits of the modular value we use. This is neither the + -- Object_Size nor the Value_Size, either of which may have been + -- reset to strange values, but rather the minimum size. Note that + -- since this is a modular type with full range, the issue of + -- biased representation does not arise. + + Osiz := UI_From_Int (Minimum_Size (Otyp)); + end if; + + Compute_Linear_Subscript (Atyp, N, Shift); + + -- If the component size is not 1, then the subscript must be + -- multiplied by the component size to get the shift count. + + if Csiz /= 1 then + Shift := + Make_Op_Multiply (Loc, + Left_Opnd => Make_Integer_Literal (Loc, Csiz), + Right_Opnd => Shift); + end if; + + -- If we have the array case, then this shift count must be broken + -- down into a byte subscript, and a shift within the byte. + + if Is_Array_Type (PAT) then + + declare + New_Shift : Node_Id; + + begin + -- We must analyze shift, since we will duplicate it + + Set_Parent (Shift, N); + Analyze_And_Resolve + (Shift, Standard_Integer, Suppress => All_Checks); + + -- The shift count within the word is + -- shift mod Osiz + + New_Shift := + Make_Op_Mod (Loc, + Left_Opnd => Duplicate_Subexpr (Shift), + Right_Opnd => Make_Integer_Literal (Loc, Osiz)); + + -- The subscript to be used on the PAT array is + -- shift / Osiz + + Obj := + Make_Indexed_Component (Loc, + Prefix => Obj, + Expressions => New_List ( + Make_Op_Divide (Loc, + Left_Opnd => Duplicate_Subexpr (Shift), + Right_Opnd => Make_Integer_Literal (Loc, Osiz)))); + + Shift := New_Shift; + end; + + -- For the modular integer case, the object to be manipulated is + -- the entire array, so Obj is unchanged. Note that we will reset + -- its type to PAT before returning to the caller. + + else + null; + end if; + + -- The one remaining step is to modify the shift count for the + -- big-endian case. Consider the following example in a byte: + + -- xxxxxxxx bits of byte + -- vvvvvvvv bits of value + -- 33221100 little-endian numbering + -- 00112233 big-endian numbering + + -- Here we have the case of 2-bit fields + + -- For the little-endian case, we already have the proper shift + -- count set, e.g. for element 2, the shift count is 2*2 = 4. + + -- For the big endian case, we have to adjust the shift count, + -- computing it as (N - F) - shift, where N is the number of bits + -- in an element of the array used to implement the packed array, + -- F is the number of bits in a source level array element, and + -- shift is the count so far computed. + + if Bytes_Big_Endian then + Shift := + Make_Op_Subtract (Loc, + Left_Opnd => Make_Integer_Literal (Loc, Osiz - Csiz), + Right_Opnd => Shift); + end if; + + Set_Parent (Shift, N); + Set_Parent (Obj, N); + Analyze_And_Resolve (Obj, Otyp, Suppress => All_Checks); + Analyze_And_Resolve (Shift, Standard_Integer, Suppress => All_Checks); + + -- Make sure final type of object is the appropriate packed type + + Set_Etype (Obj, Otyp); + + end Setup_Inline_Packed_Array_Reference; + +end Exp_Pakd; diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads new file mode 100644 index 00000000000..8cfcead4f6f --- /dev/null +++ b/gcc/ada/exp_pakd.ads @@ -0,0 +1,280 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P A K D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.22 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for manipulation of packed arrays + +with Types; use Types; + +package Exp_Pakd is + + ------------------------------------- + -- Implementation of Packed Arrays -- + ------------------------------------- + + -- When a packed array (sub)type is frozen, we create a corresponding + -- type that will be used to hold the bits of the packed value, and + -- store the entity for this type in the Packed_Array_Type field of the + -- E_Array_Type or E_Array_Subtype entity for the packed array. + + -- This packed array type has the name xxxPn, where xxx is the name + -- of the packed type, and n is the component size. The expanded + -- declaration declares a type that is one of the following: + + -- For an unconstrained array with component size 1,2,4 or any other + -- odd component size. These are the cases in which we do not need + -- to align the underlying array. + + -- type xxxPn is new Packed_Bytes1; + + -- For an unconstrained array with component size that is divisible + -- by 2, but not divisible by 4 (other than 2 itself). These are the + -- cases in which we can generate better code if the underlying array + -- is 2-byte aligned (see System.Pack_14 in file s-pack14 for example). + + -- type xxxPn is new Packed_Bytes2; + + -- For an unconstrained array with component size that is divisible + -- by 4, other than powers of 2 (which either come under the 1,2,4 + -- exception above, or are not packed at all). These are cases where + -- we can generate better code if the underlying array is 4-byte + -- aligned (see System.Pack_20 in file s-pack20 for example). + + -- type xxxPn is new Packed_Bytes4; + + -- For a constrained array with a static index type where the number + -- of bits does not exceed the size of Unsigned: + + -- type xxxPn is new Unsigned range 0 .. 2 ** nbits - 1; + + -- For a constrained array with a static index type where the number + -- of bits is greater than the size of Unsigned, but does not exceed + -- the size of Long_Long_Unsigned: + + -- type xxxPn is new Long_Long_Unsigned range 0 .. 2 ** nbits - 1; + + -- For all other constrained arrays, we use one of + + -- type xxxPn is new Packed_Bytes1 (0 .. m); + -- type xxxPn is new Packed_Bytes2 (0 .. m); + -- type xxxPn is new Packed_Bytes4 (0 .. m); + + -- where m is calculated (from the length of the original packed array) + -- to hold the required number of bits, and the choice of the particular + -- Packed_Bytes{1,2,4} type is made on the basis of alignment needs as + -- described above for the unconstrained case. + + -- When a variable of packed array type is allocated, gigi will allocate + -- the amount of space indicated by the corresponding packed array type. + -- However, we do NOT attempt to rewrite the types of any references or + -- to retype the variable itself, since this would cause all kinds of + -- semantic problems in the front end (remember that expansion proceeds + -- at the same time as analysis). + + -- For an indexed reference to a packed array, we simply convert the + -- reference to the appropriate equivalent reference to the object + -- of the packed array type (using unchecked conversion). + + -- In some cases (for internally generated types, and for the subtypes + -- for record fields that depend on a discriminant), the corresponding + -- packed type cannot be easily generated in advance. In these cases, + -- we generate the required subtype on the fly at the reference point. + + -- For the modular case, any unused bits are initialized to zero, and + -- all operations maintain these bits as zero (where necessary all + -- unchecked conversions from corresponding array values require + -- these bits to be clear, which is done automatically by gigi). + + -- For the array cases, there can be unused bits in the last byte, and + -- these are neither initialized, nor treated specially in operations + -- (i.e. it is allowable for these bits to be clobbered, e.g. by not). + + --------------------------- + -- Endian Considerations -- + --------------------------- + + -- The standard does not specify the way in which bits are numbered in + -- a packed array. There are two reasonable rules for deciding this: + + -- Store the first bit at right end (low order) word. This means + -- that the scaled subscript can be used directly as a right shift + -- count (if we put bit 0 at the left end, then we need an extra + -- subtract to compute the shift count. + + -- Layout the bits so that if the packed boolean array is overlaid on + -- a record, using unchecked conversion, then bit 0 of the array is + -- the same as the bit numbered bit 0 in a record representation + -- clause applying to the record. For example: + + -- type Rec is record + -- C : Bits4; + -- D : Bits7; + -- E : Bits5; + -- end record; + + -- for Rec use record + -- C at 0 range 0 .. 3; + -- D at 0 range 4 .. 10; + -- E at 0 range 11 .. 15; + -- end record; + + -- type P16 is array (0 .. 15) of Boolean; + -- pragma Pack (P16); + + -- Now if we use unchecked conversion to convert a value of the record + -- type to the packed array type, according to this second criterion, + -- we would expect field D to occupy bits 4..10 of the Boolean array. + + -- Although not required, this correspondence seems a highly desirable + -- property, and is one that GNAT decides to guarantee. For a little + -- endian machine, we can also meet the first requirement, but for a + -- big endian machine, it will be necessary to store the first bit of + -- a Boolean array in the left end (most significant) bit of the word. + -- This may cost an extra instruction on some machines, but we consider + -- that a worthwhile price to pay for the consistency. + + -- One more important point arises in the case where we have a constrained + -- subtype of an unconstrained array. Take the case of 20-bits. For the + -- unconstrained representation, we would use an array of bytes: + + -- Little-endian case + -- 8-7-6-5-4-3-2-1 16-15-14-13-12-11-10-9 x-x-x-x-20-19-18-17 + + -- Big-endian case + -- 1-2-3-4-5-6-7-8 9-10-11-12-13-14-15-16 17-18-19-20-x-x-x-x + + -- For the constrained case, we use a 20-bit modular value, but in + -- general this value may well be stored in 32 bits. Let's look at + -- what it looks like: + + -- Little-endian case + + -- x-x-x-x-x-x-x-x-x-x-x-x-20-19-18-17-...-10-9-8-7-6-5-4-3-2-1 + + -- which stored in memory looks like + + -- 8-7-...-2-1 16-15-...-10-9 x-x-x-x-20-19-18-17 x-x-x-x-x-x-x + + -- An important rule is that the constrained and unconstrained cases + -- must have the same bit representation in memory, since we will often + -- convert from one to the other (e.g. when calling a procedure whose + -- formal is unconstrained). As we see, that criterion is met for the + -- little-endian case above. Now let's look at the big-endian case: + + -- Big-endian case + + -- x-x-x-x-x-x-x-x-x-x-x-x-1-2-3-4-5-6-7-8-9-10-...-17-18-19-20 + + -- which stored in memory looks like + + -- x-x-x-x-x-x-x-x x-x-x-x-1-2-3-4 5-6-...11-12 13-14-...-19-20 + + -- That won't do, the representation value in memory is NOT the same in + -- the constrained and unconstrained case. The solution is to store the + -- modular value left-justified: + + -- 1-2-3-4-5-6-7-8-9-10-...-17-18-19-20-x-x-x-x-x-x-x-x-x-x-x + + -- which stored in memory looks like + + -- 1-2-...-7-8 9-10-...15-16 17-18-19-20-x-x-x-x x-x-x-x-x-x-x-x + + -- and now, we do indeed have the same representation. The special flag + -- Is_Left_Justified_Modular is set in the modular type used as the + -- packed array type in the big-endian case to ensure that this required + -- left justification occurs. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Create_Packed_Array_Type (Typ : Entity_Id); + -- Typ is a array type or subtype to which pragma Pack applies. If the + -- Packed_Array_Type field of Typ is already set, then the call has no + -- effect, otherwise a suitable type or subtype is created and stored + -- in the Packed_Array_Type field of Typ. This created type is an Itype + -- so that Gigi will simply elaborate and freeze the type on first use + -- (which is typically the definition of the corresponding array type). + -- + -- Note: although this routine is included in the expander package for + -- packed types, it is actually called unconditionally from Freeze, + -- whether or not expansion (and code generation) is enabled. We do this + -- since we want gigi to be able to properly compute type charactersitics + -- (for the Data Decomposition Annex of ASIS, and possible other future + -- uses) even if code generation is not active. Strictly this means that + -- this procedure is not part of the expander, but it seems appropriate + -- to keep it together with the other expansion routines that have to do + -- with packed array types. + + procedure Expand_Packed_Boolean_Operator (N : Node_Id); + -- N is an N_Op_And, N_Op_Or or N_Op_Xor node whose operand type is a + -- packed boolean array. This routine expands the appropriate operations + -- to carry out the logical operation on the packed arrays. It handles + -- both the modular and array representation cases. + + procedure Expand_Packed_Element_Reference (N : Node_Id); + -- N is an N_Indexed_Component node whose prefix is a packed array. In + -- the bit packed case, this routine can only be used for the expression + -- evaluation case not the assignment case, since the result is not a + -- variable. See Expand_Bit_Packed_Element_Set for how he assignment case + -- is handled in the bit packed case. For the enumeration case, the result + -- of this call is always a variable, so the call can be used for both the + -- expression evaluation and assignment cases. + + procedure Expand_Bit_Packed_Element_Set (N : Node_Id); + -- N is an N_Assignment_Statement node whose name is an indexed + -- component of a bit-packed array. This procedure rewrites the entire + -- assignment statement with appropriate code to set the referenced + -- bits of the packed array type object. Note that this procedure is + -- used only for the bit-packed case, not for the enumeration case. + + procedure Expand_Packed_Eq (N : Node_Id); + -- N is an N_Op_Eq node where the operands are packed arrays whose + -- representation is an array-of-bytes type (the case where a modular + -- type is used for the representation does not require any special + -- handling, because in the modular case, unused bits are zeroes. + + procedure Expand_Packed_Not (N : Node_Id); + -- N is an N_Op_Not node where the operand is packed array of Boolean + -- in standard representation (i.e. component size is one bit). This + -- procedure expands the corresponding not operation. Note that the + -- non-standard representation case is handled by using a loop through + -- elements generated by the normal non-packed circuitry. + + function Involves_Packed_Array_Reference (N : Node_Id) return Boolean; + -- N is the node for a name. This function returns true if the name + -- involves a packed array reference. A node involves a packed array + -- reference if it is itself an indexed compoment referring to a bit- + -- packed array, or it is a selected component whose prefix involves + -- a packed array reference. + + procedure Expand_Packed_Address_Reference (N : Node_Id); + -- The node N is an attribute reference for the 'Address reference, where + -- the prefix involves a packed array reference. This routine expands the + -- necessary code for performing the address reference in this case. + +end Exp_Pakd; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb new file mode 100644 index 00000000000..855c3725dd1 --- /dev/null +++ b/gcc/ada/exp_prag.adb @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P R A G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.53 $ +-- -- +-- Copyright (C) 1992-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 Casing; use Casing; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch11; use Exp_Ch11; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Expander; use Expander; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Prag is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Arg1 (N : Node_Id) return Node_Id; + function Arg2 (N : Node_Id) return Node_Id; + function Arg3 (N : Node_Id) return Node_Id; + -- Obtain specified Pragma_Argument_Association + + procedure Expand_Pragma_Abort_Defer (N : Node_Id); + procedure Expand_Pragma_Assert (N : Node_Id); + procedure Expand_Pragma_Import (N : Node_Id); + procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); + procedure Expand_Pragma_Inspection_Point (N : Node_Id); + procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); + + -------------- + -- Arg1,2,3 -- + -------------- + + function Arg1 (N : Node_Id) return Node_Id is + begin + return First (Pragma_Argument_Associations (N)); + end Arg1; + + function Arg2 (N : Node_Id) return Node_Id is + begin + return Next (Arg1 (N)); + end Arg2; + + function Arg3 (N : Node_Id) return Node_Id is + begin + return Next (Arg2 (N)); + end Arg3; + + --------------------- + -- Expand_N_Pragma -- + --------------------- + + procedure Expand_N_Pragma (N : Node_Id) is + begin + -- Note: we may have a pragma whose chars field is not a + -- recognized pragma, and we must ignore it at this stage. + + if Is_Pragma_Name (Chars (N)) then + case Get_Pragma_Id (Chars (N)) is + + -- Pragmas requiring special expander action + + when Pragma_Abort_Defer => + Expand_Pragma_Abort_Defer (N); + + when Pragma_Assert => + Expand_Pragma_Assert (N); + + when Pragma_Export_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Import => + Expand_Pragma_Import (N); + + when Pragma_Import_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Inspection_Point => + Expand_Pragma_Inspection_Point (N); + + when Pragma_Interrupt_Priority => + Expand_Pragma_Interrupt_Priority (N); + + -- All other pragmas need no expander action + + when others => null; + end case; + end if; + + end Expand_N_Pragma; + + ------------------------------- + -- Expand_Pragma_Abort_Defer -- + ------------------------------- + + -- An Abort_Defer pragma appears as the first statement in a handled + -- statement sequence (right after the begin). It defers aborts for + -- the entire statement sequence, but not for any declarations or + -- handlers (if any) associated with this statement sequence. + + -- The transformation is to transform + + -- pragma Abort_Defer; + -- statements; + + -- into + + -- begin + -- Abort_Defer.all; + -- statements + -- exception + -- when all others => + -- Abort_Undefer.all; + -- raise; + -- at end + -- Abort_Undefer_Direct; + -- end; + + procedure Expand_Pragma_Abort_Defer (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stm : Node_Id; + Stms : List_Id; + HSS : Node_Id; + Blk : constant Entity_Id := + New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); + + begin + Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); + + loop + Stm := Remove_Next (N); + exit when No (Stm); + Append (Stm, Stms); + end loop; + + HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms, + At_End_Proc => + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => HSS)); + + Set_Scope (Blk, Current_Scope); + Set_Etype (Blk, Standard_Void_Type); + Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); + Expand_At_End_Handler (HSS, Blk); + Analyze (N); + end Expand_Pragma_Abort_Defer; + + -------------------------- + -- Expand_Pragma_Assert -- + -------------------------- + + procedure Expand_Pragma_Assert (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Cond : constant Node_Id := Expression (Arg1 (N)); + Msg : String_Id; + + begin + -- We already know that assertions are enabled, because otherwise + -- the semantic pass dealt with rewriting the assertion (see Sem_Prag) + + pragma Assert (Assertions_Enabled); + + -- Since assertions are on, we rewrite the pragma with its + -- corresponding if statement, and then analyze the statement + -- The expansion transforms: + + -- pragma Assert (condition [,message]); + + -- into + + -- if not condition then + -- System.Assertions.Raise_Assert_Failure (Str); + -- end if; + + -- where Str is the message if one is present, or the default of + -- file:line if no message is given. + + -- First, we need to prepare the character literal + + if Present (Arg2 (N)) then + Msg := Strval (Expr_Value_S (Expression (Arg2 (N)))); + else + Build_Location_String (Loc); + Msg := String_From_Name_Buffer; + end if; + + -- Now generate the if statement. Note that we consider this to be + -- an explicit conditional in the source, not an implicit if, so we + -- do not call Make_Implicit_If_Statement. + + Rewrite (N, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => Cond), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Msg)))))); + + Analyze (N); + + -- If new condition is always false, give a warning + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) + then + -- If original condition was a Standard.False, we assume + -- that this is indeed intented to raise assert error + -- and no warning is required. + + if Is_Entity_Name (Original_Node (Cond)) + and then Entity (Original_Node (Cond)) = Standard_False + then + return; + else + Error_Msg_N ("?assertion will fail at run-time", N); + end if; + end if; + end Expand_Pragma_Assert; + + -------------------------- + -- Expand_Pragma_Import -- + -------------------------- + + -- When applied to a variable, the default initialization must not be + -- done. As it is already done when the pragma is found, we just get rid + -- of the call the initialization procedure which followed the object + -- declaration. + + -- We can't use the freezing mechanism for this purpose, since we + -- have to elaborate the initialization expression when it is first + -- seen (i.e. this elaboration cannot be deferred to the freeze point). + + procedure Expand_Pragma_Import (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N))); + Typ : Entity_Id; + After_Def : Node_Id; + + begin + if Ekind (Def_Id) = E_Variable then + Typ := Etype (Def_Id); + After_Def := Next (Parent (Def_Id)); + + if Has_Non_Null_Base_Init_Proc (Typ) + and then Nkind (After_Def) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (After_Def)) + and then Entity (Name (After_Def)) = Base_Init_Proc (Typ) + then + Remove (After_Def); + + elsif Is_Access_Type (Typ) then + Set_Expression (Parent (Def_Id), Empty); + end if; + end if; + end Expand_Pragma_Import; + + ------------------------------------------- + -- Expand_Pragma_Import_Export_Exception -- + ------------------------------------------- + + -- For a VMS exception fix up the language field with "VMS" + -- instead of "Ada" (gigi needs this), create a constant that will be the + -- value of the VMS condition code and stuff the Interface_Name field + -- with the unexpanded name of the exception (if not already set). + -- For a Ada exception, just stuff the Interface_Name field + -- with the unexpanded name of the exception (if not already set). + + procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is + Id : constant Entity_Id := Entity (Expression (Arg1 (N))); + Call : constant Node_Id := Register_Exception_Call (Id); + Loc : constant Source_Ptr := Sloc (N); + begin + if Present (Call) then + declare + Excep_Internal : constant Node_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('V')); + Export_Pragma : Node_Id; + Excep_Alias : Node_Id; + Excep_Object : Node_Id; + Excep_Image : String_Id; + Exdata : List_Id; + Lang1 : Node_Id; + Lang2 : Node_Id; + Lang3 : Node_Id; + Code : Node_Id; + begin + if Present (Interface_Name (Id)) then + Excep_Image := Strval (Interface_Name (Id)); + else + Get_Name_String (Chars (Id)); + Set_All_Upper_Case; + Excep_Image := String_From_Name_Buffer; + end if; + + Exdata := Component_Associations (Expression (Parent (Id))); + + if Is_VMS_Exception (Id) then + + Lang1 := Next (First (Exdata)); + Lang2 := Next (Lang1); + Lang3 := Next (Lang2); + + Rewrite (Expression (Lang1), + Make_Character_Literal (Loc, Name_uV, Get_Char_Code ('V'))); + Analyze (Expression (Lang1)); + + Rewrite (Expression (Lang2), + Make_Character_Literal (Loc, Name_uM, Get_Char_Code ('M'))); + Analyze (Expression (Lang2)); + + Rewrite (Expression (Lang3), + Make_Character_Literal (Loc, Name_uS, Get_Char_Code ('S'))); + Analyze (Expression (Lang3)); + + if Exception_Code (Id) /= No_Uint then + Code := Make_Integer_Literal (Loc, Exception_Code (Id)); + + Excep_Object := + Make_Object_Declaration (Loc, + Defining_Identifier => Excep_Internal, + Object_Definition => + New_Reference_To (Standard_Integer, Loc)); + + Insert_Action (N, Excep_Object); + Analyze (Excep_Object); + + Start_String; + Store_String_Int (UI_To_Int (Exception_Code (Id)) / 8 * 8); + + Excep_Alias := + Make_Pragma + (Loc, + Name_Linker_Alias, + New_List + (Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + New_Reference_To (Excep_Internal, Loc)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => End_String)))); + + Insert_Action (N, Excep_Alias); + Analyze (Excep_Alias); + + Export_Pragma := + Make_Pragma + (Loc, + Name_Export, + New_List + (Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => Make_Identifier (Loc, Name_C)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + New_Reference_To (Excep_Internal, Loc)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)))); + + Insert_Action (N, Export_Pragma); + Analyze (Export_Pragma); + + else + Code := + Unchecked_Convert_To (Standard_Integer, + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Import_Value), Loc), + Parameter_Associations => New_List + (Make_String_Literal (Loc, + Strval => Excep_Image)))); + end if; + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Register_VMS_Exception), Loc), + Parameter_Associations => New_List (Code))); + + Analyze_And_Resolve (Code, Standard_Integer); + Analyze (Call); + + end if; + + if not Present (Interface_Name (Id)) then + Set_Interface_Name (Id, + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)); + end if; + end; + end if; + end Expand_Pragma_Import_Export_Exception; + + ------------------------------------ + -- Expand_Pragma_Inspection_Point -- + ------------------------------------ + + -- If no argument is given, then we supply a default argument list that + -- includes all objects declared at the source level in all subprograms + -- that enclose the inspection point pragma. + + procedure Expand_Pragma_Inspection_Point (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + A : List_Id; + Assoc : Node_Id; + S : Entity_Id; + E : Entity_Id; + + begin + if No (Pragma_Argument_Associations (N)) then + A := New_List; + S := Current_Scope; + + while S /= Standard_Standard loop + E := First_Entity (S); + while Present (E) loop + if Comes_From_Source (E) + and then Is_Object (E) + and then not Is_Entry_Formal (E) + and then Ekind (E) /= E_Component + and then Ekind (E) /= E_Discriminant + and then Ekind (E) /= E_Generic_In_Parameter + and then Ekind (E) /= E_Generic_In_Out_Parameter + then + Append_To (A, + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc))); + end if; + + Next_Entity (E); + end loop; + + S := Scope (S); + end loop; + + Set_Pragma_Argument_Associations (N, A); + end if; + + -- Expand the arguments of the pragma. Expanding an entity reference + -- is a noop, except in a protected operation, where a reference may + -- have to be transformed into a reference to the corresponding prival. + -- Are there other pragmas that may require this ??? + + Assoc := First (Pragma_Argument_Associations (N)); + + while Present (Assoc) loop + Expand (Expression (Assoc)); + Next (Assoc); + end loop; + end Expand_Pragma_Inspection_Point; + + -------------------------------------- + -- Expand_Pragma_Interrupt_Priority -- + -------------------------------------- + + -- Supply default argument if none exists (System.Interrupt_Priority'Last) + + procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if No (Pragma_Argument_Associations (N)) then + Set_Pragma_Argument_Associations (N, New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), + Attribute_Name => Name_Last)))); + end if; + end Expand_Pragma_Interrupt_Priority; + +end Exp_Prag; diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads new file mode 100644 index 00000000000..9034b8d16bb --- /dev/null +++ b/gcc/ada/exp_prag.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P R A G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for pragmas + +with Types; use Types; + +package Exp_Prag is + + procedure Expand_N_Pragma (N : Node_Id); + +end Exp_Prag; diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb new file mode 100644 index 00000000000..b89f42fc405 --- /dev/null +++ b/gcc/ada/exp_smem.adb @@ -0,0 +1,502 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S M E M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1998-2000 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 Exp_Util; use Exp_Util; +with Nmake; use Nmake; +with Namet; use Namet; +with Nlists; use Nlists; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Exp_Smem is + + Insert_Node : Node_Id; + -- Node after which a write call is to be inserted + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Read_Before (N : Node_Id); + -- Insert a Shared_Var_ROpen call for variable before node N + + procedure Add_Write_After (N : Node_Id); + -- Insert a Shared_Var_WOpen call for variable after the node + -- Insert_Node, as recorded by On_Lhs_Of_Assigment (where it points + -- to the assignment statement) or Is_Out_Actual (where it points to + -- the procedure call statement). + + procedure Build_Full_Name + (E : in Entity_Id; + N : out String_Id); + -- Build the fully qualified string name of a shared variable. + + function On_Lhs_Of_Assignment (N : Node_Id) return Boolean; + -- Determines if N is on the left hand of the assignment. This means + -- that either it is a simple variable, or it is a record or array + -- variable with a corresponding selected or indexed component on + -- the left side of an assignment. If the result is True, then + -- Insert_Node is set to point to the assignment + + function Is_Out_Actual (N : Node_Id) return Boolean; + -- In a similar manner, this function determines if N appears as an + -- OUT or IN OUT parameter to a procedure call. If the result is + -- True, then Insert_Node is set to point to the assignment. + + --------------------- + -- Add_Read_Before -- + --------------------- + + procedure Add_Read_Before (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Node_Id := Entity (N); + + begin + if Present (Shared_Var_Read_Proc (Ent)) then + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc), + Parameter_Associations => Empty_List)); + end if; + end Add_Read_Before; + + ------------------------------- + -- Add_Shared_Var_Lock_Procs -- + ------------------------------- + + procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); + Inode : Node_Id; + Vnm : String_Id; + + begin + -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around + -- the procedure or function call node. First we locate the right + -- place to do the insertion, which is the call itself in the + -- procedure call case, or else the nearest non subexpression + -- node that contains the function call. + + Inode := N; + while Nkind (Inode) /= N_Procedure_Call_Statement + and then Nkind (Inode) in N_Subexpr + loop + Inode := Parent (Inode); + end loop; + + -- Now insert the Lock and Unlock calls and the read/write calls + + -- Two concerns here. First we are not dealing with the exception + -- case, really we need some kind of cleanup routine to do the + -- Unlock. Second, these lock calls should be inside the protected + -- object processing, not outside, otherwise they can be done at + -- the wrong priority, resulting in dead lock situations ??? + + Build_Full_Name (Obj, Vnm); + + -- First insert the Lock call before + + Insert_Before_And_Analyze (Inode, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Vnm)))); + + -- Now, right after the Lock, insert a call to read the object + + Insert_Before_And_Analyze (Inode, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc))); + + -- Now insert the Unlock call after + + Insert_After_And_Analyze (Inode, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Vnm)))); + + -- Now for a procedure call, but not a function call, insert the + -- call to write the object just before the unlock. + + if Nkind (N) = N_Procedure_Call_Statement then + Insert_After_And_Analyze (Inode, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc))); + end if; + + end Add_Shared_Var_Lock_Procs; + + --------------------- + -- Add_Write_After -- + --------------------- + + procedure Add_Write_After (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Node_Id := Entity (N); + + begin + if Present (Shared_Var_Assign_Proc (Ent)) then + Insert_After_And_Analyze (Insert_Node, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc), + Parameter_Associations => Empty_List)); + end if; + end Add_Write_After; + + --------------------- + -- Build_Full_Name -- + --------------------- + + procedure Build_Full_Name + (E : in Entity_Id; + N : out String_Id) + is + + procedure Build_Name (E : Entity_Id); + -- This is a recursive routine used to construct the fully + -- qualified string name of the package corresponding to the + -- shared variable. + + procedure Build_Name (E : Entity_Id) is + begin + if Scope (E) /= Standard_Standard then + Build_Name (Scope (E)); + Store_String_Char ('.'); + end if; + + Get_Decoded_Name_String (Chars (E)); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + end Build_Name; + + begin + Start_String; + Build_Name (E); + N := End_String; + end Build_Full_Name; + + ------------------------------------ + -- Expand_Shared_Passive_Variable -- + ------------------------------------ + + procedure Expand_Shared_Passive_Variable (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + -- Nothing to do for protected or limited objects + + if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then + return; + + -- If we are on the left hand side of an assignment, then we add + -- the write call after the assignment. + + elsif On_Lhs_Of_Assignment (N) then + Add_Write_After (N); + + -- If we are a parameter for an out or in out formal, then put + -- the read before and the write after. + + elsif Is_Out_Actual (N) then + Add_Read_Before (N); + Add_Write_After (N); + + -- All other cases are simple reads + + else + Add_Read_Before (N); + end if; + end Expand_Shared_Passive_Variable; + + ------------------- + -- Is_Out_Actual -- + ------------------- + + function Is_Out_Actual (N : Node_Id) return Boolean is + Parnt : constant Node_Id := Parent (N); + Formal : Entity_Id; + Call : Node_Id; + Actual : Node_Id; + + begin + if (Nkind (Parnt) = N_Indexed_Component + or else + Nkind (Parnt) = N_Selected_Component) + and then N = Prefix (Parnt) + then + return Is_Out_Actual (Parnt); + + elsif Nkind (Parnt) = N_Parameter_Association + and then N = Explicit_Actual_Parameter (Parnt) + then + Call := Parent (Parnt); + + elsif Nkind (Parnt) = N_Procedure_Call_Statement then + Call := Parnt; + + else + return False; + end if; + + -- Fall here if we are definitely a parameter + + Actual := First_Actual (Call); + Formal := First_Formal (Entity (Name (Call))); + + loop + if Actual = N then + if Ekind (Formal) /= E_In_Parameter then + Insert_Node := Call; + return True; + else + return False; + end if; + + else + Actual := Next_Actual (Actual); + Formal := Next_Formal (Formal); + end if; + end loop; + end Is_Out_Actual; + + --------------------------- + -- Make_Shared_Var_Procs -- + --------------------------- + + procedure Make_Shared_Var_Procs (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Defining_Identifier (N); + Typ : constant Entity_Id := Etype (Ent); + Vnm : String_Id; + Atr : Node_Id; + + Assign_Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Ent), 'A')); + + Read_Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Ent), 'R')); + + S : Entity_Id; + + -- Start of processing for Make_Shared_Var_Procs + + begin + Build_Full_Name (Ent, Vnm); + + -- We turn off Shared_Passive during construction and analysis of + -- the assign and read routines, to avoid improper attempts to + -- process the variable references within these procedures. + + Set_Is_Shared_Passive (Ent, False); + + -- Construct assignment routine + + -- procedure VarA is + -- S : Ada.Streams.Stream_IO.Stream_Access; + -- begin + -- S := Shared_Var_WOpen ("pkg.var"); + -- typ'Write (S, var); + -- Shared_Var_Close (S); + -- end VarA; + + S := Make_Defining_Identifier (Loc, Name_uS); + + Atr := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Reference_To (S, Loc), + New_Occurrence_Of (Ent, Loc))); + + Set_OK_For_Stream (Atr, True); + + Insert_After_And_Analyze (N, + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Assign_Proc), + + -- S : Ada.Streams.Stream_IO.Stream_Access; + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => S, + Object_Definition => + New_Occurrence_Of (RTE (RE_Stream_Access), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + + -- S := Shared_Var_WOpen ("pkg.var"); + + Make_Assignment_Statement (Loc, + Name => New_Reference_To (S, Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Shared_Var_WOpen), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Vnm)))), + + Atr, + + -- Shared_Var_Close (S); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc), + Parameter_Associations => + New_List (New_Reference_To (S, Loc))))))); + + -- Construct read routine + + -- procedure varR is + -- S : Ada.Streams.Stream_IO.Stream_Access; + -- begin + -- S := Shared_Var_ROpen ("pkg.var"); + -- if S /= null then + -- typ'Read (S, Var); + -- Shared_Var_Close (S); + -- end if; + -- end varR; + + S := Make_Defining_Identifier (Loc, Name_uS); + + Atr := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Reference_To (S, Loc), + New_Occurrence_Of (Ent, Loc))); + + Set_OK_For_Stream (Atr, True); + + Insert_After_And_Analyze (N, + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Read_Proc), + + -- S : Ada.Streams.Stream_IO.Stream_Access; + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => S, + Object_Definition => + New_Occurrence_Of (RTE (RE_Stream_Access), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + + -- S := Shared_Var_ROpen ("pkg.var"); + + Make_Assignment_Statement (Loc, + Name => New_Reference_To (S, Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Shared_Var_ROpen), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Vnm)))), + + -- if S /= null then + + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (S, Loc), + Right_Opnd => Make_Null (Loc)), + + Then_Statements => New_List ( + + -- typ'Read (S, Var); + + Atr, + + -- Shared_Var_Close (S); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Shared_Var_Close), Loc), + Parameter_Associations => + New_List (New_Reference_To (S, Loc))))))))); + + Set_Is_Shared_Passive (Ent, True); + Set_Shared_Var_Assign_Proc (Ent, Assign_Proc); + Set_Shared_Var_Read_Proc (Ent, Read_Proc); + end Make_Shared_Var_Procs; + + -------------------------- + -- On_Lhs_Of_Assignment -- + -------------------------- + + function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + + begin + if Nkind (P) = N_Assignment_Statement then + if N = Name (P) then + Insert_Node := P; + return True; + else + return False; + end if; + + elsif (Nkind (P) = N_Indexed_Component + or else + Nkind (P) = N_Selected_Component) + and then N = Prefix (P) + then + return On_Lhs_Of_Assignment (P); + + else + return False; + end if; + end On_Lhs_Of_Assignment; + + +end Exp_Smem; diff --git a/gcc/ada/exp_smem.ads b/gcc/ada/exp_smem.ads new file mode 100644 index 00000000000..1d6cbd5dcba --- /dev/null +++ b/gcc/ada/exp_smem.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S M E M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1998-2000, 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines involved in the required expansions for +-- handling shared memory accesses for variables in Shared_Passive packages. + +-- See detailed documentation in System.Shared_Storage spec for a full +-- description of the approach that is taken for handling distributed +-- shared memory. This expansion unit in the compiler is responsible +-- for generating the calls to routines in System.Shared_Storage. + +with Types; use Types; +package Exp_Smem is + + procedure Expand_Shared_Passive_Variable (N : Node_Id); + -- N is the identifier for a shared passive variable. This routine is + -- responsible for determining if this is an assigned to N, or a + -- reference to N, and generating the required calls to the shared + -- memory read/write procedures. + + procedure Add_Shared_Var_Lock_Procs (N : Node_Id); + -- The argument is a protected subprogram call, before it is rewritten + -- by Exp_Ch9.Build_Protected_Subprogram_Call. This routine, which is + -- called only in the case of an external call to a protected object + -- that has Is_Shared_Passive set, deals with installing the required + -- global lock calls for this case. It also generates the necessary + -- read/write calls for the protected object within the lock region. + + procedure Make_Shared_Var_Procs (N : Node_Id); + -- N is the node for the declaration of a shared passive variable. This + -- procedure constructs and inserts the read and assignment procedures + -- for the shared memory variable. See System.Shared_Storage for a full + -- description of these procedures and how they are used. + +end Exp_Smem; diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb new file mode 100644 index 00000000000..92ff393b2ef --- /dev/null +++ b/gcc/ada/exp_strm.adb @@ -0,0 +1,1472 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S T R M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.39 $ +-- -- +-- Copyright (C) 1992-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 Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Exp_Tss; use Exp_Tss; +with Uintp; use Uintp; + +package body Exp_Strm is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Build_Array_Read_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id); + -- Common routine shared to build either an array Read procedure or an + -- array Write procedure, Nam is Name_Read or Name_Write to select which. + -- Pnam is the defining identifier for the constructed procedure. The + -- other parameters are as for Build_Array_Read_Procedure except that + -- the first parameter Nod supplies the Sloc to be used to generate code. + + procedure Build_Record_Read_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id); + -- Common routine shared to build a record Read Write procedure, Nam + -- is Name_Read or Name_Write to select which. Pnam is the defining + -- identifier for the constructed procedure. The other parameters are + -- as for Build_Record_Read_Procedure. + + procedure Build_Stream_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : Entity_Id; + Decls : List_Id; + Stms : List_Id); + -- Called to build an array or record stream function. The first three + -- arguments are the same as Build_Record_Or_Elementary_Input_Function. + -- Decls and Stms are the declarations and statements for the body and + -- The parameter Fnam is the name of the constructed function. + + procedure Build_Stream_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Stms : List_Id; + Outp : Boolean); + -- Called to build an array or record stream procedure. The first three + -- arguments are the same as Build_Record_Or_Elementary_Output_Procedure. + -- Stms is the list of statements for the body (the declaration list is + -- always null), and Pnam is the name of the constructed procedure. + + function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean; + -- This function is used to test U_Type, which is a type + -- Returns True if U_Type has a standard representation for stream + -- purposes, i.e. there is no non-standard enumeration representation + -- clause, and the size of the first subtype is the same as the size + -- of the root type. + + function Stream_Base_Type (E : Entity_Id) return Entity_Id; + -- Stream attributes work on the basis of the base type except for the + -- array case. For the array case, we do not go to the base type, but + -- to the first subtype if it is constrained. This avoids problems with + -- incorrect conversions in the packed array case. Stream_Base_Type is + -- exactly this function (returns the base type, unless we have an array + -- type whose first subtype is constrained, in which case it returns the + -- first subtype). + + -------------------------------- + -- Build_Array_Input_Function -- + -------------------------------- + + -- The function we build looks like + + -- function InputN (S : access RST) return Typ is + -- L1 : constant Index_Type_1 := Index_Type_1'Input (S); + -- H1 : constant Index_Type_1 := Index_Type_1'Input (S); + -- L2 : constant Index_Type_2 := Index_Type_2'Input (S); + -- H2 : constant Index_Type_2 := Index_Type_2'Input (S); + -- .. + -- Ln : constant Index_Type_n := Index_Type_n'Input (S); + -- Hn : constant Index_Type_n := Index_Type_n'Input (S); + -- + -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn) + + -- begin + -- Typ'Read (S, V); + -- return V; + -- end InputN + + procedure Build_Array_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Dim : constant Pos := Number_Dimensions (Typ); + Lnam : Name_Id; + Hnam : Name_Id; + Decls : List_Id; + Ranges : List_Id; + Stms : List_Id; + Indx : Node_Id; + + begin + Decls := New_List; + Ranges := New_List; + Indx := First_Index (Typ); + + for J in 1 .. Dim loop + Lnam := New_External_Name ('L', J); + Hnam := New_External_Name ('H', J); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etype (Indx), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Ranges, + Make_Range (Loc, + Low_Bound => Make_Identifier (Loc, Lnam), + High_Bound => Make_Identifier (Loc, Hnam))); + + Next_Index (Indx); + end loop; + + -- If the first subtype is constrained, use it directly. Otherwise + -- build a subtype indication with the proper bounds. + + if Is_Constrained (Stream_Base_Type (Typ)) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => + New_Occurrence_Of (Stream_Base_Type (Typ), Loc))); + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Stream_Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Ranges)))); + end if; + + Stms := New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))), + + Make_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + + Fnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uInput, ' ', Increment_Serial_Number)); + + Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + end Build_Array_Input_Function; + + ---------------------------------- + -- Build_Array_Output_Procedure -- + ---------------------------------- + + procedure Build_Array_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Indx : Node_Id; + + begin + -- Build series of statements to output bounds + + Indx := First_Index (Typ); + Stms := New_List; + + for J in 1 .. Number_Dimensions (Typ) loop + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Next_Index (Indx); + end loop; + + -- Append Write attribute to write array elements + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V)))); + + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uOutput, ' ', Increment_Serial_Number)); + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + end Build_Array_Output_Procedure; + + -------------------------------- + -- Build_Array_Read_Procedure -- + -------------------------------- + + procedure Build_Array_Read_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + begin + Pnam := + Make_Defining_Identifier (Loc, + New_External_Name + (Name_uRead, ' ', Increment_Serial_Number)); + + Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read); + end Build_Array_Read_Procedure; + + -------------------------------------- + -- Build_Array_Read_Write_Procedure -- + -------------------------------------- + + -- The form of the array read/write procedure is as follows: + + -- procedure pnam (S : access RST, V : [out] Typ) is + -- begin + -- for L1 in V'Range (1) loop + -- for L2 in V'Range (2) loop + -- ... + -- for Ln in V'Range (n) loop + -- Component_Type'Read/Write (S, V (L1, L2, .. Ln)); + -- end loop; + -- .. + -- end loop; + -- end loop + -- end pnam; + + -- The out keyword for V is supplied in the Read case + + procedure Build_Array_Read_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Ndim : constant Pos := Number_Dimensions (Typ); + Ctyp : constant Entity_Id := Component_Type (Typ); + + Stm : Node_Id; + Exl : List_Id; + RW : Entity_Id; + + begin + -- First build the inner attribute call + + Exl := New_List; + + for J in 1 .. Ndim loop + Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J))); + end loop; + + Stm := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc), + Attribute_Name => Nam, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Expressions => Exl))); + + -- The corresponding stream attribute for the component type of the + -- array may be user-defined, and be frozen after the type for which + -- we are generating the stream subprogram. In that case, freeze the + -- stream attribute of the component type, whose declaration could not + -- generate any additional freezing actions in any case. See 5509-003. + + if Nam = Name_Read then + RW := TSS (Base_Type (Ctyp), Name_uRead); + else + RW := TSS (Base_Type (Ctyp), Name_uWrite); + end if; + + if Present (RW) + and then not Is_Frozen (RW) + then + Set_Is_Frozen (RW); + end if; + + -- Now this is the big loop to wrap that statement up in a sequence + -- of loops. The first time around, Stm is the attribute call. The + -- second and subsequent times, Stm is an inner loop. + + for J in 1 .. Ndim loop + Stm := + Make_Implicit_Loop_Statement (Nod, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('L', Ndim - J + 1)), + + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + + Expressions => New_List ( + Make_Integer_Literal (Loc, Ndim - J + 1))))), + + Statements => New_List (Stm)); + + end loop; + + Build_Stream_Procedure + (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read); + end Build_Array_Read_Write_Procedure; + + --------------------------------- + -- Build_Array_Write_Procedure -- + --------------------------------- + + procedure Build_Array_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + begin + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uWrite, ' ', Increment_Serial_Number)); + + Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write); + end Build_Array_Write_Procedure; + + --------------------------------- + -- Build_Elementary_Input_Call -- + --------------------------------- + + function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + P_Type : constant Entity_Id := Entity (Prefix (N)); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Rt_Type : constant Entity_Id := Root_Type (U_Type); + FST : constant Entity_Id := First_Subtype (U_Type); + P_Size : constant Uint := Esize (FST); + Strm : constant Node_Id := First (Expressions (N)); + Lib_RE : RE_Id; + + begin + -- Check first for Boolean and Character. These are enumeration types, + -- but we treat them specially, since they may require special handling + -- in the transfer protocol. However, this special handling only applies + -- if they have standard representation, otherwise they are treated like + -- any other enumeration type. + + if Rt_Type = Standard_Boolean + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_B; + + elsif Rt_Type = Standard_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_C; + + elsif Rt_Type = Standard_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_WC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + if Rt_Type = Standard_Short_Float then + Lib_RE := RE_I_SF; + + elsif Rt_Type = Standard_Float then + Lib_RE := RE_I_F; + + elsif Rt_Type = Standard_Long_Float then + Lib_RE := RE_I_LF; + + else pragma Assert (Rt_Type = Standard_Long_Long_Float); + Lib_RE := RE_I_LLF; + end if; + + -- Signed integer types. Also includes signed fixed-point types and + -- enumeration types with a signed representation. + + -- Note on signed integer types. We do not consider types as signed for + -- this purpose if they have no negative numbers, or if they have biased + -- representation. The reason is that the value in either case basically + -- represents an unsigned value. + + -- For example, consider: + + -- type W is range 0 .. 2**32 - 1; + -- for W'Size use 32; + + -- This is a signed type, but the representation is unsigned, and may + -- be outside the range of a 32-bit signed integer, so this must be + -- treated as 32-bit unsigned. + + -- Similarly, if we have + + -- type W is range -1 .. +254; + -- for W'Size use 8; + + -- then the representation is unsigned + + elsif not Is_Unsigned_Type (FST) + and then + (Is_Fixed_Point_Type (U_Type) + or else + Is_Enumeration_Type (U_Type) + or else + (Is_Signed_Integer_Type (U_Type) + and then not Has_Biased_Representation (FST))) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_I_SSI; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_I_SI; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_I_I; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_I_LI; + + else + Lib_RE := RE_I_LLI; + end if; + + -- Unsigned integer types, also includes unsigned fixed-point types + -- and enumeration types with an unsigned representation (note that + -- we know they are unsigned because we already tested for signed). + + -- Also includes signed integer types that are unsigned in the sense + -- that they do not include negative numbers. See above for details. + + elsif Is_Modular_Integer_Type (U_Type) + or else Is_Fixed_Point_Type (U_Type) + or else Is_Enumeration_Type (U_Type) + or else Is_Signed_Integer_Type (U_Type) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_I_SSU; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_I_SU; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_I_U; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_I_LU; + + else + Lib_RE := RE_I_LLU; + end if; + + else pragma Assert (Is_Access_Type (U_Type)); + if P_Size > System_Address_Size then + Lib_RE := RE_I_AD; + else + Lib_RE := RE_I_AS; + end if; + end if; + + -- Call the function, and do an unchecked conversion of the result + -- to the actual type of the prefix. + + return + Unchecked_Convert_To (P_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Lib_RE), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm)))); + + end Build_Elementary_Input_Call; + + --------------------------------- + -- Build_Elementary_Write_Call -- + --------------------------------- + + function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + P_Type : constant Entity_Id := Entity (Prefix (N)); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Rt_Type : constant Entity_Id := Root_Type (U_Type); + FST : constant Entity_Id := First_Subtype (U_Type); + P_Size : constant Uint := Esize (FST); + Strm : constant Node_Id := First (Expressions (N)); + Item : constant Node_Id := Next (Strm); + Lib_RE : RE_Id; + Libent : Entity_Id; + + begin + -- Find the routine to be called + + -- Check for First Boolean and Character. These are enumeration types, + -- but we treat them specially, since they may require special handling + -- in the transfer protocol. However, this special handling only applies + -- if they have standard representation, otherwise they are treated like + -- any other enumeration type. + + if Rt_Type = Standard_Boolean + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_B; + + elsif Rt_Type = Standard_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_C; + + elsif Rt_Type = Standard_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_WC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + if Rt_Type = Standard_Short_Float then + Lib_RE := RE_W_SF; + + elsif Rt_Type = Standard_Float then + Lib_RE := RE_W_F; + + elsif Rt_Type = Standard_Long_Float then + Lib_RE := RE_W_LF; + + else pragma Assert (Rt_Type = Standard_Long_Long_Float); + Lib_RE := RE_W_LLF; + end if; + + -- Signed integer types. Also includes signed fixed-point types and + -- signed enumeration types share this circuitry. + + -- Note on signed integer types. We do not consider types as signed for + -- this purpose if they have no negative numbers, or if they have biased + -- representation. The reason is that the value in either case basically + -- represents an unsigned value. + + -- For example, consider: + + -- type W is range 0 .. 2**32 - 1; + -- for W'Size use 32; + + -- This is a signed type, but the representation is unsigned, and may + -- be outside the range of a 32-bit signed integer, so this must be + -- treated as 32-bit unsigned. + + -- Similarly, if we have + + -- type W is range -1 .. +254; + -- for W'Size use 8; + + -- then the representation is also unsigned. + + elsif not Is_Unsigned_Type (FST) + and then + (Is_Fixed_Point_Type (U_Type) + or else + Is_Enumeration_Type (U_Type) + or else + (Is_Signed_Integer_Type (U_Type) + and then not Has_Biased_Representation (FST))) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_W_SSI; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_W_SI; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_W_I; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_W_LI; + + else + Lib_RE := RE_W_LLI; + end if; + + -- Unsigned integer types, also includes unsigned fixed-point types + -- and unsigned enumeration types (note we know they are unsigned + -- because we already tested for signed above). + + -- Also includes signed integer types that are unsigned in the sense + -- that they do not include negative numbers. See above for details. + + elsif Is_Modular_Integer_Type (U_Type) + or else Is_Fixed_Point_Type (U_Type) + or else Is_Enumeration_Type (U_Type) + or else Is_Signed_Integer_Type (U_Type) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_W_SSU; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_W_SU; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_W_U; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_W_LU; + + else + Lib_RE := RE_W_LLU; + end if; + + else pragma Assert (Is_Access_Type (U_Type)); + + if P_Size > System_Address_Size then + Lib_RE := RE_W_AD; + else + Lib_RE := RE_W_AS; + end if; + end if; + + -- Unchecked-convert parameter to the required type (i.e. the type of + -- the corresponding parameter, and call the appropriate routine. + + Libent := RTE (Lib_RE); + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Libent, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm), + Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))), + Relocate_Node (Item)))); + + end Build_Elementary_Write_Call; + + ----------------------------------------- + -- Build_Mutable_Record_Read_Procedure -- + ----------------------------------------- + + procedure Build_Mutable_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + Comp : Node_Id; + + begin + Stms := New_List; + Disc := First_Discriminant (Typ); + + -- Generate Reads for the discriminants of the type. + + while Present (Disc) loop + Comp := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Set_Assignment_OK (Comp); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Disc), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Comp))); + + Next_Discriminant (Disc); + end loop; + + -- A mutable type cannot be a tagged type, so we generate a new name + -- for the stream procedure. + + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uRead, ' ', Increment_Serial_Number)); + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + + -- Read the discriminants before the rest of the components, so + -- that discriminant values are properly set of variants, etc. + -- If this is an empty record with discriminants, there are no + -- previous statements. If this is an unchecked union, the stream + -- procedure is erroneous, because there are no discriminants to read. + + if Is_Unchecked_Union (Typ) then + Stms := New_List (Make_Raise_Program_Error (Loc)); + end if; + + if Is_Non_Empty_List ( + Statements (Handled_Statement_Sequence (Decl))) + then + Insert_List_Before + (First (Statements (Handled_Statement_Sequence (Decl))), Stms); + else + Set_Statements (Handled_Statement_Sequence (Decl), Stms); + end if; + end Build_Mutable_Record_Read_Procedure; + + ------------------------------------------ + -- Build_Mutable_Record_Write_Procedure -- + ------------------------------------------ + + procedure Build_Mutable_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + + begin + Stms := New_List; + Disc := First_Discriminant (Typ); + + -- Generate Writes for the discriminants of the type. + + while Present (Disc) loop + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Disc), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc))))); + + Next_Discriminant (Disc); + end loop; + + -- A mutable type cannot be a tagged type, so we generate a new name + -- for the stream procedure. + + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uWrite, ' ', Increment_Serial_Number)); + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + + -- Write the discriminants before the rest of the components, so + -- that discriminant values are properly set of variants, etc. + -- If this is an unchecked union, the stream procedure is erroneous + -- because there are no discriminants to write. + + if Is_Unchecked_Union (Typ) then + Stms := New_List (Make_Raise_Program_Error (Loc)); + end if; + + if Is_Non_Empty_List ( + Statements (Handled_Statement_Sequence (Decl))) + then + Insert_List_Before + (First (Statements (Handled_Statement_Sequence (Decl))), Stms); + else + Set_Statements (Handled_Statement_Sequence (Decl), Stms); + end if; + end Build_Mutable_Record_Write_Procedure; + + ----------------------------------------------- + -- Build_Record_Or_Elementary_Input_Function -- + ----------------------------------------------- + + -- The function we build looks like + + -- function InputN (S : access RST) return Typ is + -- C1 : constant Disc_Type_1 := Discr_Type_1'Input (S); + -- C2 : constant Disc_Type_1 := Discr_Type_2'Input (S); + -- ... + -- Cn : constant Disc_Type_1 := Discr_Type_n'Input (S); + -- V : Typ (C1, C2, .. Cn) + + -- begin + -- Typ'Read (S, V); + -- return V; + -- end InputN + + -- The discriminants are of course only present in the case of a record + -- with discriminants. In the case of a record with no discriminants, or + -- an elementary type, then no Cn constants are defined. + + procedure Build_Record_Or_Elementary_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Cn : Name_Id; + J : Pos; + Decls : List_Id; + Constr : List_Id; + Stms : List_Id; + Discr : Entity_Id; + Odef : Node_Id; + + begin + Decls := New_List; + Constr := New_List; + + J := 1; + + if Has_Discriminants (Typ) then + Discr := First_Discriminant (Typ); + + while Present (Discr) loop + Cn := New_External_Name ('C', J); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Cn), + Object_Definition => New_Occurrence_Of (Etype (Discr), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Stream_Base_Type (Etype (Discr)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Constr, Make_Identifier (Loc, Cn)); + + Next_Discriminant (Discr); + J := J + 1; + end loop; + + Odef := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constr)); + + -- If no discriminants, then just use the type with no constraint + + else + Odef := New_Occurrence_Of (Typ, Loc); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => Odef)); + + Stms := New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))), + + Make_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Fnam := Make_Defining_Identifier (Loc, Name_uInput); + else + Fnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uInput, ' ', Increment_Serial_Number)); + end if; + + Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + end Build_Record_Or_Elementary_Input_Function; + + ------------------------------------------------- + -- Build_Record_Or_Elementary_Output_Procedure -- + ------------------------------------------------- + + procedure Build_Record_Or_Elementary_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + + begin + Stms := New_List; + + -- Note that of course there will be no discriminants for the + -- elementary type case, so Has_Discriminants will be False. + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + + while Present (Disc) loop + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc))))); + + Next_Discriminant (Disc); + end loop; + end if; + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V)))); + + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Pnam := Make_Defining_Identifier (Loc, Name_uOutput); + else + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Name_uOutput, ' ', Increment_Serial_Number)); + end if; + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + end Build_Record_Or_Elementary_Output_Procedure; + + --------------------------------- + -- Build_Record_Read_Procedure -- + --------------------------------- + + procedure Build_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + begin + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Pnam := Make_Defining_Identifier (Loc, Name_uRead); + else + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uRead, ' ', Increment_Serial_Number)); + end if; + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + end Build_Record_Read_Procedure; + + --------------------------------------- + -- Build_Record_Read_Write_Procedure -- + --------------------------------------- + + -- The form of the record read/write procedure is as shown by the + -- following example for a case with one discriminant case variant: + + -- procedure pnam (S : access RST, V : [out] Typ) is + -- begin + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- + -- case V.discriminant is + -- when choices => + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- + -- when choices => + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- ... + -- end case; + -- end pnam; + + -- The out keyword for V is supplied in the Read case + + procedure Build_Record_Read_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id) + is + Rdef : Node_Id; + Stms : List_Id; + Typt : Entity_Id; + + function Make_Component_List_Attributes (CL : Node_Id) return List_Id; + -- Returns a sequence of attributes to process the components that + -- are referenced in the given component list. + + function Make_Field_Attribute (C : Entity_Id) return Node_Id; + -- Given C, the entity for a discriminant or component, build + -- an attribute for the corresponding field values. + + function Make_Field_Attributes (Clist : List_Id) return List_Id; + -- Given Clist, a component items list, construct series of attributes + -- for fieldwise processing of the corresponding components. + + ------------------------------------ + -- Make_Component_List_Attributes -- + ------------------------------------ + + function Make_Component_List_Attributes (CL : Node_Id) return List_Id is + CI : constant List_Id := Component_Items (CL); + VP : constant Node_Id := Variant_Part (CL); + + Result : List_Id; + Alts : List_Id; + V : Node_Id; + DC : Node_Id; + DCH : List_Id; + + begin + Result := Make_Field_Attributes (CI); + + -- If a component is an unchecked union, there is no discriminant + -- and we cannot generate a read/write procedure for it. + + if Present (VP) then + if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then + return New_List (Make_Raise_Program_Error (Sloc (VP))); + end if; + + V := First_Non_Pragma (Variants (VP)); + Alts := New_List; + while Present (V) loop + + DCH := New_List; + DC := First (Discrete_Choices (V)); + while Present (DC) loop + Append_To (DCH, New_Copy_Tree (DC)); + Next (DC); + end loop; + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => DCH, + Statements => + Make_Component_List_Attributes (Component_List (V)))); + Next_Non_Pragma (V); + end loop; + + -- Note: in the following, we make sure that we use new occurrence + -- of for the selector, since there are cases in which we make a + -- reference to a hidden discriminant that is not visible. + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => + New_Occurrence_Of (Entity (Name (VP)), Loc)), + Alternatives => Alts)); + + end if; + + return Result; + end Make_Component_List_Attributes; + + -------------------------- + -- Make_Field_Attribute -- + -------------------------- + + function Make_Field_Attribute (C : Entity_Id) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (C)), Loc), + Attribute_Name => Nam, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (C, Loc)))); + end Make_Field_Attribute; + + --------------------------- + -- Make_Field_Attributes -- + --------------------------- + + function Make_Field_Attributes (Clist : List_Id) return List_Id is + Item : Node_Id; + Result : List_Id; + + begin + Result := New_List; + + if Present (Clist) then + Item := First (Clist); + + -- Loop through components, skipping all internal components, + -- which are not part of the value (e.g. _Tag), except that we + -- don't skip the _Parent, since we do want to process that + -- recursively. + + while Present (Item) loop + if Nkind (Item) = N_Component_Declaration + and then + (Chars (Defining_Identifier (Item)) = Name_uParent + or else + not Is_Internal_Name (Chars (Defining_Identifier (Item)))) + then + Append_To + (Result, + Make_Field_Attribute (Defining_Identifier (Item))); + end if; + + Next (Item); + end loop; + end if; + + return Result; + end Make_Field_Attributes; + + -- Start of processing for Build_Record_Read_Write_Procedure + + begin + -- For the protected type case, use corresponding record + + if Is_Protected_Type (Typ) then + Typt := Corresponding_Record_Type (Typ); + else + Typt := Typ; + end if; + + -- Note that we do nothing with the discriminants, since Read and + -- Write do not read or write the discriminant values. All handling + -- of discriminants occurs in the Input and Output subprograms. + + Rdef := Type_Definition (Declaration_Node (Underlying_Type (Typt))); + Stms := Empty_List; + + -- In record extension case, the fields we want, including the _Parent + -- field representing the parent type, are to be found in the extension. + -- Note that we will naturally process the _Parent field using the type + -- of the parent, and hence its stream attributes, which is appropriate. + + if Nkind (Rdef) = N_Derived_Type_Definition then + Rdef := Record_Extension_Part (Rdef); + end if; + + if Present (Component_List (Rdef)) then + Append_List_To (Stms, + Make_Component_List_Attributes (Component_List (Rdef))); + end if; + + Build_Stream_Procedure + (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read); + + end Build_Record_Read_Write_Procedure; + + ---------------------------------- + -- Build_Record_Write_Procedure -- + ---------------------------------- + + procedure Build_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + begin + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Pnam := Make_Defining_Identifier (Loc, Name_uWrite); + else + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uWrite, ' ', Increment_Serial_Number)); + end if; + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + end Build_Record_Write_Procedure; + + ------------------------------- + -- Build_Stream_Attr_Profile -- + ------------------------------- + + function Build_Stream_Attr_Profile + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) + return List_Id + is + Profile : List_Id; + + begin + Profile := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))); + + if Nam /= Name_uInput then + Append_To (Profile, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => (Nam = Name_uRead), + Parameter_Type => New_Reference_To (Typ, Loc))); + end if; + + return Profile; + end Build_Stream_Attr_Profile; + + --------------------------- + -- Build_Stream_Function -- + --------------------------- + + procedure Build_Stream_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : Entity_Id; + Decls : List_Id; + Stms : List_Id) + is + Spec : Node_Id; + + begin + -- Construct function specification + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), + + Subtype_Mark => New_Occurrence_Of (Typ, Loc)); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + + end Build_Stream_Function; + + ---------------------------- + -- Build_Stream_Procedure -- + ---------------------------- + + procedure Build_Stream_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Stms : List_Id; + Outp : Boolean) + is + Spec : Node_Id; + + begin + -- Construct procedure specification + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Pnam, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => Outp, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + + end Build_Stream_Procedure; + + ----------------------------- + -- Has_Stream_Standard_Rep -- + ----------------------------- + + function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is + begin + if Has_Non_Standard_Rep (U_Type) then + return False; + + else + return + Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type)); + end if; + end Has_Stream_Standard_Rep; + + ---------------------- + -- Stream_Base_Type -- + ---------------------- + + function Stream_Base_Type (E : Entity_Id) return Entity_Id is + begin + if Is_Array_Type (E) + and then Is_First_Subtype (E) + then + return E; + + else + return Base_Type (E); + end if; + end Stream_Base_Type; + +end Exp_Strm; diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads new file mode 100644 index 00000000000..c70f4e9ac7e --- /dev/null +++ b/gcc/ada/exp_strm.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S T R M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1992-1999 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Routines to build stream subprograms for composite types + +with Types; use Types; + +package Exp_Strm is + + function Build_Elementary_Input_Call (N : Node_Id) return Node_Id; + -- Build call to Read attribute function for elementary type. Also used + -- for Input attributes for elementary types with an appropriate extra + -- assignment statement. N is the attribute reference node. + + function Build_Elementary_Write_Call (N : Node_Id) return Node_Id; + -- Build call to Write attribute function for elementary type. Also used + -- for Output attributes for elementary types (since the effect of the + -- two attributes is identical for elementary types). N is the attribute + -- reference node. + + function Build_Stream_Attr_Profile + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) + return List_Id; + -- Builds the parameter profile for the stream attribute identified by + -- the given name (which is the underscore version, e.g. Name_uWrite to + -- identify the Write attribute). This is used for the tagged case to + -- build the spec for the primitive operation. + + -- The following routines build procedures and functions for stream + -- attributes applied to composite types. For each of these routines, + -- Loc is used to provide the location for the constructed subprogram + -- declaration. Typ is the base type to which the subprogram applies + -- (i.e. the base type of the stream attribute prefix). The returned + -- results are the declaration and name (entity) of the subprogram. + + procedure Build_Array_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build function for Input attribute for array type + + procedure Build_Array_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Output attribute for array type + + procedure Build_Array_Read_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Read attribute for array type. Nod provides the + -- Sloc value for generated code. + + procedure Build_Array_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Write attribute for array type. Nod provides the + -- Sloc value for generated code. + + procedure Build_Mutable_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure to Read a record with default discriminants. + -- Discriminants must be read explicitly (RM 13.13.2(9)) in the + -- same manner as is done for 'Input. + + procedure Build_Mutable_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure to write a record with default discriminants. + -- Discriminants must be written explicitly (RM 13.13.2(9)) in + -- the same manner as is done for 'Output. + + procedure Build_Record_Or_Elementary_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build function for Input attribute for record type or for an + -- elementary type (the latter is used only in the case where a + -- user defined Read routine is defined, since in other cases, + -- Input calls the appropriate runtime library routine directly. + + procedure Build_Record_Or_Elementary_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Output attribute for record type or for an + -- elementary type (the latter is used only in the case where a + -- user defined Write routine is defined, since in other cases, + -- Output calls the appropriate runtime library routine directly. + + procedure Build_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Read attribute for record type + + procedure Build_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Write attribute for record type + +end Exp_Strm; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb new file mode 100644 index 00000000000..6e3722c5202 --- /dev/null +++ b/gcc/ada/exp_tss.adb @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ T S S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.26 $ +-- -- +-- Copyright (C) 1992-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 Elists; use Elists; +with Exp_Util; use Exp_Util; +with Lib; use Lib; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; + +package body Exp_Tss is + + -------------------- + -- Base_Init_Proc -- + -------------------- + + function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is + Full_Type : E; + Proc : Entity_Id; + + begin + pragma Assert (Ekind (Typ) in Type_Kind); + + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Base_Type (Typ)); + else + Full_Type := Typ; + end if; + + if No (Full_Type) then + return Empty; + elsif Is_Concurrent_Type (Full_Type) + and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) + then + return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type))); + + else + Proc := Init_Proc (Base_Type (Full_Type)); + + if No (Proc) + and then Is_Composite_Type (Full_Type) + and then Is_Derived_Type (Full_Type) + then + return Init_Proc (Root_Type (Full_Type)); + else + return Proc; + end if; + end if; + end Base_Init_Proc; + + -------------- + -- Copy_TSS -- + -------------- + + -- Note: internally this routine is also used to initially set up + -- a TSS entry for a new type (case of being called from Set_TSS) + + procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is + FN : Node_Id; + + begin + Ensure_Freeze_Node (Typ); + FN := Freeze_Node (Typ); + + if No (TSS_Elist (FN)) then + Set_TSS_Elist (FN, New_Elmt_List); + end if; + + -- We prepend here, so that a second call overrides the first, it + -- is not clear that this is required, but it seems reasonable. + + Prepend_Elmt (TSS, TSS_Elist (FN)); + end Copy_TSS; + + --------------------------------- + -- Has_Non_Null_Base_Init_Proc -- + --------------------------------- + + function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is + BIP : constant Entity_Id := Base_Init_Proc (Typ); + + begin + return Present (BIP) and then not Is_Null_Init_Proc (BIP); + end Has_Non_Null_Base_Init_Proc; + + --------------- + -- Init_Proc -- + --------------- + + function Init_Proc (Typ : Entity_Id) return Entity_Id is + begin + return TSS (Typ, Name_uInit_Proc); + end Init_Proc; + + ------------------- + -- Set_Init_Proc -- + ------------------- + + procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is + begin + Set_TSS (Typ, Init); + end Set_Init_Proc; + + ------------- + -- Set_TSS -- + ------------- + + procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is + Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS); + + begin + -- Case of insertion location is in unit defining the type + + if In_Same_Code_Unit (Typ, TSS) then + Append_Freeze_Action (Typ, Subprog_Body); + + -- Otherwise, we are using an already existing TSS in another unit + + else + null; + end if; + + Copy_TSS (TSS, Typ); + end Set_TSS; + + --------- + -- TSS -- + --------- + + function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is + FN : constant Node_Id := Freeze_Node (Typ); + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + if No (FN) then + return Empty; + + elsif No (TSS_Elist (FN)) then + return Empty; + + else + Elmt := First_Elmt (TSS_Elist (FN)); + + while Present (Elmt) loop + if Chars (Node (Elmt)) = Nam then + Subp := Node (Elmt); + + -- For stream subprograms, the TSS entity may be a renaming- + -- as-body of an already generated entity. Use that one rather + -- the one introduced by the renaming, which is an artifact of + -- current stream handling. + + if Nkind (Parent (Parent (Subp))) = + N_Subprogram_Renaming_Declaration + and then + Present (Corresponding_Spec (Parent (Parent (Subp)))) + then + return Corresponding_Spec (Parent (Parent (Subp))); + else + return Subp; + end if; + + else + Next_Elmt (Elmt); + end if; + end loop; + end if; + + return Empty; + end TSS; + +end Exp_Tss; diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads new file mode 100644 index 00000000000..1df084fed88 --- /dev/null +++ b/gcc/ada/exp_tss.ads @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ T S S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Type Support Subprogram (TSS) handling + +with Types; use Types; + +package Exp_Tss is + + -- A type support subprogram (TSS) is an internally generated function or + -- procedure that is associated with a particular type. Examples are the + -- implicit initialization procedure, and subprograms for the Input and + -- Output attributes. + + -- A given TSS is either generated once at the point of the declaration of + -- the type, or it is generated as needed in clients, but only one copy is + -- required in any one generated object file. The choice between these two + -- possibilities is made on a TSS-by-TSS basis depending on the estimation + -- of how likely the TSS is to be used. Initialization procedures fall in + -- the first category, for example, since it is likely that any declared + -- type will be used in a context requiring initialization, but the stream + -- attributes use the second approach, since it is more likely that they + -- will not be used at all, or will only be used in one client in any case. + + -- A TSS is identified by its Chars name, i.e. for a given TSS type, the + -- same name is used for all types, e.g. the initialization routine has + -- the name _init for all types. + + -- The TSS's for a given type are stored in an element list associated with + -- the type, and referenced from the TSS_Elist field of the N_Freeze_Entity + -- node associated with the type (all types that need TSS's always need to + -- be explicitly frozen, so the N_Freeze_Entity node always exists). + + function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id; + -- Finds the TSS with the given name associated with the given type. If + -- no such TSS exists, then Empty is returned. + + procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id); + -- This procedure is used to install a newly created TSS. The second + -- argument is the entity for such a new TSS. This entity is placed in + -- the TSS list for the type given as the first argument, replacing an + -- old entry of the same name if one was present. The tree for the body + -- of this TSS, which is not analyzed yet, is placed in the actions field + -- of the freeze node for the type. All such bodies are inserted into the + -- main tree and analyzed at the point at which the freeze node itself is + -- is expanded. + + procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id); + -- Given an existing TSS for another type (which is already installed, + -- analyzed and expanded), install it as the corresponding TSS for Typ. + -- Note that this just copies a reference, not the tree. This can also + -- be used to initially install a TSS in the case where the subprogram + -- for the TSS has already been created and its declaration processed. + + function Init_Proc (Typ : Entity_Id) return Entity_Id; + pragma Inline (Init_Proc); + -- Obtains the _init TSS entry for the given type. This function call is + -- equivalent to TSS (Typ, Name_uInit). The _init TSS is the procedure + -- used to initialize otherwise uninitialized instances of a type. If + -- there is no _init TSS, then the type requires no initialization. Note + -- that subtypes and implicit types never have an _init TSS since subtype + -- objects are always initialized using the initialization procedure for + -- the corresponding base type (see Base_Init_Proc function). A special + -- case arises for concurrent types. Such types do not themselves have an + -- _init TSR, but initialization is required. The initialization procedure + -- used is the one fot the corresponding record type (see Base_Init_Proc). + + function Base_Init_Proc (Typ : Entity_Id) return Entity_Id; + -- Obtains the _Init TSS entry from the base type of the entity, and also + -- deals with going indirect through the Corresponding_Record_Type field + -- for concurrent objects (which are initialized with the initialization + -- routine for the corresponding record type). Returns Empty if there is + -- no _Init TSS entry for the base type. + + procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id); + pragma Inline (Set_Init_Proc); + -- The second argument is the _init TSS to be established for the type + -- given as the first argument. Equivalent to Set_TSS (Typ, Init). + + function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean; + -- Returns true if the given type has a defined Base_Init_Proc and + -- this init proc is not a null init proc (null init procs occur as + -- a result of the processing for Initialize_Scalars. This function + -- is used to test for the presence of an Init_Proc in cases where + -- a null init proc is considered equivalent to no Init_Proc. + +end Exp_Tss; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb new file mode 100644 index 00000000000..c95fd9f841d --- /dev/null +++ b/gcc/ada/exp_util.adb @@ -0,0 +1,3186 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ U T I L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.331 $ +-- -- +-- Copyright (C) 1992-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 Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch11; use Exp_Ch11; +with Hostparm; use Hostparm; +with Inline; use Inline; +with Itypes; use Itypes; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Util is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Build_Task_Array_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id) + return Node_Id; + -- Build function to generate the image string for a task that is an + -- array component, concatenating the images of each index. To avoid + -- storage leaks, the string is built with successive slice assignments. + + function Build_Task_Image_Function + (Loc : Source_Ptr; + Decls : List_Id; + Stats : List_Id; + Res : Entity_Id) + return Node_Id; + -- Common processing for Task_Array_Image and Task_Record_Image. + -- Build function body that computes image. + + procedure Build_Task_Image_Prefix + (Loc : Source_Ptr; + Len : out Entity_Id; + Res : out Entity_Id; + Pos : out Entity_Id; + Prefix : Entity_Id; + Sum : Node_Id; + Decls : in out List_Id; + Stats : in out List_Id); + -- Common processing for Task_Array_Image and Task_Record_Image. + -- Create local variables and assign prefix of name to result string. + + function Build_Task_Record_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id) + return Node_Id; + -- Build function to generate the image string for a task that is a + -- record component. Concatenate name of variable with that of selector. + + function Make_CW_Equivalent_Type + (T : Entity_Id; + E : Node_Id) + return Entity_Id; + -- T is a class-wide type entity, E is the initial expression node that + -- constrains T in case such as: " X: T := E" or "new T'(E)" + -- This function returns the entity of the Equivalent type and inserts + -- on the fly the necessary declaration such as: + -- type anon is record + -- _parent : Root_Type (T); constrained with E discriminants (if any) + -- Extension : String (1 .. expr to match size of E); + -- end record; + -- + -- This record is compatible with any object of the class of T thanks + -- to the first field and has the same size as E thanks to the second. + + function Make_Literal_Range + (Loc : Source_Ptr; + Literal_Typ : Entity_Id; + Index_Typ : Entity_Id) + return Node_Id; + -- Produce a Range node whose bounds are: + -- Index_Typ'first .. Index_Typ'First + Length (Literal_Typ) + -- this is used for expanding declarations like X : String := "sdfgdfg"; + + function New_Class_Wide_Subtype + (CW_Typ : Entity_Id; + N : Node_Id) + return Entity_Id; + -- Create an implicit subtype of CW_Typ attached to node N. + + ---------------------- + -- Adjust_Condition -- + ---------------------- + + procedure Adjust_Condition (N : Node_Id) is + begin + if No (N) then + return; + end if; + + declare + Loc : constant Source_Ptr := Sloc (N); + T : constant Entity_Id := Etype (N); + Ti : Entity_Id; + + begin + -- For now, we simply ignore a call where the argument has no + -- type (probably case of unanalyzed condition), or has a type + -- that is not Boolean. This is because this is a pretty marginal + -- piece of functionality, and violations of these rules are + -- likely to be truly marginal (how much code uses Fortran Logical + -- as the barrier to a protected entry?) and we do not want to + -- blow up existing programs. We can change this to an assertion + -- after 3.12a is released ??? + + if No (T) or else not Is_Boolean_Type (T) then + return; + end if; + + -- Apply validity checking if needed + + if Validity_Checks_On and Validity_Check_Tests then + Ensure_Valid (N); + end if; + + -- Immediate return if standard boolean, the most common case, + -- where nothing needs to be done. + + if Base_Type (T) = Standard_Boolean then + return; + end if; + + -- Case of zero/non-zero semantics or non-standard enumeration + -- representation. In each case, we rewrite the node as: + + -- ityp!(N) /= False'Enum_Rep + + -- where ityp is an integer type with large enough size to hold + -- any value of type T. + + if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then + if Esize (T) <= Esize (Standard_Integer) then + Ti := Standard_Integer; + else + Ti := Standard_Long_Long_Integer; + end if; + + Rewrite (N, + Make_Op_Ne (Loc, + Left_Opnd => Unchecked_Convert_To (Ti, N), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Enum_Rep, + Prefix => + New_Occurrence_Of (First_Literal (T), Loc)))); + Analyze_And_Resolve (N, Standard_Boolean); + + else + Rewrite (N, Convert_To (Standard_Boolean, N)); + Analyze_And_Resolve (N, Standard_Boolean); + end if; + end; + end Adjust_Condition; + + ------------------------ + -- Adjust_Result_Type -- + ------------------------ + + procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is + begin + -- Ignore call if current type is not Standard.Boolean + + if Etype (N) /= Standard_Boolean then + return; + end if; + + -- If result is already of correct type, nothing to do. Note that + -- this will get the most common case where everything has a type + -- of Standard.Boolean. + + if Base_Type (T) = Standard_Boolean then + return; + + else + declare + KP : constant Node_Kind := Nkind (Parent (N)); + + begin + -- If result is to be used as a Condition in the syntax, no need + -- to convert it back, since if it was changed to Standard.Boolean + -- using Adjust_Condition, that is just fine for this usage. + + if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then + return; + + -- If result is an operand of another logical operation, no need + -- to reset its type, since Standard.Boolean is just fine, and + -- such operations always do Adjust_Condition on their operands. + + elsif KP in N_Op_Boolean + or else KP = N_And_Then + or else KP = N_Or_Else + or else KP = N_Op_Not + then + return; + + -- Otherwise we perform a conversion from the current type, + -- which must be Standard.Boolean, to the desired type. + + else + Set_Analyzed (N); + Rewrite (N, Convert_To (T, N)); + Analyze_And_Resolve (N, T); + end if; + end; + end if; + end Adjust_Result_Type; + + -------------------------- + -- Append_Freeze_Action -- + -------------------------- + + procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is + Fnode : Node_Id := Freeze_Node (T); + + begin + Ensure_Freeze_Node (T); + Fnode := Freeze_Node (T); + + if not Present (Actions (Fnode)) then + Set_Actions (Fnode, New_List); + end if; + + Append (N, Actions (Fnode)); + end Append_Freeze_Action; + + --------------------------- + -- Append_Freeze_Actions -- + --------------------------- + + procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is + Fnode : constant Node_Id := Freeze_Node (T); + + begin + if No (L) then + return; + + else + if No (Actions (Fnode)) then + Set_Actions (Fnode, L); + + else + Append_List (L, Actions (Fnode)); + end if; + + end if; + end Append_Freeze_Actions; + + ------------------------ + -- Build_Runtime_Call -- + ------------------------ + + function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE), Loc)); + end Build_Runtime_Call; + + ----------------------------- + -- Build_Task_Array_Image -- + ----------------------------- + + -- This function generates the body for a function that constructs the + -- image string for a task that is an array component. The function is + -- local to the init_proc for the array type, and is called for each one + -- of the components. The constructed image has the form of an indexed + -- component, whose prefix is the outer variable of the array type. + -- The n-dimensional array type has known indices Index, Index2... + -- Id_Ref is an indexed component form created by the enclosing init_proc. + -- Its successive indices are Val1, Val2,.. which are the loop variables + -- in the loops that call the individual task init_proc on each component. + + -- The generated function has the following structure: + + -- function F return Task_Image_Type is + -- Prefix : string := Task_Id.all; + -- T1 : String := Index1'Image (Val1); + -- ... + -- Tn : String := indexn'image (Valn); + -- Len : Integer := T1'Length + ... + Tn'Length + n + 1; + -- -- Len includes commas and the end parentheses. + -- Res : String (1..Len); + -- Pos : Integer := Prefix'Length; + -- + -- begin + -- Res (1 .. Pos) := Prefix; + -- Pos := Pos + 1; + -- Res (Pos) := '('; + -- Pos := Pos + 1; + -- Res (Pos .. Pos + T1'Length - 1) := T1; + -- Pos := Pos + T1'Length; + -- Res (Pos) := '.'; + -- Pos := Pos + 1; + -- ... + -- Res (Pos .. Pos + Tn'Length - 1) := Tn; + -- Res (Len) := ')'; + -- + -- return new String (Res); + -- end F; + -- + -- Needless to say, multidimensional arrays of tasks are rare enough + -- that the bulkiness of this code is not really a concern. + + function Build_Task_Array_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id) + return Node_Id + is + Dims : constant Nat := Number_Dimensions (A_Type); + -- Number of dimensions for array of tasks. + + Temps : array (1 .. Dims) of Entity_Id; + -- Array of temporaries to hold string for each index. + + Indx : Node_Id; + -- Index expression + + Len : Entity_Id; + -- Total length of generated name + + Pos : Entity_Id; + -- Running index for substring assignments + + Prefix : Entity_Id; + -- Name of enclosing variable, prefix of resulting name + + Res : Entity_Id; + -- String to hold result + + Val : Node_Id; + -- Value of successive indices + + Sum : Node_Id; + -- Expression to compute total size of string + + T : Entity_Id; + -- Entity for name at one index position + + Decls : List_Id := New_List; + Stats : List_Id := New_List; + + begin + Prefix := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Prefix, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => Make_Identifier (Loc, Name_uTask_Id)))); + + Indx := First_Index (A_Type); + Val := First (Expressions (Id_Ref)); + + for J in 1 .. Dims loop + T := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Temps (J) := T; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => T, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Image, + Prefix => + New_Occurrence_Of (Etype (Indx), Loc), + Expressions => New_List ( + New_Copy_Tree (Val))))); + + Next_Index (Indx); + Next (Val); + end loop; + + Sum := Make_Integer_Literal (Loc, Dims + 1); + + Sum := + Make_Op_Add (Loc, + Left_Opnd => Sum, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Prefix, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1)))); + + for J in 1 .. Dims loop + Sum := + Make_Op_Add (Loc, + Left_Opnd => Sum, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Temps (J), Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1)))); + end loop; + + Build_Task_Image_Prefix (Loc, Len, Res, Pos, Prefix, Sum, Decls, Stats); + + Set_Character_Literal_Name (Char_Code (Character'Pos ('('))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Pos, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + Char_Code (Character'Pos ('('))))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + for J in 1 .. Dims loop + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => New_Occurrence_Of (Pos, Loc), + High_Bound => Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Temps (J), Loc), + Expressions => + New_List (Make_Integer_Literal (Loc, 1)))), + Right_Opnd => Make_Integer_Literal (Loc, 1)))), + + Expression => New_Occurrence_Of (Temps (J), Loc))); + + if J < Dims then + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Temps (J), Loc), + Expressions => + New_List (Make_Integer_Literal (Loc, 1)))))); + + Set_Character_Literal_Name (Char_Code (Character'Pos (','))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Pos, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + Char_Code (Character'Pos (','))))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + end if; + end loop; + + Set_Character_Literal_Name (Char_Code (Character'Pos (')'))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Len, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + Char_Code (Character'Pos (')'))))); + return Build_Task_Image_Function (Loc, Decls, Stats, Res); + end Build_Task_Array_Image; + + ---------------------------- + -- Build_Task_Image_Decls -- + ---------------------------- + + function Build_Task_Image_Decls + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id) + return List_Id + is + T_Id : Entity_Id := Empty; + Decl : Node_Id; + Decls : List_Id := New_List; + Expr : Node_Id := Empty; + Fun : Node_Id := Empty; + + begin + -- If Discard_Names is in effect, generate a dummy declaration only. + + if Global_Discard_Names then + T_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + return + New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => T_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc))); + + else + if Nkind (Id_Ref) = N_Identifier + or else Nkind (Id_Ref) = N_Defining_Identifier + then + -- For a simple variable, the image of the task is the name + -- of the variable. + + T_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Id_Ref), 'I')); + + Get_Name_String (Chars (Id_Ref)); + + Expr := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal + (Loc, Strval => String_From_Name_Buffer))); + + elsif Nkind (Id_Ref) = N_Selected_Component then + T_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Selector_Name (Id_Ref)), 'I')); + Fun := Build_Task_Record_Image (Loc, Id_Ref, A_Type); + + elsif Nkind (Id_Ref) = N_Indexed_Component then + T_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (A_Type), 'I')); + + Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type); + end if; + end if; + + if Present (Fun) then + Append (Fun, Decls); + + Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Defining_Entity (Fun), Loc)); + end if; + + Decl := Make_Object_Declaration (Loc, + Defining_Identifier => T_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc), + Expression => Expr); + + Append (Decl, Decls); + return Decls; + end Build_Task_Image_Decls; + + ------------------------------- + -- Build_Task_Image_Function -- + ------------------------------- + + function Build_Task_Image_Function + (Loc : Source_Ptr; + Decls : List_Id; + Stats : List_Id; + Res : Entity_Id) + return Node_Id + is + Spec : Node_Id; + + begin + Append_To (Stats, + Make_Return_Statement (Loc, + Expression => + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_String, Loc), + Expression => New_Occurrence_Of (Res, Loc))))); + + Spec := Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc)); + + return Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats)); + end Build_Task_Image_Function; + + ----------------------------- + -- Build_Task_Image_Prefix -- + ----------------------------- + + procedure Build_Task_Image_Prefix + (Loc : Source_Ptr; + Len : out Entity_Id; + Res : out Entity_Id; + Pos : out Entity_Id; + Prefix : Entity_Id; + Sum : Node_Id; + Decls : in out List_Id; + Stats : in out List_Id) + is + begin + Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Len, + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => Sum)); + + Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Len, Loc))))))); + + Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Pos, + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); + + -- Pos := Prefix'Length; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Prefix, Loc), + Expressions => + New_List (Make_Integer_Literal (Loc, 1))))); + + -- Res (1 .. Pos) := Prefix; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Pos, Loc))), + + Expression => New_Occurrence_Of (Prefix, Loc))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + end Build_Task_Image_Prefix; + + ----------------------------- + -- Build_Task_Record_Image -- + ----------------------------- + + function Build_Task_Record_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id) + return Node_Id + is + Len : Entity_Id; + -- Total length of generated name + + Pos : Entity_Id; + -- Index into result + + Res : Entity_Id; + -- String to hold result + + Prefix : Entity_Id; + -- Name of enclosing variable, prefix of resulting name + + Sum : Node_Id; + -- Expression to compute total size of string. + + Sel : Entity_Id; + -- Entity for selector name + + Decls : List_Id := New_List; + Stats : List_Id := New_List; + + begin + Prefix := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Prefix, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => Make_Identifier (Loc, Name_uTask_Id)))); + + Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + Get_Name_String (Chars (Selector_Name (Id_Ref))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Sel, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Strval => String_From_Name_Buffer))); + + Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1)); + + Sum := + Make_Op_Add (Loc, + Left_Opnd => Sum, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Prefix, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1)))); + + Build_Task_Image_Prefix (Loc, Len, Res, Pos, Prefix, Sum, Decls, Stats); + + Set_Character_Literal_Name (Char_Code (Character'Pos ('.'))); + + -- Res (Pos) := '.'; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Pos, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + Char_Code (Character'Pos ('.'))))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + -- Res (Pos .. Len) := Selector; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => New_Occurrence_Of (Pos, Loc), + High_Bound => New_Occurrence_Of (Len, Loc))), + Expression => New_Occurrence_Of (Sel, Loc))); + + return Build_Task_Image_Function (Loc, Decls, Stats, Res); + end Build_Task_Record_Image; + + ------------------------------- + -- Convert_To_Actual_Subtype -- + ------------------------------- + + procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is + Act_ST : Entity_Id; + + begin + Act_ST := Get_Actual_Subtype (Exp); + + if Act_ST = Etype (Exp) then + return; + + else + Rewrite (Exp, + Convert_To (Act_ST, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Act_ST); + end if; + end Convert_To_Actual_Subtype; + + ----------------------------------- + -- Current_Sem_Unit_Declarations -- + ----------------------------------- + + function Current_Sem_Unit_Declarations return List_Id is + U : Node_Id := Unit (Cunit (Current_Sem_Unit)); + Decls : List_Id; + + begin + -- If the current unit is a package body, locate the visible + -- declarations of the package spec. + + if Nkind (U) = N_Package_Body then + U := Unit (Library_Unit (Cunit (Current_Sem_Unit))); + end if; + + if Nkind (U) = N_Package_Declaration then + U := Specification (U); + Decls := Visible_Declarations (U); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (U, Decls); + end if; + + else + Decls := Declarations (U); + + if No (Decls) then + Decls := New_List; + Set_Declarations (U, Decls); + end if; + end if; + + return Decls; + end Current_Sem_Unit_Declarations; + + ----------------------- + -- Duplicate_Subexpr -- + ----------------------- + + function Duplicate_Subexpr + (Exp : Node_Id; + Name_Req : Boolean := False) + return Node_Id + is + begin + Remove_Side_Effects (Exp, Name_Req); + return New_Copy_Tree (Exp); + end Duplicate_Subexpr; + + -------------------- + -- Ensure_Defined -- + -------------------- + + procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is + IR : Node_Id; + P : Node_Id; + + begin + if Is_Itype (Typ) then + IR := Make_Itype_Reference (Sloc (N)); + Set_Itype (IR, Typ); + + if not In_Open_Scopes (Scope (Typ)) + and then Is_Subprogram (Current_Scope) + and then Scope (Current_Scope) /= Standard_Standard + then + -- Insert node in front of subprogram, to avoid scope anomalies + -- in gigi. + + P := Parent (N); + + while Present (P) + and then Nkind (P) /= N_Subprogram_Body + loop + P := Parent (P); + end loop; + + if Present (P) then + Insert_Action (P, IR); + else + Insert_Action (N, IR); + end if; + + else + Insert_Action (N, IR); + end if; + end if; + end Ensure_Defined; + + --------------------- + -- Evolve_And_Then -- + --------------------- + + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is + begin + if No (Cond) then + Cond := Cond1; + else + Cond := + Make_And_Then (Sloc (Cond1), + Left_Opnd => Cond, + Right_Opnd => Cond1); + end if; + end Evolve_And_Then; + + -------------------- + -- Evolve_Or_Else -- + -------------------- + + procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is + begin + if No (Cond) then + Cond := Cond1; + else + Cond := + Make_Or_Else (Sloc (Cond1), + Left_Opnd => Cond, + Right_Opnd => Cond1); + end if; + end Evolve_Or_Else; + + ------------------------------ + -- Expand_Subtype_From_Expr -- + ------------------------------ + + -- This function is applicable for both static and dynamic allocation of + -- objects which are constrained by an initial expression. Basically it + -- transforms an unconstrained subtype indication into a constrained one. + -- The expression may also be transformed in certain cases in order to + -- avoid multiple evaulation. In the static allocation case, the general + -- scheme is : + + -- Val : T := Expr; + + -- is transformed into + + -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr; + -- + -- Here are the main cases : + -- + -- <if Expr is a Slice> + -- Val : T ([Index_Subtype (Expr)]) := Expr; + -- + -- <elsif Expr is a String Literal> + -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr; + -- + -- <elsif Expr is Constrained> + -- subtype T is Type_Of_Expr + -- Val : T := Expr; + -- + -- <elsif Expr is an entity_name> + -- Val : T (contraints taken from Expr) := Expr; + -- + -- <else> + -- type Axxx is access all T; + -- Rval : Axxx := Expr'ref; + -- Val : T (contraints taken from Rval) := Rval.all; + + -- ??? note: when the Expression is allocated in the secondary stack + -- we could use it directly instead of copying it by declaring + -- Val : T (...) renames Rval.all + + procedure Expand_Subtype_From_Expr + (N : Node_Id; + Unc_Type : Entity_Id; + Subtype_Indic : Node_Id; + Exp : Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Exp_Typ : constant Entity_Id := Etype (Exp); + T : Entity_Id; + + begin + -- In general we cannot build the subtype if expansion is disabled, + -- because internal entities may not have been defined. However, to + -- avoid some cascaded errors, we try to continue when the expression + -- is an array (or string), because it is safe to compute the bounds. + -- It is in fact required to do so even in a generic context, because + -- there may be constants that depend on bounds of string literal. + + if not Expander_Active + and then (No (Etype (Exp)) + or else Base_Type (Etype (Exp)) /= Standard_String) + then + return; + end if; + + if Nkind (Exp) = N_Slice then + declare + Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ)); + + begin + Rewrite (Subtype_Indic, + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Unc_Type, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List + (New_Reference_To (Slice_Type, Loc))))); + + -- This subtype indication may be used later for contraint checks + -- we better make sure that if a variable was used as a bound of + -- of the original slice, its value is frozen. + + Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type))); + Force_Evaluation (High_Bound (Scalar_Range (Slice_Type))); + end; + + elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then + Rewrite (Subtype_Indic, + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Unc_Type, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Literal_Range (Loc, + Literal_Typ => Exp_Typ, + Index_Typ => Etype (First_Index (Unc_Type))))))); + + elsif Is_Constrained (Exp_Typ) + and then not Is_Class_Wide_Type (Unc_Type) + then + if Is_Itype (Exp_Typ) then + + -- No need to generate a new one. + + T := Exp_Typ; + + else + T := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => T, + Subtype_Indication => New_Reference_To (Exp_Typ, Loc))); + + -- This type is marked as an itype even though it has an + -- explicit declaration because otherwise it can be marked + -- with Is_Generic_Actual_Type and generate spurious errors. + -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers) + + Set_Is_Itype (T); + Set_Associated_Node_For_Itype (T, Exp); + end if; + + Rewrite (Subtype_Indic, New_Reference_To (T, Loc)); + + -- nothing needs to be done for private types with unknown discriminants + -- if the underlying type is not an unconstrained composite type. + + elsif Is_Private_Type (Unc_Type) + and then Has_Unknown_Discriminants (Unc_Type) + and then (not Is_Composite_Type (Underlying_Type (Unc_Type)) + or else Is_Constrained (Underlying_Type (Unc_Type))) + then + null; + + else + Remove_Side_Effects (Exp); + Rewrite (Subtype_Indic, + Make_Subtype_From_Expr (Exp, Unc_Type)); + end if; + end Expand_Subtype_From_Expr; + + ------------------ + -- Find_Prim_Op -- + ------------------ + + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is + Prim : Elmt_Id; + Typ : Entity_Id := T; + + begin + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ := Underlying_Type (Typ); + + Prim := First_Elmt (Primitive_Operations (Typ)); + while Chars (Node (Prim)) /= Name loop + Next_Elmt (Prim); + pragma Assert (Present (Prim)); + end loop; + + return Node (Prim); + end Find_Prim_Op; + + ---------------------- + -- Force_Evaluation -- + ---------------------- + + procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is + begin + Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True); + end Force_Evaluation; + + ------------------------ + -- Generate_Poll_Call -- + ------------------------ + + procedure Generate_Poll_Call (N : Node_Id) is + begin + -- No poll call if polling not active + + if not Polling_Required then + return; + + -- Otherwise generate require poll call + + else + Insert_Before_And_Analyze (N, + Make_Procedure_Call_Statement (Sloc (N), + Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N)))); + end if; + end Generate_Poll_Call; + + -------------------- + -- Homonym_Number -- + -------------------- + + function Homonym_Number (Subp : Entity_Id) return Nat is + Count : Nat; + Hom : Entity_Id; + + begin + Count := 1; + Hom := Homonym (Subp); + while Present (Hom) loop + if Scope (Hom) = Scope (Subp) then + Count := Count + 1; + end if; + + Hom := Homonym (Hom); + end loop; + + return Count; + end Homonym_Number; + + ------------------------------ + -- In_Unconditional_Context -- + ------------------------------ + + function In_Unconditional_Context (Node : Node_Id) return Boolean is + P : Node_Id; + + begin + P := Node; + while Present (P) loop + case Nkind (P) is + when N_Subprogram_Body => + return True; + + when N_If_Statement => + return False; + + when N_Loop_Statement => + return False; + + when N_Case_Statement => + return False; + + when others => + P := Parent (P); + end case; + end loop; + + return False; + end In_Unconditional_Context; + + ------------------- + -- Insert_Action -- + ------------------- + + procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is + begin + if Present (Ins_Action) then + Insert_Actions (Assoc_Node, New_List (Ins_Action)); + end if; + end Insert_Action; + + -- Version with check(s) suppressed + + procedure Insert_Action + (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id) + is + begin + Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress); + end Insert_Action; + + -------------------- + -- Insert_Actions -- + -------------------- + + procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is + N : Node_Id; + P : Node_Id; + + Wrapped_Node : Node_Id := Empty; + + begin + if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then + return; + end if; + + -- Ignore insert of actions from inside default expression in the + -- special preliminary analyze mode. Any insertions at this point + -- have no relevance, since we are only doing the analyze to freeze + -- the types of any static expressions. See section "Handling of + -- Default Expressions" in the spec of package Sem for further details. + + if In_Default_Expression then + return; + end if; + + -- If the action derives from stuff inside a record, then the actions + -- are attached to the current scope, to be inserted and analyzed on + -- exit from the scope. The reason for this is that we may also + -- be generating freeze actions at the same time, and they must + -- eventually be elaborated in the correct order. + + if Is_Record_Type (Current_Scope) + and then not Is_Frozen (Current_Scope) + then + if No (Scope_Stack.Table + (Scope_Stack.Last).Pending_Freeze_Actions) + then + Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions := + Ins_Actions; + else + Append_List + (Ins_Actions, + Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions); + end if; + + return; + end if; + + -- We now intend to climb up the tree to find the right point to + -- insert the actions. We start at Assoc_Node, unless this node is + -- a subexpression in which case we start with its parent. We do this + -- for two reasons. First it speeds things up. Second, if Assoc_Node + -- is itself one of the special nodes like N_And_Then, then we assume + -- that an initial request to insert actions for such a node does not + -- expect the actions to get deposited in the node for later handling + -- when the node is expanded, since clearly the node is being dealt + -- with by the caller. Note that in the subexpression case, N is + -- always the child we came from. + + -- N_Raise_xxx_Error is an annoying special case, it is a statement + -- if it has type Standard_Void_Type, and a subexpression otherwise. + -- otherwise. Procedure attribute references are also statements. + + if Nkind (Assoc_Node) in N_Subexpr + and then (Nkind (Assoc_Node) in N_Raise_xxx_Error + or else Etype (Assoc_Node) /= Standard_Void_Type) + and then (Nkind (Assoc_Node) /= N_Attribute_Reference + or else + not Is_Procedure_Attribute_Name + (Attribute_Name (Assoc_Node))) + then + P := Assoc_Node; -- ????? does not agree with above! + N := Parent (Assoc_Node); + + -- Non-subexpression case. Note that N is initially Empty in this + -- case (N is only guaranteed Non-Empty in the subexpr case). + + else + P := Assoc_Node; + N := Empty; + end if; + + -- Capture root of the transient scope + + if Scope_Is_Transient then + Wrapped_Node := Node_To_Be_Wrapped; + end if; + + loop + pragma Assert (Present (P)); + + case Nkind (P) is + + -- Case of right operand of AND THEN or OR ELSE. Put the actions + -- in the Actions field of the right operand. They will be moved + -- out further when the AND THEN or OR ELSE operator is expanded. + -- Nothing special needs to be done for the left operand since + -- in that case the actions are executed unconditionally. + + when N_And_Then | N_Or_Else => + if N = Right_Opnd (P) then + if Present (Actions (P)) then + Insert_List_After_And_Analyze + (Last (Actions (P)), Ins_Actions); + else + Set_Actions (P, Ins_Actions); + Analyze_List (Actions (P)); + end if; + + return; + end if; + + -- Then or Else operand of conditional expression. Add actions to + -- Then_Actions or Else_Actions field as appropriate. The actions + -- will be moved further out when the conditional is expanded. + + when N_Conditional_Expression => + declare + ThenX : constant Node_Id := Next (First (Expressions (P))); + ElseX : constant Node_Id := Next (ThenX); + + begin + -- Actions belong to the then expression, temporarily + -- place them as Then_Actions of the conditional expr. + -- They will be moved to the proper place later when + -- the conditional expression is expanded. + + if N = ThenX then + if Present (Then_Actions (P)) then + Insert_List_After_And_Analyze + (Last (Then_Actions (P)), Ins_Actions); + else + Set_Then_Actions (P, Ins_Actions); + Analyze_List (Then_Actions (P)); + end if; + + return; + + -- Actions belong to the else expression, temporarily + -- place them as Else_Actions of the conditional expr. + -- They will be moved to the proper place later when + -- the conditional expression is expanded. + + elsif N = ElseX then + if Present (Else_Actions (P)) then + Insert_List_After_And_Analyze + (Last (Else_Actions (P)), Ins_Actions); + else + Set_Else_Actions (P, Ins_Actions); + Analyze_List (Else_Actions (P)); + end if; + + return; + + -- Actions belong to the condition. In this case they are + -- unconditionally executed, and so we can continue the + -- search for the proper insert point. + + else + null; + end if; + end; + + -- Case of appearing in the condition of a while expression or + -- elsif. We insert the actions into the Condition_Actions field. + -- They will be moved further out when the while loop or elsif + -- is analyzed. + + when N_Iteration_Scheme | + N_Elsif_Part + => + if N = Condition (P) then + if Present (Condition_Actions (P)) then + Insert_List_After_And_Analyze + (Last (Condition_Actions (P)), Ins_Actions); + else + Set_Condition_Actions (P, Ins_Actions); + + -- Set the parent of the insert actions explicitly. + -- This is not a syntactic field, but we need the + -- parent field set, in particular so that freeze + -- can understand that it is dealing with condition + -- actions, and properly insert the freezing actions. + + Set_Parent (Ins_Actions, P); + Analyze_List (Condition_Actions (P)); + end if; + + return; + end if; + + -- Statements, declarations, pragmas, representation clauses. + + when + -- Statements + + N_Procedure_Call_Statement | + N_Statement_Other_Than_Procedure_Call | + + -- Pragmas + + N_Pragma | + + -- Representation_Clause + + N_At_Clause | + N_Attribute_Definition_Clause | + N_Enumeration_Representation_Clause | + N_Record_Representation_Clause | + + -- Declarations + + N_Abstract_Subprogram_Declaration | + N_Entry_Body | + N_Exception_Declaration | + N_Exception_Renaming_Declaration | + N_Formal_Object_Declaration | + N_Formal_Subprogram_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Function_Instantiation | + N_Generic_Function_Renaming_Declaration | + N_Generic_Package_Declaration | + N_Generic_Package_Renaming_Declaration | + N_Generic_Procedure_Renaming_Declaration | + N_Generic_Subprogram_Declaration | + N_Implicit_Label_Declaration | + N_Incomplete_Type_Declaration | + N_Number_Declaration | + N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Package_Body | + N_Package_Body_Stub | + N_Package_Declaration | + N_Package_Instantiation | + N_Package_Renaming_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Procedure_Instantiation | + N_Protected_Body_Stub | + N_Protected_Type_Declaration | + N_Single_Task_Declaration | + N_Subprogram_Body | + N_Subprogram_Body_Stub | + N_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration | + N_Subtype_Declaration | + N_Task_Body | + N_Task_Body_Stub | + N_Task_Type_Declaration | + + -- Freeze entity behaves like a declaration or statement + + N_Freeze_Entity + => + -- Do not insert here if the item is not a list member (this + -- happens for example with a triggering statement, and the + -- proper approach is to insert before the entire select). + + if not Is_List_Member (P) then + null; + + -- Do not insert if parent of P is an N_Component_Association + -- node (i.e. we are in the context of an N_Aggregate node. + -- In this case we want to insert before the entire aggregate. + + elsif Nkind (Parent (P)) = N_Component_Association then + null; + + -- Do not insert if the parent of P is either an N_Variant + -- node or an N_Record_Definition node, meaning in either + -- case that P is a member of a component list, and that + -- therefore the actions should be inserted outside the + -- complete record declaration. + + elsif Nkind (Parent (P)) = N_Variant + or else Nkind (Parent (P)) = N_Record_Definition + then + null; + + -- Do not insert freeze nodes within the loop generated for + -- an aggregate, because they may be elaborated too late for + -- subsequent use in the back end: within a package spec the + -- loop is part of the elaboration procedure and is only + -- elaborated during the second pass. + -- If the loop comes from source, or the entity is local to + -- the loop itself it must remain within. + + elsif Nkind (Parent (P)) = N_Loop_Statement + and then not Comes_From_Source (Parent (P)) + and then Nkind (First (Ins_Actions)) = N_Freeze_Entity + and then + Scope (Entity (First (Ins_Actions))) /= Current_Scope + then + null; + + -- Otherwise we can go ahead and do the insertion + + elsif P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + return; + + else + Insert_List_Before_And_Analyze (P, Ins_Actions); + return; + end if; + + -- A special case, N_Raise_xxx_Error can act either as a + -- statement or a subexpression. We tell the difference + -- by looking at the Etype. It is set to Standard_Void_Type + -- in the statement case. + + when + N_Raise_xxx_Error => + if Etype (P) = Standard_Void_Type then + if P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + else + Insert_List_Before_And_Analyze (P, Ins_Actions); + end if; + + return; + + -- In the subexpression case, keep climbing + + else + null; + end if; + + -- If a component association appears within a loop created for + -- an array aggregate, attach the actions to the association so + -- they can be subsequently inserted within the loop. For other + -- component associations insert outside of the aggregate. + + -- The list of loop_actions can in turn generate additional ones, + -- that are inserted before the associated node. If the associated + -- node is outside the aggregate, the new actions are collected + -- at the end of the loop actions, to respect the order in which + -- they are to be elaborated. + + when + N_Component_Association => + if Nkind (Parent (P)) = N_Aggregate + and then Present (Aggregate_Bounds (Parent (P))) + and then Nkind (First (Choices (P))) = N_Others_Choice + and then Nkind (First (Ins_Actions)) /= N_Freeze_Entity + then + if No (Loop_Actions (P)) then + Set_Loop_Actions (P, Ins_Actions); + Analyze_List (Ins_Actions); + + else + declare + Decl : Node_Id := Assoc_Node; + + begin + -- Check whether these actions were generated + -- by a declaration that is part of the loop_ + -- actions for the component_association. + + while Present (Decl) loop + exit when Parent (Decl) = P + and then Is_List_Member (Decl) + and then + List_Containing (Decl) = Loop_Actions (P); + Decl := Parent (Decl); + end loop; + + if Present (Decl) then + Insert_List_Before_And_Analyze + (Decl, Ins_Actions); + else + Insert_List_After_And_Analyze + (Last (Loop_Actions (P)), Ins_Actions); + end if; + end; + end if; + + return; + + else + null; + end if; + + -- Another special case, an attribute denoting a procedure call + + when + N_Attribute_Reference => + if Is_Procedure_Attribute_Name (Attribute_Name (P)) then + if P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + else + Insert_List_Before_And_Analyze (P, Ins_Actions); + end if; + + return; + + -- In the subexpression case, keep climbing + + else + null; + end if; + + -- For all other node types, keep climbing tree + + when + N_Abortable_Part | + N_Accept_Alternative | + N_Access_Definition | + N_Access_Function_Definition | + N_Access_Procedure_Definition | + N_Access_To_Object_Definition | + N_Aggregate | + N_Allocator | + N_Case_Statement_Alternative | + N_Character_Literal | + N_Compilation_Unit | + N_Compilation_Unit_Aux | + N_Component_Clause | + N_Component_Declaration | + N_Component_List | + N_Constrained_Array_Definition | + N_Decimal_Fixed_Point_Definition | + N_Defining_Character_Literal | + N_Defining_Identifier | + N_Defining_Operator_Symbol | + N_Defining_Program_Unit_Name | + N_Delay_Alternative | + N_Delta_Constraint | + N_Derived_Type_Definition | + N_Designator | + N_Digits_Constraint | + N_Discriminant_Association | + N_Discriminant_Specification | + N_Empty | + N_Entry_Body_Formal_Part | + N_Entry_Call_Alternative | + N_Entry_Declaration | + N_Entry_Index_Specification | + N_Enumeration_Type_Definition | + N_Error | + N_Exception_Handler | + N_Expanded_Name | + N_Explicit_Dereference | + N_Extension_Aggregate | + N_Floating_Point_Definition | + N_Formal_Decimal_Fixed_Point_Definition | + N_Formal_Derived_Type_Definition | + N_Formal_Discrete_Type_Definition | + N_Formal_Floating_Point_Definition | + N_Formal_Modular_Type_Definition | + N_Formal_Ordinary_Fixed_Point_Definition | + N_Formal_Package_Declaration | + N_Formal_Private_Type_Definition | + N_Formal_Signed_Integer_Type_Definition | + N_Function_Call | + N_Function_Specification | + N_Generic_Association | + N_Handled_Sequence_Of_Statements | + N_Identifier | + N_In | + N_Index_Or_Discriminant_Constraint | + N_Indexed_Component | + N_Integer_Literal | + N_Itype_Reference | + N_Label | + N_Loop_Parameter_Specification | + N_Mod_Clause | + N_Modular_Type_Definition | + N_Not_In | + N_Null | + N_Op_Abs | + N_Op_Add | + N_Op_And | + N_Op_Concat | + N_Op_Divide | + N_Op_Eq | + N_Op_Expon | + N_Op_Ge | + N_Op_Gt | + N_Op_Le | + N_Op_Lt | + N_Op_Minus | + N_Op_Mod | + N_Op_Multiply | + N_Op_Ne | + N_Op_Not | + N_Op_Or | + N_Op_Plus | + N_Op_Rem | + N_Op_Rotate_Left | + N_Op_Rotate_Right | + N_Op_Shift_Left | + N_Op_Shift_Right | + N_Op_Shift_Right_Arithmetic | + N_Op_Subtract | + N_Op_Xor | + N_Operator_Symbol | + N_Ordinary_Fixed_Point_Definition | + N_Others_Choice | + N_Package_Specification | + N_Parameter_Association | + N_Parameter_Specification | + N_Pragma_Argument_Association | + N_Procedure_Specification | + N_Protected_Body | + N_Protected_Definition | + N_Qualified_Expression | + N_Range | + N_Range_Constraint | + N_Real_Literal | + N_Real_Range_Specification | + N_Record_Definition | + N_Reference | + N_Selected_Component | + N_Signed_Integer_Type_Definition | + N_Single_Protected_Declaration | + N_Slice | + N_String_Literal | + N_Subprogram_Info | + N_Subtype_Indication | + N_Subunit | + N_Task_Definition | + N_Terminate_Alternative | + N_Triggering_Alternative | + N_Type_Conversion | + N_Unchecked_Expression | + N_Unchecked_Type_Conversion | + N_Unconstrained_Array_Definition | + N_Unused_At_End | + N_Unused_At_Start | + N_Use_Package_Clause | + N_Use_Type_Clause | + N_Variant | + N_Variant_Part | + N_Validate_Unchecked_Conversion | + N_With_Clause | + N_With_Type_Clause + => + null; + + end case; + + -- Make sure that inserted actions stay in the transient scope + + if P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + return; + end if; + + -- If we fall through above tests, keep climbing tree + + N := P; + + if Nkind (Parent (N)) = N_Subunit then + + -- This is the proper body corresponding to a stub. Insertion + -- must be done at the point of the stub, which is in the decla- + -- tive part of the parent unit. + + P := Corresponding_Stub (Parent (N)); + + else + P := Parent (N); + end if; + end loop; + + end Insert_Actions; + + -- Version with check(s) suppressed + + procedure Insert_Actions + (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id) + is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Record := Scope_Suppress; + + begin + Scope_Suppress := (others => True); + Insert_Actions (Assoc_Node, Ins_Actions); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Get_Scope_Suppress (Suppress); + + begin + Set_Scope_Suppress (Suppress, True); + Insert_Actions (Assoc_Node, Ins_Actions); + Set_Scope_Suppress (Suppress, Svg); + end; + end if; + end Insert_Actions; + + -------------------------- + -- Insert_Actions_After -- + -------------------------- + + procedure Insert_Actions_After + (Assoc_Node : Node_Id; + Ins_Actions : List_Id) + is + begin + if Scope_Is_Transient + and then Assoc_Node = Node_To_Be_Wrapped + then + Store_After_Actions_In_Scope (Ins_Actions); + else + Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions); + end if; + end Insert_Actions_After; + + --------------------------------- + -- Insert_Library_Level_Action -- + --------------------------------- + + procedure Insert_Library_Level_Action (N : Node_Id) is + Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); + + begin + New_Scope (Cunit_Entity (Main_Unit)); + + if No (Actions (Aux)) then + Set_Actions (Aux, New_List (N)); + else + Append (N, Actions (Aux)); + end if; + + Analyze (N); + Pop_Scope; + end Insert_Library_Level_Action; + + ---------------------------------- + -- Insert_Library_Level_Actions -- + ---------------------------------- + + procedure Insert_Library_Level_Actions (L : List_Id) is + Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); + + begin + if Is_Non_Empty_List (L) then + New_Scope (Cunit_Entity (Main_Unit)); + + if No (Actions (Aux)) then + Set_Actions (Aux, L); + Analyze_List (L); + else + Insert_List_After_And_Analyze (Last (Actions (Aux)), L); + end if; + + Pop_Scope; + end if; + end Insert_Library_Level_Actions; + + ---------------------- + -- Inside_Init_Proc -- + ---------------------- + + function Inside_Init_Proc return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while S /= Standard_Standard loop + if Chars (S) = Name_uInit_Proc then + return True; + else + S := Scope (S); + end if; + end loop; + + return False; + end Inside_Init_Proc; + + -------------------------------- + -- Is_Ref_To_Bit_Packed_Array -- + -------------------------------- + + function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean is + Result : Boolean; + Expr : Node_Id; + + begin + if Nkind (P) = N_Indexed_Component + or else + Nkind (P) = N_Selected_Component + then + if Is_Bit_Packed_Array (Etype (Prefix (P))) then + Result := True; + else + Result := Is_Ref_To_Bit_Packed_Array (Prefix (P)); + end if; + + if Result and then Nkind (P) = N_Indexed_Component then + Expr := First (Expressions (P)); + + while Present (Expr) loop + Force_Evaluation (Expr); + Next (Expr); + end loop; + end if; + + return Result; + + else + return False; + end if; + end Is_Ref_To_Bit_Packed_Array; + + -------------------------------- + -- Is_Ref_To_Bit_Packed_Slce -- + -------------------------------- + + function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is + begin + if Nkind (P) = N_Slice + and then Is_Bit_Packed_Array (Etype (Prefix (P))) + then + return True; + + elsif Nkind (P) = N_Indexed_Component + or else + Nkind (P) = N_Selected_Component + then + return Is_Ref_To_Bit_Packed_Slice (Prefix (P)); + + else + return False; + end if; + end Is_Ref_To_Bit_Packed_Slice; + + ----------------------- + -- Is_Renamed_Object -- + ----------------------- + + function Is_Renamed_Object (N : Node_Id) return Boolean is + Pnod : constant Node_Id := Parent (N); + Kind : constant Node_Kind := Nkind (Pnod); + + begin + if Kind = N_Object_Renaming_Declaration then + return True; + + elsif Kind = N_Indexed_Component + or else Kind = N_Selected_Component + then + return Is_Renamed_Object (Pnod); + + else + return False; + end if; + end Is_Renamed_Object; + + ---------------------------- + -- Is_Untagged_Derivation -- + ---------------------------- + + function Is_Untagged_Derivation (T : Entity_Id) return Boolean is + begin + return (not Is_Tagged_Type (T) and then Is_Derived_Type (T)) + or else + (Is_Private_Type (T) and then Present (Full_View (T)) + and then not Is_Tagged_Type (Full_View (T)) + and then Is_Derived_Type (Full_View (T)) + and then Etype (Full_View (T)) /= T); + + end Is_Untagged_Derivation; + + -------------------- + -- Kill_Dead_Code -- + -------------------- + + procedure Kill_Dead_Code (N : Node_Id) is + begin + if Present (N) then + Remove_Handler_Entries (N); + Remove_Warning_Messages (N); + + -- Recurse into block statements to process declarations/statements + + if Nkind (N) = N_Block_Statement then + Kill_Dead_Code (Declarations (N)); + Kill_Dead_Code (Statements (Handled_Statement_Sequence (N))); + + -- Recurse into composite statement to kill individual statements, + -- in particular instantiations. + + elsif Nkind (N) = N_If_Statement then + Kill_Dead_Code (Then_Statements (N)); + Kill_Dead_Code (Elsif_Parts (N)); + Kill_Dead_Code (Else_Statements (N)); + + elsif Nkind (N) = N_Loop_Statement then + Kill_Dead_Code (Statements (N)); + + elsif Nkind (N) = N_Case_Statement then + declare + Alt : Node_Id := First (Alternatives (N)); + + begin + while Present (Alt) loop + Kill_Dead_Code (Statements (Alt)); + Next (Alt); + end loop; + end; + + -- Deal with dead instances caused by deleting instantiations + + elsif Nkind (N) in N_Generic_Instantiation then + Remove_Dead_Instance (N); + end if; + + Delete_Tree (N); + end if; + end Kill_Dead_Code; + + -- Case where argument is a list of nodes to be killed + + procedure Kill_Dead_Code (L : List_Id) is + N : Node_Id; + + begin + if Is_Non_Empty_List (L) then + loop + N := Remove_Head (L); + exit when No (N); + Kill_Dead_Code (N); + end loop; + end if; + end Kill_Dead_Code; + + ------------------------ + -- Known_Non_Negative -- + ------------------------ + + function Known_Non_Negative (Opnd : Node_Id) return Boolean is + begin + if Is_OK_Static_Expression (Opnd) + and then Expr_Value (Opnd) >= 0 + then + return True; + + else + declare + Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd)); + + begin + return + Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0; + end; + end if; + end Known_Non_Negative; + + ----------------------------- + -- Make_CW_Equivalent_Type -- + ----------------------------- + + -- Create a record type used as an equivalent of any member + -- of the class which takes its size from exp. + + -- Generate the following code: + + -- type Equiv_T is record + -- _parent : T (List of discriminant constaints taken from Exp); + -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'size) / Storage_Unit); + -- end Equiv_T; + + function Make_CW_Equivalent_Type + (T : Entity_Id; + E : Node_Id) + return Entity_Id + is + Loc : constant Source_Ptr := Sloc (E); + Root_Typ : constant Entity_Id := Root_Type (T); + Equiv_Type : Entity_Id; + Range_Type : Entity_Id; + Str_Type : Entity_Id; + List_Def : List_Id := Empty_List; + Constr_Root : Entity_Id; + Sizexpr : Node_Id; + + begin + if not Has_Discriminants (Root_Typ) then + Constr_Root := Root_Typ; + else + Constr_Root := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + -- subtype cstr__n is T (List of discr constraints taken from Exp) + + Append_To (List_Def, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Constr_Root, + Subtype_Indication => + Make_Subtype_From_Expr (E, Root_Typ))); + end if; + + -- subtype rg__xx is Storage_Offset range + -- (Expr'size - typ'size) / Storage_Unit + + Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); + + Sizexpr := + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => OK_Convert_To (T, Duplicate_Subexpr (E)), + Attribute_Name => Name_Size), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Constr_Root, Loc), + Attribute_Name => Name_Size)); + + Set_Paren_Count (Sizexpr, 1); + + Append_To (List_Def, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Range_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc), + Constraint => Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Op_Divide (Loc, + Left_Opnd => Sizexpr, + Right_Opnd => Make_Integer_Literal (Loc, + Intval => System_Storage_Unit))))))); + + -- subtype str__nn is Storage_Array (rg__x); + + Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Append_To (List_Def, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Str_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (New_Reference_To (Range_Type, Loc)))))); + + -- type Equiv_T is record + -- _parent : Tnn; + -- E : Str_Type; + -- end Equiv_T; + + Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + -- Avoid the generation of an init procedure + + Set_Is_Frozen (Equiv_Type); + + Set_Ekind (Equiv_Type, E_Record_Type); + Set_Parent_Subtype (Equiv_Type, Constr_Root); + + Append_To (List_Def, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Equiv_Type, + + Type_Definition => + Make_Record_Definition (Loc, + Component_List => Make_Component_List (Loc, + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uParent), + Subtype_Indication => New_Reference_To (Constr_Root, Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('C')), + Subtype_Indication => New_Reference_To (Str_Type, Loc))), + Variant_Part => Empty)))); + + Insert_Actions (E, List_Def); + return Equiv_Type; + end Make_CW_Equivalent_Type; + + ------------------------ + -- Make_Literal_Range -- + ------------------------ + + function Make_Literal_Range + (Loc : Source_Ptr; + Literal_Typ : Entity_Id; + Index_Typ : Entity_Id) + return Node_Id + is + begin + return + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Typ, Loc), + Attribute_Name => Name_First), + + High_Bound => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Typ, Loc), + Attribute_Name => Name_First), + Right_Opnd => Make_Integer_Literal (Loc, + String_Literal_Length (Literal_Typ))), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + end Make_Literal_Range; + + ---------------------------- + -- Make_Subtype_From_Expr -- + ---------------------------- + + -- 1. If Expr is an uncontrained array expression, creates + -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n)) + + -- 2. If Expr is a unconstrained discriminated type expression, creates + -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) + + -- 3. If Expr is class-wide, creates an implicit class wide subtype + + function Make_Subtype_From_Expr + (E : Node_Id; + Unc_Typ : Entity_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (E); + List_Constr : List_Id := New_List; + D : Entity_Id; + + Full_Subtyp : Entity_Id; + Priv_Subtyp : Entity_Id; + Utyp : Entity_Id; + Full_Exp : Node_Id; + + begin + if Is_Private_Type (Unc_Typ) + and then Has_Unknown_Discriminants (Unc_Typ) + then + -- Prepare the subtype completion + + Utyp := Underlying_Type (Unc_Typ); + Full_Subtyp := Make_Defining_Identifier (Loc, + New_Internal_Name ('C')); + Full_Exp := Unchecked_Convert_To (Utyp, Duplicate_Subexpr (E)); + Set_Parent (Full_Exp, Parent (E)); + + Priv_Subtyp := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Insert_Action (E, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Full_Subtyp, + Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp))); + + -- Define the dummy private subtype + + Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ))); + Set_Etype (Priv_Subtyp, Unc_Typ); + Set_Scope (Priv_Subtyp, Full_Subtyp); + Set_Is_Constrained (Priv_Subtyp); + Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ)); + Set_Is_Itype (Priv_Subtyp); + Set_Associated_Node_For_Itype (Priv_Subtyp, E); + + if Is_Tagged_Type (Priv_Subtyp) then + Set_Class_Wide_Type + (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ)); + Set_Primitive_Operations (Priv_Subtyp, + Primitive_Operations (Unc_Typ)); + end if; + + Set_Full_View (Priv_Subtyp, Full_Subtyp); + + return New_Reference_To (Priv_Subtyp, Loc); + + elsif Is_Array_Type (Unc_Typ) then + for J in 1 .. Number_Dimensions (Unc_Typ) loop + Append_To (List_Constr, + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (E), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (E), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))))); + end loop; + + elsif Is_Class_Wide_Type (Unc_Typ) then + declare + CW_Subtype : Entity_Id; + EQ_Typ : Entity_Id := Empty; + + begin + -- A class-wide equivalent type is not needed when Java_VM + -- because the JVM back end handles the class-wide object + -- intialization itself (and doesn't need or want the + -- additional intermediate type to handle the assignment). + + if Expander_Active and then not Java_VM then + EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); + end if; + + CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E); + Set_Equivalent_Type (CW_Subtype, EQ_Typ); + Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ)); + + return New_Occurrence_Of (CW_Subtype, Loc); + end; + + else + D := First_Discriminant (Unc_Typ); + while (Present (D)) loop + + Append_To (List_Constr, + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (E), + Selector_Name => New_Reference_To (D, Loc))); + + Next_Discriminant (D); + end loop; + end if; + + return + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Unc_Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => List_Constr)); + end Make_Subtype_From_Expr; + + ----------------------------- + -- May_Generate_Large_Temp -- + ----------------------------- + + -- At the current time, the only types that we return False for (i.e. + -- where we decide we know they cannot generate large temps) are ones + -- where we know the size is 128 bits or less at compile time, and we + -- are still not doing a thorough job on arrays and records ??? + + function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is + begin + if not Stack_Checking_Enabled then + return False; + + elsif not Size_Known_At_Compile_Time (Typ) then + return False; + + elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then + return False; + + elsif Is_Array_Type (Typ) + and then Present (Packed_Array_Type (Typ)) + then + return May_Generate_Large_Temp (Packed_Array_Type (Typ)); + + -- We could do more here to find other small types ??? + + else + return True; + end if; + end May_Generate_Large_Temp; + + --------------------- + -- Must_Be_Aligned -- + --------------------- + + function Must_Be_Aligned (Obj : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Obj); + + begin + -- If object is strictly aligned, we can quit now + + if Strict_Alignment (Typ) then + return True; + + -- Case of subscripted array reference + + elsif Nkind (Obj) = N_Indexed_Component then + + -- If we have a pointer to an array, then this is definitely + -- aligned, because pointers always point to aligned versions. + + if Is_Access_Type (Etype (Prefix (Obj))) then + return True; + + -- Otherwise, go look at the prefix + + else + return Must_Be_Aligned (Prefix (Obj)); + end if; + + -- Case of record field + + elsif Nkind (Obj) = N_Selected_Component then + + -- What is significant here is whether the record type is packed + + if Is_Record_Type (Etype (Prefix (Obj))) + and then Is_Packed (Etype (Prefix (Obj))) + then + return False; + + -- Or the component has a component clause which might cause + -- the component to become unaligned (we can't tell if the + -- backend is doing alignment computations). + + elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then + return False; + + -- In all other cases, go look at prefix + + else + return Must_Be_Aligned (Prefix (Obj)); + end if; + + -- If not selected or indexed component, must be aligned + + else + return True; + end if; + end Must_Be_Aligned; + + ---------------------------- + -- New_Class_Wide_Subtype -- + ---------------------------- + + function New_Class_Wide_Subtype + (CW_Typ : Entity_Id; + N : Node_Id) + return Entity_Id + is + Res : Entity_Id := Create_Itype (E_Void, N); + Res_Name : constant Name_Id := Chars (Res); + Res_Scope : Entity_Id := Scope (Res); + + begin + Copy_Node (CW_Typ, Res); + Set_Sloc (Res, Sloc (N)); + Set_Is_Itype (Res); + Set_Associated_Node_For_Itype (Res, N); + Set_Is_Public (Res, False); -- By default, may be changed below. + Set_Public_Status (Res); + Set_Chars (Res, Res_Name); + Set_Scope (Res, Res_Scope); + Set_Ekind (Res, E_Class_Wide_Subtype); + Set_Next_Entity (Res, Empty); + Set_Etype (Res, Base_Type (CW_Typ)); + Set_Freeze_Node (Res, Empty); + return (Res); + end New_Class_Wide_Subtype; + + ------------------------- + -- Remove_Side_Effects -- + ------------------------- + + procedure Remove_Side_Effects + (Exp : Node_Id; + Name_Req : Boolean := False; + Variable_Ref : Boolean := False) + is + Loc : constant Source_Ptr := Sloc (Exp); + Exp_Type : constant Entity_Id := Etype (Exp); + Svg_Suppress : constant Suppress_Record := Scope_Suppress; + Def_Id : Entity_Id; + Ref_Type : Entity_Id; + Res : Node_Id; + Ptr_Typ_Decl : Node_Id; + New_Exp : Node_Id; + E : Node_Id; + + function Side_Effect_Free (N : Node_Id) return Boolean; + -- Determines if the tree N represents an expession that is known + -- not to have side effects, and for which no processing is required. + + function Side_Effect_Free (L : List_Id) return Boolean; + -- Determines if all elements of the list L are side effect free + + function Mutable_Dereference (N : Node_Id) return Boolean; + -- If a selected component involves an implicit dereference and + -- the type of the prefix is not an_access_to_constant, the node + -- must be evaluated because it may be affected by a subsequent + -- assignment. + + ------------------------- + -- Mutable_Dereference -- + ------------------------- + + function Mutable_Dereference (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Selected_Component + and then Is_Access_Type (Etype (Prefix (N))) + and then not Is_Access_Constant (Etype (Prefix (N))) + and then Variable_Ref; + end Mutable_Dereference; + + ---------------------- + -- Side_Effect_Free -- + ---------------------- + + function Side_Effect_Free (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + + begin + -- Note on checks that could raise Constraint_Error. Strictly, if + -- we take advantage of 11.6, these checks do not count as side + -- effects. However, we would just as soon consider that they are + -- side effects, since the backend CSE does not work very well on + -- expressions which can raise Constraint_Error. On the other + -- hand, if we do not consider them to be side effect free, then + -- we get some awkward expansions in -gnato mode, resulting in + -- code insertions at a point where we do not have a clear model + -- for performing the insertions. See 4908-002/comment for details. + + -- An attribute reference is side effect free if its expressions + -- are side effect free and its prefix is (could be a dereference + -- or an indexed retrieval for example). + + if K = N_Attribute_Reference then + return Side_Effect_Free (Expressions (N)) + and then (Is_Entity_Name (Prefix (N)) + or else Side_Effect_Free (Prefix (N))); + + -- An entity is side effect free unless it is a function call, or + -- a reference to a volatile variable and Name_Req is False. If + -- Name_Req is True then we can't help returning a name which + -- effectively allows multiple references in any case. + + elsif Is_Entity_Name (N) + and then Ekind (Entity (N)) /= E_Function + and then (not Is_Volatile (Entity (N)) or else Name_Req) + then + -- If the entity is a constant, it is definitely side effect + -- free. Note that the test of Is_Variable (N) below might + -- be expected to catch this case, but it does not, because + -- this test goes to the original tree, and we may have + -- already rewritten a variable node with a constant as + -- a result of an earlier Force_Evaluation call. + + if Ekind (Entity (N)) = E_Constant then + return True; + + -- If the Variable_Ref flag is set, any variable reference is + -- is considered a side-effect + + elsif Variable_Ref then + return not Is_Variable (N); + + else + return True; + end if; + + -- A value known at compile time is always side effect free + + elsif Compile_Time_Known_Value (N) then + return True; + + -- Literals are always side-effect free + + elsif (K = N_Integer_Literal + or else K = N_Real_Literal + or else K = N_Character_Literal + or else K = N_String_Literal + or else K = N_Null) + and then not Raises_Constraint_Error (N) + then + return True; + + -- A type conversion or qualification is side effect free if the + -- expression to be converted is side effect free. + + elsif K = N_Type_Conversion or else K = N_Qualified_Expression then + return Side_Effect_Free (Expression (N)); + + -- An unchecked type conversion is never side effect free since we + -- need to check whether it is safe. + -- effect free if its argument is side effect free. + + elsif K = N_Unchecked_Type_Conversion then + if Safe_Unchecked_Type_Conversion (N) then + return Side_Effect_Free (Expression (N)); + else + return False; + end if; + + -- A unary operator is side effect free if the operand + -- is side effect free. + + elsif K in N_Unary_Op then + return Side_Effect_Free (Right_Opnd (N)); + + -- A binary operator is side effect free if and both operands + -- are side effect free. + + elsif K in N_Binary_Op then + return Side_Effect_Free (Left_Opnd (N)) + and then Side_Effect_Free (Right_Opnd (N)); + + -- An explicit dereference or selected component is side effect + -- free if its prefix is side effect free. + + elsif K = N_Explicit_Dereference + or else K = N_Selected_Component + then + return Side_Effect_Free (Prefix (N)) + and then not Mutable_Dereference (Prefix (N)); + + -- An indexed component can be copied if the prefix is copyable + -- and all the indexing expressions are copyable and there is + -- no access check and no range checks. + + elsif K = N_Indexed_Component then + return Side_Effect_Free (Prefix (N)) + and then Side_Effect_Free (Expressions (N)); + + elsif K = N_Unchecked_Expression then + return Side_Effect_Free (Expression (N)); + + -- A call to _rep_to_pos is side effect free, since we generate + -- this pure function call ourselves. Moreover it is critically + -- important to make this exception, since otherwise we can + -- have discriminants in array components which don't look + -- side effect free in the case of an array whose index type + -- is an enumeration type with an enumeration rep clause. + + elsif K = N_Function_Call + and then Nkind (Name (N)) = N_Identifier + and then Chars (Name (N)) = Name_uRep_To_Pos + then + return True; + + -- We consider that anything else has side effects. This is a bit + -- crude, but we are pretty close for most common cases, and we + -- are certainly correct (i.e. we never return True when the + -- answer should be False). + + else + return False; + end if; + end Side_Effect_Free; + + function Side_Effect_Free (L : List_Id) return Boolean is + N : Node_Id; + + begin + if L = No_List or else L = Error_List then + return True; + + else + N := First (L); + + while Present (N) loop + if not Side_Effect_Free (N) then + return False; + else + Next (N); + end if; + end loop; + + return True; + end if; + end Side_Effect_Free; + + -- Start of processing for Remove_Side_Effects + + begin + -- If we are side effect free already or expansion is disabled, + -- there is nothing to do. + + if Side_Effect_Free (Exp) or else not Expander_Active then + return; + end if; + + -- All the must not have any checks + + Scope_Suppress := (others => True); + + -- If the expression has the form v.all then we can just capture + -- the pointer, and then do an explicit dereference on the result. + + if Nkind (Exp) = N_Explicit_Dereference then + Def_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Res := + Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc)); + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => + New_Reference_To (Etype (Prefix (Exp)), Loc), + Constant_Present => True, + Expression => Relocate_Node (Prefix (Exp)))); + + -- If this is a type conversion, leave the type conversion and remove + -- the side effects in the expression. This is important in several + -- circumstances: for change of representations, and also when this + -- is a view conversion to a smaller object, where gigi can end up + -- its own temporary of the wrong size. + -- ??? this transformation is inhibited for elementary types that are + -- not involved in a change of representation because it causes + -- regressions that are not fully understood yet. + + elsif Nkind (Exp) = N_Type_Conversion + and then (not Is_Elementary_Type (Underlying_Type (Exp_Type)) + or else Nkind (Parent (Exp)) = N_Assignment_Statement) + then + Remove_Side_Effects (Expression (Exp), Variable_Ref); + Scope_Suppress := Svg_Suppress; + return; + + -- For expressions that denote objects, we can use a renaming scheme. + -- We skip using this if we have a volatile variable and we do not + -- have Nam_Req set true (see comments above for Side_Effect_Free). + -- We also skip this scheme for class-wide expressions in order to + -- avoid recursive expension (see Expand_N_Object_Renaming_Declaration) + -- If the object is a function call, we need to create a temporary and + -- not a renaming. + + elsif Is_Object_Reference (Exp) + and then Nkind (Exp) /= N_Function_Call + and then not Variable_Ref + and then (Name_Req + or else not Is_Entity_Name (Exp) + or else not Is_Volatile (Entity (Exp))) + and then not Is_Class_Wide_Type (Exp_Type) + then + Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + if Nkind (Exp) = N_Selected_Component + and then Nkind (Prefix (Exp)) = N_Function_Call + and then Is_Array_Type (Etype (Exp)) + then + -- Avoid generating a variable-sized temporary, by generating + -- the renaming declaration just for the function call. The + -- transformation could be refined to apply only when the array + -- component is constrained by a discriminant??? + + Res := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Def_Id, Loc), + Selector_Name => Selector_Name (Exp)); + + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => + New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc), + Name => Relocate_Node (Prefix (Exp)))); + else + Res := New_Reference_To (Def_Id, Loc); + + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Reference_To (Exp_Type, Loc), + Name => Relocate_Node (Exp))); + end if; + + -- If it is a scalar type, just make a copy. + + elsif Is_Elementary_Type (Exp_Type) then + Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Set_Etype (Def_Id, Exp_Type); + Res := New_Reference_To (Def_Id, Loc); + + E := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Exp_Type, Loc), + Constant_Present => True, + Expression => Relocate_Node (Exp)); + + Set_Assignment_OK (E); + Insert_Action (Exp, E); + + -- If this is an unchecked conversion that Gigi can't handle, make + -- a copy or a use a renaming to capture the value. + + elsif (Nkind (Exp) = N_Unchecked_Type_Conversion + and then not Safe_Unchecked_Type_Conversion (Exp)) + then + if Controlled_Type (Etype (Exp)) then + -- Use a renaming to capture the expression, rather than create + -- a controlled temporary. + + Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Res := New_Reference_To (Def_Id, Loc); + + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Reference_To (Exp_Type, Loc), + Name => Relocate_Node (Exp))); + + else + Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Set_Etype (Def_Id, Exp_Type); + Res := New_Reference_To (Def_Id, Loc); + + E := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Exp_Type, Loc), + Constant_Present => True, + Expression => Relocate_Node (Exp)); + + Set_Assignment_OK (E); + Insert_Action (Exp, E); + end if; + + -- Otherwise we generate a reference to the value + + else + Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Ptr_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Exp_Type, Loc))); + + E := Exp; + Insert_Action (Exp, Ptr_Typ_Decl); + + Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Set_Etype (Def_Id, Exp_Type); + + Res := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Def_Id, Loc)); + + if Nkind (E) = N_Explicit_Dereference then + New_Exp := Relocate_Node (Prefix (E)); + else + E := Relocate_Node (E); + New_Exp := Make_Reference (Loc, E); + end if; + + if Nkind (E) = N_Aggregate and then Expansion_Delayed (E) then + Set_Expansion_Delayed (E, False); + Set_Analyzed (E, False); + end if; + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Ref_Type, Loc), + Expression => New_Exp)); + end if; + + -- Preserve the Assignment_OK flag in all copies, since at least + -- one copy may be used in a context where this flag must be set + -- (otherwise why would the flag be set in the first place). + + Set_Assignment_OK (Res, Assignment_OK (Exp)); + + -- Finally rewrite the original expression and we are done + + Rewrite (Exp, Res); + Analyze_And_Resolve (Exp, Exp_Type); + Scope_Suppress := Svg_Suppress; + end Remove_Side_Effects; + + ------------------------------------ + -- Safe_Unchecked_Type_Conversion -- + ------------------------------------ + + -- Note: this function knows quite a bit about the exact requirements + -- of Gigi with respect to unchecked type conversions, and its code + -- must be coordinated with any changes in Gigi in this area. + + -- The above requirements should be documented in Sinfo ??? + + function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is + Otyp : Entity_Id; + Ityp : Entity_Id; + Oalign : Uint; + Ialign : Uint; + Pexp : constant Node_Id := Parent (Exp); + + begin + -- If the expression is the RHS of an assignment or object declaration + -- we are always OK because there will always be a target. + + -- Object renaming declarations, (generated for view conversions of + -- actuals in inlined calls), like object declarations, provide an + -- explicit type, and are safe as well. + + if (Nkind (Pexp) = N_Assignment_Statement + and then Expression (Pexp) = Exp) + or else Nkind (Pexp) = N_Object_Declaration + or else Nkind (Pexp) = N_Object_Renaming_Declaration + then + return True; + + -- If the expression is the prefix of an N_Selected_Component + -- we should also be OK because GCC knows to look inside the + -- conversion except if the type is discriminated. We assume + -- that we are OK anyway if the type is not set yet or if it is + -- controlled since we can't afford to introduce a temporary in + -- this case. + + elsif Nkind (Pexp) = N_Selected_Component + and then Prefix (Pexp) = Exp + then + if No (Etype (Pexp)) then + return True; + else + return + not Has_Discriminants (Etype (Pexp)) + or else Is_Constrained (Etype (Pexp)); + end if; + end if; + + -- Set the output type, this comes from Etype if it is set, otherwise + -- we take it from the subtype mark, which we assume was already + -- fully analyzed. + + if Present (Etype (Exp)) then + Otyp := Etype (Exp); + else + Otyp := Entity (Subtype_Mark (Exp)); + end if; + + -- The input type always comes from the expression, and we assume + -- this is indeed always analyzed, so we can simply get the Etype. + + Ityp := Etype (Expression (Exp)); + + -- Initialize alignments to unknown so far + + Oalign := No_Uint; + Ialign := No_Uint; + + -- Replace a concurrent type by its corresponding record type + -- and each type by its underlying type and do the tests on those. + -- The original type may be a private type whose completion is a + -- concurrent type, so find the underlying type first. + + if Present (Underlying_Type (Otyp)) then + Otyp := Underlying_Type (Otyp); + end if; + + if Present (Underlying_Type (Ityp)) then + Ityp := Underlying_Type (Ityp); + end if; + + if Is_Concurrent_Type (Otyp) then + Otyp := Corresponding_Record_Type (Otyp); + end if; + + if Is_Concurrent_Type (Ityp) then + Ityp := Corresponding_Record_Type (Ityp); + end if; + + -- If the base types are the same, we know there is no problem since + -- this conversion will be a noop. + + if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then + return True; + + -- If the size of output type is known at compile time, there is + -- never a problem. Note that unconstrained records are considered + -- to be of known size, but we can't consider them that way here, + -- because we are talking about the actual size of the object. + + -- We also make sure that in addition to the size being known, we do + -- not have a case which might generate an embarrassingly large temp + -- in stack checking mode. + + elsif Size_Known_At_Compile_Time (Otyp) + and then not May_Generate_Large_Temp (Otyp) + and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp)) + then + return True; + + -- If either type is tagged, then we know the alignment is OK so + -- Gigi will be able to use pointer punning. + + elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then + return True; + + -- If either type is a limited record type, we cannot do a copy, so + -- say safe since there's nothing else we can do. + + elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then + return True; + + -- Conversions to and from packed array types are always ignored and + -- hence are safe. + + elsif Is_Packed_Array_Type (Otyp) + or else Is_Packed_Array_Type (Ityp) + then + return True; + end if; + + -- The only other cases known to be safe is if the input type's + -- alignment is known to be at least the maximum alignment for the + -- target or if both alignments are known and the output type's + -- alignment is no stricter than the input's. We can use the alignment + -- of the component type of an array if a type is an unpacked + -- array type. + + if Present (Alignment_Clause (Otyp)) then + Oalign := Expr_Value (Expression (Alignment_Clause (Otyp))); + + elsif Is_Array_Type (Otyp) + and then Present (Alignment_Clause (Component_Type (Otyp))) + then + Oalign := Expr_Value (Expression (Alignment_Clause + (Component_Type (Otyp)))); + end if; + + if Present (Alignment_Clause (Ityp)) then + Ialign := Expr_Value (Expression (Alignment_Clause (Ityp))); + + elsif Is_Array_Type (Ityp) + and then Present (Alignment_Clause (Component_Type (Ityp))) + then + Ialign := Expr_Value (Expression (Alignment_Clause + (Component_Type (Ityp)))); + end if; + + if Ialign /= No_Uint and then Ialign > Maximum_Alignment then + return True; + + elsif Ialign /= No_Uint and then Oalign /= No_Uint + and then Ialign <= Oalign + then + return True; + + -- Otherwise, Gigi cannot handle this and we must make a temporary. + + else + return False; + end if; + + end Safe_Unchecked_Type_Conversion; + + -------------------------- + -- Set_Elaboration_Flag -- + -------------------------- + + procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Asn : Node_Id; + + begin + if Present (Elaboration_Entity (Spec_Id)) then + + -- Nothing to do if at the compilation unit level, because in this + -- case the flag is set by the binder generated elaboration routine. + + if Nkind (Parent (N)) = N_Compilation_Unit then + null; + + -- Here we do need to generate an assignment statement + + else + Check_Restriction (No_Elaboration_Code, N); + Asn := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Elaboration_Entity (Spec_Id), Loc), + Expression => New_Occurrence_Of (Standard_True, Loc)); + + if Nkind (Parent (N)) = N_Subunit then + Insert_After (Corresponding_Stub (Parent (N)), Asn); + else + Insert_After (N, Asn); + end if; + + Analyze (Asn); + end if; + end if; + end Set_Elaboration_Flag; + + ---------------------------- + -- Wrap_Cleanup_Procedure -- + ---------------------------- + + procedure Wrap_Cleanup_Procedure (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stseq : constant Node_Id := Handled_Statement_Sequence (N); + Stmts : constant List_Id := Statements (Stseq); + + begin + if Abort_Allowed then + Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; + end Wrap_Cleanup_Procedure; + +end Exp_Util; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads new file mode 100644 index 00000000000..2af5b800a59 --- /dev/null +++ b/gcc/ada/exp_util.ads @@ -0,0 +1,432 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.112 $ +-- -- +-- Copyright (C) 1992-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). -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing utility procedures used throughout the expander + +with Snames; use Snames; +with Rtsfind; use Rtsfind; +with Types; use Types; + +package Exp_Util is + + ----------------------------------------------- + -- Handling of Actions Associated with Nodes -- + ----------------------------------------------- + + -- The evaluation of certain expression nodes involves the elaboration + -- of associated types and other declarations, and the execution of + -- statement sequences. Expansion routines generating such actions must + -- find an appropriate place in the tree to hang the actions so that + -- they will be evaluated at the appropriate point. + + -- Some cases are simple: + + -- For an expression occurring in a simple statement that is in a list + -- of statements, the actions are simply inserted into the list before + -- the associated statement. + + -- For an expression occurring in a declaration (declarations always + -- appear in lists), the actions are similarly inserted into the list + -- just before the associated declaration. + + -- The following special cases arise: + + -- For actions associated with the right operand of a short circuit + -- form, the actions are first stored in the short circuit form node + -- in the Actions field. The expansion of these forms subsequently + -- expands the short circuit forms into if statements which can then + -- be moved as described above. + + -- For actions appearing in the Condition expression of a while loop, + -- or an elsif clause, the actions are similarly temporarily stored in + -- in the node (N_Elsif_Part or N_Iteration_Scheme) associated with + -- the expression using the Condition_Actions field. Subsequently, the + -- expansion of these nodes rewrites the control structures involved to + -- reposition the actions in normal statement sequence. + + -- For actions appearing in the then or else expression of a conditional + -- expression, these actions are similarly placed in the node, using the + -- Then_Actions or Else_Actions field as appropriate. Once again the + -- expansion of the N_Conditional_Expression node rewrites the node so + -- that the actions can be normally positioned. + + -- Basically what we do is to climb up to the tree looking for the + -- proper insertion point, as described by one of the above cases, + -- and then insert the appropriate action or actions. + + -- Note if more than one insert call is made specifying the same + -- Assoc_Node, then the actions are elaborated in the order of the + -- calls, and this guarantee is preserved for the special cases above. + + procedure Insert_Action + (Assoc_Node : Node_Id; + Ins_Action : Node_Id); + -- Insert the action Ins_Action at the appropriate point as described + -- above. The action is analyzed using the default checks after it is + -- inserted. Assoc_Node is the node with which the action is associated. + + procedure Insert_Action + (Assoc_Node : Node_Id; + Ins_Action : Node_Id; + Suppress : Check_Id); + -- Insert the action Ins_Action at the appropriate point as described + -- above. The action is analyzed using the default checks as modified + -- by the given Suppress argument after it is inserted. Assoc_Node is + -- the node with which the action is associated. + + procedure Insert_Actions + (Assoc_Node : Node_Id; + Ins_Actions : List_Id); + -- Insert the list of action Ins_Actions at the appropriate point as + -- described above. The actions are analyzed using the default checks + -- after they are inserted. Assoc_Node is the node with which the actions + -- are associated. Ins_Actions may be No_List, in which case the call has + -- no effect. + + procedure Insert_Actions + (Assoc_Node : Node_Id; + Ins_Actions : List_Id; + Suppress : Check_Id); + -- Insert the list of action Ins_Actions at the appropriate point as + -- described above. The actions are analyzed using the default checks + -- as modified by the given Suppress argument after they are inserted. + -- Assoc_Node is the node with which the actions are associated. + -- Ins_Actions may be No_List, in which case the call has no effect. + + procedure Insert_Actions_After + (Assoc_Node : Node_Id; + Ins_Actions : List_Id); + -- Assoc_Node must be a node in a list. Same as Insert_Actions but + -- actions will be inserted after N in a manner that is compatible with + -- the transient scope mechanism. This procedure must be used instead + -- of Insert_List_After if Assoc_Node may be in a transient scope. + -- + -- Implementation limitation: Assoc_Node must be a statement. We can + -- generalize to expressions if there is a need but this is tricky to + -- implement because of short-ciruits (among other things).??? + + procedure Insert_Library_Level_Action (N : Node_Id); + -- This procedure inserts and analyzes the node N as an action at the + -- library level for the current unit (i.e. it is attached to the + -- Actions field of the N_Compilation_Aux node for the main unit). + + procedure Insert_Library_Level_Actions (L : List_Id); + -- Similar, but inserts a list of actions. + + ----------------------- + -- Other Subprograms -- + ----------------------- + + procedure Adjust_Condition (N : Node_Id); + -- The node N is an expression whose root-type is Boolean, and which + -- represents a boolean value used as a condition (i.e. a True/False + -- value). This routine handles the case of C and Fortran convention + -- boolean types, which have zero/non-zero semantics rather than the + -- normal 0/1 semantics, and also the case of an enumeration rep + -- clause that specifies a non-standard representation. On return, + -- node N always has the type Standard.Boolean, with a value that + -- is a standard Boolean values of 0/1 for False/True. This procedure + -- is used in two situations. First, the processing for a condition + -- field always calls Adjust_Condition, so that the boolean value + -- presented to the backend is a standard value. Second, for the + -- code for boolean operations such as AND, Adjust_Condition is + -- called on both operands, and then the operation is done in the + -- domain of Standard_Boolean, then Adjust_Result_Type is called + -- on the result to possibly reset the original type. This procedure + -- also takes care of validity checking if Validity_Checks = Tests. + + procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id); + -- The processing of boolean operations like AND uses the procedure + -- Adjust_Condition so that it can operate on Standard.Boolean, which + -- is the only boolean type on which the backend needs to be able to + -- implement such operators. This means that the result is also of + -- type Standard.Boolean. In general the type must be reset back to + -- the original type to get proper semantics, and that is the purpose + -- of this procedure. N is the node (of type Standard.Boolean), and + -- T is the desired type. As an optimization, this procedure leaves + -- the type as Standard.Boolean in contexts where this is permissible + -- (in particular for Condition fields, and for operands of other + -- logical operations higher up the tree). The call to this procedure + -- is completely ignored if the argument N is not of type Boolean. + + procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id); + -- Add a new freeze action for the given type. The freeze action is + -- attached to the freeze node for the type. Actions will be elaborated + -- in the order in which they are added. Note that the added node is not + -- analyzed. The analyze call is found in Sem_Ch13.Expand_N_Freeze_Entity. + + procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id); + -- Adds the given list of freeze actions (declarations or statements) + -- for the given type. The freeze actions are attached to the freeze + -- node for the type. Actions will be elaborated in the order in which + -- they are added, and the actions within the list will be elaborated in + -- list order. Note that the added nodes are not analyzed. The analyze + -- call is found in Sem_Ch13.Expand_N_Freeze_Entity. + + function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id; + -- Build an N_Procedure_Call_Statement calling the given runtime entity. + -- The call has no parameters. The first argument provides the location + -- information for the tree and for error messages. The call node is not + -- analyzed on return, the caller is responsible for analyzing it. + + function Build_Task_Image_Decls + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id) + return List_Id; + -- Build declaration for a variable that holds an identifying string + -- to be used as a task name. Id_Ref is an identifier if the task is + -- a variable, and a selected or indexed component if the task is a + -- component of an object. If it is an indexed component, A_Type is + -- the corresponding array type. Its index types are used to build the + -- string as an image of the index values. For composite types, the + -- result includes two declarations: one for a generated function that + -- computes the image without using concatenation, and one for the + -- variable that holds the result. + + procedure Convert_To_Actual_Subtype (Exp : Node_Id); + -- The Etype of an expression is the nominal type of the expression, + -- not the actual subtype. Often these are the same, but not always. + -- For example, a reference to a formal of unconstrained type has the + -- unconstrained type as its Etype, but the actual subtype is obtained + -- by applying the actual bounds. This routine is given an expression, + -- Exp, and (if necessary), replaces it using Rewrite, with a conversion + -- to the actual subtype, building the actual subtype if necessary. If + -- the expression is already of the requested type, then it is unchanged. + + function Current_Sem_Unit_Declarations return List_Id; + -- Return the a place where it is fine to insert declarations for the + -- current semantic unit. If the unit is a package body, return the + -- visible declarations of the corresponding spec. For RCI stubs, this + -- is necessary because the point at which they are generated may not + -- be the earliest point at which they are used. + + function Duplicate_Subexpr + (Exp : Node_Id; + Name_Req : Boolean := False) + return Node_Id; + -- Given the node for a subexpression, this function makes a logical + -- copy of the subexpression, and returns it. This is intended for use + -- when the expansion of an expression needs to repeat part of it. For + -- example, replacing a**2 by a*a requires two references to a which + -- may be a complex subexpression. Duplicate_Subexpression guarantees + -- not to duplicate side effects. If necessary, it generates actions + -- to save the expression value in a temporary, inserting these actions + -- into the tree using Insert_Actions with Exp as the insertion location. + -- The original expression and the returned result then become references + -- to this saved value. Exp must be analyzed on entry. On return, Exp + -- is analyzed, but the caller is responsible for analyzing the returned + -- copy after it is attached to the tree. The Name_Req flag is set to + -- ensure that the result is suitable for use in a context requiring a + -- name (e.g. the prefix of an attribute reference). + + procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id); + -- This procedure ensures that type referenced by Typ is defined. For the + -- case of a type other than an Itype, nothing needs to be done, since + -- all such types have declaration nodes. For Itypes, an N_Itype_Reference + -- node is generated and inserted at the given node N. This is typically + -- used to ensure that an Itype is properly defined outside a conditional + -- construct when it is referenced in more than one branch. + + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); + -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is + -- Empty, then simply returns Cond1 (this allows the use of Empty to + -- initialize a series of checks evolved by this routine, with a final + -- result of Empty indicating that no checks were required). The Sloc + -- field of the constructed N_And_Then node is copied from Cond1. + + procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id); + -- Rewrites Cond with the expression: Cond or else Cond1. If Cond is + -- Empty, then simply returns Cond1 (this allows the use of Empty to + -- initialize a series of checks evolved by this routine, with a final + -- result of Empty indicating that no checks were required). The Sloc + -- field of the constructed N_And_Then node is copied from Cond1. + + procedure Expand_Subtype_From_Expr + (N : Node_Id; + Unc_Type : Entity_Id; + Subtype_Indic : Node_Id; + Exp : Node_Id); + -- Build a constrained subtype from the initial value in object + -- declarations and/or allocations when the type is indefinite (including + -- class-wide). + + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; + -- Find the first primitive operation of type T whose name is 'Name'. + -- this function allows the use of a primitive operation which is not + -- directly visible + + procedure Force_Evaluation + (Exp : Node_Id; + Name_Req : Boolean := False); + -- Force the evaluation of the expression right away. Similar behavior + -- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to + -- say, it removes the side-effects and capture the values of the + -- variables. Remove_Side_effects guarantees that multiple evaluations + -- of the same expression won't generate multiple side effects, whereas + -- Force_Evaluation further guarantees that all evaluations will yield + -- the same result. + + procedure Generate_Poll_Call (N : Node_Id); + -- If polling is active, then a call to the Poll routine is built, + -- and then inserted before the given node N and analyzed. + + function Homonym_Number (Subp : Entity_Id) return Nat; + -- Here subp is the entity for a subprogram. This routine returns the + -- homonym number used to disambiguate overloaded subprograms in the + -- same scope (the number is used as part of constructed names to make + -- sure that they are unique). The number is the ordinal position on + -- the Homonym chain, counting only entries in the curren scope. If + -- an entity is not overloaded, the returned number will be one. + + function Inside_Init_Proc return Boolean; + -- Returns True if current scope is within an Init_Proc + + function In_Unconditional_Context (Node : Node_Id) return Boolean; + -- Node is the node for a statement or a component of a statement. + -- This function deteermines if the statement appears in a context + -- that is unconditionally executed, i.e. it is not within a loop + -- or a conditional or a case statement etc. + + function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean; + -- Determine whether the node P is a reference to a bit packed + -- array, i.e. whether the designated object is a component of + -- a bit packed array, or a subcomponent of such a component. + -- If so, then all subscripts in P are evaluated with a call + -- to Force_Evaluation, and True is returned. Otherwise False + -- is returned, and P is not affected. + + function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean; + -- Determine whether the node P is a reference to a bit packed + -- slice, i.e. whether the designated object is bit packed slice + -- or a component of a bit packed slice. Return True if so. + + function Is_Renamed_Object (N : Node_Id) return Boolean; + -- Returns True if the node N is a renamed object. An expression + -- is considered to be a renamed object if either it is the Name + -- of an object renaming declaration, or is the prefix of a name + -- which is a renamed object. For example, in: + -- + -- x : r renames a (1 .. 2) (1); + -- + -- We consider that a (1 .. 2) is a renamed object since it is the + -- prefix of the name in the renaming declaration. + + function Is_Untagged_Derivation (T : Entity_Id) return Boolean; + -- Returns true if type T is not tagged and is a derived type, + -- or is a private type whose completion is such a type. + + procedure Kill_Dead_Code (N : Node_Id); + -- N represents a node for a section of code that is known to be + -- dead. The node is deleted, and any exception handler references + -- and warning messages relating to this code are removed. + + procedure Kill_Dead_Code (L : List_Id); + -- Like the above procedure, but applies to every element in the given + -- list. Each of the entries is removed from the list before killing it. + + function Known_Non_Negative (Opnd : Node_Id) return Boolean; + -- Given a node for a subexpression, determines if it represents a value + -- that cannot possibly be negative, and if so returns True. A value of + -- False means that it is not known if the value is positive or negative. + + function Make_Subtype_From_Expr + (E : Node_Id; + Unc_Typ : Entity_Id) + return Node_Id; + -- Returns a subtype indication corresponding to the actual type of an + -- expresion E. Unc_Typ is an unconstrained array or record, or + -- a classwide type. + + function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean; + -- Determines if the given type, Typ, may require a large temporary + -- of the type that causes trouble if stack checking is enabled. The + -- result is True only if stack checking is enabled and the size of + -- the type is known at compile time and large, where large is defined + -- hueristically by the body of this routine. The purpose of this + -- routine is to help avoid generating troublesome temporaries that + -- intefere with the stack checking mechanism. + + function Must_Be_Aligned (Obj : Node_Id) return Boolean; + -- Given an object reference, determines whether or not the object + -- is required to be aligned according to its type'alignment value. + -- Normally, objects are required to be aligned, and the result will + -- be True. The situation in which this is not the case is if the + -- object reference involves a component of a packed array, where + -- the type of the component is not required to have strict alignment. + -- In this case, false will be returned. + + procedure Remove_Side_Effects + (Exp : Node_Id; + Name_Req : Boolean := False; + Variable_Ref : Boolean := False); + -- Given the node for a subexpression, this function replaces the node + -- if necessary by an equivalent subexpression that is guaranteed to be + -- side effect free. This is done by extracting any actions that could + -- cause side effects, and inserting them using Insert_Actions into the + -- tree to which Exp is attached. Exp must be analayzed and resolved + -- before the call and is analyzed and resolved on return. The Name_Req + -- may only be set to True if Exp has the form of a name, and the + -- effect is to guarantee that any replacement maintains the form of a + -- name. If Variable_Ref is set to TRUE, a variable is considered as a + -- side effect (used in implementing Force_Evaluation). Note: after a + -- call to Remove_Side_Effects, it is safe to use a call to + -- New_Copy_Tree to obtain a copy of the resulting expression. + + function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean; + -- Given the node for an N_Unchecked_Type_Conversion, return True + -- if this is an unchecked conversion that Gigi can handle directly. + -- Otherwise return False if it is one for which the front end must + -- provide a temporary. Note that the node need not be analyzed, and + -- thus the Etype field may not be set, but in that case it must be + -- the case that the Subtype_Mark field of the node is set/analyzed. + + procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id); + -- N is the node for a subprogram or generic body, and Spec_Id + -- is the entity for the corresponding spec. If an elaboration + -- entity is defined, then this procedure generates an assignment + -- statement to set it True, immediately after the body is elaborated. + -- However, no assignment is generated in the case of library level + -- procedures, since the setting of the flag in this case is generated + -- in the binder. We do that so that we can detect cases where this is + -- the only elaboration action that is required. + + procedure Wrap_Cleanup_Procedure (N : Node_Id); + -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer + -- call at the start of the statement sequence, and an Abort_Undefer call + -- at the end of the statement sequence. All cleanup routines (i.e. those + -- that are called from "at end" handlers) must defer abort on entry and + -- undefer abort on exit. Note that it is assumed that the code for the + -- procedure does not contain any return statements which would allow the + -- flow of control to escape doing the undefer call. + +private + pragma Inline (Force_Evaluation); + pragma Inline (Duplicate_Subexpr); + +end Exp_Util; diff --git a/gcc/ada/exp_vfpt.adb b/gcc/ada/exp_vfpt.adb new file mode 100644 index 00000000000..0d4c74a6104 --- /dev/null +++ b/gcc/ada/exp_vfpt.adb @@ -0,0 +1,507 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ V F P T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ -- +-- -- +-- Copyright (C) 1997-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 Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sem_Res; use Sem_Res; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypef; use Ttypef; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_VFpt is + + ---------------------- + -- Expand_Vax_Arith -- + ---------------------- + + procedure Expand_Vax_Arith (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Typc : Character; + Atyp : Entity_Id; + Func : RE_Id; + Args : List_Id; + + begin + -- Get arithmetic type, note that we do D stuff in G + + if Digits_Value (Typ) = VAXFF_Digits then + Typc := 'F'; + Atyp := RTE (RE_F); + else + Typc := 'G'; + Atyp := RTE (RE_G); + end if; + + case Nkind (N) is + + when N_Op_Abs => + if Typc = 'F' then + Func := RE_Abs_F; + else + Func := RE_Abs_G; + end if; + + when N_Op_Add => + if Typc = 'F' then + Func := RE_Add_F; + else + Func := RE_Add_G; + end if; + + when N_Op_Divide => + if Typc = 'F' then + Func := RE_Div_F; + else + Func := RE_Div_G; + end if; + + when N_Op_Multiply => + if Typc = 'F' then + Func := RE_Mul_F; + else + Func := RE_Mul_G; + end if; + + when N_Op_Minus => + if Typc = 'F' then + Func := RE_Neg_F; + else + Func := RE_Neg_G; + end if; + + when N_Op_Subtract => + if Typc = 'F' then + Func := RE_Sub_F; + else + Func := RE_Sub_G; + end if; + + when others => + Func := RE_Null; + raise Program_Error; + + end case; + + Args := New_List; + + if Nkind (N) in N_Binary_Op then + Append_To (Args, + Convert_To (Atyp, Left_Opnd (N))); + end if; + + Append_To (Args, + Convert_To (Atyp, Right_Opnd (N))); + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Vax_Arith; + + --------------------------- + -- Expand_Vax_Comparison -- + --------------------------- + + procedure Expand_Vax_Comparison (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N))); + Typc : Character; + Func : RE_Id; + Atyp : Entity_Id; + Revrs : Boolean := False; + Args : List_Id; + + begin + -- Get arithmetic type, note that we do D stuff in G + + if Digits_Value (Typ) = VAXFF_Digits then + Typc := 'F'; + Atyp := RTE (RE_F); + else + Typc := 'G'; + Atyp := RTE (RE_G); + end if; + + case Nkind (N) is + + when N_Op_Eq => + if Typc = 'F' then + Func := RE_Eq_F; + else + Func := RE_Eq_G; + end if; + + when N_Op_Ge => + if Typc = 'F' then + Func := RE_Le_F; + else + Func := RE_Le_G; + end if; + + Revrs := True; + + when N_Op_Gt => + if Typc = 'F' then + Func := RE_Lt_F; + else + Func := RE_Lt_G; + end if; + + Revrs := True; + + when N_Op_Le => + if Typc = 'F' then + Func := RE_Le_F; + else + Func := RE_Le_G; + end if; + + when N_Op_Lt => + if Typc = 'F' then + Func := RE_Lt_F; + else + Func := RE_Lt_G; + end if; + + when others => + Func := RE_Null; + raise Program_Error; + + end case; + + if not Revrs then + Args := New_List ( + Convert_To (Atyp, Left_Opnd (N)), + Convert_To (Atyp, Right_Opnd (N))); + + else + Args := New_List ( + Convert_To (Atyp, Right_Opnd (N)), + Convert_To (Atyp, Left_Opnd (N))); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args)); + + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end Expand_Vax_Comparison; + + --------------------------- + -- Expand_Vax_Conversion -- + --------------------------- + + procedure Expand_Vax_Conversion (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Expr : constant Node_Id := Expression (N); + S_Typ : constant Entity_Id := Base_Type (Etype (Expr)); + T_Typ : constant Entity_Id := Base_Type (Etype (N)); + + CallS : RE_Id; + CallT : RE_Id; + Func : RE_Id; + + function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; + -- Given one of the two types T, determines the coresponding call + -- type, i.e. the type to be used for the call (or the result of + -- the call). The actual operand is converted to (or from) this type. + -- Otyp is the other type, which is useful in figuring out the result. + -- The result returned is the RE_Id value for the type entity. + + function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id; + -- Find the predefined integer type that has the same size as the + -- fixed-point type T, for use in fixed/float conversions. + + --------------- + -- Call_Type -- + --------------- + + function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is + begin + -- Vax float formats + + if Vax_Float (T) then + if Digits_Value (T) = VAXFF_Digits then + return RE_F; + + elsif Digits_Value (T) = VAXGF_Digits then + return RE_G; + + -- For D_Float, leave it as D float if the other operand is + -- G_Float, since this is the one conversion that is properly + -- supported for D_Float, but otherwise, use G_Float. + + else pragma Assert (Digits_Value (T) = VAXDF_Digits); + + if Vax_Float (Otyp) + and then Digits_Value (Otyp) = VAXGF_Digits + then + return RE_D; + else + return RE_G; + end if; + end if; + + -- For all discrete types, use 64-bit integer + + elsif Is_Discrete_Type (T) then + return RE_Q; + + -- For all real types (other than Vax float format), we use the + -- IEEE float-type which corresponds in length to the other type + -- (which is Vax Float). + + else pragma Assert (Is_Real_Type (T)); + + if Digits_Value (Otyp) = VAXFF_Digits then + return RE_S; + else + return RE_T; + end if; + end if; + end Call_Type; + + function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is + begin + if Esize (T) = Esize (Standard_Long_Long_Integer) then + return Standard_Long_Long_Integer; + + elsif Esize (T) = Esize (Standard_Long_Integer) then + return Standard_Long_Integer; + + else + return Standard_Integer; + end if; + end Equivalent_Integer_Type; + + + -- Start of processing for Expand_Vax_Conversion; + + begin + -- If input and output are the same Vax type, we change the + -- conversion to be an unchecked conversion and that's it. + + if Vax_Float (S_Typ) and then Vax_Float (T_Typ) + and then Digits_Value (S_Typ) = Digits_Value (T_Typ) + then + Rewrite (N, + Unchecked_Convert_To (T_Typ, Expr)); + + + elsif Is_Fixed_Point_Type (S_Typ) then + + -- convert the scaled integer value to the target type, and multiply + -- by 'Small of type. + + Rewrite (N, + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (T_Typ, Loc), + Expression => + Unchecked_Convert_To ( + Equivalent_Integer_Type (S_Typ), Expr)), + Right_Opnd => + Make_Real_Literal (Loc, Realval => Small_Value (S_Typ)))); + + elsif Is_Fixed_Point_Type (T_Typ) then + + -- multiply value by 'small of type, and convert to the corresponding + -- integer type. + + Rewrite (N, + Unchecked_Convert_To (T_Typ, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc), + Expression => + Make_Op_Multiply (Loc, + Left_Opnd => Expr, + Right_Opnd => + Make_Real_Literal (Loc, + Realval => Ureal_1 / Small_Value (T_Typ)))))); + + -- All other cases. + + else + -- Compute types for call + + CallS := Call_Type (S_Typ, T_Typ); + CallT := Call_Type (T_Typ, S_Typ); + + -- Get function and its types + + if CallS = RE_D and then CallT = RE_G then + Func := RE_D_To_G; + + elsif CallS = RE_G and then CallT = RE_D then + Func := RE_G_To_D; + + elsif CallS = RE_G and then CallT = RE_F then + Func := RE_G_To_F; + + elsif CallS = RE_F and then CallT = RE_G then + Func := RE_F_To_G; + + elsif CallS = RE_F and then CallT = RE_S then + Func := RE_F_To_S; + + elsif CallS = RE_S and then CallT = RE_F then + Func := RE_S_To_F; + + elsif CallS = RE_G and then CallT = RE_T then + Func := RE_G_To_T; + + elsif CallS = RE_T and then CallT = RE_G then + Func := RE_T_To_G; + + elsif CallS = RE_F and then CallT = RE_Q then + Func := RE_F_To_Q; + + elsif CallS = RE_Q and then CallT = RE_F then + Func := RE_Q_To_F; + + elsif CallS = RE_G and then CallT = RE_Q then + Func := RE_G_To_Q; + + else pragma Assert (CallS = RE_Q and then CallT = RE_G); + Func := RE_Q_To_G; + end if; + + Rewrite (N, + Convert_To (T_Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => New_List ( + Convert_To (RTE (CallS), Expr))))); + end if; + + Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); + end Expand_Vax_Conversion; + + ----------------------------- + -- Expand_Vax_Real_Literal -- + ----------------------------- + + procedure Expand_Vax_Real_Literal (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Stat : constant Boolean := Is_Static_Expression (N); + Nod : Node_Id; + + RE_Source : RE_Id; + RE_Target : RE_Id; + RE_Fncall : RE_Id; + -- Entities for source, target and function call in conversion + + begin + -- We do not know how to convert Vax format real literals, so what + -- we do is to convert these to be IEEE literals, and introduce the + -- necessary conversion operation. + + if Vax_Float (Btyp) then + -- What we want to construct here is + + -- x!(y_to_z (1.0E0)) + + -- where + + -- x is the base type of the literal (Btyp) + + -- y_to_z is + + -- s_to_f for F_Float + -- t_to_g for G_Float + -- t_to_d for D_Float + + -- The literal is typed as S (for F_Float) or T otherwise + + -- We do all our own construction, analysis, and expansion here, + -- since things are at too low a level to use Analyze or Expand + -- to get this built (we get circularities and other strange + -- problems if we try!) + + if Digits_Value (Btyp) = VAXFF_Digits then + RE_Source := RE_S; + RE_Target := RE_F; + RE_Fncall := RE_S_To_F; + + elsif Digits_Value (Btyp) = VAXDF_Digits then + RE_Source := RE_T; + RE_Target := RE_D; + RE_Fncall := RE_T_To_D; + + else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits); + RE_Source := RE_T; + RE_Target := RE_G; + RE_Fncall := RE_T_To_G; + end if; + + Nod := Relocate_Node (N); + + Set_Etype (Nod, RTE (RE_Source)); + Set_Analyzed (Nod, True); + + Nod := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Fncall), Loc), + Parameter_Associations => New_List (Nod)); + + Set_Etype (Nod, RTE (RE_Target)); + Set_Analyzed (Nod, True); + + Nod := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Nod); + + Set_Etype (Nod, Typ); + Set_Analyzed (Nod, True); + Rewrite (N, Nod); + + -- This odd expression is still a static expression. Note that + -- the routine Sem_Eval.Expr_Value_R understands this. + + Set_Is_Static_Expression (N, Stat); + end if; + end Expand_Vax_Real_Literal; + +end Exp_VFpt; diff --git a/gcc/ada/exp_vfpt.ads b/gcc/ada/exp_vfpt.ads new file mode 100644 index 00000000000..8e3c95c0789 --- /dev/null +++ b/gcc/ada/exp_vfpt.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ V F P T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1997 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains specialized routines for handling the expansion +-- of arithmetic and conversion operations involving Vax format floating- +-- point formats as used on the Vax and the Alpha. + +with Types; use Types; + +package Exp_VFpt is + + procedure Expand_Vax_Arith (N : Node_Id); + -- The node N is an arithmetic node (N_Op_Abs, N_Op_Add, N_Op_Sub, + -- N_Op_Div, N_Op_Mul, N_Op_Minus where the operands are in Vax + -- float format. This procedure expands the necessary call. + + procedure Expand_Vax_Comparison (N : Node_Id); + -- The node N is an arithmetic comparison node where the types to + -- be compared are in Vax float format. This procedure expands the + -- necessary call. + + procedure Expand_Vax_Conversion (N : Node_Id); + -- The node N is a type conversion node where either the source or + -- the target type, or both, are Vax floating-point type. + + procedure Expand_Vax_Real_Literal (N : Node_Id); + -- The node N is a real literal node where the type is a Vax + -- floating-point type. This procedure rewrites the node to eliminate + -- the occurrence of such constants. + +end Exp_VFpt; diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb new file mode 100644 index 00000000000..7c48655ecc5 --- /dev/null +++ b/gcc/ada/expander.adb @@ -0,0 +1,492 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P A N D E R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.120 $ +-- -- +-- Copyright (C) 1992-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 Debug_A; use Debug_A; +with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; +with Exp_Attr; use Exp_Attr; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch5; use Exp_Ch5; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch8; use Exp_Ch8; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Ch12; use Exp_Ch12; +with Exp_Ch13; use Exp_Ch13; +with Exp_Prag; use Exp_Prag; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Table; + +package body Expander is + + ---------------- + -- Local Data -- + ---------------- + + -- The following table is used to save values of the Expander_Active + -- flag when they are saved by Expander_Mode_Save_And_Set. We use an + -- extendible table (which is a bit of overkill) because it is easier + -- than figuring out a maximum value or bothering with range checks! + + package Expander_Flags is new Table.Table ( + Table_Component_Type => Boolean, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 32, + Table_Increment => 200, + Table_Name => "Expander_Flags"); + + ------------ + -- Expand -- + ------------ + + procedure Expand (N : Node_Id) is + begin + -- If we were analyzing a default expression the Full_Analysis flag + -- must have be off. If we are in expansion mode then we must be + -- performing a full analysis. If we are analyzing a generic then + -- Expansion must be off. + + pragma Assert + (not (Full_Analysis and then In_Default_Expression) + and then (Full_Analysis or else not Expander_Active) + and then not (Inside_A_Generic and then Expander_Active)); + + -- There are three reasons for the Expander_Active flag to be false. + -- + -- The first is when are not generating code. In this mode the + -- Full_Analysis flag indicates whether we are performing a complete + -- analysis, in which case Full_Analysis = True or a pre-analysis in + -- which case Full_Analysis = False. See the spec of Sem for more + -- info on this. + -- + -- The second reason for the Expander_Active flag to be False is that + -- we are performing a pre-analysis. During pre-analysis all + -- expansion activity is turned off to make sure nodes are + -- semantically decorated but no extra nodes are generated. This is + -- for instance needed for the first pass of aggregate semantic + -- processing. Note that in this case the Full_Analysis flag is set + -- to False because the node will subsequently be re-analyzed with + -- expansion on (see the spec of sem). + + -- Finally, expansion is turned off in a regular compilation if there + -- are semantic errors. In that case there will be no further expansion, + -- but one cleanup action may be required: if a transient scope was + -- created (e.g. for a function that returns an unconstrained type) + -- the scope may still be on the stack, and must be removed explicitly, + -- given that the expansion actions that would normally process it will + -- not take place. This prevents cascaded errors due to stack mismatch. + + if not Expander_Active then + Set_Analyzed (N, Full_Analysis); + + if Errors_Detected > 0 + and then Scope_Is_Transient + then + Scope_Stack.Table + (Scope_Stack.Last).Actions_To_Be_Wrapped_Before := No_List; + Scope_Stack.Table + (Scope_Stack.Last).Actions_To_Be_Wrapped_After := No_List; + + Pop_Scope; + end if; + + return; + + else + + Debug_A_Entry ("expanding ", N); + + -- Processing depends on node kind. For full details on the expansion + -- activity required in each case, see bodies of corresponding + -- expand routines + + case Nkind (N) is + + when N_Abort_Statement => + Expand_N_Abort_Statement (N); + + when N_Accept_Statement => + Expand_N_Accept_Statement (N); + + when N_Aggregate => + Expand_N_Aggregate (N); + + when N_Allocator => + Expand_N_Allocator (N); + + when N_And_Then => + Expand_N_And_Then (N); + + when N_Assignment_Statement => + Expand_N_Assignment_Statement (N); + + when N_Asynchronous_Select => + Expand_N_Asynchronous_Select (N); + + when N_Attribute_Definition_Clause => + Expand_N_Attribute_Definition_Clause (N); + + when N_Attribute_Reference => + Expand_N_Attribute_Reference (N); + + when N_Block_Statement => + Expand_N_Block_Statement (N); + + when N_Case_Statement => + Expand_N_Case_Statement (N); + + when N_Conditional_Entry_Call => + Expand_N_Conditional_Entry_Call (N); + + when N_Conditional_Expression => + Expand_N_Conditional_Expression (N); + + when N_Delay_Relative_Statement => + Expand_N_Delay_Relative_Statement (N); + + when N_Delay_Until_Statement => + Expand_N_Delay_Until_Statement (N); + + when N_Entry_Body => + Expand_N_Entry_Body (N); + + when N_Entry_Call_Statement => + Expand_N_Entry_Call_Statement (N); + + when N_Entry_Declaration => + Expand_N_Entry_Declaration (N); + + when N_Exception_Declaration => + Expand_N_Exception_Declaration (N); + + when N_Exception_Renaming_Declaration => + Expand_N_Exception_Renaming_Declaration (N); + + when N_Exit_Statement => + Expand_N_Exit_Statement (N); + + when N_Expanded_Name => + Expand_N_Expanded_Name (N); + + when N_Explicit_Dereference => + Expand_N_Explicit_Dereference (N); + + when N_Extension_Aggregate => + Expand_N_Extension_Aggregate (N); + + when N_Freeze_Entity => + Expand_N_Freeze_Entity (N); + + when N_Full_Type_Declaration => + Expand_N_Full_Type_Declaration (N); + + when N_Function_Call => + Expand_N_Function_Call (N); + + when N_Generic_Instantiation => + Expand_N_Generic_Instantiation (N); + + when N_Goto_Statement => + Expand_N_Goto_Statement (N); + + when N_Handled_Sequence_Of_Statements => + Expand_N_Handled_Sequence_Of_Statements (N); + + when N_Identifier => + Expand_N_Identifier (N); + + when N_Indexed_Component => + Expand_N_Indexed_Component (N); + + when N_If_Statement => + Expand_N_If_Statement (N); + + when N_In => + Expand_N_In (N); + + when N_Loop_Statement => + Expand_N_Loop_Statement (N); + + when N_Not_In => + Expand_N_Not_In (N); + + when N_Null => + Expand_N_Null (N); + + when N_Object_Declaration => + Expand_N_Object_Declaration (N); + + when N_Object_Renaming_Declaration => + Expand_N_Object_Renaming_Declaration (N); + + when N_Op_Add => + Expand_N_Op_Add (N); + + when N_Op_Abs => + Expand_N_Op_Abs (N); + + when N_Op_And => + Expand_N_Op_And (N); + + when N_Op_Concat => + Expand_N_Op_Concat (N); + + when N_Op_Divide => + Expand_N_Op_Divide (N); + + when N_Op_Eq => + Expand_N_Op_Eq (N); + + when N_Op_Expon => + Expand_N_Op_Expon (N); + + when N_Op_Ge => + Expand_N_Op_Ge (N); + + when N_Op_Gt => + Expand_N_Op_Gt (N); + + when N_Op_Le => + Expand_N_Op_Le (N); + + when N_Op_Lt => + Expand_N_Op_Lt (N); + + when N_Op_Minus => + Expand_N_Op_Minus (N); + + when N_Op_Mod => + Expand_N_Op_Mod (N); + + when N_Op_Multiply => + Expand_N_Op_Multiply (N); + + when N_Op_Ne => + Expand_N_Op_Ne (N); + + when N_Op_Not => + Expand_N_Op_Not (N); + + when N_Op_Or => + Expand_N_Op_Or (N); + + when N_Op_Plus => + Expand_N_Op_Plus (N); + + when N_Op_Rem => + Expand_N_Op_Rem (N); + + when N_Op_Rotate_Left => + Expand_N_Op_Rotate_Left (N); + + when N_Op_Rotate_Right => + Expand_N_Op_Rotate_Right (N); + + when N_Op_Shift_Left => + Expand_N_Op_Shift_Left (N); + + when N_Op_Shift_Right => + Expand_N_Op_Shift_Right (N); + + when N_Op_Shift_Right_Arithmetic => + Expand_N_Op_Shift_Right_Arithmetic (N); + + when N_Op_Subtract => + Expand_N_Op_Subtract (N); + + when N_Op_Xor => + Expand_N_Op_Xor (N); + + when N_Or_Else => + Expand_N_Or_Else (N); + + when N_Package_Body => + Expand_N_Package_Body (N); + + when N_Package_Declaration => + Expand_N_Package_Declaration (N); + + when N_Package_Renaming_Declaration => + Expand_N_Package_Renaming_Declaration (N); + + when N_Pragma => + Expand_N_Pragma (N); + + when N_Procedure_Call_Statement => + Expand_N_Procedure_Call_Statement (N); + + when N_Protected_Type_Declaration => + Expand_N_Protected_Type_Declaration (N); + + when N_Protected_Body => + Expand_N_Protected_Body (N); + + when N_Qualified_Expression => + Expand_N_Qualified_Expression (N); + + when N_Raise_Statement => + Expand_N_Raise_Statement (N); + + when N_Raise_Constraint_Error => + Expand_N_Raise_Constraint_Error (N); + + when N_Raise_Program_Error => + Expand_N_Raise_Program_Error (N); + + when N_Raise_Storage_Error => + Expand_N_Raise_Storage_Error (N); + + when N_Real_Literal => + Expand_N_Real_Literal (N); + + when N_Record_Representation_Clause => + Expand_N_Record_Representation_Clause (N); + + when N_Requeue_Statement => + Expand_N_Requeue_Statement (N); + + when N_Return_Statement => + Expand_N_Return_Statement (N); + + when N_Selected_Component => + Expand_N_Selected_Component (N); + + when N_Selective_Accept => + Expand_N_Selective_Accept (N); + + when N_Single_Task_Declaration => + Expand_N_Single_Task_Declaration (N); + + when N_Slice => + Expand_N_Slice (N); + + when N_Subtype_Indication => + Expand_N_Subtype_Indication (N); + + when N_Subprogram_Body => + Expand_N_Subprogram_Body (N); + + when N_Subprogram_Body_Stub => + Expand_N_Subprogram_Body_Stub (N); + + when N_Subprogram_Declaration => + Expand_N_Subprogram_Declaration (N); + + when N_Subprogram_Info => + Expand_N_Subprogram_Info (N); + + when N_Task_Body => + Expand_N_Task_Body (N); + + when N_Task_Type_Declaration => + Expand_N_Task_Type_Declaration (N); + + when N_Timed_Entry_Call => + Expand_N_Timed_Entry_Call (N); + + when N_Type_Conversion => + Expand_N_Type_Conversion (N); + + when N_Unchecked_Expression => + Expand_N_Unchecked_Expression (N); + + when N_Unchecked_Type_Conversion => + Expand_N_Unchecked_Type_Conversion (N); + + when N_Variant_Part => + Expand_N_Variant_Part (N); + + -- For all other node kinds, no expansion activity is required + + when others => null; + + end case; + + -- Set result as analyzed and then do a possible transient wrap. The + -- transient wrap must be done after the Analyzed flag is set on, so + -- that we do not get a recursive attempt to expand the node N. + + Set_Analyzed (N); + + -- Deal with transient scopes + + if Scope_Is_Transient and then N = Node_To_Be_Wrapped then + + case Nkind (N) is + when N_Statement_Other_Than_Procedure_Call | + N_Procedure_Call_Statement => + Wrap_Transient_Statement (N); + + when N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Subtype_Declaration => + Wrap_Transient_Declaration (N); + + when others => Wrap_Transient_Expression (N); + end case; + end if; + + Debug_A_Exit ("expanding ", N, " (done)"); + end if; + end Expand; + + --------------------------- + -- Expander_Mode_Restore -- + --------------------------- + + procedure Expander_Mode_Restore is + begin + Expander_Active := Expander_Flags.Table (Expander_Flags.Last); + Expander_Flags.Decrement_Last; + + if Errors_Detected /= 0 then + Expander_Active := False; + end if; + end Expander_Mode_Restore; + + -------------------------------- + -- Expander_Mode_Save_And_Set -- + -------------------------------- + + procedure Expander_Mode_Save_And_Set (Status : Boolean) is + begin + Expander_Flags.Increment_Last; + Expander_Flags.Table (Expander_Flags.Last) := Expander_Active; + Expander_Active := Status; + end Expander_Mode_Save_And_Set; + +end Expander; diff --git a/gcc/ada/expander.ads b/gcc/ada/expander.ads new file mode 100644 index 00000000000..529fabaf28c --- /dev/null +++ b/gcc/ada/expander.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P A N D E R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure performs any required expansion for the specified node. +-- The argument is the node that is a candidate for possible expansion. +-- If no expansion is required, then Expand returns without doing anything. + +-- If the node does need expansion, then the subtree is replaced by the +-- tree corresponding to the required rewriting. This tree is a syntactic +-- tree, except that all Entity fields must be correctly set on all +-- direct names, since the expander presumably knows what it wants, and in +-- any case it doesn't work to have the semantic analyzer perform visibility +-- analysis on these trees (they may have references to non-visible runtime +-- routines etc.) There are a few exceptions to this rule in special cases, +-- but they must be documented clearly. + +-- Expand is called in two different situations: + +-- Nodes that are not subexpressions (Nkind not in N_Subexpr) + +-- In this case, Expand is called from the body of Sem, immediately +-- after completing semantic analysis by calling the corresponding +-- Analyze_N_xxx procedure. If expansion occurs, the given node must +-- be replaced with another node that is also not a subexpression. +-- This seems naturally to be the case, since it is hard to imagine any +-- situation in which it would make sense to replace a non-expression +-- subtree with an expression. Once the substitution is completed, the +-- Expand routine must call Analyze on the resulting node to do any +-- required semantic analysis. Note that references to children copied +-- from the old tree won't be reanalyzed, since their Analyze flag is set. + +-- Nodes that are subexpressions (Nkind in N_Subexpr) + +-- In this case, Expand is called from Sem_Res.Resolve after completing +-- the resolution of the subexpression (this means that the expander sees +-- the fully typed subtree). If expansion occurs, the given node must be +-- replaced by a node that is also a subexpression. Again it is hard +-- to see how this restriction could possibly be violated. Once the +-- substitution is completed, the Expand routine must first call Analyze +-- on the resulting node to do any required semantic analysis, and then +-- call Resolve on the node to set the type (typically the type will be +-- the same as the original type of the input node, but this is not +-- always the case). + +-- In both these cases, Replace or Rewrite must be used to achieve the +-- of the node, since the Expander routine is only passed the Node_Id +-- of the node to be expanded, and the resulting expanded Node_Id must +-- be the same (the parameter to Expand is mode in, not mode in-out). + +-- For nodes other than subexpressions, it is not necessary to preserve the +-- original tree in the Expand routines, unlike the case for modifications +-- to the tree made in the semantic analyzer. This is because anyone who is +-- interested in working with the original tree (like ASIS) is required to +-- compile in semantics checks only mode. Thus Replace may be freely used +-- in such instances. + +-- For subexpressions, preservation of the original tree is required because +-- of the need for conformance checking of default expressions, which occurs +-- on expanded trees. This means that Replace should not ever be used on +-- on subexpression nodes. Instead use Rewrite. + +-- Note: the front end avoids calls to any of the expand routines if code +-- is not being generated. This is done for three reasons: + +-- 1. Make sure tree does not get mucked up by the expander if no +-- code is being generated, and is thus usable by ASIS etc. + +-- 2. Save time, since expansion is not needed if a compilation is +-- being done only to check the semantics, or if code generation +-- has been canceled due to previously detected errors. + +-- 3. Allow the expand routines to assume that the tree is error free. +-- This results from the fact that code generation mode is always +-- cancelled when any error occurs. + +-- If we ever decide to implement a feature allowing object modules to be +-- generated even if errors have been detected, then point 3 will no longer +-- hold, and the expand routines will have to be modified to operate properly +-- in the presence of errors (for many reasons this is not currently true). + +-- Note: a consequence of this approach is that error messages must never +-- be generated in the expander, since this would mean that such error +-- messages are not generated when the expander is not being called. + +-- Expansion is the last stage of analyzing a node, so Expand sets the +-- Analyzed flag of the node being analyzed as its last action. This is +-- done even if expansion is off (in this case, the only effect of the +-- call to Expand is to set the Analyzed flag to True). + +with Types; use Types; + +package Expander is + + -- The flag Opt.Expander_Active controls whether expansion is active + -- (True) or deactivated (False). When expansion is deactivated all + -- calls to expander routines have no effect. To temporarily disable + -- expansion, always call the routines defined below, do NOT change + -- Expander_Active directly. + -- + -- You should not use this flag to test if you are currently processing + -- a generic spec or body. Use the flag Inside_A_Generic instead (see + -- the spec of package Sem). + -- + -- There is no good reason for permanently changing the value of this flag + -- except after detecting a syntactic or semantic error. In this event + -- this flag is set to False to disable all subsequent expansion activity. + -- + -- In general this flag should be used as a read only value. The only + -- exceptions where it makes sense to temporarily change its value are: + -- + -- (a) when starting/completing the processing of a generic definition + -- or declaration (see routines Start_Generic_Processing and + -- End_Generic_Processing in Sem_Ch12) + -- + -- (b) when starting/completing the pre-analysis of an expression + -- (see the spec of package Sem for more info on pre-analysis.) + -- + -- Note that when processing a default expression (In_Default_Expression + -- is True) or performing semantic analysis of a generic spec or body + -- (Inside_A_Generic) or when performing pre-analysis (Full_Analysis is + -- False) the Expander_Active flag is False. + + procedure Expand (N : Node_Id); + -- Expand node N, as described above + + procedure Expander_Mode_Save_And_Set (Status : Boolean); + -- Saves the current setting of the Expander_Active flag on an internal + -- stack and then sets the flag to the given value. + + procedure Expander_Mode_Restore; + -- Restores the setting of the Expander_Active flag using the top entry + -- pushed onto the stack by Expander_Mode_Save_And_Reset, popping the + -- stack, except that if any errors have been detected, then the state + -- of the flag is left set to False. + +end Expander; diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c new file mode 100644 index 00000000000..591401cf1dc --- /dev/null +++ b/gcc/ada/expect.c @@ -0,0 +1,240 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * E X P E C T * + * * + * C Implementation File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 2001 Ada Core Technologies, 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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#define POSIX +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +#endif + +/* This file provides the low level functionalities needed to implement Expect + capabilities in GNAT.Expect. + Implementations for unix and windows systems is provided. + Dummy stubs are also provided for other systems. */ + +#ifdef _AIX +/* Work around the fact that gcc/cpp does not define "unix" under AiX. */ +#define unix +#endif + +#ifdef _WIN32 + +#include <windows.h> +#include <process.h> + +/* ??? Provide a no-op for now */ + +void +kill () +{ +} + +int +__gnat_expect_fork () +{ + return 0; +} + +void +__gnat_expect_portable_execvp (cmd, argv) + char *cmd; + char *argv[]; +{ + (void) spawnve (_P_NOWAIT, cmd, argv, NULL); +} + +int +__gnat_pipe (fd) + int *fd; +{ + HANDLE read, write; + + CreatePipe (&read, &write, NULL, 0); + fd[0]=_open_osfhandle (read, 0); + fd[1]=_open_osfhandle (write, 0); + return 0; /* always success */ +} + +int +__gnat_expect_poll (fd, num_fd, timeout, is_set) + int *fd; + int num_fd; + int timeout; + int *is_set; +{ + int i, num; + DWORD avail; + HANDLE handles[num_fd]; + + for (i = 0; i < num_fd; i++) + is_set[i] = 0; + + for (i = 0; i < num_fd; i++) + handles[i] = (HANDLE) _get_osfhandle (fd [i]); + + num = timeout / 10; + + while (1) + { + for (i = 0; i < num_fd; i++) + { + if (!PeekNamedPipe (handles [i], NULL, 0, NULL, &avail, NULL)) + return -1; + + if (avail > 0) + { + is_set[i] = 1; + return 1; + } + } + + if (timeout >= 0 && num == 0) + return 0; + + Sleep (10); + num--; + } +} + +#elif defined (unix) + +#include <sys/time.h> + +#ifndef NO_FD_SET +#define SELECT_MASK fd_set +#else /* !NO_FD_SET */ +#ifndef _AIX +typedef long fd_mask; +#endif /* _AIX */ +#ifdef _IBMR2 +#define SELECT_MASK void +#else /* !_IBMR2 */ +#define SELECT_MASK int +#endif /* !_IBMR2 */ +#endif /* !NO_FD_SET */ + +int +__gnat_pipe (fd) + int *fd; +{ + return pipe (fd); +} + +int +__gnat_expect_fork () +{ + return fork (); +} + +void +__gnat_expect_portable_execvp (cmd, argv) + char *cmd; + char *argv[]; +{ + execvp (cmd, argv); +} + +int +__gnat_expect_poll (fd, num_fd, timeout, is_set) + int *fd; + int num_fd; + int timeout; + int *is_set; +{ + struct timeval tv; + SELECT_MASK rset; + int max_fd = 0; + int ready; + int i; + + FD_ZERO (&rset); + + for (i = 0; i < num_fd; i++) + { + FD_SET (fd [i], &rset); + if (fd [i] > max_fd) + max_fd = fd [i]; + } + + tv.tv_sec = timeout / 1000; + tv.tv_usec = (timeout % 1000) * 1000; + + ready = select (max_fd + 1, &rset, NULL, NULL, timeout == -1 ? NULL : &tv); + + if (ready > 0) + for (i = 0; i < num_fd; i++) + is_set [i] = (FD_ISSET (fd [i], &rset) ? 1 : 0); + + return ready; +} + +#else + +int +__gnat_pipe (fd) + int *fd; +{ + return -1; +} + +int +__gnat_expect_fork () +{ + return -1; +} + +void +__gnat_expect_portable_execvp (cmd, argv) + char *cmd; + char *argv[]; +{ +} + +int +__gnat_expect_poll (fd, num_fd, timeout, is_set) + int *fd; + int num_fd; + int timeout; + int *is_set; +{ + return -1; +} +#endif diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h new file mode 100644 index 00000000000..e21f0cf49b2 --- /dev/null +++ b/gcc/ada/fe.h @@ -0,0 +1,197 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * FE * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +/* This file contains definitions to access front-end functions and + variables used by gigi. */ + +/* atree: */ + +#define Is_Rewrite_Substitution atree__is_rewrite_substitution +#define Original_Node atree__original_node + +extern Boolean Is_Rewrite_Subsitution PARAMS ((Node_Id)); +extern Node_Id Original_Node PARAMS ((Node_Id)); + +/* comperr: */ + +#define Compiler_Abort comperr__compiler_abort +extern int Compiler_Abort PARAMS ((Fat_Pointer, int)) ATTRIBUTE_NORETURN; + +/* csets: Definitions to access the front-end's character translation + tables. */ + +#define Fold_Lower(C) csets__fold_lower[C] +#define Fold_Upper(C) csets__fold_upper[C] +extern char Fold_Lower[], Fold_Upper[]; + +/* debug: */ + +#define Debug_Flag_XX debug__debug_flag_xx +#define Debug_Flag_NN debug__debug_flag_nn + +extern Boolean Debug_Flag_XX; +extern Boolean Debug_Flag_NN; + +/* einfo: We will be setting Esize for types, Component_Bit_Offset for fields, + Alignment for types and objects, Component_Size for array types, and + Present_Expr for N_Variant nodes. */ + +#define Set_Alignment einfo__set_alignment +#define Set_Esize einfo__set_esize +#define Set_RM_Size einfo__set_rm_size +#define Set_Component_Bit_Offset einfo__set_component_bit_offset +#define Set_Component_Size einfo__set_component_size +#define Set_Present_Expr sinfo__set_present_expr + +extern void Set_Alignment PARAMS ((Entity_Id, Uint)); +extern void Set_Component_Size PARAMS ((Entity_Id, Uint)); +extern void Set_Esize PARAMS ((Entity_Id, Uint)); +extern void Set_RM_Size PARAMS ((Entity_Id, Uint)); +extern void Set_Component_Bit_Offset PARAMS ((Entity_Id, Uint)); +extern void Set_Present_Expr PARAMS ((Node_Id, Uint)); + +/* errout: */ + +#define Error_Msg_N errout__error_msg_n +#define Error_Msg_NE errout__error_msg_ne +#define Error_Msg_Node_2 errout__error_msg_node_2 +#define Error_Msg_Uint_1 errout__error_msg_uint_1 +#define Error_Msg_Uint_2 errout__error_msg_uint_2 + +extern void Error_Msg_N PARAMS ((Fat_Pointer, Node_Id)); +extern void Error_Msg_NE PARAMS ((Fat_Pointer, Node_Id, Entity_Id)); + +extern Entity_Id Error_Msg_Node_2; +extern Uint Error_Msg_Uint_1; +extern Uint Error_Msg_Uint_2; + +/* exp_code: */ +#define Asm_Input_Constraint exp_code__asm_input_constraint +#define Asm_Input_Value exp_code__asm_input_value +#define Asm_Output_Constraint exp_code__asm_output_constraint +#define Asm_Output_Variable exp_code__asm_output_variable +#define Asm_Template exp_code__asm_template +#define Clobber_Get_Next exp_code__clobber_get_next +#define Clobber_Setup exp_code__clobber_setup +#define Is_Asm_Volatile exp_code__is_asm_volatile +#define Next_Asm_Input exp_code__next_asm_input +#define Next_Asm_Output exp_code__next_asm_output +#define Setup_Asm_Inputs exp_code__setup_asm_inputs +#define Setup_Asm_Outputs exp_code__setup_asm_outputs + +extern Node_Id Asm_Input_Constraint PARAMS ((void)); +extern Node_Id Asm_Input_Value PARAMS ((void)); +extern Node_Id Asm_Output_Constraint PARAMS ((void)); +extern Node_Id Asm_Output_Variable PARAMS ((void)); +extern Node_Id Asm_Template PARAMS ((Node_Id)); +extern char *Clobber_Get_Next PARAMS ((void)); +extern void Clobber_Setup PARAMS ((Node_Id)); +extern Boolean Is_Asm_Volatile PARAMS ((Node_Id)); +extern void Next_Asm_Input PARAMS ((void)); +extern void Next_Asm_Output PARAMS ((void)); +extern void Setup_Asm_Inputs PARAMS ((Node_Id)); +extern void Setup_Asm_Outputs PARAMS ((Node_Id)); + +/* exp_dbug: */ + +#define Get_Encoded_Name exp_dbug__get_encoded_name +#define Get_External_Name_With_Suffix exp_dbug__get_external_name_with_suffix + +extern void Get_Encoded_Name PARAMS ((Entity_Id)); +extern void Get_External_Name_With_Suffix PARAMS ((Entity_Id, Fat_Pointer)); + +/* lib: */ + +#define Cunit lib__cunit +#define Ident_String lib__ident_string +#define In_Extended_Main_Code_Unit lib__in_extended_main_code_unit + +extern Node_Id Cunit PARAMS ((Unit_Number_Type)); +extern Node_Id Ident_String PARAMS ((Unit_Number_Type)); +extern Boolean In_Extended_Main_Code_Unit PARAMS ((Entity_Id)); + +/* opt: */ + +#define Global_Discard_Names opt__global_discard_names +extern Boolean Global_Discard_Names; + +/* restrict: */ + +#define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed +#define No_Exception_Handlers_Set restrict__no_exception_handlers_set + +extern void Check_Elaboration_Code_Allowed PARAMS ((Node_Id)); +extern Boolean No_Exception_Handlers_Set PARAMS ((void)); + +/* sem_ch13: */ + +#define Get_Attribute_Definition_Clause \ + sem_ch13__get_attribute_definition_clause +extern Node_Id Get_Attribute_Definition_Clause PARAMS ((Entity_Id, char)); + +/* sem_eval: */ + +#define Compile_Time_Known_Value sem_eval__compile_time_known_value +#define Expr_Value sem_eval__expr_value +#define Expr_Value_S sem_eval__expr_value_s +#define Is_OK_Static_Expression sem_eval__is_ok_static_expression + +extern Uint Expr_Value PARAMS ((Node_Id)); +extern Node_Id Expr_Value_S PARAMS ((Node_Id)); +extern Boolean Compile_Time_Known_Value PARAMS((Node_Id)); +extern Boolean Is_OK_Static_Expression PARAMS((Node_Id)); + +/* sem_util: */ + +#define Defining_Entity sem_util__defining_entity +#define First_Actual sem_util__first_actual +#define Next_Actual sem_util__next_actual +#define Requires_Transient_Scope sem_util__requires_transient_scope + +extern Entity_Id Defining_Entity PARAMS ((Node_Id)); +extern Node_Id First_Actual PARAMS ((Node_Id)); +extern Node_Id Next_Actual PARAMS ((Node_Id)); +extern Boolean Requires_Transient_Scope PARAMS ((Entity_Id)); + +/* sinfo: These functions aren't in sinfo.h since we don't make the + setting functions, just the retrieval functions. */ +#define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code +extern void Set_Has_No_Elaboration_Code PARAMS ((Node_Id, Boolean)); + +/* targparm: */ + +#define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target + +extern Boolean Stack_Check_Probes_On_Target; + diff --git a/gcc/ada/final.c b/gcc/ada/final.c new file mode 100644 index 00000000000..f388b3fb69e --- /dev/null +++ b/gcc/ada/final.c @@ -0,0 +1,57 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * F I N A L * + * * + * $Revision: 1.1 $ + * * + * C Implementation File * + * * + * Copyright (C) 1992-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. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * 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). * + * * + ****************************************************************************/ + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +#endif + +#include "raise.h" + +/* This routine is called at the extreme end of execution of an Ada program + (the call is generated by the binder). The standard routine does nothing + at all, the intention is that this be replaced by system specific code + where finalization is required. */ + +void +__gnat_finalize () +{ +} diff --git a/gcc/ada/fname-sf.adb b/gcc/ada/fname-sf.adb new file mode 100644 index 00000000000..ddb0134ca73 --- /dev/null +++ b/gcc/ada/fname-sf.adb @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . S F -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1992-2000 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 Casing; use Casing; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with SFN_Scan; use SFN_Scan; +with Namet; use Namet; +with Osint; use Osint; +with Types; use Types; + +with Unchecked_Conversion; + +package body Fname.SF is + + subtype Big_String is String (Positive); + type Big_String_Ptr is access all Big_String; + + function To_Big_String_Ptr is new Unchecked_Conversion + (Source_Buffer_Ptr, Big_String_Ptr); + + ---------------------- + -- Local Procedures -- + ---------------------- + + procedure Set_File_Name (Typ : Character; U : String; F : String); + -- This is a transfer function that is called from Scan_SFN_Pragmas, + -- and reformats its parameters appropriately for the version of + -- Set_File_Name found in Fname.SF. + + procedure Set_File_Name_Pattern + (Pat : String; + Typ : Character; + Dot : String; + Cas : Character); + -- This is a transfer function that is called from Scan_SFN_Pragmas, + -- and reformats its parameters appropriately for the version of + -- Set_File_Name_Pattern found in Fname.SF. + + ----------------------------------- + -- Read_Source_File_Name_Pragmas -- + ----------------------------------- + + procedure Read_Source_File_Name_Pragmas is + Src : Source_Buffer_Ptr; + Hi : Source_Ptr; + BS : Big_String_Ptr; + SP : String_Ptr; + + begin + Name_Buffer (1 .. 8) := "gnat.adc"; + Name_Len := 8; + Read_Source_File (Name_Enter, 0, Hi, Src); + + if Src /= null then + BS := To_Big_String_Ptr (Src); + SP := BS (1 .. Natural (Hi))'Unrestricted_Access; + Scan_SFN_Pragmas + (SP.all, + Set_File_Name'Access, + Set_File_Name_Pattern'Access); + end if; + end Read_Source_File_Name_Pragmas; + + ------------------- + -- Set_File_Name -- + ------------------- + + procedure Set_File_Name (Typ : Character; U : String; F : String) is + Unm : Unit_Name_Type; + Fnm : File_Name_Type; + + begin + Name_Buffer (1 .. U'Length) := U; + Name_Len := U'Length; + Set_Casing (All_Lower_Case); + Name_Buffer (Name_Len + 1) := '%'; + Name_Buffer (Name_Len + 2) := Typ; + Name_Len := Name_Len + 2; + Unm := Name_Find; + Name_Buffer (1 .. F'Length) := F; + Name_Len := F'Length; + Fnm := Name_Find; + Fname.UF.Set_File_Name (Unm, Fnm); + end Set_File_Name; + + --------------------------- + -- Set_File_Name_Pattern -- + --------------------------- + + procedure Set_File_Name_Pattern + (Pat : String; + Typ : Character; + Dot : String; + Cas : Character) + is + Ctyp : Casing_Type; + Patp : constant String_Ptr := new String'(Pat); + Dotp : constant String_Ptr := new String'(Dot); + + begin + if Cas = 'l' then + Ctyp := All_Lower_Case; + elsif Cas = 'u' then + Ctyp := All_Upper_Case; + else -- Cas = 'm' + Ctyp := Mixed_Case; + end if; + + Fname.UF.Set_File_Name_Pattern (Patp, Typ, Dotp, Ctyp); + end Set_File_Name_Pattern; + +end Fname.SF; diff --git a/gcc/ada/fname-sf.ads b/gcc/ada/fname-sf.ads new file mode 100644 index 00000000000..c401045be8c --- /dev/null +++ b/gcc/ada/fname-sf.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . S F -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains a routine to read and process Source_File_Name +-- pragmas from the gnat.adc file in the current directory. In order to use +-- the routines in package Fname.UF, it is required that Source_File_Name +-- pragmas be processed. There are two places where such processing takes +-- place: + +-- The compiler front end (par-prag.adb), which is the general circuit +-- for processing all pragmas, including Source_File_Name. + +-- The stand alone routine in this unit, which is convenient to use +-- from tools that do not want to include the compiler front end. + +-- Note that this unit does depend on several of the compiler front-end +-- sources, including osint. If it is necesary to scan source file name +-- pragmas with less dependence on such sources, look at unit SFN_Scan. + +package Fname.SF is + + procedure Read_Source_File_Name_Pragmas; + -- This procedure is called to read the gnat.adc file and process any + -- Source_File_Name pragmas contained in this file. All other pragmas + -- are ignored. The result is appropriate calls to routines in the + -- package Fname.UF to register the pragmas so that subsequent calls + -- to Get_File_Name work correctly. + -- + -- Note: The caller must have made an appropriate call to the + -- Osint.Initialize routine to initialize Osint before calling + -- this procedure. + -- + -- If a syntax error is detected while scanning the gnat.adc file, + -- then the exception SFN_Scan.Syntax_Error_In_GNAT_ADC is raised + -- and SFN_Scan.Cursor contains the approximate index relative to + -- the start of the gnat.adc file of the error. + +end Fname.SF; diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb new file mode 100644 index 00000000000..ab6aaeb6b82 --- /dev/null +++ b/gcc/ada/fname-uf.adb @@ -0,0 +1,488 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . U F -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1992-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 Alloc; +with Debug; use Debug; +with Krunch; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Table; +with Widechar; use Widechar; + +with GNAT.HTable; + +package body Fname.UF is + + -------------------------------------------------------- + -- Declarations for Handling Source_File_Name pragmas -- + -------------------------------------------------------- + + type SFN_Entry is record + U : Unit_Name_Type; -- Unit name + F : File_Name_Type; -- Spec/Body file name + end record; + -- Record single Unit_Name type call to Set_File_Name + + package SFN_Table is new Table.Table ( + Table_Component_Type => SFN_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.SFN_Table_Initial, + Table_Increment => Alloc.SFN_Table_Increment, + Table_Name => "SFN_Table"); + -- Table recording all Unit_Name calls to Set_File_Name + + type SFN_Header_Num is range 0 .. 100; + + function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num; + -- Compute hash index for use by Simple_HTable + + No_Entry : constant Int := -1; + -- Signals no entry in following table + + package SFN_HTable is new GNAT.HTable.Simple_HTable ( + Header_Num => SFN_Header_Num, + Element => Int, + No_Element => No_Entry, + Key => Unit_Name_Type, + Hash => SFN_Hash, + Equal => "="); + -- Hash table allowing rapid access to SFN_Table, the element value + -- is an index into this table. + + type SFN_Pattern_Entry is record + Pat : String_Ptr; -- File name pattern (with asterisk in it) + Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit + Dot : String_Ptr; -- Dot_Separator string + Cas : Casing_Type; -- Upper/Lower/Mixed + end record; + -- Records single call to Set_File_Name_Patterm + + package SFN_Patterns is new Table.Table ( + Table_Component_Type => SFN_Pattern_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "SFN_Patterns"); + -- Table recording all calls to Set_File_Name_Pattern. Note that the + -- first two entries are set to represent the standard GNAT rules + -- for file naming. + + ----------------------- + -- File_Name_Of_Body -- + ----------------------- + + function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is + begin + Get_Name_String (Name); + Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b"; + Name_Len := Name_Len + 2; + return Get_File_Name (Name_Enter, Subunit => False); + end File_Name_Of_Body; + + ----------------------- + -- File_Name_Of_Spec -- + ----------------------- + + function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is + begin + Get_Name_String (Name); + Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s"; + Name_Len := Name_Len + 2; + return Get_File_Name (Name_Enter, Subunit => False); + end File_Name_Of_Spec; + + ------------------- + -- Get_File_Name -- + ------------------- + + function Get_File_Name + (Uname : Unit_Name_Type; + Subunit : Boolean) + return File_Name_Type + is + Unit_Char : Character; + -- Set to 's' or 'b' for spec or body or to 'u' for a subunit + + Unit_Char_Search : Character; + -- Same as Unit_Char, except that in the case of 'u' for a subunit, + -- we set Unit_Char_Search to 'b' if we do not find a subunit match. + + N : Int; + + begin + -- Null or error name means that some previous error occured + -- This is an unrecoverable error, so signal it. + + if Uname <= Error_Name then + raise Unrecoverable_Error; + end if; + + N := SFN_HTable.Get (Uname); + + if N /= No_Entry then + return SFN_Table.Table (N).F; + end if; + + -- Here for the case where the name was not found in the table + + Get_Decoded_Name_String (Uname); + + -- A special fudge, normally we don't have operator symbols present, + -- since it is always an error to do so. However, if we do, at this + -- stage it has a leading double quote. + + -- What we do in this case is to go back to the undecoded name, which + -- is of the form, for example: + + -- Oand%s + + -- and build a file name that looks like: + + -- _and_.ads + + -- which is bit peculiar, but we keep it that way. This means that + -- we avoid bombs due to writing a bad file name, and w get expected + -- error processing downstream, e.g. a compilation following gnatchop. + + if Name_Buffer (1) = '"' then + Get_Name_String (Uname); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1); + Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2); + Name_Buffer (Name_Len - 2) := '_'; + Name_Buffer (1) := '_'; + end if; + + -- Deal with spec or body suffix + + Unit_Char := Name_Buffer (Name_Len); + pragma Assert (Unit_Char = 'b' or else Unit_Char = 's'); + pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%'); + Name_Len := Name_Len - 2; + + if Subunit then + Unit_Char := 'u'; + end if; + + -- Now we need to find the proper translation of the name + + declare + Uname : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + + Pent : Nat; + Plen : Natural; + Fnam : File_Name_Type := No_File; + J : Natural; + Dot : String_Ptr; + Dotl : Natural; + + function C (N : Natural) return Character; + -- Return N'th character of pattern + + function C (N : Natural) return Character is + begin + return SFN_Patterns.Table (Pent).Pat (N); + end C; + + -- Start of search through pattern table + + begin + -- Search pattern table to find a matching entry. In the general + -- case we do two complete searches. The first time through we + -- stop only if a matching file is found, the second time through + -- we accept the first match regardless. Note that there will + -- always be a match the second time around, because of the + -- default entries at the end of the table. + + for No_File_Check in False .. True loop + Unit_Char_Search := Unit_Char; + + <<Repeat_Search>> + -- The search is repeated with Unit_Char_Search set to b, if an + -- initial search for the subunit case fails to find any match. + + Pent := SFN_Patterns.First; + while Pent <= SFN_Patterns.Last loop + if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then + Name_Len := 0; + + -- Found a match, execute the pattern + + Name_Len := Uname'Length; + Name_Buffer (1 .. Name_Len) := Uname; + Set_Casing (SFN_Patterns.Table (Pent).Cas); + + -- If dot translation required do it + + Dot := SFN_Patterns.Table (Pent).Dot; + Dotl := Dot.all'Length; + + if Dot.all /= "." then + J := 1; + + while J <= Name_Len loop + if Name_Buffer (J) = '.' then + + if Dotl = 1 then + Name_Buffer (J) := Dot (Dot'First); + + else + Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) := + Name_Buffer (J + 1 .. Name_Len); + Name_Buffer (J .. J + Dotl - 1) := Dot.all; + Name_Len := Name_Len + Dotl - 1; + end if; + + J := J + Dotl; + + -- Skip past wide char sequences to avoid messing + -- with dot characters that are part of a sequence. + + elsif Name_Buffer (J) = ASCII.ESC + or else (Upper_Half_Encoding + and then + Name_Buffer (J) in Upper_Half_Character) + then + Skip_Wide (Name_Buffer, J); + else + J := J + 1; + end if; + end loop; + end if; + + -- Here move result to right if preinsertion before * + + Plen := SFN_Patterns.Table (Pent).Pat'Length; + for K in 1 .. Plen loop + if C (K) = '*' then + if K /= 1 then + Name_Buffer (1 + K - 1 .. Name_Len + K - 1) := + Name_Buffer (1 .. Name_Len); + + for L in 1 .. K - 1 loop + Name_Buffer (L) := C (L); + end loop; + + Name_Len := Name_Len + K - 1; + end if; + + for L in K + 1 .. Plen loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := C (L); + end loop; + + exit; + end if; + end loop; + + -- Execute possible crunch on constructed name. The krunch + -- operation excludes any extension that may be present. + + J := Name_Len; + while J > 1 loop + exit when Name_Buffer (J) = '.'; + J := J - 1; + end loop; + + -- Case of extension present + + if J > 1 then + declare + Ext : constant String := Name_Buffer (J .. Name_Len); + + begin + -- Remove extension + + Name_Len := J - 1; + + -- Krunch what's left + + Krunch + (Name_Buffer, + Name_Len, + Integer (Maximum_File_Name_Length), + Debug_Flag_4); + + -- Replace extension + + Name_Buffer + (Name_Len + 1 .. Name_Len + Ext'Length) := Ext; + Name_Len := Name_Len + Ext'Length; + end; + + -- Case of no extension present, straight krunch on + -- the entire file name. + + else + Krunch + (Name_Buffer, + Name_Len, + Integer (Maximum_File_Name_Length), + Debug_Flag_4); + end if; + + Fnam := File_Name_Type (Name_Find); + + -- If we are in the first search of the table, then + -- we check if the file is present, and only accept + -- the entry if it is indeed present. For the second + -- search, we accept the entry without this check. + + -- If we only have two entries in the table, then there + -- is no point in seeing if the file exists, since we + -- will end up accepting it anyway on the second search, + -- so just quit and accept it now to save time. + + if No_File_Check or else SFN_Patterns.Last = 2 then + return Fnam; + + -- Check if file exists and if so, return the entry + + elsif Find_File (Fnam, Source) /= No_File then + return Fnam; + + -- This entry does not match after all, because this is + -- the first search loop, and the file does not exist. + + else + Fnam := No_File; + end if; + end if; + + Pent := Pent + 1; + end loop; + + -- If search failed, and was for a subunit, repeat the search + -- with Unit_Char_Search reset to 'b', since in the normal case + -- we simply treat subunits as bodies. + + if Fnam = No_File and then Unit_Char_Search = 'u' then + Unit_Char_Search := 'b'; + goto Repeat_Search; + end if; + + -- Repeat entire search in No_File_Check mode if necessary + + end loop; + + -- Something is wrong if search fails completely, since the + -- default entries should catch all possibilities at this stage. + + raise Program_Error; + end; + end Get_File_Name; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SFN_Table.Init; + SFN_Patterns.Init; + + -- Add default entries to SFN_Patterns.Table to represent the + -- standard default GNAT rules for file name translation. + + SFN_Patterns.Append (New_Val => + (Pat => new String'("*.ads"), + Typ => 's', + Dot => new String'("-"), + Cas => All_Lower_Case)); + + SFN_Patterns.Append (New_Val => + (Pat => new String'("*.adb"), + Typ => 'b', + Dot => new String'("-"), + Cas => All_Lower_Case)); + end Initialize; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + SFN_Table.Locked := True; + SFN_Table.Release; + end Lock; + + ------------------- + -- Set_File_Name -- + ------------------- + + procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type) is + begin + SFN_Table.Increment_Last; + SFN_Table.Table (SFN_Table.Last) := (U, F); + SFN_HTable.Set (U, SFN_Table.Last); + end Set_File_Name; + + --------------------------- + -- Set_File_Name_Pattern -- + --------------------------- + + procedure Set_File_Name_Pattern + (Pat : String_Ptr; + Typ : Character; + Dot : String_Ptr; + Cas : Casing_Type) + is + L : constant Nat := SFN_Patterns.Last; + begin + SFN_Patterns.Increment_Last; + + -- Move up the last two entries (the default ones) and then + -- put the new entry into the table just before them (we + -- always have the default entries be the last ones). + + SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L); + SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1); + SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas); + end Set_File_Name_Pattern; + + -------------- + -- SFN_Hash -- + -------------- + + function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is + begin + return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length); + end SFN_Hash; + +begin + + -- We call the initialization routine from the package body, so that + -- Fname.Init only needs to be called explicitly to reinitialize. + + Fname.UF.Initialize; +end Fname.UF; diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads new file mode 100644 index 00000000000..5c626ecca78 --- /dev/null +++ b/gcc/ada/fname-uf.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . U F -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 1992-2000 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains the routines to translate a unit name to +-- a file name taking into account Source_File_Name pragmas. It also +-- contains the auxiliary routines used to record data from the pragmas. + +-- Note: the reason we split this into a child unit is that the routines +-- for unit name translation have a significant number of additional +-- dependencies, including osint, and hence sdefault. There are a number +-- of tools that use utility subprograms in the Fname parent, but do not +-- need the functionality in this child package (and certainly do not want +-- to deal with the extra dependencies). + +with Casing; use Casing; + +package Fname.UF is + + ----------------- + -- Subprograms -- + ----------------- + + function Get_File_Name + (Uname : Unit_Name_Type; + Subunit : Boolean) + return File_Name_Type; + -- This function returns the file name that corresponds to a given unit + -- name, Uname. The Subunit parameter is set True for subunits, and + -- false for all other kinds of units. The caller is responsible for + -- ensuring that the unit name meets the requirements given in package + -- Uname and described above. + + procedure Initialize; + -- Initialize internal tables. This is called automatically when the + -- package body is elaborated, so an explicit call to Initialize is + -- only required if it is necessary to reinitialize the source file + -- name pragma tables. + + procedure Lock; + -- Lock tables before calling back end + + function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type; + -- Returns the file name that corresponds to the spec of a given unit + -- name. The unit name here is not encoded as a Unit_Name_Type, but is + -- rather just a normal form name in lower case, e.g. "xyz.def". + + function File_Name_Of_Body (Name : Name_Id) return File_Name_Type; + -- Returns the file name that corresponds to the body of a given unit + -- name. The unit name here is not encoded as a Unit_Name_Type, but is + -- rather just a normal form name in lower case, e.g. "xyz.def". + + procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type); + -- Make association between given unit name, U, and the given file name, + -- F. This is the routine called to process a Source_File_Name pragma. + + procedure Set_File_Name_Pattern + (Pat : String_Ptr; + Typ : Character; + Dot : String_Ptr; + Cas : Casing_Type); + -- This is called to process a Source_File_Name pragma whose first + -- argument is a file name pattern string. Pat is this pattern string, + -- which contains an asterisk to correspond to the unit. Typ is one of + -- 'b'/'s'/'u' for body/spec/subunit, Dot is the separator string + -- for child/subunit names, and Cas is one of Lower/Upper/Mixed + -- indicating the required case for the file name. + +end Fname.UF; diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb new file mode 100644 index 00000000000..7ac38bbc52d --- /dev/null +++ b/gcc/ada/fname.adb @@ -0,0 +1,224 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.64 $ +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 Alloc; +with Hostparm; use Hostparm; +with Namet; use Namet; +with Table; + +package body Fname is + + ----------------------------- + -- Dummy Table Definitions -- + ----------------------------- + + -- The following table was used in old versions of the compiler. We retain + -- the declarations here for compatibility with old tree files. The new + -- version of the compiler does not use this table, and will write out a + -- dummy empty table for Tree_Write. + + type SFN_Entry is record + U : Unit_Name_Type; + F : File_Name_Type; + end record; + + package SFN_Table is new Table.Table ( + Table_Component_Type => SFN_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.SFN_Table_Initial, + Table_Increment => Alloc.SFN_Table_Increment, + Table_Name => "Fname_Dummy_Table"); + ---------------------------- + -- Get_Expected_Unit_Type -- + ---------------------------- + + -- We assume that a file name whose last character is a lower case b is + -- a body and a file name whose last character is a lower case s is a + -- spec. If any other character is found (e.g. when we are in syntax + -- checking only mode, where the file name conventions are not set), + -- then we return Unknown. + + function Get_Expected_Unit_Type + (Fname : File_Name_Type) + return Expected_Unit_Type + is + begin + Get_Name_String (Fname); + + if Name_Buffer (Name_Len) = 'b' then + return Expect_Body; + elsif Name_Buffer (Name_Len) = 's' then + return Expect_Spec; + else + return Unknown; + end if; + end Get_Expected_Unit_Type; + + --------------------------- + -- Is_Internal_File_Name -- + --------------------------- + + function Is_Internal_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) + return Boolean + is + begin + if Is_Predefined_File_Name (Fname, Renamings_Included) then + return True; + + -- Once Is_Predefined_File_Name has been called and returns False, + -- Name_Buffer contains Fname and Name_Len is set to 8. + + elsif Name_Buffer (1 .. 2) = "g-" + or else Name_Buffer (1 .. 8) = "gnat " + then + return True; + + elsif OpenVMS + and then + (Name_Buffer (1 .. 4) = "dec-" + or else Name_Buffer (1 .. 8) = "dec ") + then + return True; + + else + return False; + end if; + end Is_Internal_File_Name; + + ----------------------------- + -- Is_Predefined_File_Name -- + ----------------------------- + + -- This should really be a test of unit name, given the possibility of + -- pragma Source_File_Name setting arbitrary file names for any files??? + + -- Once Is_Predefined_File_Name has been called and returns False, + -- Name_Buffer contains Fname and Name_Len is set to 8. This is used + -- only by Is_Internal_File_Name, and is not part of the official + -- external interface of this function. + + function Is_Predefined_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) + return Boolean + is + subtype Str8 is String (1 .. 8); + + Predef_Names : array (1 .. 11) of Str8 := + ("ada ", -- Ada + "calendar", -- Calendar + "interfac", -- Interfaces + "system ", -- System + "machcode", -- Machine_Code + "unchconv", -- Unchecked_Conversion + "unchdeal", -- Unchecked_Deallocation + + -- Remaining entries are only considered if Renamings_Included true + + "directio", -- Direct_IO + "ioexcept", -- IO_Exceptions + "sequenio", -- Sequential_IO + "text_io "); -- Text_IO + + Num_Entries : constant Natural := + 7 + 4 * Boolean'Pos (Renamings_Included); + + begin + -- Get file name, removing the extension (if any) + + Get_Name_String (Fname); + + if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then + Name_Len := Name_Len - 4; + end if; + + -- Definitely false if longer than 12 characters (8.3) + + if Name_Len > 8 then + return False; + + -- Definitely predefined if prefix is a- i- or s- + + elsif Name_Len > 2 + and then Name_Buffer (2) = '-' + and then (Name_Buffer (1) = 'a' or else + Name_Buffer (1) = 'i' or else + Name_Buffer (1) = 's') + then + return True; + end if; + + -- Otherwise check against special list, first padding to 8 characters + + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + for J in 1 .. Num_Entries loop + if Name_Buffer (1 .. 8) = Predef_Names (J) then + return True; + end if; + end loop; + + -- Note: when we return False here, the Name_Buffer contains the + -- padded file name. This is not defined for clients of the package, + -- but is used by Is_Internal_File_Name. + + return False; + end Is_Predefined_File_Name; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + SFN_Table.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + SFN_Table.Tree_Write; + end Tree_Write; + +end Fname; diff --git a/gcc/ada/fname.ads b/gcc/ada/fname.ads new file mode 100644 index 00000000000..d4b589fd858 --- /dev/null +++ b/gcc/ada/fname.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.33 $ +-- -- +-- Copyright (C) 1992-2000 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package, together with its child package Fname.UF define the +-- association between source file names and unit names as defined +-- (see package Uname for definition of format of unit names). + +with Types; use Types; + +package Fname is + + -- Note: this package spec does not depend on the Uname spec in the Ada + -- sense, but the comments and description of the semantics do depend on + -- the conventions established by Uname. + + --------------------------- + -- File Name Conventions -- + --------------------------- + + -- GNAT requires that there be a one to one correspondence between source + -- file names (as used in the Osint package interface) and unit names as + -- defined by the Uname package. This correspondence is defined by the + -- two subprograms defined here in the Fname package. + + -- For full rules of file naming, see GNAT User's Guide. Note that the + -- naming rules are affected by the presence of Source_File_Name pragmas + -- that have been previously processed. + + -- Note that the file name does *not* include the directory name. The + -- management of directories is provided by Osint, and full file names + -- are used only for error message purposes within GNAT itself. + + ----------------- + -- Subprograms -- + ----------------- + + type Expected_Unit_Type is (Expect_Body, Expect_Spec, Unknown); + -- Return value from Get_Expected_Unit_Type + + function Get_Expected_Unit_Type + (Fname : File_Name_Type) + return Expected_Unit_Type; + -- If possible, determine whether the given file name corresponds to a unit + -- that is a spec or body (e.g. by examining the extension). If this cannot + -- be determined with the file naming conventions in use, then the returned + -- value is set to Unknown. + + function Is_Predefined_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) + return Boolean; + -- This function determines if the given file name (which must be a simple + -- file name with no directory information) is the file name for one of + -- the predefined library units. On return, Name_Buffer contains the + -- file name. The Renamings_Included parameter indicates whether annex + -- J renamings such as Text_IO are to be considered as predefined. If + -- Renamings_Included is True, then Text_IO will return True, otherwise + -- only children of Ada, Interfaces and System return True. + + function Is_Internal_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) + return Boolean; + -- Similar to Is_Predefined_File_Name. The internal file set is a + -- superset of the predefined file set including children of GNAT, + -- and also children of DEC for the VMS case. + + procedure Tree_Read; + -- Dummy procedure (reads dummy table values from tree file) + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write + -- This is actually a dummy routine, since the relevant table is + -- no longer used, but we retain it for now, to avoid a tree file + -- incompatibility with the 3.13 compiler. Should be removed for + -- the 3.14a release ??? + +end Fname; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb new file mode 100644 index 00000000000..6f4c4c7c7c1 --- /dev/null +++ b/gcc/ada/freeze.adb @@ -0,0 +1,3903 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R E E Z E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.281 $ +-- -- +-- Copyright (C) 1992-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 Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch11; use Exp_Ch11; +with Exp_Pakd; use Exp_Pakd; +with Exp_Util; use Exp_Util; +with Layout; use Layout; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Sem; use Sem; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Freeze is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Adjust_Esize_For_Alignment (Typ : Entity_Id); + -- Typ is a type that is being frozen. If no size clause is given, + -- but a default Esize has been computed, then this default Esize is + -- adjusted up if necessary to be consistent with a given alignment, + -- but never to a value greater than Long_Long_Integer'Size. This + -- is used for all discrete types and for fixed-point types. + + procedure Build_And_Analyze_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id; + After : in out Node_Id); + -- Build body for a renaming declaration, insert in tree and analyze. + + procedure Check_Strict_Alignment (E : Entity_Id); + -- E is a base type. If E is tagged or has a component that is aliased + -- or tagged or contains something this is aliased or tagged, set + -- Strict_Alignment. + + procedure Check_Unsigned_Type (E : Entity_Id); + pragma Inline (Check_Unsigned_Type); + -- If E is a fixed-point or discrete type, then all the necessary work + -- to freeze it is completed except for possible setting of the flag + -- Is_Unsigned_Type, which is done by this procedure. The call has no + -- effect if the entity E is not a discrete or fixed-point type. + + procedure Freeze_And_Append + (Ent : Entity_Id; + Loc : Source_Ptr; + Result : in out List_Id); + -- Freezes Ent using Freeze_Entity, and appends the resulting list of + -- nodes to Result, modifying Result from No_List if necessary. + + procedure Freeze_Enumeration_Type (Typ : Entity_Id); + -- Freeze enumeration type. The Esize field is set as processing + -- proceeds (i.e. set by default when the type is declared and then + -- adjusted by rep clauses. What this procedure does is to make sure + -- that if a foreign convention is specified, and no specific size + -- is given, then the size must be at least Integer'Size. + + procedure Freeze_Fixed_Point_Type (Typ : Entity_Id); + -- Freeze fixed point type. For fixed-point types, we have to defer + -- setting the size and bounds till the freeze point, since they are + -- potentially affected by the presence of size and small clauses. + + procedure Freeze_Static_Object (E : Entity_Id); + -- If an object is frozen which has Is_Statically_Allocated set, then + -- all referenced types must also be marked with this flag. This routine + -- is in charge of meeting this requirement for the object entity E. + + procedure Freeze_Subprogram (E : Entity_Id); + -- Perform freezing actions for a subprogram (create extra formals, + -- and set proper default mechanism values). Note that this routine + -- is not called for internal subprograms, for which neither of these + -- actions is needed (or desirable, we do not want for example to have + -- these extra formals present in initialization procedures, where they + -- would serve no purpose). In this call E is either a subprogram or + -- a subprogram type (i.e. an access to a subprogram). + + function Is_Fully_Defined (T : Entity_Id) return Boolean; + -- true if T is not private, or has a full view. + + procedure Process_Default_Expressions + (E : Entity_Id; + After : in out Node_Id); + -- This procedure is called for each subprogram to complete processing + -- of default expressions at the point where all types are known to be + -- frozen. The expressions must be analyzed in full, to make sure that + -- all error processing is done (they have only been pre-analyzed). If + -- the expression is not an entity or literal, its analysis may generate + -- code which must not be executed. In that case we build a function + -- body to hold that code. This wrapper function serves no other purpose + -- (it used to be called to evaluate the default, but now the default is + -- inlined at each point of call). + + procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); + -- Typ is a record or array type that is being frozen. This routine + -- sets the default component alignment from the scope stack values + -- if the alignment is otherwise not specified. + + procedure Check_Debug_Info_Needed (T : Entity_Id); + -- As each entity is frozen, this routine is called to deal with the + -- setting of Debug_Info_Needed for the entity. This flag is set if + -- the entity comes from source, or if we are in Debug_Generated_Code + -- mode or if the -gnatdV debug flag is set. However, it never sets + -- the flag if Debug_Info_Off is set. + + procedure Set_Debug_Info_Needed (T : Entity_Id); + -- Sets the Debug_Info_Needed flag on entity T if not already set, and + -- also on any entities that are needed by T (for an object, the type + -- of the object is needed, and for a type, the subsidiary types are + -- needed -- see body for details). Never has any effect on T if the + -- Debug_Info_Off flag is set. + + ------------------------------- + -- Adjust_Esize_For_Alignment -- + ------------------------------- + + procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is + Align : Uint; + + begin + if Known_Esize (Typ) and then Known_Alignment (Typ) then + Align := Alignment_In_Bits (Typ); + + if Align > Esize (Typ) + and then Align <= Standard_Long_Long_Integer_Size + then + Set_Esize (Typ, Align); + end if; + end if; + end Adjust_Esize_For_Alignment; + + ------------------------------------ + -- Build_And_Analyze_Renamed_Body -- + ------------------------------------ + + procedure Build_And_Analyze_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id; + After : in out Node_Id) + is + Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S); + + begin + Insert_After (After, Body_Node); + Mark_Rewrite_Insertion (Body_Node); + Analyze (Body_Node); + After := Body_Node; + end Build_And_Analyze_Renamed_Body; + + ------------------------ + -- Build_Renamed_Body -- + ------------------------ + + function Build_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (New_S); + -- We use for the source location of the renamed body, the location + -- of the spec entity. It might seem more natural to use the location + -- of the renaming declaration itself, but that would be wrong, since + -- then the body we create would look as though it was created far + -- too late, and this could cause problems with elaboration order + -- analysis, particularly in connection with instantiations. + + N : constant Node_Id := Unit_Declaration_Node (New_S); + Nam : constant Node_Id := Name (N); + Old_S : Entity_Id; + Spec : constant Node_Id := New_Copy_Tree (Specification (Decl)); + Actuals : List_Id := No_List; + Call_Node : Node_Id; + Call_Name : Node_Id; + Body_Node : Node_Id; + Formal : Entity_Id; + O_Formal : Entity_Id; + Param_Spec : Node_Id; + + begin + -- Determine the entity being renamed, which is the target of the + -- call statement. If the name is an explicit dereference, this is + -- a renaming of a subprogram type rather than a subprogram. The + -- name itself is fully analyzed. + + if Nkind (Nam) = N_Selected_Component then + Old_S := Entity (Selector_Name (Nam)); + + elsif Nkind (Nam) = N_Explicit_Dereference then + Old_S := Etype (Nam); + + elsif Nkind (Nam) = N_Indexed_Component then + + if Is_Entity_Name (Prefix (Nam)) then + Old_S := Entity (Prefix (Nam)); + else + Old_S := Entity (Selector_Name (Prefix (Nam))); + end if; + + elsif Nkind (Nam) = N_Character_Literal then + Old_S := Etype (New_S); + + else + Old_S := Entity (Nam); + end if; + + if Is_Entity_Name (Nam) then + Call_Name := New_Reference_To (Old_S, Loc); + else + Call_Name := New_Copy (Name (N)); + + -- The original name may have been overloaded, but + -- is fully resolved now. + + Set_Is_Overloaded (Call_Name, False); + end if; + + -- For simple renamings, subsequent calls can be expanded directly + -- as called to the renamed entity. The body must be generated in + -- any case for calls they may appear elsewhere. + + if (Ekind (Old_S) = E_Function + or else Ekind (Old_S) = E_Procedure) + and then Nkind (Decl) = N_Subprogram_Declaration + then + Set_Body_To_Inline (Decl, Old_S); + end if; + + -- The body generated for this renaming is an internal artifact, and + -- does not constitute a freeze point for the called entity. + + Set_Must_Not_Freeze (Call_Name); + + Formal := First_Formal (Defining_Entity (Decl)); + + if Present (Formal) then + Actuals := New_List; + + while Present (Formal) loop + Append (New_Reference_To (Formal, Loc), Actuals); + Next_Formal (Formal); + end loop; + end if; + + -- If the renamed entity is an entry, inherit its profile. For + -- other renamings as bodies, both profiles must be subtype + -- conformant, so it is not necessary to replace the profile given + -- in the declaration. However, default values that are aggregates + -- are rewritten when partially analyzed, so we recover the original + -- aggregate to insure that subsequent conformity checking works. + + Formal := First_Formal (Defining_Entity (Decl)); + + if Present (Formal) then + O_Formal := First_Formal (Old_S); + Param_Spec := First (Parameter_Specifications (Spec)); + + while Present (Formal) loop + if Is_Entry (Old_S) then + + if Nkind (Parameter_Type (Param_Spec)) /= + N_Access_Definition + then + Set_Etype (Formal, Etype (O_Formal)); + Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); + end if; + + elsif Nkind (Default_Value (O_Formal)) = N_Aggregate then + Set_Expression (Param_Spec, + New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); + end if; + + Next_Formal (Formal); + Next_Formal (O_Formal); + Next (Param_Spec); + end loop; + end if; + + -- If the renamed entity is a function, the generated body contains a + -- return statement. Otherwise, build a procedure call. If the entity is + -- an entry, subsequent analysis of the call will transform it into the + -- proper entry or protected operation call. If the renamed entity is + -- a character literal, return it directly. + + if Ekind (Old_S) = E_Function + or else Ekind (Old_S) = E_Operator + or else (Ekind (Old_S) = E_Subprogram_Type + and then Etype (Old_S) /= Standard_Void_Type) + then + Call_Node := + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => Call_Name, + Parameter_Associations => Actuals)); + + elsif Ekind (Old_S) = E_Enumeration_Literal then + Call_Node := + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Old_S, Loc)); + + elsif Nkind (Nam) = N_Character_Literal then + Call_Node := + Make_Return_Statement (Loc, + Expression => Call_Name); + + else + Call_Node := + Make_Procedure_Call_Statement (Loc, + Name => Call_Name, + Parameter_Associations => Actuals); + end if; + + -- Create entities for subprogram body and formals. + + Set_Defining_Unit_Name (Spec, + Make_Defining_Identifier (Loc, Chars => Chars (New_S))); + + Param_Spec := First (Parameter_Specifications (Spec)); + + while Present (Param_Spec) loop + Set_Defining_Identifier (Param_Spec, + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Param_Spec)))); + Next (Param_Spec); + end loop; + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call_Node))); + + if Nkind (Decl) /= N_Subprogram_Declaration then + Rewrite (N, + Make_Subprogram_Declaration (Loc, + Specification => Specification (N))); + end if; + + -- Link the body to the entity whose declaration it completes. If + -- the body is analyzed when the renamed entity is frozen, it may be + -- necessary to restore the proper scope (see package Exp_Ch13). + + if Nkind (N) = N_Subprogram_Renaming_Declaration + and then Present (Corresponding_Spec (N)) + then + Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N)); + else + Set_Corresponding_Spec (Body_Node, New_S); + end if; + + return Body_Node; + end Build_Renamed_Body; + + ----------------------------- + -- Check_Compile_Time_Size -- + ----------------------------- + + procedure Check_Compile_Time_Size (T : Entity_Id) is + + procedure Set_Small_Size (S : Uint); + -- Sets the compile time known size (32 bits or less) in the Esize + -- field, checking for a size clause that was given which attempts + -- to give a smaller size. + + function Size_Known (T : Entity_Id) return Boolean; + -- Recursive function that does all the work. + -- Is this right??? isn't recursive case already handled??? + -- certainly yes for normal call, but what about bogus sem_res call??? + + function Static_Discriminated_Components (T : Entity_Id) return Boolean; + -- If T is a constrained subtype, its size is not known if any of its + -- discriminant constraints is not static and it is not a null record. + -- The test is conservative and doesn't check that the components are + -- in fact constrained by non-static discriminant values. Could be made + -- more precise ??? + + -------------------- + -- Set_Small_Size -- + -------------------- + + procedure Set_Small_Size (S : Uint) is + begin + if S > 32 then + return; + + elsif Has_Size_Clause (T) then + if RM_Size (T) < S then + Error_Msg_Uint_1 := S; + Error_Msg_NE + ("size for & is too small, minimum is ^", + Size_Clause (T), T); + + elsif Unknown_Esize (T) then + Set_Esize (T, S); + end if; + + -- Set sizes if not set already + + else + if Unknown_Esize (T) then + Set_Esize (T, S); + end if; + + if Unknown_RM_Size (T) then + Set_RM_Size (T, S); + end if; + end if; + end Set_Small_Size; + + ---------------- + -- Size_Known -- + ---------------- + + function Size_Known (T : Entity_Id) return Boolean is + Index : Entity_Id; + Comp : Entity_Id; + Ctyp : Entity_Id; + Low : Node_Id; + High : Node_Id; + + begin + if Size_Known_At_Compile_Time (T) then + return True; + + elsif Error_Posted (T) then + return False; + + elsif Is_Scalar_Type (T) + or else Is_Task_Type (T) + then + return not Is_Generic_Type (T); + + elsif Is_Array_Type (T) then + + if Ekind (T) = E_String_Literal_Subtype then + Set_Small_Size (Component_Size (T) * String_Literal_Length (T)); + return True; + + elsif not Is_Constrained (T) then + return False; + + elsif not Size_Known (Component_Type (T)) then + return False; + end if; + + -- Check for all indexes static, and also compute possible + -- size (in case it is less than 32 and may be packable). + + declare + Esiz : Uint := Component_Size (T); + Dim : Uint; + + begin + Index := First_Index (T); + + while Present (Index) loop + if Nkind (Index) = N_Range then + Get_Index_Bounds (Index, Low, High); + + elsif Error_Posted (Scalar_Range (Etype (Index))) then + return False; + + else + Low := Type_Low_Bound (Etype (Index)); + High := Type_High_Bound (Etype (Index)); + end if; + + if not Compile_Time_Known_Value (Low) + or else not Compile_Time_Known_Value (High) + or else Etype (Index) = Any_Type + then + return False; + + else + Dim := Expr_Value (High) - Expr_Value (Low) + 1; + + if Dim >= 0 then + Esiz := Esiz * Dim; + else + Esiz := Uint_0; + end if; + end if; + + Next_Index (Index); + end loop; + + Set_Small_Size (Esiz); + return True; + end; + + elsif Is_Access_Type (T) then + return True; + + elsif Is_Private_Type (T) + and then not Is_Generic_Type (T) + and then Present (Underlying_Type (T)) + then + return Size_Known (Underlying_Type (T)); + + elsif Is_Record_Type (T) then + if Is_Class_Wide_Type (T) then + return False; + + elsif T /= Base_Type (T) then + return Size_Known_At_Compile_Time (Base_Type (T)) + and then Static_Discriminated_Components (T); + + else + declare + Packed_Size_Known : Boolean := Is_Packed (T); + Packed_Size : Uint := Uint_0; + + begin + -- Test for variant part present + + if Has_Discriminants (T) + and then Present (Parent (T)) + and then Nkind (Parent (T)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (T))) = + N_Record_Definition + and then not Null_Present (Type_Definition (Parent (T))) + and then Present (Variant_Part + (Component_List (Type_Definition (Parent (T))))) + then + -- If variant part is present, and type is unconstrained, + -- then we must have defaulted discriminants, or a size + -- clause must be present for the type, or else the size + -- is definitely not known at compile time. + + if not Is_Constrained (T) + and then + No (Discriminant_Default_Value + (First_Discriminant (T))) + and then Unknown_Esize (T) + then + return False; + else + -- We do not know the packed size, it is too much + -- trouble to figure it out. + + Packed_Size_Known := False; + end if; + end if; + + Comp := First_Entity (T); + + while Present (Comp) loop + if Ekind (Comp) = E_Component + or else + Ekind (Comp) = E_Discriminant + then + Ctyp := Etype (Comp); + + if Present (Component_Clause (Comp)) then + Packed_Size_Known := False; + end if; + + if not Size_Known (Ctyp) then + return False; + + elsif Packed_Size_Known then + + -- If RM_Size is known and static, then we can + -- keep accumulating the packed size. + + if Known_Static_RM_Size (Ctyp) then + + -- A little glitch, to be removed sometime ??? + -- gigi does not understand zero sizes yet. + + if RM_Size (Ctyp) = Uint_0 then + Packed_Size_Known := False; + end if; + + Packed_Size := + Packed_Size + RM_Size (Ctyp); + + -- If we have a field whose RM_Size is not known + -- then we can't figure out the packed size here. + + else + Packed_Size_Known := False; + end if; + end if; + end if; + + Next_Entity (Comp); + end loop; + + if Packed_Size_Known then + Set_Small_Size (Packed_Size); + end if; + + return True; + end; + end if; + + else + return False; + end if; + end Size_Known; + + ------------------------------------- + -- Static_Discriminated_Components -- + ------------------------------------- + + function Static_Discriminated_Components + (T : Entity_Id) + return Boolean + is + Constraint : Elmt_Id; + + begin + if Has_Discriminants (T) + and then Present (Discriminant_Constraint (T)) + and then Present (First_Component (T)) + then + Constraint := First_Elmt (Discriminant_Constraint (T)); + + while Present (Constraint) loop + if not Compile_Time_Known_Value (Node (Constraint)) then + return False; + end if; + + Next_Elmt (Constraint); + end loop; + end if; + + return True; + end Static_Discriminated_Components; + + -- Start of processing for Check_Compile_Time_Size + + begin + Set_Size_Known_At_Compile_Time (T, Size_Known (T)); + end Check_Compile_Time_Size; + + ----------------------------- + -- Check_Debug_Info_Needed -- + ----------------------------- + + procedure Check_Debug_Info_Needed (T : Entity_Id) is + begin + if Needs_Debug_Info (T) or else Debug_Info_Off (T) then + return; + + elsif Comes_From_Source (T) + or else Debug_Generated_Code + or else Debug_Flag_VV + then + Set_Debug_Info_Needed (T); + end if; + end Check_Debug_Info_Needed; + + ---------------------------- + -- Check_Strict_Alignment -- + ---------------------------- + + procedure Check_Strict_Alignment (E : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Tagged_Type (E) or else Is_Concurrent_Type (E) then + Set_Strict_Alignment (E); + + elsif Is_Array_Type (E) then + Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E))); + + elsif Is_Record_Type (E) then + if Is_Limited_Record (E) then + Set_Strict_Alignment (E); + return; + end if; + + Comp := First_Component (E); + + while Present (Comp) loop + if not Is_Type (Comp) + and then (Strict_Alignment (Etype (Comp)) + or else Is_Aliased (Comp)) + then + Set_Strict_Alignment (E); + return; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Strict_Alignment; + + ------------------------- + -- Check_Unsigned_Type -- + ------------------------- + + procedure Check_Unsigned_Type (E : Entity_Id) is + Ancestor : Entity_Id; + Lo_Bound : Node_Id; + Btyp : Entity_Id; + + begin + if not Is_Discrete_Or_Fixed_Point_Type (E) then + return; + end if; + + -- Do not attempt to analyze case where range was in error + + if Error_Posted (Scalar_Range (E)) then + return; + end if; + + -- The situation that is non trivial is something like + + -- subtype x1 is integer range -10 .. +10; + -- subtype x2 is x1 range 0 .. V1; + -- subtype x3 is x2 range V2 .. V3; + -- subtype x4 is x3 range V4 .. V5; + + -- where Vn are variables. Here the base type is signed, but we still + -- know that x4 is unsigned because of the lower bound of x2. + + -- The only way to deal with this is to look up the ancestor chain + + Ancestor := E; + loop + if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then + return; + end if; + + Lo_Bound := Type_Low_Bound (Ancestor); + + if Compile_Time_Known_Value (Lo_Bound) then + + if Expr_Rep_Value (Lo_Bound) >= 0 then + Set_Is_Unsigned_Type (E, True); + end if; + + return; + + else + Ancestor := Ancestor_Subtype (Ancestor); + + -- If no ancestor had a static lower bound, go to base type + + if No (Ancestor) then + + -- Note: the reason we still check for a compile time known + -- value for the base type is that at least in the case of + -- generic formals, we can have bounds that fail this test, + -- and there may be other cases in error situations. + + Btyp := Base_Type (E); + + if Btyp = Any_Type or else Etype (Btyp) = Any_Type then + return; + end if; + + Lo_Bound := Type_Low_Bound (Base_Type (E)); + + if Compile_Time_Known_Value (Lo_Bound) + and then Expr_Rep_Value (Lo_Bound) >= 0 + then + Set_Is_Unsigned_Type (E, True); + end if; + + return; + + end if; + end if; + end loop; + end Check_Unsigned_Type; + + ---------------- + -- Freeze_All -- + ---------------- + + -- Note: the easy coding for this procedure would be to just build a + -- single list of freeze nodes and then insert them and analyze them + -- all at once. This won't work, because the analysis of earlier freeze + -- nodes may recursively freeze types which would otherwise appear later + -- on in the freeze list. So we must analyze and expand the freeze nodes + -- as they are generated. + + procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is + Loc : constant Source_Ptr := Sloc (After); + E : Entity_Id; + Decl : Node_Id; + + procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id); + -- This is the internal recursive routine that does freezing of + -- entities (but NOT the analysis of default expressions, which + -- should not be recursive, we don't want to analyze those till + -- we are sure that ALL the types are frozen). + + procedure Freeze_All_Ent + (From : Entity_Id; + After : in out Node_Id) + is + E : Entity_Id; + Flist : List_Id; + Lastn : Node_Id; + + procedure Process_Flist; + -- If freeze nodes are present, insert and analyze, and reset + -- cursor for next insertion. + + procedure Process_Flist is + begin + if Is_Non_Empty_List (Flist) then + Lastn := Next (After); + Insert_List_After_And_Analyze (After, Flist); + + if Present (Lastn) then + After := Prev (Lastn); + else + After := Last (List_Containing (After)); + end if; + end if; + end Process_Flist; + + begin + E := From; + while Present (E) loop + + -- If the entity is an inner package which is not a package + -- renaming, then its entities must be frozen at this point. + -- Note that such entities do NOT get frozen at the end of + -- the nested package itself (only library packages freeze). + + -- Same is true for task declarations, where anonymous records + -- created for entry parameters must be frozen. + + if Ekind (E) = E_Package + and then No (Renamed_Object (E)) + and then not Is_Child_Unit (E) + and then not Is_Frozen (E) + then + New_Scope (E); + Install_Visible_Declarations (E); + Install_Private_Declarations (E); + + Freeze_All (First_Entity (E), After); + + End_Package_Scope (E); + + elsif Ekind (E) in Task_Kind + and then + (Nkind (Parent (E)) = N_Task_Type_Declaration + or else + Nkind (Parent (E)) = N_Single_Task_Declaration) + then + New_Scope (E); + Freeze_All (First_Entity (E), After); + End_Scope; + + -- For a derived tagged type, we must ensure that all the + -- primitive operations of the parent have been frozen, so + -- that their addresses will be in the parent's dispatch table + -- at the point it is inherited. + + elsif Ekind (E) = E_Record_Type + and then Is_Tagged_Type (E) + and then Is_Tagged_Type (Etype (E)) + and then Is_Derived_Type (E) + then + declare + Prim_List : constant Elist_Id := + Primitive_Operations (Etype (E)); + Prim : Elmt_Id; + Subp : Entity_Id; + + begin + Prim := First_Elmt (Prim_List); + + while Present (Prim) loop + Subp := Node (Prim); + + if Comes_From_Source (Subp) + and then not Is_Frozen (Subp) + then + Flist := Freeze_Entity (Subp, Loc); + Process_Flist; + end if; + + Next_Elmt (Prim); + end loop; + end; + end if; + + if not Is_Frozen (E) then + Flist := Freeze_Entity (E, Loc); + Process_Flist; + end if; + + Next_Entity (E); + end loop; + end Freeze_All_Ent; + + -- Start of processing for Freeze_All + + begin + Freeze_All_Ent (From, After); + + -- Now that all types are frozen, we can deal with default expressions + -- that require us to build a default expression functions. This is the + -- point at which such functions are constructed (after all types that + -- might be used in such expressions have been frozen). + -- We also add finalization chains to access types whose designated + -- types are controlled. This is normally done when freezing the type, + -- but this misses recursive type definitions where the later members + -- of the recursion introduce controlled components (e.g. 5624-001). + + -- Loop through entities + + E := From; + while Present (E) loop + + if Is_Subprogram (E) then + + if not Default_Expressions_Processed (E) then + Process_Default_Expressions (E, After); + end if; + + if not Has_Completion (E) then + Decl := Unit_Declaration_Node (E); + + if Nkind (Decl) = N_Subprogram_Renaming_Declaration then + Build_And_Analyze_Renamed_Body (Decl, E, After); + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + and then + Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) + = N_Subprogram_Renaming_Declaration + then + Build_And_Analyze_Renamed_Body + (Decl, Corresponding_Body (Decl), After); + end if; + end if; + + elsif Ekind (E) in Task_Kind + and then + (Nkind (Parent (E)) = N_Task_Type_Declaration + or else + Nkind (Parent (E)) = N_Single_Task_Declaration) + then + declare + Ent : Entity_Id; + + begin + Ent := First_Entity (E); + + while Present (Ent) loop + + if Is_Entry (Ent) + and then not Default_Expressions_Processed (Ent) + then + Process_Default_Expressions (Ent, After); + end if; + + Next_Entity (Ent); + end loop; + end; + + elsif Is_Access_Type (E) + and then Comes_From_Source (E) + and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type + and then Controlled_Type (Designated_Type (E)) + and then No (Associated_Final_Chain (E)) + then + Build_Final_List (Parent (E), E); + end if; + + Next_Entity (E); + end loop; + + end Freeze_All; + + ----------------------- + -- Freeze_And_Append -- + ----------------------- + + procedure Freeze_And_Append + (Ent : Entity_Id; + Loc : Source_Ptr; + Result : in out List_Id) + is + L : constant List_Id := Freeze_Entity (Ent, Loc); + + begin + if Is_Non_Empty_List (L) then + if Result = No_List then + Result := L; + else + Append_List (L, Result); + end if; + end if; + end Freeze_And_Append; + + ------------------- + -- Freeze_Before -- + ------------------- + + procedure Freeze_Before (N : Node_Id; T : Entity_Id) is + Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N)); + F : Node_Id; + + begin + if Is_Non_Empty_List (Freeze_Nodes) then + F := First (Freeze_Nodes); + + if Present (F) then + Insert_Actions (N, Freeze_Nodes); + end if; + end if; + end Freeze_Before; + + ------------------- + -- Freeze_Entity -- + ------------------- + + function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id is + Comp : Entity_Id; + F_Node : Node_Id; + Result : List_Id; + Indx : Node_Id; + Formal : Entity_Id; + Atype : Entity_Id; + + procedure Check_Current_Instance (Comp_Decl : Node_Id); + -- Check that an Access or Unchecked_Access attribute with + -- a prefix which is the current instance type can only be + -- applied when the type is limited. + + function After_Last_Declaration return Boolean; + -- If Loc is a freeze_entity that appears after the last declaration + -- in the scope, inhibit error messages on late completion. + + procedure Freeze_Record_Type (Rec : Entity_Id); + -- Freeze each component, handle some representation clauses, and + -- freeze primitive operations if this is a tagged type. + + ---------------------------- + -- After_Last_Declaration -- + ---------------------------- + + function After_Last_Declaration return Boolean is + Spec : Node_Id := Parent (Current_Scope); + + begin + if Nkind (Spec) = N_Package_Specification then + if Present (Private_Declarations (Spec)) then + return Loc >= Sloc (Last (Private_Declarations (Spec))); + + elsif Present (Visible_Declarations (Spec)) then + return Loc >= Sloc (Last (Visible_Declarations (Spec))); + else + return False; + end if; + + else + return False; + end if; + end After_Last_Declaration; + + ---------------------------- + -- Check_Current_Instance -- + ---------------------------- + + procedure Check_Current_Instance (Comp_Decl : Node_Id) is + + function Process (N : Node_Id) return Traverse_Result; + -- Process routine to apply check to given node. + + function Process (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Attribute_Reference => + if (Attribute_Name (N) = Name_Access + or else + Attribute_Name (N) = Name_Unchecked_Access) + and then Is_Entity_Name (Prefix (N)) + and then Is_Type (Entity (Prefix (N))) + and then Entity (Prefix (N)) = E + then + Error_Msg_N + ("current instance must be a limited type", Prefix (N)); + return Abandon; + else + return OK; + end if; + + when others => return OK; + end case; + end Process; + + procedure Traverse is new Traverse_Proc (Process); + + -- Start of processing for Check_Current_Instance + + begin + Traverse (Comp_Decl); + end Check_Current_Instance; + + ------------------------ + -- Freeze_Record_Type -- + ------------------------ + + procedure Freeze_Record_Type (Rec : Entity_Id) is + Comp : Entity_Id; + Junk : Boolean; + ADC : Node_Id; + + Unplaced_Component : Boolean := False; + -- Set True if we find at least one component with no component + -- clause (used to warn about useless Pack pragmas). + + Placed_Component : Boolean := False; + -- Set True if we find at least one component with a component + -- clause (used to warn about useless Bit_Order pragmas). + + begin + -- Freeze components and embedded subtypes + + Comp := First_Entity (Rec); + + while Present (Comp) loop + + if not Is_Type (Comp) then + Freeze_And_Append (Etype (Comp), Loc, Result); + end if; + + -- If the component is an access type with an allocator + -- as default value, the designated type will be frozen + -- by the corresponding expression in init_proc. In order + -- to place the freeze node for the designated type before + -- that for the current record type, freeze it now. + + -- Same process if the component is an array of access types, + -- initialized with an aggregate. If the designated type is + -- private, it cannot contain allocators, and it is premature + -- to freeze the type, so we check for this as well. + + if Is_Access_Type (Etype (Comp)) + and then Present (Parent (Comp)) + and then Present (Expression (Parent (Comp))) + and then Nkind (Expression (Parent (Comp))) = N_Allocator + then + declare + Alloc : constant Node_Id := Expression (Parent (Comp)); + + begin + -- If component is pointer to a classwide type, freeze + -- the specific type in the expression being allocated. + -- The expression may be a subtype indication, in which + -- case freeze the subtype mark. + + if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then + + if Is_Entity_Name (Expression (Alloc)) then + Freeze_And_Append + (Entity (Expression (Alloc)), Loc, Result); + elsif + Nkind (Expression (Alloc)) = N_Subtype_Indication + then + Freeze_And_Append + (Entity (Subtype_Mark (Expression (Alloc))), + Loc, Result); + end if; + else + Freeze_And_Append + (Designated_Type (Etype (Comp)), Loc, Result); + end if; + end; + + elsif Is_Array_Type (Etype (Comp)) + and then Is_Access_Type (Component_Type (Etype (Comp))) + and then Present (Parent (Comp)) + and then Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp))) + and then Nkind (Expression (Parent (Comp))) = N_Aggregate + and then Is_Fully_Defined + (Designated_Type (Component_Type (Etype (Comp)))) + then + Freeze_And_Append + (Designated_Type + (Component_Type (Etype (Comp))), Loc, Result); + end if; + + -- Processing for real components (exclude anonymous subtypes) + + if Ekind (Comp) = E_Component + or else Ekind (Comp) = E_Discriminant + then + -- Check for error of component clause given for variable + -- sized type. We have to delay this test till this point, + -- since the component type has to be frozen for us to know + -- if it is variable length. We omit this test in a generic + -- context, it will be applied at instantiation time. + + declare + CC : constant Node_Id := Component_Clause (Comp); + + begin + if Present (CC) then + Placed_Component := True; + + if not Size_Known_At_Compile_Time + (Underlying_Type (Etype (Comp))) + and then not Inside_A_Generic + then + Error_Msg_N + ("component clause not allowed for variable " & + "length component", CC); + end if; + + else + Unplaced_Component := True; + end if; + end; + + -- If component clause is present, then deal with the + -- non-default bit order case. We cannot do this before + -- the freeze point, because there is no required order + -- for the component clause and the bit_order clause. + + -- We only do this processing for the base type, and in + -- fact that's important, since otherwise if there are + -- record subtypes, we could reverse the bits once for + -- each subtype, which would be incorrect. + + if Present (Component_Clause (Comp)) + and then Reverse_Bit_Order (Rec) + and then Ekind (E) = E_Record_Type + then + declare + CFB : constant Uint := Component_Bit_Offset (Comp); + CSZ : constant Uint := Esize (Comp); + CLC : constant Node_Id := Component_Clause (Comp); + Pos : constant Node_Id := Position (CLC); + FB : constant Node_Id := First_Bit (CLC); + + Storage_Unit_Offset : constant Uint := + CFB / System_Storage_Unit; + + Start_Bit : constant Uint := + CFB mod System_Storage_Unit; + + begin + -- Cases where field goes over storage unit boundary + + if Start_Bit + CSZ > System_Storage_Unit then + + -- Allow multi-byte field but generate warning + + if Start_Bit mod System_Storage_Unit = 0 + and then CSZ mod System_Storage_Unit = 0 + then + Error_Msg_N + ("multi-byte field specified with non-standard" + & " Bit_Order?", CLC); + + if Bytes_Big_Endian then + Error_Msg_N + ("bytes are not reversed " + & "(component is big-endian)?", CLC); + else + Error_Msg_N + ("bytes are not reversed " + & "(component is little-endian)?", CLC); + end if; + + -- Do not allow non-contiguous field + + else + Error_Msg_N + ("attempt to specify non-contiguous field" + & " not permitted", CLC); + Error_Msg_N + ("\(caused by non-standard Bit_Order " + & "specified)", CLC); + end if; + + -- Case where field fits in one storage unit + + else + -- Give warning if suspicious component clause + + if Intval (FB) >= System_Storage_Unit then + Error_Msg_N + ("?Bit_Order clause does not affect " & + "byte ordering", Pos); + Error_Msg_Uint_1 := + Intval (Pos) + Intval (FB) / System_Storage_Unit; + Error_Msg_N + ("?position normalized to ^ before bit " & + "order interpreted", Pos); + end if; + + -- Here is where we fix up the Component_Bit_Offset + -- value to account for the reverse bit order. + -- Some examples of what needs to be done are: + + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new + + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 + + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 + + -- The general rule is that the first bit is + -- is obtained by subtracting the old ending bit + -- from storage_unit - 1. + + Set_Component_Bit_Offset (Comp, + (Storage_Unit_Offset * System_Storage_Unit) + + (System_Storage_Unit - 1) + - (Start_Bit + CSZ - 1)); + + Set_Normalized_First_Bit (Comp, + Component_Bit_Offset (Comp) mod System_Storage_Unit); + end if; + end; + end if; + end if; + + Next_Entity (Comp); + end loop; + + -- Check for useless pragma Bit_Order + + if not Placed_Component and then Reverse_Bit_Order (Rec) then + ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); + Error_Msg_N ("?Bit_Order specification has no effect", ADC); + Error_Msg_N ("\?since no component clauses were specified", ADC); + end if; + + -- Check for useless pragma Pack when all components placed + + if Is_Packed (Rec) + and then not Unplaced_Component + and then Warn_On_Redundant_Constructs + then + Error_Msg_N + ("?pragma Pack has no effect, no unplaced components", + Get_Rep_Pragma (Rec, Name_Pack)); + Set_Is_Packed (Rec, False); + end if; + + -- If this is the record corresponding to a remote type, + -- freeze the remote type here since that is what we are + -- semantically freeing. This prevents having the freeze node + -- for that type in an inner scope. + + -- Also, Check for controlled components and unchecked unions. + -- Finally, enforce the restriction that access attributes with + -- a current instance prefix can only apply to limited types. + + if Ekind (Rec) = E_Record_Type then + + if Present (Corresponding_Remote_Type (Rec)) then + Freeze_And_Append + (Corresponding_Remote_Type (Rec), Loc, Result); + end if; + + Comp := First_Component (Rec); + + while Present (Comp) loop + if Has_Controlled_Component (Etype (Comp)) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + or else (Is_Protected_Type (Etype (Comp)) + and then Present + (Corresponding_Record_Type (Etype (Comp))) + and then Has_Controlled_Component + (Corresponding_Record_Type (Etype (Comp)))) + then + Set_Has_Controlled_Component (Rec); + exit; + end if; + + if Has_Unchecked_Union (Etype (Comp)) then + Set_Has_Unchecked_Union (Rec); + end if; + + if Has_Per_Object_Constraint (Comp) + and then not Is_Limited_Type (Rec) + then + -- Scan component declaration for likely misuses of + -- current instance, either in a constraint or in a + -- default expression. + + Check_Current_Instance (Parent (Comp)); + end if; + + Next_Component (Comp); + end loop; + end if; + + Set_Component_Alignment_If_Not_Set (Rec); + + -- For first subtypes, check if there are any fixed-point + -- fields with component clauses, where we must check the size. + -- This is not done till the freeze point, since for fixed-point + -- types, we do not know the size until the type is frozen. + + if Is_First_Subtype (Rec) then + Comp := First_Component (Rec); + + while Present (Comp) loop + if Present (Component_Clause (Comp)) + and then Is_Fixed_Point_Type (Etype (Comp)) + then + Check_Size + (Component_Clause (Comp), + Etype (Comp), + Esize (Comp), + Junk); + end if; + + Next_Component (Comp); + end loop; + end if; + end Freeze_Record_Type; + + -- Start of processing for Freeze_Entity + + begin + -- Do not freeze if already frozen since we only need one freeze node. + + if Is_Frozen (E) then + return No_List; + + -- It is improper to freeze an external entity within a generic + -- because its freeze node will appear in a non-valid context. + -- ??? We should probably freeze the entity at that point and insert + -- the freeze node in a proper place but this proper place is not + -- easy to find, and the proper scope is not easy to restore. For + -- now, just wait to get out of the generic to freeze ??? + + elsif Inside_A_Generic and then External_Ref_In_Generic (E) then + return No_List; + + -- Do not freeze a global entity within an inner scope created during + -- expansion. A call to subprogram E within some internal procedure + -- (a stream attribute for example) might require freezing E, but the + -- freeze node must appear in the same declarative part as E itself. + -- The two-pass elaboration mechanism in gigi guarantees that E will + -- be frozen before the inner call is elaborated. We exclude constants + -- from this test, because deferred constants may be frozen early, and + -- must be diagnosed (see e.g. 1522-005). If the enclosing subprogram + -- comes from source, or is a generic instance, then the freeze point + -- is the one mandated by the language. and we freze the entity. + + elsif In_Open_Scopes (Scope (E)) + and then Scope (E) /= Current_Scope + and then Ekind (E) /= E_Constant + then + declare + S : Entity_Id := Current_Scope; + + begin + while Present (S) loop + if Is_Overloadable (S) then + if Comes_From_Source (S) + or else Is_Generic_Instance (S) + then + exit; + else + return No_List; + end if; + end if; + + S := Scope (S); + end loop; + end; + end if; + + -- Here to freeze the entity + + Result := No_List; + Set_Is_Frozen (E); + + -- Case of entity being frozen is other than a type + + if not Is_Type (E) then + + -- If entity is exported or imported and does not have an external + -- name, now is the time to provide the appropriate default name. + -- Skip this if the entity is stubbed, since we don't need a name + -- for any stubbed routine. + + if (Is_Imported (E) or else Is_Exported (E)) + and then No (Interface_Name (E)) + and then Convention (E) /= Convention_Stubbed + then + Set_Encoded_Interface_Name + (E, Get_Default_External_Name (E)); + end if; + + -- For a subprogram, freeze all parameter types and also the return + -- type (RM 13.14(13)). However skip this for internal subprograms. + -- This is also the point where any extra formal parameters are + -- created since we now know whether the subprogram will use + -- a foreign convention. + + if Is_Subprogram (E) then + + if not Is_Internal (E) then + + declare + F_Type : Entity_Id; + + function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean; + -- Determines if given type entity is a fat pointer type + -- used as an argument type or return type to a subprogram + -- with C or C++ convention set. + + -------------------------- + -- Is_Fat_C_Access_Type -- + -------------------------- + + function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean is + begin + return (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then Is_Access_Type (T) + and then Esize (T) > Ttypes.System_Address_Size; + end Is_Fat_C_Ptr_Type; + + begin + -- Loop through formals + + Formal := First_Formal (E); + + while Present (Formal) loop + + F_Type := Etype (Formal); + Freeze_And_Append (F_Type, Loc, Result); + + if Is_Private_Type (F_Type) + and then Is_Private_Type (Base_Type (F_Type)) + and then No (Full_View (Base_Type (F_Type))) + and then not Is_Generic_Type (F_Type) + and then not Is_Derived_Type (F_Type) + then + -- If the type of a formal is incomplete, subprogram + -- is being frozen prematurely. Within an instance + -- (but not within a wrapper package) this is an + -- an artifact of our need to regard the end of an + -- instantiation as a freeze point. Otherwise it is + -- a definite error. + -- and then not Is_Wrapper_Package (Current_Scope) ??? + + if In_Instance then + Set_Is_Frozen (E, False); + return No_List; + + elsif not After_Last_Declaration then + Error_Msg_Node_1 := F_Type; + Error_Msg + ("type& must be fully defined before this point", + Loc); + end if; + end if; + + -- Check bad use of fat C pointer + + if Is_Fat_C_Ptr_Type (F_Type) then + Error_Msg_Qual_Level := 1; + Error_Msg_N + ("?type of & does not correspond to C pointer", + Formal); + Error_Msg_Qual_Level := 0; + end if; + + -- Check for unconstrained array in exported foreign + -- convention case. + + if Convention (E) in Foreign_Convention + and then not Is_Imported (E) + and then Is_Array_Type (F_Type) + and then not Is_Constrained (F_Type) + then + Error_Msg_Qual_Level := 1; + Error_Msg_N + ("?type of argument& is unconstrained array", + Formal); + Error_Msg_N + ("?foreign caller must pass bounds explicitly", + Formal); + Error_Msg_Qual_Level := 0; + end if; + + Next_Formal (Formal); + end loop; + + -- Check return type + + if Ekind (E) = E_Function then + Freeze_And_Append (Etype (E), Loc, Result); + + if Is_Fat_C_Ptr_Type (Etype (E)) then + Error_Msg_N + ("?return type of& does not correspond to C pointer", + E); + + elsif Is_Array_Type (Etype (E)) + and then not Is_Constrained (Etype (E)) + and then not Is_Imported (E) + and then Convention (E) in Foreign_Convention + then + Error_Msg_N + ("foreign convention function may not " & + "return unconstrained array", E); + end if; + end if; + end; + end if; + + -- Must freeze its parent first if it is a derived subprogram + + if Present (Alias (E)) then + Freeze_And_Append (Alias (E), Loc, Result); + end if; + + -- If the return type requires a transient scope, and we are on + -- a target allowing functions to return with a depressed stack + -- pointer, then we mark the function as requiring this treatment. + + if Ekind (E) = E_Function + and then Functions_Return_By_DSP_On_Target + and then Requires_Transient_Scope (Etype (E)) + then + Set_Function_Returns_With_DSP (E); + end if; + + if not Is_Internal (E) then + Freeze_Subprogram (E); + end if; + + -- Here for other than a subprogram or type + + else + -- If entity has a type, and it is not a generic unit, then + -- freeze it first (RM 13.14(10)) + + if Present (Etype (E)) + and then Ekind (E) /= E_Generic_Function + then + Freeze_And_Append (Etype (E), Loc, Result); + end if; + + -- For object created by object declaration, perform required + -- categorization (preelaborate and pure) checks. Defer these + -- checks to freeze time since pragma Import inhibits default + -- initialization and thus pragma Import affects these checks. + + if Nkind (Declaration_Node (E)) = N_Object_Declaration then + Validate_Object_Declaration (Declaration_Node (E)); + end if; + + -- Check that a constant which has a pragma Volatile[_Components] + -- or Atomic[_Components] also has a pragma Import (RM C.6(13)) + + -- Note: Atomic[_Components] also sets Volatile[_Components] + + if Ekind (E) = E_Constant + and then (Has_Volatile_Components (E) or else Is_Volatile (E)) + and then not Is_Imported (E) + then + -- Make sure we actually have a pragma, and have not merely + -- inherited the indication from elsewhere (e.g. an address + -- clause, which is not good enough in RM terms!) + + if Present (Get_Rep_Pragma (E, Name_Atomic)) or else + Present (Get_Rep_Pragma (E, Name_Atomic_Components)) or else + Present (Get_Rep_Pragma (E, Name_Volatile)) or else + Present (Get_Rep_Pragma (E, Name_Volatile_Components)) + then + Error_Msg_N + ("stand alone atomic/volatile constant must be imported", + E); + end if; + end if; + + -- Static objects require special handling + + if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then Is_Statically_Allocated (E) + then + Freeze_Static_Object (E); + end if; + + -- Remaining step is to layout objects + + if Ekind (E) = E_Variable + or else + Ekind (E) = E_Constant + or else + Ekind (E) = E_Loop_Parameter + or else + Is_Formal (E) + then + Layout_Object (E); + end if; + end if; + + -- Case of a type or subtype being frozen + + else + -- The type may be defined in a generic unit. This can occur when + -- freezing a generic function that returns the type (which is + -- defined in a parent unit). It is clearly meaningless to freeze + -- this type. However, if it is a subtype, its size may be determi- + -- nable and used in subsequent checks, so might as well try to + -- compute it. + + if Present (Scope (E)) + and then Is_Generic_Unit (Scope (E)) + then + Check_Compile_Time_Size (E); + return No_List; + end if; + + -- Deal with special cases of freezing for subtype + + if E /= Base_Type (E) then + + -- If ancestor subtype present, freeze that first. + -- Note that this will also get the base type frozen. + + Atype := Ancestor_Subtype (E); + + if Present (Atype) then + Freeze_And_Append (Atype, Loc, Result); + + -- Otherwise freeze the base type of the entity before + -- freezing the entity itself, (RM 13.14(14)). + + elsif E /= Base_Type (E) then + Freeze_And_Append (Base_Type (E), Loc, Result); + end if; + + -- For a derived type, freeze its parent type first (RM 13.14(14)) + + elsif Is_Derived_Type (E) then + Freeze_And_Append (Etype (E), Loc, Result); + Freeze_And_Append (First_Subtype (Etype (E)), Loc, Result); + end if; + + -- For array type, freeze index types and component type first + -- before freezing the array (RM 13.14(14)). + + if Is_Array_Type (E) then + declare + Ctyp : constant Entity_Id := Component_Type (E); + + Non_Standard_Enum : Boolean := False; + -- Set true if any of the index types is an enumeration + -- type with a non-standard representation. + + begin + Freeze_And_Append (Ctyp, Loc, Result); + + Indx := First_Index (E); + while Present (Indx) loop + Freeze_And_Append (Etype (Indx), Loc, Result); + + if Is_Enumeration_Type (Etype (Indx)) + and then Has_Non_Standard_Rep (Etype (Indx)) + then + Non_Standard_Enum := True; + end if; + + Next_Index (Indx); + end loop; + + -- For base type, propagate flags for component type + + if Ekind (E) = E_Array_Type then + if Is_Controlled (Component_Type (E)) + or else Has_Controlled_Component (Ctyp) + then + Set_Has_Controlled_Component (E); + end if; + + if Has_Unchecked_Union (Component_Type (E)) then + Set_Has_Unchecked_Union (E); + end if; + end if; + + -- If packing was requested or if the component size was set + -- explicitly, then see if bit packing is required. This + -- processing is only done for base types, since all the + -- representation aspects involved are type-related. This + -- is not just an optimization, if we start processing the + -- subtypes, they intefere with the settings on the base + -- type (this is because Is_Packed has a slightly different + -- meaning before and after freezing). + + if E = Base_Type (E) then + declare + Csiz : Uint; + Esiz : Uint; + + begin + if (Is_Packed (E) or else Has_Pragma_Pack (E)) + and then not Has_Atomic_Components (E) + and then Known_Static_RM_Size (Ctyp) + then + Csiz := UI_Max (RM_Size (Ctyp), 1); + + elsif Known_Component_Size (E) then + Csiz := Component_Size (E); + + elsif not Known_Static_Esize (Ctyp) then + Csiz := Uint_0; + + else + Esiz := Esize (Ctyp); + + -- We can set the component size if it is less than + -- 16, rounding it up to the next storage unit size. + + if Esiz <= 8 then + Csiz := Uint_8; + elsif Esiz <= 16 then + Csiz := Uint_16; + else + Csiz := Uint_0; + end if; + + -- Set component size up to match alignment if + -- it would otherwise be less than the alignment. + -- This deals with cases of types whose alignment + -- exceeds their sizes (padded types). + + if Csiz /= 0 then + declare + A : constant Uint := Alignment_In_Bits (Ctyp); + + begin + if Csiz < A then + Csiz := A; + end if; + end; + end if; + + end if; + + if 1 <= Csiz and then Csiz <= 64 then + + -- We set the component size for all cases 1-64 + + Set_Component_Size (Base_Type (E), Csiz); + + -- Actual packing is not needed for 8,16,32,64 + -- Also not needed for 24 if alignment is 1 + + if Csiz = 8 + or else Csiz = 16 + or else Csiz = 32 + or else Csiz = 64 + or else (Csiz = 24 and then Alignment (Ctyp) = 1) + then + -- Here the array was requested to be packed, but + -- the packing request had no effect, so Is_Packed + -- is reset. + + -- Note: semantically this means that we lose + -- track of the fact that a derived type inherited + -- a pack pragma that was non-effective, but that + -- seems fine. + + -- We regard a Pack pragma as a request to set a + -- representation characteristic, and this request + -- may be ignored. + + Set_Is_Packed (Base_Type (E), False); + + -- In all other cases, packing is indeed needed + + else + Set_Has_Non_Standard_Rep (Base_Type (E)); + Set_Is_Bit_Packed_Array (Base_Type (E)); + Set_Is_Packed (Base_Type (E)); + end if; + end if; + end; + end if; + + -- If any of the index types was an enumeration type with + -- a non-standard rep clause, then we indicate that the + -- array type is always packed (even if it is not bit packed). + + if Non_Standard_Enum then + Set_Has_Non_Standard_Rep (Base_Type (E)); + Set_Is_Packed (Base_Type (E)); + end if; + end; + + Set_Component_Alignment_If_Not_Set (E); + + -- If the array is packed, we must create the packed array + -- type to be used to actually implement the type. This is + -- only needed for real array types (not for string literal + -- types, since they are present only for the front end). + + if Is_Packed (E) + and then Ekind (E) /= E_String_Literal_Subtype + then + Create_Packed_Array_Type (E); + Freeze_And_Append (Packed_Array_Type (E), Loc, Result); + + -- Size information of packed array type is copied to the + -- array type, since this is really the representation. + + Set_Size_Info (E, Packed_Array_Type (E)); + Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); + end if; + + -- For a class wide type, the corresponding specific type is + -- frozen as well (RM 13.14(14)) + + elsif Is_Class_Wide_Type (E) then + Freeze_And_Append (Root_Type (E), Loc, Result); + + -- If the Class_Wide_Type is an Itype (when type is the anonymous + -- parent of a derived type) and it is a library-level entity, + -- generate an itype reference for it. Otherwise, its first + -- explicit reference may be in an inner scope, which will be + -- rejected by the back-end. + + if Is_Itype (E) + and then Is_Compilation_Unit (Scope (E)) + then + + declare + Ref : Node_Id := Make_Itype_Reference (Loc); + + begin + Set_Itype (Ref, E); + if No (Result) then + Result := New_List (Ref); + else + Append (Ref, Result); + end if; + end; + end if; + + -- For record (sub)type, freeze all the component types (RM + -- 13.14(14). We test for E_Record_(sub)Type here, rather than + -- using Is_Record_Type, because we don't want to attempt the + -- freeze for the case of a private type with record extension + -- (we will do that later when the full type is frozen). + + elsif Ekind (E) = E_Record_Type + or else Ekind (E) = E_Record_Subtype + then + Freeze_Record_Type (E); + + -- For a concurrent type, freeze corresponding record type. This + -- does not correpond to any specific rule in the RM, but the + -- record type is essentially part of the concurrent type. + -- Freeze as well all local entities. This includes record types + -- created for entry parameter blocks, and whatever local entities + -- may appear in the private part. + + elsif Is_Concurrent_Type (E) then + if Present (Corresponding_Record_Type (E)) then + Freeze_And_Append + (Corresponding_Record_Type (E), Loc, Result); + end if; + + Comp := First_Entity (E); + + while Present (Comp) loop + if Is_Type (Comp) then + Freeze_And_Append (Comp, Loc, Result); + + elsif (Ekind (Comp)) /= E_Function then + Freeze_And_Append (Etype (Comp), Loc, Result); + end if; + + Next_Entity (Comp); + end loop; + + -- Private types are required to point to the same freeze node + -- as their corresponding full views. The freeze node itself + -- has to point to the partial view of the entity (because + -- from the partial view, we can retrieve the full view, but + -- not the reverse). However, in order to freeze correctly, + -- we need to freeze the full view. If we are freezing at the + -- end of a scope (or within the scope of the private type), + -- the partial and full views will have been swapped, the + -- full view appears first in the entity chain and the swapping + -- mechanism enusres that the pointers are properly set (on + -- scope exit). + + -- If we encounter the partial view before the full view + -- (e.g. when freezing from another scope), we freeze the + -- full view, and then set the pointers appropriately since + -- we cannot rely on swapping to fix things up (subtypes in an + -- outer scope might not get swapped). + + elsif Is_Incomplete_Or_Private_Type (E) + and then not Is_Generic_Type (E) + then + -- Case of full view present + + if Present (Full_View (E)) then + + -- If full view has already been frozen, then no + -- further processing is required + + if Is_Frozen (Full_View (E)) then + + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + Check_Debug_Info_Needed (E); + + -- Otherwise freeze full view and patch the pointers + + else + if Is_Private_Type (Full_View (E)) + and then Present (Underlying_Full_View (Full_View (E))) + then + Freeze_And_Append + (Underlying_Full_View (Full_View (E)), Loc, Result); + end if; + + Freeze_And_Append (Full_View (E), Loc, Result); + + if Has_Delayed_Freeze (E) then + F_Node := Freeze_Node (Full_View (E)); + + if Present (F_Node) then + Set_Freeze_Node (E, F_Node); + Set_Entity (F_Node, E); + else + -- {Incomplete,Private}_Subtypes + -- with Full_Views constrained by discriminants + + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + end if; + end if; + + Check_Debug_Info_Needed (E); + end if; + + -- AI-117 requires that the convention of a partial view + -- be the same as the convention of the full view. Note + -- that this is a recognized breach of privacy, but it's + -- essential for logical consistency of representation, + -- and the lack of a rule in RM95 was an oversight. + + Set_Convention (E, Convention (Full_View (E))); + + Set_Size_Known_At_Compile_Time (E, + Size_Known_At_Compile_Time (Full_View (E))); + + -- Size information is copied from the full view to the + -- incomplete or private view for consistency + + -- We skip this is the full view is not a type. This is + -- very strange of course, and can only happen as a result + -- of certain illegalities, such as a premature attempt to + -- derive from an incomplete type. + + if Is_Type (Full_View (E)) then + Set_Size_Info (E, Full_View (E)); + Set_RM_Size (E, RM_Size (Full_View (E))); + end if; + + return Result; + + -- Case of no full view present. If entity is derived or subtype, + -- it is safe to freeze, correctness depends on the frozen status + -- of parent. Otherwise it is either premature usage, or a Taft + -- amendment type, so diagnosis is at the point of use and the + -- type might be frozen later. + + elsif E /= Base_Type (E) + or else Is_Derived_Type (E) + then + null; + + else + Set_Is_Frozen (E, False); + return No_List; + end if; + + -- For access subprogram, freeze types of all formals, the return + -- type was already frozen, since it is the Etype of the function. + + elsif Ekind (E) = E_Subprogram_Type then + Formal := First_Formal (E); + while Present (Formal) loop + Freeze_And_Append (Etype (Formal), Loc, Result); + Next_Formal (Formal); + end loop; + + -- If the return type requires a transient scope, and we are on + -- a target allowing functions to return with a depressed stack + -- pointer, then we mark the function as requiring this treatment. + + if Functions_Return_By_DSP_On_Target + and then Requires_Transient_Scope (Etype (E)) + then + Set_Function_Returns_With_DSP (E); + end if; + + Freeze_Subprogram (E); + + -- For access to a protected subprogram, freeze the equivalent + -- type (however this is not set if we are not generating code) + -- or if this is an anonymous type used just for resolution). + + elsif Ekind (E) = E_Access_Protected_Subprogram_Type + and then Operating_Mode = Generate_Code + and then Present (Equivalent_Type (E)) + then + Freeze_And_Append (Equivalent_Type (E), Loc, Result); + end if; + + -- Generic types are never seen by the back-end, and are also not + -- processed by the expander (since the expander is turned off for + -- generic processing), so we never need freeze nodes for them. + + if Is_Generic_Type (E) then + return Result; + end if; + + -- Some special processing for non-generic types to complete + -- representation details not known till the freeze point. + + if Is_Fixed_Point_Type (E) then + Freeze_Fixed_Point_Type (E); + + elsif Is_Enumeration_Type (E) then + Freeze_Enumeration_Type (E); + + elsif Is_Integer_Type (E) then + Adjust_Esize_For_Alignment (E); + + elsif Is_Access_Type (E) + and then No (Associated_Storage_Pool (E)) + then + Check_Restriction (No_Standard_Storage_Pools, E); + end if; + + -- If the current entity is an array or record subtype and has + -- discriminants used to constrain it, it must not freeze, because + -- Freeze_Entity nodes force Gigi to process the frozen type. + + if Is_Composite_Type (E) then + + if Is_Array_Type (E) then + + declare + Index : Node_Id := First_Index (E); + Expr1 : Node_Id; + Expr2 : Node_Id; + + begin + while Present (Index) loop + if Etype (Index) /= Any_Type then + Get_Index_Bounds (Index, Expr1, Expr2); + + for J in 1 .. 2 loop + if Nkind (Expr1) = N_Identifier + and then Ekind (Entity (Expr1)) = E_Discriminant + then + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + Check_Debug_Info_Needed (E); + return Result; + end if; + + Expr1 := Expr2; + end loop; + end if; + + Next_Index (Index); + end loop; + end; + + elsif Has_Discriminants (E) + and Is_Constrained (E) + then + + declare + Constraint : Elmt_Id; + Expr : Node_Id; + begin + Constraint := First_Elmt (Discriminant_Constraint (E)); + + while Present (Constraint) loop + + Expr := Node (Constraint); + if Nkind (Expr) = N_Identifier + and then Ekind (Entity (Expr)) = E_Discriminant + then + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + Check_Debug_Info_Needed (E); + return Result; + end if; + + Next_Elmt (Constraint); + end loop; + end; + + end if; + + -- AI-117 requires that all new primitives of a tagged type + -- must inherit the convention of the full view of the type. + -- Inherited and overriding operations are defined to inherit + -- the convention of their parent or overridden subprogram + -- (also specified in AI-117), and that will have occurred + -- earlier (in Derive_Subprogram and New_Overloaded_Entity). + -- Here we set the convention of primitives that are still + -- convention Ada, which will ensure that any new primitives + -- inherit the type's convention. Class-wide types can have + -- a foreign convention inherited from their specific type, + -- but are excluded from this since they don't have any + -- associated primitives. + + if Is_Tagged_Type (E) + and then not Is_Class_Wide_Type (E) + and then Convention (E) /= Convention_Ada + then + declare + Prim_List : constant Elist_Id := Primitive_Operations (E); + Prim : Elmt_Id := First_Elmt (Prim_List); + + begin + while Present (Prim) loop + if Convention (Node (Prim)) = Convention_Ada then + Set_Convention (Node (Prim), Convention (E)); + end if; + + Next_Elmt (Prim); + end loop; + end; + end if; + end if; + + -- Now that all types from which E may depend are frozen, see + -- if the size is known at compile time, if it must be unsigned, + -- or if strict alignent is required + + Check_Compile_Time_Size (E); + Check_Unsigned_Type (E); + + if Base_Type (E) = E then + Check_Strict_Alignment (E); + end if; + + -- Do not allow a size clause for a type which does not have a size + -- that is known at compile time + + if Has_Size_Clause (E) + and then not Size_Known_At_Compile_Time (E) + then + Error_Msg_N + ("size clause not allowed for variable length type", + Size_Clause (E)); + end if; + + -- Remaining process is to set/verify the representation information, + -- in particular the size and alignment values. This processing is + -- not required for generic types, since generic types do not play + -- any part in code generation, and so the size and alignment values + -- for suhc types are irrelevant. + + if Is_Generic_Type (E) then + return Result; + + -- Otherwise we call the layout procedure + + else + Layout_Type (E); + end if; + + -- End of freeze processing for type entities + end if; + + -- Here is where we logically freeze the current entity. If it has a + -- freeze node, then this is the point at which the freeze node is + -- linked into the result list. + + if Has_Delayed_Freeze (E) then + + -- If a freeze node is already allocated, use it, otherwise allocate + -- a new one. The preallocation happens in the case of anonymous base + -- types, where we preallocate so that we can set First_Subtype_Link. + -- Note that we reset the Sloc to the current freeze location. + + if Present (Freeze_Node (E)) then + F_Node := Freeze_Node (E); + Set_Sloc (F_Node, Loc); + + else + F_Node := New_Node (N_Freeze_Entity, Loc); + Set_Freeze_Node (E, F_Node); + Set_Access_Types_To_Process (F_Node, No_Elist); + Set_TSS_Elist (F_Node, No_Elist); + Set_Actions (F_Node, No_List); + end if; + + Set_Entity (F_Node, E); + + if Result = No_List then + Result := New_List (F_Node); + else + Append (F_Node, Result); + end if; + + end if; + + -- When a type is frozen, the first subtype of the type is frozen as + -- well (RM 13.14(15)). This has to be done after freezing the type, + -- since obviously the first subtype depends on its own base type. + + if Is_Type (E) then + Freeze_And_Append (First_Subtype (E), Loc, Result); + + -- If we just froze a tagged non-class wide record, then freeze the + -- corresponding class-wide type. This must be done after the tagged + -- type itself is frozen, because the class-wide type refers to the + -- tagged type which generates the class. + + if Is_Tagged_Type (E) + and then not Is_Class_Wide_Type (E) + and then Present (Class_Wide_Type (E)) + then + Freeze_And_Append (Class_Wide_Type (E), Loc, Result); + end if; + end if; + + Check_Debug_Info_Needed (E); + + -- Special handling for subprograms + + if Is_Subprogram (E) then + + -- If subprogram has address clause then reset Is_Public flag, since + -- we do not want the backend to generate external references. + + if Present (Address_Clause (E)) + and then not Is_Library_Level_Entity (E) + then + Set_Is_Public (E, False); + + -- If no address clause and not intrinsic, then for imported + -- subprogram in main unit, generate descriptor if we are in + -- Propagate_Exceptions mode. + + elsif Propagate_Exceptions + and then Is_Imported (E) + and then not Is_Intrinsic_Subprogram (E) + and then Convention (E) /= Convention_Stubbed + then + if Result = No_List then + Result := Empty_List; + end if; + + Generate_Subprogram_Descriptor_For_Imported_Subprogram + (E, Result); + end if; + + end if; + + return Result; + end Freeze_Entity; + + ----------------------------- + -- Freeze_Enumeration_Type -- + ----------------------------- + + procedure Freeze_Enumeration_Type (Typ : Entity_Id) is + begin + if Has_Foreign_Convention (Typ) + and then not Has_Size_Clause (Typ) + and then Esize (Typ) < Standard_Integer_Size + then + Init_Esize (Typ, Standard_Integer_Size); + + else + Adjust_Esize_For_Alignment (Typ); + end if; + end Freeze_Enumeration_Type; + + ----------------------- + -- Freeze_Expression -- + ----------------------- + + procedure Freeze_Expression (N : Node_Id) is + In_Def_Exp : constant Boolean := In_Default_Expression; + Typ : Entity_Id; + Nam : Entity_Id; + Desig_Typ : Entity_Id; + P : Node_Id; + Parent_P : Node_Id; + + Freeze_Outside : Boolean := False; + -- This flag is set true if the entity must be frozen outside the + -- current subprogram. This happens in the case of expander generated + -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do + -- not freeze all entities like other bodies, but which nevertheless + -- may reference entities that have to be frozen before the body and + -- obviously cannot be frozen inside the body. + + function In_Exp_Body (N : Node_Id) return Boolean; + -- Given an N_Handled_Sequence_Of_Statements node N, determines whether + -- it is the handled statement sequence of an expander generated + -- subprogram (init proc, or stream subprogram). If so, it returns + -- True, otherwise False. + + function In_Exp_Body (N : Node_Id) return Boolean is + P : Node_Id; + + begin + if Nkind (N) = N_Subprogram_Body then + P := N; + else + P := Parent (N); + end if; + + if Nkind (P) /= N_Subprogram_Body then + return False; + + else + P := Defining_Unit_Name (Specification (P)); + + if Nkind (P) = N_Defining_Identifier + and then (Chars (P) = Name_uInit_Proc or else + Chars (P) = Name_uInput or else + Chars (P) = Name_uOutput or else + Chars (P) = Name_uRead or else + Chars (P) = Name_uWrite) + then + return True; + else + return False; + end if; + end if; + + end In_Exp_Body; + + -- Start of processing for Freeze_Expression + + begin + -- Immediate return if freezing is inhibited. This flag is set by + -- the analyzer to stop freezing on generated expressions that would + -- cause freezing if they were in the source program, but which are + -- not supposed to freeze, since they are created. + + if Must_Not_Freeze (N) then + return; + end if; + + -- If expression is non-static, then it does not freeze in a default + -- expression, see section "Handling of Default Expressions" in the + -- spec of package Sem for further details. Note that we have to + -- make sure that we actually have a real expression (if we have + -- a subtype indication, we can't test Is_Static_Expression!) + + if In_Def_Exp + and then Nkind (N) in N_Subexpr + and then not Is_Static_Expression (N) + then + return; + end if; + + -- Freeze type of expression if not frozen already + + if Nkind (N) in N_Has_Etype + and then not Is_Frozen (Etype (N)) + then + Typ := Etype (N); + else + Typ := Empty; + end if; + + -- For entity name, freeze entity if not frozen already. A special + -- exception occurs for an identifier that did not come from source. + -- We don't let such identifiers freeze a non-internal entity, i.e. + -- an entity that did come from source, since such an identifier was + -- generated by the expander, and cannot have any semantic effect on + -- the freezing semantics. For example, this stops the parameter of + -- an initialization procedure from freezing the variable. + + if Is_Entity_Name (N) + and then not Is_Frozen (Entity (N)) + and then (Nkind (N) /= N_Identifier + or else Comes_From_Source (N) + or else not Comes_From_Source (Entity (N))) + then + Nam := Entity (N); + + else + Nam := Empty; + end if; + + -- For an allocator freeze designated type if not frozen already. + + -- For an aggregate whose component type is an access type, freeze + -- the designated type now, so that its freeze does not appear within + -- the loop that might be created in the expansion of the aggregate. + -- If the designated type is a private type without full view, the + -- expression cannot contain an allocator, so the type is not frozen. + + Desig_Typ := Empty; + case Nkind (N) is + + when N_Allocator => + Desig_Typ := Designated_Type (Etype (N)); + + when N_Aggregate => + if Is_Array_Type (Etype (N)) + and then Is_Access_Type (Component_Type (Etype (N))) + then + Desig_Typ := Designated_Type (Component_Type (Etype (N))); + end if; + + when N_Selected_Component | + N_Indexed_Component | + N_Slice => + + if Is_Access_Type (Etype (Prefix (N))) then + Desig_Typ := Designated_Type (Etype (Prefix (N))); + end if; + + when others => + null; + + end case; + + if Desig_Typ /= Empty + and then (Is_Frozen (Desig_Typ) + or else (not Is_Fully_Defined (Desig_Typ))) + then + Desig_Typ := Empty; + end if; + + -- All done if nothing needs freezing + + if No (Typ) + and then No (Nam) + and then No (Desig_Typ) + then + return; + end if; + + -- Loop for looking at the right place to insert the freeze nodes + -- exiting from the loop when it is appropriate to insert the freeze + -- node before the current node P. + + -- Also checks some special exceptions to the freezing rules. These + -- cases result in a direct return, bypassing the freeze action. + + P := N; + loop + Parent_P := Parent (P); + + -- If we don't have a parent, then we are not in a well-formed + -- tree. This is an unusual case, but there are some legitimate + -- situations in which this occurs, notably when the expressions + -- in the range of a type declaration are resolved. We simply + -- ignore the freeze request in this case. Is this right ??? + + if No (Parent_P) then + return; + end if; + + -- See if we have got to an appropriate point in the tree + + case Nkind (Parent_P) is + + -- A special test for the exception of (RM 13.14(8)) for the + -- case of per-object expressions (RM 3.8(18)) occurring in a + -- component definition or a discrete subtype definition. Note + -- that we test for a component declaration which includes both + -- cases we are interested in, and furthermore the tree does not + -- have explicit nodes for either of these two constructs. + + when N_Component_Declaration => + + -- The case we want to test for here is an identifier that is + -- a per-object expression, this is either a discriminant that + -- appears in a context other than the component declaration + -- or it is a reference to the type of the enclosing construct. + + -- For either of these cases, we skip the freezing + + if not In_Default_Expression + and then Nkind (N) = N_Identifier + and then (Present (Entity (N))) + then + -- We recognize the discriminant case by just looking for + -- a reference to a discriminant. It can only be one for + -- the enclosing construct. Skip freezing in this case. + + if Ekind (Entity (N)) = E_Discriminant then + return; + + -- For the case of a reference to the enclosing record, + -- (or task or protected type), we look for a type that + -- matches the current scope. + + elsif Entity (N) = Current_Scope then + return; + end if; + end if; + + -- If we have an enumeration literal that appears as the + -- choice in the aggregate of an enumeration representation + -- clause, then freezing does not occur (RM 13.14(9)). + + when N_Enumeration_Representation_Clause => + + -- The case we are looking for is an enumeration literal + + if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal) + and then Is_Enumeration_Type (Etype (N)) + then + -- If enumeration literal appears directly as the choice, + -- do not freeze (this is the normal non-overloade case) + + if Nkind (Parent (N)) = N_Component_Association + and then First (Choices (Parent (N))) = N + then + return; + + -- If enumeration literal appears as the name of a + -- function which is the choice, then also do not freeze. + -- This happens in the overloaded literal case, where the + -- enumeration literal is temporarily changed to a function + -- call for overloading analysis purposes. + + elsif Nkind (Parent (N)) = N_Function_Call + and then + Nkind (Parent (Parent (N))) = N_Component_Association + and then + First (Choices (Parent (Parent (N)))) = Parent (N) + then + return; + end if; + end if; + + -- Normally if the parent is a handled sequence of statements, + -- then the current node must be a statement, and that is an + -- appropriate place to insert a freeze node. + + when N_Handled_Sequence_Of_Statements => + + -- An exception occurs when the sequence of statements is + -- for an expander generated body that did not do the usual + -- freeze all operation. In this case we usually want to + -- freeze outside this body, not inside it, and we skip + -- past the subprogram body that we are inside. + + if In_Exp_Body (Parent_P) then + + -- However, we *do* want to freeze at this point if we have + -- an entity to freeze, and that entity is declared *inside* + -- the body of the expander generated procedure. This case + -- is recognized by the scope of the type, which is either + -- the spec for some enclosing body, or (in the case of + -- init_procs, for which there are no separate specs) the + -- current scope. + + declare + Subp : constant Node_Id := Parent (Parent_P); + Cspc : Entity_Id; + + begin + if Nkind (Subp) = N_Subprogram_Body then + Cspc := Corresponding_Spec (Subp); + + if (Present (Typ) and then Scope (Typ) = Cspc) + or else + (Present (Nam) and then Scope (Nam) = Cspc) + then + exit; + + elsif Present (Typ) + and then Scope (Typ) = Current_Scope + and then Current_Scope = Defining_Entity (Subp) + then + exit; + end if; + end if; + end; + + -- If not that exception to the exception, then this is + -- where we delay the freeze till outside the body. + + Parent_P := Parent (Parent_P); + Freeze_Outside := True; + + -- Here if normal case where we are in handled statement + -- sequence and want to do the insertion right there. + + else + exit; + end if; + + -- If parent is a body or a spec or a block, then the current + -- node is a statement or declaration and we can insert the + -- freeze node before it. + + when N_Package_Specification | + N_Package_Body | + N_Subprogram_Body | + N_Task_Body | + N_Protected_Body | + N_Entry_Body | + N_Block_Statement => exit; + + -- The expander is allowed to define types in any statements list, + -- so any of the following parent nodes also mark a freezing point + -- if the actual node is in a list of statements or declarations. + + when N_Exception_Handler | + N_If_Statement | + N_Elsif_Part | + N_Case_Statement_Alternative | + N_Compilation_Unit_Aux | + N_Selective_Accept | + N_Accept_Alternative | + N_Delay_Alternative | + N_Conditional_Entry_Call | + N_Entry_Call_Alternative | + N_Triggering_Alternative | + N_Abortable_Part | + N_Freeze_Entity => + + exit when Is_List_Member (P); + + -- Note: The N_Loop_Statement is a special case. A type that + -- appears in the source can never be frozen in a loop (this + -- occurs only because of a loop expanded by the expander), + -- so we keep on going. Otherwise we terminate the search. + -- Same is true of any entity which comes from source. (if they + -- have a predefined type, that type does not appear to come + -- from source, but the entity should not be frozen here). + + when N_Loop_Statement => + exit when not Comes_From_Source (Etype (N)) + and then (No (Nam) or else not Comes_From_Source (Nam)); + + -- For all other cases, keep looking at parents + + when others => + null; + end case; + + -- We fall through the case if we did not yet find the proper + -- place in the free for inserting the freeze node, so climb! + + P := Parent_P; + end loop; + + -- If the expression appears in a record or an initialization + -- procedure, the freeze nodes are collected and attached to + -- the current scope, to be inserted and analyzed on exit from + -- the scope, to insure that generated entities appear in the + -- correct scope. If the expression is a default for a discriminant + -- specification, the scope is still void. The expression can also + -- appear in the discriminant part of a private or concurrent type. + + -- The other case requiring this special handling is if we are in + -- a default expression, since in that case we are about to freeze + -- a static type, and the freeze scope needs to be the outer scope, + -- not the scope of the subprogram with the default parameter. + + -- For default expressions in generic units, the Move_Freeze_Nodes + -- mechanism (see sem_ch12.adb) takes care of placing them at the + -- proper place, after the generic unit. + + if (In_Def_Exp and not Inside_A_Generic) + or else Freeze_Outside + or else (Is_Type (Current_Scope) + and then (not Is_Concurrent_Type (Current_Scope) + or else not Has_Completion (Current_Scope))) + or else Ekind (Current_Scope) = E_Void + then + declare + Loc : constant Source_Ptr := Sloc (Current_Scope); + Freeze_Nodes : List_Id := No_List; + + begin + if Present (Desig_Typ) then + Freeze_And_Append (Desig_Typ, Loc, Freeze_Nodes); + end if; + + if Present (Typ) then + Freeze_And_Append (Typ, Loc, Freeze_Nodes); + end if; + + if Present (Nam) then + Freeze_And_Append (Nam, Loc, Freeze_Nodes); + end if; + + if Is_Non_Empty_List (Freeze_Nodes) then + + if No (Scope_Stack.Table + (Scope_Stack.Last).Pending_Freeze_Actions) + then + Scope_Stack.Table + (Scope_Stack.Last).Pending_Freeze_Actions := + Freeze_Nodes; + else + Append_List (Freeze_Nodes, Scope_Stack.Table + (Scope_Stack.Last).Pending_Freeze_Actions); + end if; + end if; + end; + + return; + end if; + + -- Now we have the right place to do the freezing. First, a special + -- adjustment, if we are in default expression analysis mode, these + -- freeze actions must not be thrown away (normally all inserted + -- actions are thrown away in this mode. However, the freeze actions + -- are from static expressions and one of the important reasons we + -- are doing this special analysis is to get these freeze actions. + -- Therefore we turn off the In_Default_Expression mode to propagate + -- these freeze actions. This also means they get properly analyzed + -- and expanded. + + In_Default_Expression := False; + + -- Freeze the designated type of an allocator (RM 13.14(12)) + + if Present (Desig_Typ) then + Freeze_Before (P, Desig_Typ); + end if; + + -- Freeze type of expression (RM 13.14(9)). Note that we took care of + -- the enumeration representation clause exception in the loop above. + + if Present (Typ) then + Freeze_Before (P, Typ); + end if; + + -- Freeze name if one is present (RM 13.14(10)) + + if Present (Nam) then + Freeze_Before (P, Nam); + end if; + + In_Default_Expression := In_Def_Exp; + end Freeze_Expression; + + ----------------------------- + -- Freeze_Fixed_Point_Type -- + ----------------------------- + + -- Certain fixed-point types and subtypes, including implicit base + -- types and declared first subtypes, have not yet set up a range. + -- This is because the range cannot be set until the Small and Size + -- values are known, and these are not known till the type is frozen. + + -- To signal this case, Scalar_Range contains an unanalyzed syntactic + -- range whose bounds are unanalyzed real literals. This routine will + -- recognize this case, and transform this range node into a properly + -- typed range with properly analyzed and resolved values. + + procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is + Rng : constant Node_Id := Scalar_Range (Typ); + Lo : constant Node_Id := Low_Bound (Rng); + Hi : constant Node_Id := High_Bound (Rng); + Btyp : constant Entity_Id := Base_Type (Typ); + Brng : constant Node_Id := Scalar_Range (Btyp); + BLo : constant Node_Id := Low_Bound (Brng); + BHi : constant Node_Id := High_Bound (Brng); + Small : constant Ureal := Small_Value (Typ); + Loval : Ureal; + Hival : Ureal; + Atype : Entity_Id; + + Actual_Size : Nat; + + function Fsize (Lov, Hiv : Ureal) return Nat; + -- Returns size of type with given bounds. Also leaves these + -- bounds set as the current bounds of the Typ. + + function Fsize (Lov, Hiv : Ureal) return Nat is + begin + Set_Realval (Lo, Lov); + Set_Realval (Hi, Hiv); + return Minimum_Size (Typ); + end Fsize; + + -- Start of processing for Freeze_Fixed_Point_Type; + + begin + -- If Esize of a subtype has not previously been set, set it now + + if Unknown_Esize (Typ) then + Atype := Ancestor_Subtype (Typ); + + if Present (Atype) then + Set_Size_Info (Typ, Atype); + else + Set_Size_Info (Typ, Base_Type (Typ)); + end if; + end if; + + -- Immediate return if the range is already analyzed. This means + -- that the range is already set, and does not need to be computed + -- by this routine. + + if Analyzed (Rng) then + return; + end if; + + -- Immediate return if either of the bounds raises Constraint_Error + + if Raises_Constraint_Error (Lo) + or else Raises_Constraint_Error (Hi) + then + return; + end if; + + Loval := Realval (Lo); + Hival := Realval (Hi); + + -- Ordinary fixed-point case + + if Is_Ordinary_Fixed_Point_Type (Typ) then + + -- For the ordinary fixed-point case, we are allowed to fudge the + -- end-points up or down by small. Generally we prefer to fudge + -- up, i.e. widen the bounds for non-model numbers so that the + -- end points are included. However there are cases in which this + -- cannot be done, and indeed cases in which we may need to narrow + -- the bounds. The following circuit makes the decision. + + -- Note: our terminology here is that Incl_EP means that the + -- bounds are widened by Small if necessary to include the end + -- points, and Excl_EP means that the bounds are narrowed by + -- Small to exclude the end-points if this reduces the size. + + -- Note that in the Incl case, all we care about is including the + -- end-points. In the Excl case, we want to narrow the bounds as + -- much as permitted by the RM, to give the smallest possible size. + + Fudge : declare + Loval_Incl_EP : Ureal; + Hival_Incl_EP : Ureal; + + Loval_Excl_EP : Ureal; + Hival_Excl_EP : Ureal; + + Size_Incl_EP : Nat; + Size_Excl_EP : Nat; + + Model_Num : Ureal; + First_Subt : Entity_Id; + Actual_Lo : Ureal; + Actual_Hi : Ureal; + + begin + -- First step. Base types are required to be symmetrical. Right + -- now, the base type range is a copy of the first subtype range. + -- This will be corrected before we are done, but right away we + -- need to deal with the case where both bounds are non-negative. + -- In this case, we set the low bound to the negative of the high + -- bound, to make sure that the size is computed to include the + -- required sign. Note that we do not need to worry about the + -- case of both bounds negative, because the sign will be dealt + -- with anyway. Furthermore we can't just go making such a bound + -- symmetrical, since in a twos-complement system, there is an + -- extra negative value which could not be accomodated on the + -- positive side. + + if Typ = Btyp + and then not UR_Is_Negative (Loval) + and then Hival > Loval + then + Loval := -Hival; + Set_Realval (Lo, Loval); + end if; + + -- Compute the fudged bounds. If the number is a model number, + -- then we do nothing to include it, but we are allowed to + -- backoff to the next adjacent model number when we exclude + -- it. If it is not a model number then we straddle the two + -- values with the model numbers on either side. + + Model_Num := UR_Trunc (Loval / Small) * Small; + + if Loval = Model_Num then + Loval_Incl_EP := Model_Num; + else + Loval_Incl_EP := Model_Num - Small; + end if; + + -- The low value excluding the end point is Small greater, but + -- we do not do this exclusion if the low value is positive, + -- since it can't help the size and could actually hurt by + -- crossing the high bound. + + if UR_Is_Negative (Loval_Incl_EP) then + Loval_Excl_EP := Loval_Incl_EP + Small; + else + Loval_Excl_EP := Loval_Incl_EP; + end if; + + -- Similar processing for upper bound and high value + + Model_Num := UR_Trunc (Hival / Small) * Small; + + if Hival = Model_Num then + Hival_Incl_EP := Model_Num; + else + Hival_Incl_EP := Model_Num + Small; + end if; + + if UR_Is_Positive (Hival_Incl_EP) then + Hival_Excl_EP := Hival_Incl_EP - Small; + else + Hival_Excl_EP := Hival_Incl_EP; + end if; + + -- One further adjustment is needed. In the case of subtypes, + -- we cannot go outside the range of the base type, or we get + -- peculiarities, and the base type range is already set. This + -- only applies to the Incl values, since clearly the Excl + -- values are already as restricted as they are allowed to be. + + if Typ /= Btyp then + Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo)); + Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi)); + end if; + + -- Get size including and excluding end points + + Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP); + Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP); + + -- No need to exclude end-points if it does not reduce size + + if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then + Loval_Excl_EP := Loval_Incl_EP; + end if; + + if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then + Hival_Excl_EP := Hival_Incl_EP; + end if; + + -- Now we set the actual size to be used. We want to use the + -- bounds fudged up to include the end-points but only if this + -- can be done without violating a specifically given size + -- size clause or causing an unacceptable increase in size. + + -- Case of size clause given + + if Has_Size_Clause (Typ) then + + -- Use the inclusive size only if it is consistent with + -- the explicitly specified size. + + if Size_Incl_EP <= RM_Size (Typ) then + Actual_Lo := Loval_Incl_EP; + Actual_Hi := Hival_Incl_EP; + Actual_Size := Size_Incl_EP; + + -- If the inclusive size is too large, we try excluding + -- the end-points (will be caught later if does not work). + + else + Actual_Lo := Loval_Excl_EP; + Actual_Hi := Hival_Excl_EP; + Actual_Size := Size_Excl_EP; + end if; + + -- Case of size clause not given + + else + -- If we have a base type whose corresponding first subtype + -- has an explicit size that is large enough to include our + -- end-points, then do so. There is no point in working hard + -- to get a base type whose size is smaller than the specified + -- size of the first subtype. + + First_Subt := First_Subtype (Typ); + + if Has_Size_Clause (First_Subt) + and then Size_Incl_EP <= Esize (First_Subt) + then + Actual_Size := Size_Incl_EP; + Actual_Lo := Loval_Incl_EP; + Actual_Hi := Hival_Incl_EP; + + -- If excluding the end-points makes the size smaller and + -- results in a size of 8,16,32,64, then we take the smaller + -- size. For the 64 case, this is compulsory. For the other + -- cases, it seems reasonable. We like to include end points + -- if we can, but not at the expense of moving to the next + -- natural boundary of size. + + elsif Size_Incl_EP /= Size_Excl_EP + and then + (Size_Excl_EP = 8 or else + Size_Excl_EP = 16 or else + Size_Excl_EP = 32 or else + Size_Excl_EP = 64) + then + Actual_Size := Size_Excl_EP; + Actual_Lo := Loval_Excl_EP; + Actual_Hi := Hival_Excl_EP; + + -- Otherwise we can definitely include the end points + + else + Actual_Size := Size_Incl_EP; + Actual_Lo := Loval_Incl_EP; + Actual_Hi := Hival_Incl_EP; + end if; + + -- One pathological case: normally we never fudge a low + -- bound down, since it would seem to increase the size + -- (if it has any effect), but for ranges containing a + -- single value, or no values, the high bound can be + -- small too large. Consider: + + -- type t is delta 2.0**(-14) + -- range 131072.0 .. 0; + + -- That lower bound is *just* outside the range of 32 + -- bits, and does need fudging down in this case. Note + -- that the bounds will always have crossed here, since + -- the high bound will be fudged down if necessary, as + -- in the case of: + + -- type t is delta 2.0**(-14) + -- range 131072.0 .. 131072.0; + + -- So we can detect the situation by looking for crossed + -- bounds, and if the bounds are crossed, and the low + -- bound is greater than zero, we will always back it + -- off by small, since this is completely harmless. + + if Actual_Lo > Actual_Hi then + if UR_Is_Positive (Actual_Lo) then + Actual_Lo := Loval_Incl_EP - Small; + Actual_Size := Fsize (Actual_Lo, Actual_Hi); + + -- And of course, we need to do exactly the same parallel + -- fudge for flat ranges in the negative region. + + elsif UR_Is_Negative (Actual_Hi) then + Actual_Hi := Hival_Incl_EP + Small; + Actual_Size := Fsize (Actual_Lo, Actual_Hi); + end if; + end if; + end if; + + Set_Realval (Lo, Actual_Lo); + Set_Realval (Hi, Actual_Hi); + end Fudge; + + -- For the decimal case, none of this fudging is required, since there + -- are no end-point problems in the decimal case (the end-points are + -- always included). + + else + Actual_Size := Fsize (Loval, Hival); + end if; + + -- At this stage, the actual size has been calculated and the proper + -- required bounds are stored in the low and high bounds. + + if Actual_Size > 64 then + Error_Msg_Uint_1 := UI_From_Int (Actual_Size); + Error_Msg_N + ("size required (^) for type& too large, maximum is 64", Typ); + Actual_Size := 64; + end if; + + -- Check size against explicit given size + + if Has_Size_Clause (Typ) then + if Actual_Size > RM_Size (Typ) then + Error_Msg_Uint_1 := RM_Size (Typ); + Error_Msg_Uint_2 := UI_From_Int (Actual_Size); + Error_Msg_NE + ("size given (^) for type& too small, minimum is ^", + Size_Clause (Typ), Typ); + + else + Actual_Size := UI_To_Int (Esize (Typ)); + end if; + + -- Increase size to next natural boundary if no size clause given + + else + if Actual_Size <= 8 then + Actual_Size := 8; + elsif Actual_Size <= 16 then + Actual_Size := 16; + elsif Actual_Size <= 32 then + Actual_Size := 32; + else + Actual_Size := 64; + end if; + + Init_Esize (Typ, Actual_Size); + Adjust_Esize_For_Alignment (Typ); + end if; + + -- If we have a base type, then expand the bounds so that they + -- extend to the full width of the allocated size in bits, to + -- avoid junk range checks on intermediate computations. + + if Base_Type (Typ) = Typ then + Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); + Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1))); + end if; + + -- Final step is to reanalyze the bounds using the proper type + -- and set the Corresponding_Integer_Value fields of the literals. + + Set_Etype (Lo, Empty); + Set_Analyzed (Lo, False); + Analyze (Lo); + + -- Resolve with universal fixed if the base type, and the base + -- type if it is a subtype. Note we can't resolve the base type + -- with itself, that would be a reference before definition. + + if Typ = Btyp then + Resolve (Lo, Universal_Fixed); + else + Resolve (Lo, Btyp); + end if; + + -- Set corresponding integer value for bound + + Set_Corresponding_Integer_Value + (Lo, UR_To_Uint (Realval (Lo) / Small)); + + -- Similar processing for high bound + + Set_Etype (Hi, Empty); + Set_Analyzed (Hi, False); + Analyze (Hi); + + if Typ = Btyp then + Resolve (Hi, Universal_Fixed); + else + Resolve (Hi, Btyp); + end if; + + Set_Corresponding_Integer_Value + (Hi, UR_To_Uint (Realval (Hi) / Small)); + + -- Set type of range to correspond to bounds + + Set_Etype (Rng, Etype (Lo)); + + -- Set Esize to calculated size and also set RM_Size + + Init_Esize (Typ, Actual_Size); + + -- Set RM_Size if not already set. If already set, check value + + declare + Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); + + begin + if RM_Size (Typ) /= Uint_0 then + if RM_Size (Typ) < Minsiz then + Error_Msg_Uint_1 := RM_Size (Typ); + Error_Msg_Uint_2 := Minsiz; + Error_Msg_NE + ("size given (^) for type& too small, minimum is ^", + Size_Clause (Typ), Typ); + end if; + + else + Set_RM_Size (Typ, Minsiz); + end if; + end; + + end Freeze_Fixed_Point_Type; + + ------------------ + -- Freeze_Itype -- + ------------------ + + procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is + L : List_Id; + + begin + Set_Has_Delayed_Freeze (T); + L := Freeze_Entity (T, Sloc (N)); + + if Is_Non_Empty_List (L) then + Insert_Actions (N, L); + end if; + end Freeze_Itype; + + -------------------------- + -- Freeze_Static_Object -- + -------------------------- + + procedure Freeze_Static_Object (E : Entity_Id) is + + Cannot_Be_Static : exception; + -- Exception raised if the type of a static object cannot be made + -- static. This happens if the type depends on non-global objects. + + procedure Ensure_Expression_Is_SA (N : Node_Id); + -- Called to ensure that an expression used as part of a type + -- definition is statically allocatable, which means that the type + -- of the expression is statically allocatable, and the expression + -- is either static, or a reference to a library level constant. + + procedure Ensure_Type_Is_SA (Typ : Entity_Id); + -- Called to mark a type as static, checking that it is possible + -- to set the type as static. If it is not possible, then the + -- exception Cannot_Be_Static is raised. + + ----------------------------- + -- Ensure_Expression_Is_SA -- + ----------------------------- + + procedure Ensure_Expression_Is_SA (N : Node_Id) is + Ent : Entity_Id; + + begin + Ensure_Type_Is_SA (Etype (N)); + + if Is_Static_Expression (N) then + return; + + elsif Nkind (N) = N_Identifier then + Ent := Entity (N); + + if Present (Ent) + and then Ekind (Ent) = E_Constant + and then Is_Library_Level_Entity (Ent) + then + return; + end if; + end if; + + raise Cannot_Be_Static; + end Ensure_Expression_Is_SA; + + ----------------------- + -- Ensure_Type_Is_SA -- + ----------------------- + + procedure Ensure_Type_Is_SA (Typ : Entity_Id) is + N : Node_Id; + C : Entity_Id; + + begin + -- If type is library level, we are all set + + if Is_Library_Level_Entity (Typ) then + return; + end if; + + -- We are also OK if the type is already marked as statically + -- allocated, which means we processed it before. + + if Is_Statically_Allocated (Typ) then + return; + end if; + + -- Mark type as statically allocated + + Set_Is_Statically_Allocated (Typ); + + -- Check that it is safe to statically allocate this type + + if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then + Ensure_Expression_Is_SA (Type_Low_Bound (Typ)); + Ensure_Expression_Is_SA (Type_High_Bound (Typ)); + + elsif Is_Array_Type (Typ) then + N := First_Index (Typ); + while Present (N) loop + Ensure_Type_Is_SA (Etype (N)); + Next_Index (N); + end loop; + + Ensure_Type_Is_SA (Component_Type (Typ)); + + elsif Is_Access_Type (Typ) then + if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then + + declare + F : Entity_Id; + T : constant Entity_Id := Etype (Designated_Type (Typ)); + + begin + if T /= Standard_Void_Type then + Ensure_Type_Is_SA (T); + end if; + + F := First_Formal (Designated_Type (Typ)); + + while Present (F) loop + Ensure_Type_Is_SA (Etype (F)); + Next_Formal (F); + end loop; + end; + + else + Ensure_Type_Is_SA (Designated_Type (Typ)); + end if; + + elsif Is_Record_Type (Typ) then + C := First_Entity (Typ); + + while Present (C) loop + if Ekind (C) = E_Discriminant + or else Ekind (C) = E_Component + then + Ensure_Type_Is_SA (Etype (C)); + + elsif Is_Type (C) then + Ensure_Type_Is_SA (C); + end if; + + Next_Entity (C); + end loop; + + elsif Ekind (Typ) = E_Subprogram_Type then + Ensure_Type_Is_SA (Etype (Typ)); + + C := First_Formal (Typ); + while Present (C) loop + Ensure_Type_Is_SA (Etype (C)); + Next_Formal (C); + end loop; + + else + raise Cannot_Be_Static; + end if; + end Ensure_Type_Is_SA; + + -- Start of processing for Freeze_Static_Object + + begin + Ensure_Type_Is_SA (Etype (E)); + + exception + when Cannot_Be_Static => + + -- If the object that cannot be static is imported or exported, + -- then we give an error message saying that this object cannot + -- be imported or exported. + + if Is_Imported (E) then + Error_Msg_N + ("& cannot be imported (local type is not constant)", E); + + -- Otherwise must be exported, something is wrong if compiler + -- is marking something as statically allocated which cannot be). + + else pragma Assert (Is_Exported (E)); + Error_Msg_N + ("& cannot be exported (local type is not constant)", E); + end if; + end Freeze_Static_Object; + + ----------------------- + -- Freeze_Subprogram -- + ----------------------- + + procedure Freeze_Subprogram (E : Entity_Id) is + Retype : Entity_Id; + F : Entity_Id; + + begin + -- Subprogram may not have an address clause unless it is imported + + if Present (Address_Clause (E)) then + if not Is_Imported (E) then + Error_Msg_N + ("address clause can only be given " & + "for imported subprogram", + Name (Address_Clause (E))); + end if; + end if; + + -- For non-foreign convention subprograms, this is where we create + -- the extra formals (for accessibility level and constrained bit + -- information). We delay this till the freeze point precisely so + -- that we know the convention! + + if not Has_Foreign_Convention (E) then + Create_Extra_Formals (E); + Set_Mechanisms (E); + + -- If this is convention Ada and a Valued_Procedure, that's odd + + if Ekind (E) = E_Procedure + and then Is_Valued_Procedure (E) + and then Convention (E) = Convention_Ada + then + Error_Msg_N + ("?Valued_Procedure has no effect for convention Ada", E); + Set_Is_Valued_Procedure (E, False); + end if; + + -- Case of foreign convention + + else + Set_Mechanisms (E); + + -- For foreign conventions, do not permit return of an + -- unconstrained array. + + -- Note: we *do* allow a return by descriptor for the VMS case, + -- though here there is probably more to be done ??? + + if Ekind (E) = E_Function then + Retype := Underlying_Type (Etype (E)); + + -- If no return type, probably some other error, e.g. a + -- missing full declaration, so ignore. + + if No (Retype) then + null; + + -- If the return type is generic, we have emitted a warning + -- earlier on, and there is nothing else to check here. + -- Specific instantiations may lead to erroneous behavior. + + elsif Is_Generic_Type (Etype (E)) then + null; + + elsif Is_Array_Type (Retype) + and then not Is_Constrained (Retype) + and then Mechanism (E) not in Descriptor_Codes + then + Error_Msg_NE + ("convention for& does not permit returning " & + "unconstrained array type", E, E); + return; + end if; + end if; + + -- If any of the formals for an exported foreign convention + -- subprogram have defaults, then emit an appropriate warning + -- since this is odd (default cannot be used from non-Ada code) + + if Is_Exported (E) then + F := First_Formal (E); + while Present (F) loop + if Present (Default_Value (F)) then + Error_Msg_N + ("?parameter cannot be defaulted in non-Ada call", + Default_Value (F)); + end if; + + Next_Formal (F); + end loop; + end if; + end if; + + -- For VMS, descriptor mechanisms for parameters are allowed only + -- for imported subprograms. + + if OpenVMS_On_Target then + if not Is_Imported (E) then + F := First_Formal (E); + while Present (F) loop + if Mechanism (F) in Descriptor_Codes then + Error_Msg_N + ("descriptor mechanism for parameter not permitted", F); + Error_Msg_N + ("\can only be used for imported subprogram", F); + end if; + + Next_Formal (F); + end loop; + end if; + end if; + + end Freeze_Subprogram; + + ----------------------- + -- Is_Fully_Defined -- + ----------------------- + + -- Should this be in Sem_Util ??? + + function Is_Fully_Defined (T : Entity_Id) return Boolean is + begin + if Ekind (T) = E_Class_Wide_Type then + return Is_Fully_Defined (Etype (T)); + else + return not Is_Private_Type (T) + or else Present (Full_View (Base_Type (T))); + end if; + end Is_Fully_Defined; + + --------------------------------- + -- Process_Default_Expressions -- + --------------------------------- + + procedure Process_Default_Expressions + (E : Entity_Id; + After : in out Node_Id) + is + Loc : constant Source_Ptr := Sloc (E); + Dbody : Node_Id; + Formal : Node_Id; + Dcopy : Node_Id; + Dnam : Entity_Id; + + begin + Set_Default_Expressions_Processed (E); + + -- A subprogram instance and its associated anonymous subprogram + -- share their signature. The default expression functions are defined + -- in the wrapper packages for the anonymous subprogram, and should + -- not be generated again for the instance. + + if Is_Generic_Instance (E) + and then Present (Alias (E)) + and then Default_Expressions_Processed (Alias (E)) + then + return; + end if; + + Formal := First_Formal (E); + + while Present (Formal) loop + if Present (Default_Value (Formal)) then + + -- We work with a copy of the default expression because we + -- do not want to disturb the original, since this would mess + -- up the conformance checking. + + Dcopy := New_Copy_Tree (Default_Value (Formal)); + + -- The analysis of the expression may generate insert actions, + -- which of course must not be executed. We wrap those actions + -- in a procedure that is not called, and later on eliminated. + -- The following cases have no side-effects, and are analyzed + -- directly. + + if Nkind (Dcopy) = N_Identifier + or else Nkind (Dcopy) = N_Expanded_Name + or else Nkind (Dcopy) = N_Integer_Literal + or else (Nkind (Dcopy) = N_Real_Literal + and then not Vax_Float (Etype (Dcopy))) + or else Nkind (Dcopy) = N_Character_Literal + or else Nkind (Dcopy) = N_String_Literal + or else Nkind (Dcopy) = N_Null + or else (Nkind (Dcopy) = N_Attribute_Reference + and then + Attribute_Name (Dcopy) = Name_Null_Parameter) + + then + + -- If there is no default function, we must still do a full + -- analyze call on the default value, to ensure that all + -- error checks are performed, e.g. those associated with + -- static evaluation. Note that this branch will always be + -- taken if the analyzer is turned off (but we still need the + -- error checks). + + -- Note: the setting of parent here is to meet the requirement + -- that we can only analyze the expression while attached to + -- the tree. Really the requirement is that the parent chain + -- be set, we don't actually need to be in the tree. + + Set_Parent (Dcopy, Declaration_Node (Formal)); + Analyze (Dcopy); + + -- Default expressions are resolved with their own type if the + -- context is generic, to avoid anomalies with private types. + + if Ekind (Scope (E)) = E_Generic_Package then + Resolve (Dcopy, Etype (Dcopy)); + else + Resolve (Dcopy, Etype (Formal)); + end if; + + -- If that resolved expression will raise constraint error, + -- then flag the default value as raising constraint error. + -- This allows a proper error message on the calls. + + if Raises_Constraint_Error (Dcopy) then + Set_Raises_Constraint_Error (Default_Value (Formal)); + end if; + + -- If the default is a parameterless call, we use the name of + -- the called function directly, and there is no body to build. + + elsif Nkind (Dcopy) = N_Function_Call + and then No (Parameter_Associations (Dcopy)) + then + null; + + -- Else construct and analyze the body of a wrapper procedure + -- that contains an object declaration to hold the expression. + -- Given that this is done only to complete the analysis, it + -- simpler to build a procedure than a function which might + -- involve secondary stack expansion. + + else + Dnam := + Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + + Dbody := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Dnam), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')), + Object_Definition => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => New_Copy_Tree (Dcopy))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List)); + + Set_Scope (Dnam, Scope (E)); + Set_Assignment_OK (First (Declarations (Dbody))); + Set_Is_Eliminated (Dnam); + Insert_After (After, Dbody); + Analyze (Dbody); + After := Dbody; + end if; + end if; + + Next_Formal (Formal); + end loop; + + end Process_Default_Expressions; + + ---------------------------------------- + -- Set_Component_Alignment_If_Not_Set -- + ---------------------------------------- + + procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is + begin + -- Ignore if not base type, subtypes don't need anything + + if Typ /= Base_Type (Typ) then + return; + end if; + + -- Do not override existing representation + + if Is_Packed (Typ) then + return; + + elsif Has_Specified_Layout (Typ) then + return; + + elsif Component_Alignment (Typ) /= Calign_Default then + return; + + else + Set_Component_Alignment + (Typ, Scope_Stack.Table + (Scope_Stack.Last).Component_Alignment_Default); + end if; + end Set_Component_Alignment_If_Not_Set; + + --------------------------- + -- Set_Debug_Info_Needed -- + --------------------------- + + procedure Set_Debug_Info_Needed (T : Entity_Id) is + begin + if No (T) + or else Needs_Debug_Info (T) + or else Debug_Info_Off (T) + then + return; + else + Set_Needs_Debug_Info (T); + end if; + + if Is_Object (T) then + Set_Debug_Info_Needed (Etype (T)); + + elsif Is_Type (T) then + Set_Debug_Info_Needed (Etype (T)); + + if Is_Record_Type (T) then + declare + Ent : Entity_Id := First_Entity (T); + begin + while Present (Ent) loop + Set_Debug_Info_Needed (Ent); + Next_Entity (Ent); + end loop; + end; + + elsif Is_Array_Type (T) then + Set_Debug_Info_Needed (Component_Type (T)); + + declare + Indx : Node_Id := First_Index (T); + begin + while Present (Indx) loop + Set_Debug_Info_Needed (Etype (Indx)); + Indx := Next_Index (Indx); + end loop; + end; + + if Is_Packed (T) then + Set_Debug_Info_Needed (Packed_Array_Type (T)); + end if; + + elsif Is_Access_Type (T) then + Set_Debug_Info_Needed (Directly_Designated_Type (T)); + + elsif Is_Private_Type (T) then + Set_Debug_Info_Needed (Full_View (T)); + + elsif Is_Protected_Type (T) then + Set_Debug_Info_Needed (Corresponding_Record_Type (T)); + end if; + end if; + + end Set_Debug_Info_Needed; + +end Freeze; diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads new file mode 100644 index 00000000000..f782a5ced1d --- /dev/null +++ b/gcc/ada/freeze.ads @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R E E Z E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1992-2000, 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 Types; use Types; + +package Freeze is + + -------------------------- + -- Handling of Freezing -- + -------------------------- + + -- In the formal Ada semantics, freezing of entities occurs at a well + -- defined point, described in (RM 13.14). The model in GNAT of freezing + -- is that a Freeze_Entity node is generated at the point where an entity + -- is frozen, and the entity contains a pointer (Freeze_Node) to this + -- generated freeze node. + + -- The freeze node is processed in the expander to generate associated + -- data and subprograms (e.g. an initialization procedure) which must + -- be delayed until the type is frozen and its representation can be + -- fully determined. Subsequently the freeze node is used by Gigi to + -- determine the point at which it should elaborate the corresponding + -- entity (this elaboration also requires the representation of the + -- entity to be fully determinable). The freeze node is also used to + -- provide additional diagnostic information (pinpointing the freeze + -- point), when order of freezing errors are detected. + + -- If we were fully faithful to the Ada model, we would generate freeze + -- nodes for all entities, but that is a bit heavy so we optimize (that + -- is the nice word) or cut corners (which is a bit more honest). For + -- many entities, we do not need to delay the freeze and instead can + -- freeze them at the point of declaration. The conditions for this + -- early freezing being permissible are as follows: + + -- There is no associated expander activity that needs to be delayed + + -- Gigi can fully elaborate the entity at the point of occurrence (or, + -- equivalently, no real elaboration is required for the entity). + + -- In order for these conditions to be met (especially the second), it + -- must be the case that all representation characteristics of the entity + -- can be determined at declaration time. + + -- The following indicates how freezing is handled for all entity kinds: + + -- Types + + -- All declared types have freeze nodes, as well as anonymous base + -- types created for type declarations where the defining identifier + -- is a first subtype of the anonymous type. + + -- Subtypes + + -- All first subtypes have freeze nodes. Other subtypes need freeze + -- nodes if the corresponding base type has not yet been frozen. If + -- the base type has been frozen, then there is no need for a freeze + -- node, since no rep clauses can appear for the subtype in any case. + + -- Implicit types and subtypes + + -- As noted above, implicit base types always have freeze nodes. Other + -- implicit types and subtypes typically do not require freeze nodes, + -- because there is no possibility of delaying any information about + -- their representation. + + -- Subprograms + -- + -- Are frozen at the point of declaration unless one or more of the + -- formal types or return type themselves have delayed freezing and + -- are not yet frozen. This includes the case of a formal access type + -- where the designated type is not frozen. Note that we are talking + -- about subprogram specs here (subprogram body entities have no + -- relevance), and in any case, subprogram bodies freeze everything. + + -- Objects with dynamic address clauses + -- + -- These have a delayed freeze. Gigi will generate code to evaluate + -- the initialization expression if present and store it in a temp. + -- The actual object is created at the point of the freeze, and if + -- neccessary initialized by copying the value of this temporary. + + -- Formal Parameters + -- + -- Are frozen when the associated subprogram is frozen, so there is + -- never any need for them to have delayed freezing. + + -- Other Objects + -- + -- Are always frozen at the point of declaration + + -- All Other Entities + + -- Are always frozen at the point of declaration + + -- The flag Has_Delayed_Freeze is used for to indicate that delayed + -- freezing is required. Usually the associated freeze node is allocated + -- at the freezing point. One special exception occurs with anonymous + -- base types, where the freeze node is preallocated at the point of + -- declaration, so that the First_Subtype_Link field can be set. + + ----------------- + -- Subprograms -- + ----------------- + + function Build_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id) + return Node_Id; + -- Rewrite renaming declaration as a subprogram body, whose single + -- statement is a call to the renamed entity. New_S is the entity that + -- appears in the renaming declaration. If this is a Renaming_As_Body, + -- then Decl is the original subprogram declaration that is completed + -- by the renaming, otherwise it is the renaming declaration itself. + -- The caller inserts the body where required. If this call comes + -- from a freezing action, the resulting body is analyzed at once. + + procedure Check_Compile_Time_Size (T : Entity_Id); + -- Check to see whether the size of the type T is known at compile time. + -- There are three possible cases: + -- + -- Size is not known at compile time. In this case, the call has no + -- effect. Note that the processing is conservative here, in the sense + -- that this routine may decide that the size is not known even if in + -- fact Gigi decides it is known, but the opposite situation can never + -- occur. + -- + -- Size is known at compile time, but the actual value of the size is + -- not known to the front end or is definitely 32 or more. In this case + -- Size_Known_At_Compile_Time is set, but the Esize field is left set + -- to zero (to be set by Gigi). + -- + -- Size is known at compile time, and the actual value of the size is + -- known to the front end and is less than 32. In this case, the flag + -- Size_Known_At_Compile_Time is set, and in addition Esize is set to + -- the required size, allowing for possible front end packing of an + -- array using this type as a component type. + -- + -- Note: the flag Size_Known_At_Compile_Time is used to determine if the + -- secondary stack must be used to return a value of the type, and also + -- to determine whether a component clause is allowed for a component + -- of the given type. + -- + -- Note: this is public because of one dubious use in Sem_Res??? + -- + -- Note: Check_Compile_Time_Size does not test the case of the size being + -- known because a size clause is specifically given. That is because we + -- do not allow a size clause if the size would not otherwise be known at + -- compile time in any case. + + function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id; + -- Freeze an entity, and return Freeze nodes, to be inserted at the + -- point of call. Loc is a source location which corresponds to the + -- freeze point. This is used in placing warning messages in the + -- situation where it appears that a type has been frozen too early, + -- e.g. when a primitive operation is declared after the freezing + -- point of its tagged type. Returns No_List if no freeze nodes needed. + + procedure Freeze_All (From : Entity_Id; After : in out Node_Id); + -- Before a non-instance body, or at the end of a declarative part + -- freeze all entities therein that are not yet frozen. Calls itself + -- recursively to catch types in inner packages that were not frozen + -- at the inner level because they were not yet completely defined. + -- This routine also analyzes and freezes default parameter expressions + -- in subprogram specifications (this has to be delayed until all the + -- types are frozen). The resulting freeze nodes are inserted just + -- after node After (which is a list node) and analyzed. On return, + -- 'After' is updated to point to the last node inserted (or is returned + -- unchanged if no nodes were inserted). 'From' is the last entity frozen + -- in the scope. It is used to prevent a quadratic traversal over already + -- frozen entities. + + procedure Freeze_Before (N : Node_Id; T : Entity_Id); + -- Freeze T then Insert the generated Freeze nodes before the node N. + + procedure Freeze_Expression (N : Node_Id); + -- Freezes the required entities when the Expression N causes freezing. + -- The node N here is either a subexpression node (a "real" expression) + -- or a subtype mark, or a subtype indication. The latter two cases are + -- not really expressions, but they can appear within expressions and + -- so need to be similarly treated. Freeze_Expression takes care of + -- determining the proper insertion point for generated freeze actions. + + procedure Freeze_Itype (T : Entity_Id; N : Node_Id); + -- This routine is called when an Itype is created and must be frozen + -- immediately at the point of creation (for the sake of the expansion + -- activities in Exp_Ch3 (for example, the creation of packed array + -- types). We can't just let Freeze_Expression do this job since it + -- goes out of its way to make sure that the freeze node occurs at a + -- point outside the current construct, e.g. outside the expression or + -- outside the initialization procedure. That's normally right, but + -- not in this case, since if we create an Itype in an expression it + -- may be the case that it is not always elaborated (for example it + -- may result from the right operand of a short circuit). In this case + -- we want the freeze node to be inserted at the same point as the Itype. + -- The node N provides both the location for the freezing and also the + -- insertion point for the resulting freeze nodes. + +end Freeze; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb new file mode 100644 index 00000000000..9aa1e7d16c9 --- /dev/null +++ b/gcc/ada/frontend.adb @@ -0,0 +1,322 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R O N T E N D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.84 $ +-- -- +-- Copyright (C) 1992-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 Checks; +with CStand; +with Debug; use Debug; +with Elists; +with Exp_Ch11; +with Exp_Dbug; +with Fname.UF; +with Hostparm; use Hostparm; +with Inline; use Inline; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Live; use Live; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Osint; +with Output; use Output; +with Par; +with Rtsfind; +with Sprint; +with Scn; use Scn; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Elab; use Sem_Elab; +with Sem_Prag; use Sem_Prag; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Types; use Types; + +procedure Frontend is + Pragmas : List_Id; + Prag : Node_Id; + + Save_Style_Check : constant Boolean := Opt.Style_Check; + -- Save style check mode so it can be restored later + +begin + -- Carry out package initializations. These are initializations which + -- might logically be performed at elaboration time, were it not for + -- the fact that we may be doing things more than once in the big loop + -- over files. Like elaboration, the order in which these calls are + -- made is in some cases important. For example, Lib cannot be + -- initialized until Namet, since it uses names table entries. + + Rtsfind.Initialize; + Atree.Initialize; + Nlists.Initialize; + Elists.Initialize; + Lib.Load.Initialize; + Sem_Ch8.Initialize; + Fname.UF.Initialize; + Exp_Ch11.Initialize; + Checks.Initialize; + + -- Create package Standard + + CStand.Create_Standard; + + -- Read and process gnat.adc file if one is present + + if Opt.Config_File then + + -- We always analyze the gnat.adc file with style checks off, + -- since we don't want a miscellaneous gnat.adc that is around + -- to discombobulate intended -gnatg compilations. + + Opt.Style_Check := False; + + -- Capture current suppress options, which may get modified + + Scope_Suppress := Opt.Suppress_Options; + + Name_Buffer (1 .. 8) := "gnat.adc"; + Name_Len := 8; + Source_gnat_adc := Load_Config_File (Name_Enter); + + if Source_gnat_adc /= No_Source_File then + Initialize_Scanner (No_Unit, Source_gnat_adc); + Pragmas := Par (Configuration_Pragmas => True); + + if Pragmas /= Error_List + and then Operating_Mode /= Check_Syntax + then + Prag := First (Pragmas); + while Present (Prag) loop + Analyze_Pragma (Prag); + Next (Prag); + end loop; + end if; + end if; + + -- Restore style check, but if gnat.adc turned on checks, leave on! + + Opt.Style_Check := Save_Style_Check or Style_Check; + + -- Capture any modifications to suppress options from config pragmas + + Opt.Suppress_Options := Scope_Suppress; + end if; + + -- Read and process the configuration pragmas file if one is present + + if Config_File_Name /= null then + + declare + New_Pragmas : List_Id; + Style_Check_Saved : constant Boolean := Opt.Style_Check; + Source_Config_File : Source_File_Index := No_Source_File; + + begin + -- We always analyze the config pragmas file with style checks off, + -- since we don't want it to discombobulate intended + -- -gnatg compilations. + + Opt.Style_Check := False; + + -- Capture current suppress options, which may get modified + + Scope_Suppress := Opt.Suppress_Options; + + Name_Buffer (1 .. Config_File_Name'Length) := Config_File_Name.all; + Name_Len := Config_File_Name'Length; + Source_Config_File := Load_Config_File (Name_Enter); + + if Source_Config_File = No_Source_File then + Osint.Fail + ("cannot find configuration pragmas file ", + Config_File_Name.all); + end if; + + Initialize_Scanner (No_Unit, Source_Config_File); + New_Pragmas := Par (Configuration_Pragmas => True); + + if New_Pragmas /= Error_List + and then Operating_Mode /= Check_Syntax + then + Prag := First (New_Pragmas); + while Present (Prag) loop + Analyze_Pragma (Prag); + Next (Prag); + end loop; + end if; + + -- Restore style check, but if the config pragmas file + -- turned on checks, leave on! + + Opt.Style_Check := Style_Check_Saved or Style_Check; + + -- Capture any modifications to suppress options from config pragmas + + Opt.Suppress_Options := Scope_Suppress; + end; + + end if; + + -- We have now processed the command line switches, and the gnat.adc + -- file, so this is the point at which we want to capture the values + -- of the configuration switches (see Opt for further details). + + Opt.Register_Opt_Config_Switches; + + -- Initialize the scanner. Note that we do this after the call to + -- Create_Standard, which uses the scanner in its processing of + -- floating-point bounds. + + Initialize_Scanner (Main_Unit, Source_Index (Main_Unit)); + + -- Output header if in verbose mode or full list mode + + if Verbose_Mode or Full_List then + Write_Eol; + + if Operating_Mode = Generate_Code then + Write_Str ("Compiling: "); + else + Write_Str ("Checking: "); + end if; + + Write_Name (Full_File_Name (Current_Source_File)); + + if not Debug_Flag_7 then + Write_Str (" (source file time stamp: "); + Write_Time_Stamp (Current_Source_File); + Write_Char (')'); + end if; + + Write_Eol; + end if; + + -- Here we call the parser to parse the compilation unit (or units in + -- the check syntax mode, but in that case we won't go on to the + -- semantics in any case). + + declare + Discard : List_Id; + + begin + Discard := Par (Configuration_Pragmas => False); + end; + + -- The main unit is now loaded, and subunits of it can be loaded, + -- without reporting spurious loading circularities. + + Set_Loading (Main_Unit, False); + + -- Now on to the semantics. We skip the semantics if we are in syntax + -- only mode, or if we encountered a fatal error during the parsing. + + if Operating_Mode /= Check_Syntax + and then not Fatal_Error (Main_Unit) + then + -- Reset Operating_Mode to Check_Semantics for subunits. We cannot + -- actually generate code for subunits, so we suppress expansion. + -- This also corrects certain problems that occur if we try to + -- incorporate subunits at a lower level. + + if Operating_Mode = Generate_Code + and then Nkind (Unit (Cunit (Main_Unit))) = N_Subunit + then + Operating_Mode := Check_Semantics; + end if; + + -- Analyze (and possibly expand) main unit + + Scope_Suppress := Suppress_Options; + Semantics (Cunit (Main_Unit)); + + -- Cleanup processing after completing main analysis + + if Operating_Mode = Generate_Code + or else (Operating_Mode = Check_Semantics + and then Tree_Output) + then + Instantiate_Bodies; + end if; + + if Operating_Mode = Generate_Code then + + if Inline_Processing_Required then + Analyze_Inlined_Bodies; + end if; + + -- Remove entities from program that do not have any + -- execution time references. + + if Debug_Flag_UU then + Collect_Garbage_Entities; + end if; + + Check_Elab_Calls; + + -- Build unit exception table. We leave this up to the end to + -- make sure that all the necessary information is at hand. + + Exp_Ch11.Generate_Unit_Exception_Table; + + -- Save the unit name and list of packages named in Use_Package + -- clauses for subsequent use in generating a special symbol for + -- the debugger for certain targets that require this. + + Exp_Dbug.Save_Unitname_And_Use_List + (Cunit (Main_Unit), Nkind (Unit (Cunit (Main_Unit)))); + end if; + + -- List library units if requested + + if List_Units then + Lib.List; + end if; + + -- Output any messages for unreferenced entities + + Output_Unreferenced_Messages; + end if; + + -- Qualify all entity names in inner packages, package bodies, etc., + -- except when compiling for the JVM back end, which depends on + -- having unqualified names in certain cases and handles the generation + -- of qualified names when needed. + + if not Java_VM then + Exp_Dbug.Qualify_All_Entity_Names; + Exp_Dbug.Generate_Auxiliary_Types; + end if; + + -- Dump the source now. Note that we do this as soon as the analysis + -- of the tree is complete, because it is not just a dump in the case + -- of -gnatD, where it rewrites all source locations in the tree. + + Sprint.Source_Dump; +end Frontend; diff --git a/gcc/ada/frontend.ads b/gcc/ada/frontend.ads new file mode 100644 index 00000000000..dd8240541c6 --- /dev/null +++ b/gcc/ada/frontend.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R O N T E N D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Top level of the front-end. This procedure is used by the different +-- gnat drivers. + +procedure Frontend; |