diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 42 | ||||
| -rw-r--r-- | gcc/ada/a-tifiio.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/ali.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/g-socket.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/g-socket.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/g-socthi-vms.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 7 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 202 | ||||
| -rw-r--r-- | gcc/ada/sem.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 9 |
14 files changed, 361 insertions, 73 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 541c367..ebc1ea0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,47 @@ 2009-04-20 Thomas Quinot <quinot@adacore.com> + * sem_type.adb, ali.adb, erroutc.adb: Minor code reorganization + (no behaviour change): Use Append instead of Increment_Last followed + by assignment. + +2009-04-20 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate the + declarations of all primitives associated with dispatching asynchronous, + conditional and timed selects when dispaching calls are forbidden and + select statements are not allowed (such as in Ravenscar). + (Predefined_Primitive_Bodies): Ditto for bodies. + + * exp_disp.ad (Make_DT): Do not create and populate the + Select_Specific_Data of the dispatch table when dispatching calls are + forbidden and select statements are not allowed (such as in Ravenscar). + +2009-04-20 Robert Dewar <dewar@adacore.com> + + * a-tifiio.adb: Minor reformatting + +2009-04-20 Thomas Quinot <quinot@adacore.com> + + * g-socthi-vms.adb, g-socket.adb, g-socket.ads: inet_aton(3), unlike + other C library functions, report *failure* with a zero status, and + success with a non-zero status. + +2009-04-20 Bob Duff <duff@adacore.com> + + * sem.ads, sem.adb (Walk_Library_Items): New generic procedure. + (Semantics): After analyzing each unit, Append it to the + Comp_Unit_List, if appropriate. + + * gnat1drv.adb (Check_Library_Items): New procedure for debugging + purposes. + (Gnat1drv): Correct comment regarding Back_End_Mode. + +2009-04-20 Eric Botcazou <ebotcazou@adacore.com> + + * gnat_ugn.texi: Add documentation for -fno-inline-small-functions. + +2009-04-20 Thomas Quinot <quinot@adacore.com> + * s-taprop-irix.adb, s-taprop-tru64.adb, s-taprop-vms.adb, output.adb, output.ads, s-taprop-hpux-dce.adb, s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-posix.adb: Minor diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb index 22926f8..720fcac 100644 --- a/gcc/ada/a-tifiio.adb +++ b/gcc/ada/a-tifiio.adb @@ -290,11 +290,11 @@ package body Ada.Text_IO.Fixed_IO is and then Num'Small * 10.0**Scale < 10.0); Exact : constant Boolean := - Float'Floor (Num'Small) = Float'Ceiling (Num'Small) - or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small) - or Num'Small >= 10.0**Max_Digits; + Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small) + or Num'Small >= 10.0**Max_Digits; -- True iff a numerator and denominator can be calculated such that - -- their ratio exactly represents the small of Num + -- their ratio exactly represents the small of Num. procedure Put (To : out String; @@ -315,10 +315,8 @@ package body Ada.Text_IO.Fixed_IO is Width : Field := 0) is pragma Unsuppress (Range_Check); - begin Aux.Get (File, Long_Long_Float (Item), Width); - exception when Constraint_Error => raise Data_Error; end Get; @@ -328,10 +326,8 @@ package body Ada.Text_IO.Fixed_IO is Width : Field := 0) is pragma Unsuppress (Range_Check); - begin Aux.Get (Current_In, Long_Long_Float (Item), Width); - exception when Constraint_Error => raise Data_Error; end Get; @@ -342,10 +338,8 @@ package body Ada.Text_IO.Fixed_IO is Last : out Positive) is pragma Unsuppress (Range_Check); - begin Aux.Gets (From, Long_Long_Float (Item), Last); - exception when Constraint_Error => raise Data_Error; end Get; @@ -387,11 +381,13 @@ package body Ada.Text_IO.Fixed_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) is - Fore : constant Integer := To'Length - - 1 -- Decimal point - - Field'Max (1, Aft) -- Decimal part - - Boolean'Pos (Exp /= 0) -- Exponent indicator - - Exp; -- Exponent + Fore : constant Integer := + To'Length + - 1 -- Decimal point + - Field'Max (1, Aft) -- Decimal part + - Boolean'Pos (Exp /= 0) -- Exponent indicator + - Exp; -- Exponent + Last : Natural; begin @@ -426,13 +422,13 @@ package body Ada.Text_IO.Fixed_IO is -- Add C to the output string To, updating Last procedure Put_Digit (X : Digit); - -- Add digit X to the output string (going from left to right), - -- updating Last and Pos, and inserting the sign, leading zeros - -- or a decimal point when necessary. After outputting the first - -- digit, Pos must not be changed outside Put_Digit anymore + -- Add digit X to the output string (going from left to right), updating + -- Last and Pos, and inserting the sign, leading zeros or a decimal + -- point when necessary. After outputting the first digit, Pos must not + -- be changed outside Put_Digit anymore. procedure Put_Int64 (X : Int64; Scale : Integer); - -- Output the decimal number abs X * 10**Scale. + -- Output the decimal number abs X * 10**Scale procedure Put_Scaled (X, Y, Z : Int64; @@ -469,6 +465,7 @@ package body Ada.Text_IO.Fixed_IO is begin if Last = To'First - 1 then if X /= 0 or Pos <= 0 then + -- Before outputting first digit, include leading space, -- possible minus sign and, if the first digit is fractional, -- decimal seperator and leading zeros. @@ -541,6 +538,7 @@ package body Ada.Text_IO.Fixed_IO is -- If and only if more than one digit is output before the decimal -- point, pos will be unequal to scale when outputting the first -- digit. + pragma Assert (Pos = Scale or else Last = To'First - 1); Pos := Scale; @@ -560,15 +558,15 @@ package body Ada.Text_IO.Fixed_IO is pragma Assert (E >= -Max_Digits); AA : constant Field := E + A; N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1; + Q : array (0 .. N - 1) of Int64 := (others => 0); - -- Each element of Q has Max_Digits decimal digits, except - -- the last, which has eAA rem Max_Digits. Only Q (Q'First) - -- may have an absolute value equal to or larger than 10**Max_Digits. - -- Only the absolute value of the elements is not significant, not - -- the sign. + -- Each element of Q has Max_Digits decimal digits, except the + -- last, which has eAA rem Max_Digits. Only Q (Q'First) may have an + -- absolute value equal to or larger than 10**Max_Digits. Only the + -- absolute value of the elements is not significant, not the sign. - XX : Int64 := X; - YY : Int64 := Y; + XX : Int64 := X; + YY : Int64 := Y; begin for J in Q'Range loop @@ -584,9 +582,9 @@ package body Ada.Text_IO.Fixed_IO is if -E > A then pragma Assert (N = 1); - Discard_Extra_Digits : - declare + Discard_Extra_Digits : declare Factor : constant Int64 := 10**(-E - A); + begin -- The scaling factors were such that the first division -- produced more digits than requested. So divide away extra @@ -602,8 +600,9 @@ package body Ada.Text_IO.Fixed_IO is end Discard_Extra_Digits; end if; - -- At this point XX is a remainder and we need to determine if - -- the quotient in Q must be rounded away from zero. + -- At this point XX is a remainder and we need to determine if the + -- quotient in Q must be rounded away from zero. + -- As XX is less than the divisor, it is safe to take its absolute -- without chance of overflow. The check to see if XX is at least -- half the absolute value of the divisor must be done carefully to diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index efc0ac2..5e5c660 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -482,8 +482,7 @@ package body ALI is end if; loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Getc; + Add_Char_To_Name_Buffer (Getc); exit when At_End_Of_Field and not Ignore_Spaces; @@ -936,8 +935,7 @@ package body ALI is Name_Len := 0; while not At_Eol loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Getc; + Add_Char_To_Name_Buffer (Getc); end loop; -- If -fstack-check, record that it occurred @@ -2000,8 +1998,7 @@ package body ALI is if Nextc not in '0' .. '9' then Name_Len := 0; while not At_End_Of_Field loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Getc; + Add_Char_To_Name_Buffer (Getc); end loop; -- Set the subunit name. Note that we use Name_Find rather @@ -2022,8 +2019,7 @@ package body ALI is Name_Len := 0; while not At_End_Of_Field loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Getc; + Add_Char_To_Name_Buffer (Getc); end loop; Sdep.Table (Sdep.Last).Rfile := Name_Enter; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 6e9153f..23386b8 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -926,8 +926,7 @@ package body Erroutc is 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); + Add_Char_To_Name_Buffer (Text (J)); J := J + 1; end loop; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4442a78..629bcad 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7818,12 +7818,13 @@ package body Exp_Ch3 is -- Disp_Timed_Select -- These operations cannot be implemented on VM targets, so we simply - -- disable their generation in this case. We also disable generation - -- of these bodies if No_Dispatching_Calls is active. + -- disable their generation in this case. Disable the generation of + -- these bodies if No_Dispatching_Calls or Ravenscar is active. if Ada_Version >= Ada_05 and then VM_Target = No_VM - and then RTE_Available (RE_Select_Specific_Data) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) then -- These primitives are defined abstract in interface types @@ -8311,19 +8312,19 @@ package body Exp_Ch3 is -- The interface versions will have null bodies -- These operations cannot be implemented on VM targets, so we simply - -- disable their generation in this case. We also disable generation - -- of these bodies if No_Dispatching_Calls is active. + -- disable their generation in this case. Disable the generation of + -- these bodies if No_Dispatching_Calls or Ravenscar is active. if Ada_Version >= Ada_05 and then VM_Target = No_VM - and then not Restriction_Active (No_Dispatching_Calls) and then not Is_Interface (Tag_Typ) and then ((Is_Interface (Etype (Tag_Typ)) and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) - and then Has_Interfaces (Tag_Typ))) - and then RTE_Available (RE_Select_Specific_Data) + and then Has_Interfaces (Tag_Typ))) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) then Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 2a6f347..54a823a 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4749,6 +4749,7 @@ package body Exp_Disp is and then not Is_Abstract_Type (Typ) and then not Is_Controlled (Typ) and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) then Append_To (Result, Make_Object_Declaration (Loc, @@ -5545,13 +5546,16 @@ package body Exp_Disp is Append_List_To (Result, Elab_Code); end if; - -- Populate the two auxiliary tables used for dispatching - -- asynchronous, conditional and timed selects for synchronized - -- types that implement a limited interface. + -- Populate the two auxiliary tables used for dispatching asynchronous, + -- conditional and timed selects for synchronized types that implement + -- a limited interface. Skip this step in Ravenscar profile or when + -- general dispatching is forbidden. if Ada_Version >= Ada_05 and then Is_Concurrent_Record_Type (Typ) and then Has_Interfaces (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) then Append_List_To (Result, Make_Select_Specific_Data_Table (Typ)); diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index f5b5d47..962a8fb 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -179,6 +179,10 @@ package body GNAT.Sockets is -- Reconstruct a Duration value from a Timeval record (seconds and -- microseconds). + procedure Raise_Socket_Error (Error : Integer); + -- Raise Socket_Error with an exception message describing the error code + -- from errno. + procedure Raise_Host_Error (H_Error : Integer); -- Raise Host_Error exception with message describing error code (note -- hstrerror seems to be obsolete) from h_errno. @@ -1288,7 +1292,7 @@ package body GNAT.Sockets is Res := Inet_Aton (To_Chars_Ptr (Img'Unchecked_Access), Addr'Address); - if Res = Failure then + if Res = 0 then Raise_Socket_Error (SOSC.EINVAL); end if; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 1b3ee63..3680d75 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -1108,10 +1108,6 @@ package GNAT.Sockets is private - procedure Raise_Socket_Error (Error : Integer); - -- Raise Socket_Error with an exception message describing the error code - -- from errno. - type Socket_Type is new Integer; No_Socket : constant Socket_Type := -1; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index 8a143c1..d065f99 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -358,7 +358,8 @@ package body GNAT.Sockets.Thin is --------------- -- VMS does not support inet_aton(3), so emulate it here in terms of - -- inet_addr(3). + -- inet_addr(3). Note: unlike other C functions, inet_aton reports + -- failure with a 0 return, and success with a non-zero return. function Inet_Aton (Cp : C.Strings.chars_ptr; @@ -373,7 +374,7 @@ package body GNAT.Sockets.Thin is pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR"); begin if Cp = Null_Ptr or else Inp = Null_Address then - Raise_Socket_Error (SOSC.EINVAL); + return 0; end if; -- Special case for the all-ones broadcast address: this address has the @@ -382,16 +383,16 @@ package body GNAT.Sockets.Thin is if String'(Value (Cp)) = "255.255.255.255" then Conv.To_Pointer (Inp).all := -1; - return 0; + return 1; end if; Res := C_Inet_Addr (Cp); if Res = -1 then - return Res; + return 0; end if; Conv.To_Pointer (Inp).all := Res; - return 0; + return 1; end Inet_Aton; ---------------- diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 3d495ce..53b789e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -90,6 +90,9 @@ procedure Gnat1drv is -- Called when we are not generating code, to check if -gnatR was requested -- and if so, explain that we will not be honoring the request. + procedure Check_Library_Items; + -- For debugging -- checks the behavior of Walk_Library_Items + -------------------- -- Check_Bad_Body -- -------------------- @@ -251,6 +254,29 @@ procedure Gnat1drv is end if; end Check_Rep_Info; + ------------------------- + -- Check_Library_Items -- + ------------------------- + + procedure Check_Library_Items is + -- Walk_Library_Items has plenty of assertions, so all we need to do is + -- call it. + + procedure Action (Item : Node_Id); + -- Action passed to Walk_Library_Items to do nothing + + procedure Action (Item : Node_Id) is + begin + null; + end Action; + + procedure Walk is new Sem.Walk_Library_Items (Action); + + -- Start of processing for Check_Library_Items + begin + Walk; + end Check_Library_Items; + -- Start of processing for Gnat1drv begin @@ -578,9 +604,9 @@ begin Back_End_Mode := Skip; end if; - -- At this stage Call_Back_End is set to indicate if the backend should - -- be called to generate code. If it is not set, then code generation - -- has been turned off, even though code was requested by the original + -- At this stage Back_End_Mode is set to indicate if the backend should + -- be called to generate code. If it is Skip, then code generation has + -- been turned off, even though code was requested by the original -- command. This is not an error from the user point of view, but it is -- an error from the point of view of the gcc driver, so we must exit -- with an error status. @@ -706,6 +732,8 @@ begin Namet.Lock; Stringt.Lock; + Check_Library_Items; -- For debugging + -- Here we call the back end to generate the output code Generating_Code := True; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 14ef446..7d573f7 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3802,9 +3802,14 @@ effect if this switch is present. @item -fno-inline-functions @cindex @option{-fno-inline-functions} (@command{gcc}) -Suppresses automatic inlining of small subprograms, which is enabled +Suppresses automatic inlining of simple subprograms, which is enabled if @option{-O3} is used. +@item -fno-inline-small-functions +@cindex @option{-fno-inline-small-functions} (@command{gcc}) +Suppresses automatic inlining of small subprograms, which is enabled +if @option{-O2} is used. + @item -fno-inline-functions-called-once @cindex @option{-fno-inline-functions-called-once} (@command{gcc}) Suppresses inlining of subprograms local to the unit and called once diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 82be60b..c6c2c00 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -27,6 +27,7 @@ with Atree; use Atree; with Debug; use Debug; with Debug_A; use Debug_A; +with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Fname; use Fname; @@ -34,6 +35,7 @@ with HLO; use HLO; with Lib; use Lib; with Lib.Load; use Lib.Load; with Nlists; use Nlists; +with Output; use Output; with Sem_Attr; use Sem_Attr; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; @@ -52,6 +54,7 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Uintp; use Uintp; +with Uname; use Uname; with Unchecked_Deallocation; @@ -65,6 +68,16 @@ package body Sem is -- generic context, it is empty. At the moment, it is only used -- for avoiding freezing of external references in generics. + Comp_Unit_List : Elist_Id := No_Elist; + -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes + -- processed by Semantics, in an appropriate order. Initialized to + -- No_Elist, because it's too early to call New_Elmt_List; we will set it + -- to New_Elmt_List on first use. + + Ignore_Comp_Units : Boolean := False; + -- If True, we suppress appending compilation units onto the + -- Comp_Unit_List. + ------------- -- Analyze -- ------------- @@ -1384,7 +1397,44 @@ package body Sem is New_Nodes_OK := 0; end if; - Do_Analyze; + -- Do analysis, and then append the compilation unit onto the + -- Comp_Unit_List, if appropriate. This is done after analysis, so if + -- this unit depends on some others, they have already been + -- appended. We ignore bodies, except for the main unit itself, and + -- everything those bodies depend upon. + + if Ignore_Comp_Units then + Do_Analyze; + pragma Assert (Ignore_Comp_Units); -- still + + elsif Nkind (Unit (Comp_Unit)) in N_Proper_Body + and then not In_Extended_Main_Source_Unit (Comp_Unit) + then + Ignore_Comp_Units := True; + Do_Analyze; + pragma Assert (Ignore_Comp_Units); + Ignore_Comp_Units := False; + + else + Do_Analyze; + -- pragma Assert (not Ignore_Comp_Units); + -- The above assertion is *almost* true. It fails only when a + -- subunit with's its parent procedure body, which has no explicit + -- spec. + + if No (Comp_Unit_List) then -- Initialize if first time + Comp_Unit_List := New_Elmt_List; + end if; + if not Ignore_Comp_Units then -- See above commented-out Assert + Append_Elmt (Comp_Unit, Comp_Unit_List); + end if; + + -- Ignore all units after main unit + + if Comp_Unit = Cunit (Main_Unit) then + Ignore_Comp_Units := True; + end if; + end if; end if; -- Save indication of dynamic elaboration checks for ALI file @@ -1405,4 +1455,154 @@ package body Sem is Restore_Opt_Config_Switches (Save_Config_Switches); Expander_Mode_Restore; end Semantics; + + ------------------------ + -- Walk_Library_Items -- + ------------------------ + + procedure Walk_Library_Items is + Enable_Output : constant Boolean := False; + -- Set to True to print out the items as we go (for debugging) + + procedure Do_Action (CU : Node_Id; Item : Node_Id); + -- Calls Action, with some validity checks + + --------------- + -- Do_Action -- + --------------- + + procedure Do_Action (CU : Node_Id; Item : Node_Id) is + begin + -- This calls Action at the end. All the preceding code is just + -- assertions and debugging output. + + case Nkind (Item) is + when N_Generic_Subprogram_Declaration | + N_Generic_Package_Declaration | + N_Package_Declaration | + N_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration | + N_Package_Renaming_Declaration | + N_Generic_Function_Renaming_Declaration | + N_Generic_Package_Renaming_Declaration | + N_Generic_Procedure_Renaming_Declaration => + null; -- Specs are OK + + when N_Package_Body | N_Subprogram_Body => + -- A body must be the main unit + + pragma Assert (CU = Cunit (Main_Unit)); + null; + + -- All other cases cannot happen + + when N_Function_Instantiation | + N_Procedure_Instantiation | + N_Package_Instantiation => + pragma Assert (False, "instantiation"); + null; + + when N_Subunit => + pragma Assert (False, "subunit"); + null; + + when others => + pragma Assert (False); + null; + end case; + + if Present (CU) then + pragma Assert (Item /= Stand.Standard_Package_Node); + + if Enable_Output then + Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (CU))); + Write_Str (", Unit_Number = "); + Write_Int (Int (Get_Cunit_Unit_Number (CU))); + Write_Str (", "); + Write_Str (Node_Kind'Image (Nkind (Item))); + if Item /= Original_Node (Item) then + Write_Str (", orig = "); + Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); + end if; + Write_Eol; + end if; + + else -- Must be Standard + pragma Assert (Item = Stand.Standard_Package_Node); + if Enable_Output then + Write_Line ("Standard"); + end if; + end if; + + Action (Item); + end Do_Action; + + Cur : Elmt_Id := First_Elmt (Comp_Unit_List); + + -- Start of processing for Walk_Library_Items + + begin + if Enable_Output then + Write_Line ("Walk_Library_Items:"); + Indent; + end if; + + -- Do Standard first, then walk the Comp_Unit_List + + Do_Action (Empty, Standard_Package_Node); + + while Present (Cur) loop + declare + CU : constant Node_Id := Node (Cur); + N : constant Node_Id := Unit (CU); + begin + pragma Assert (Nkind (CU) = N_Compilation_Unit); + + case Nkind (N) is + -- If it's a body, then ignore it, unless it's an instance (in + -- which case we do the spec), or it's the main unit (in which + -- case we do it). Note that it could be both. + + when N_Package_Body | N_Subprogram_Body => + declare + Entity : Node_Id := N; + begin + if Nkind (N) = N_Subprogram_Body then + Entity := Specification (Entity); + end if; + Entity := Defining_Unit_Name (Entity); + if Nkind (Entity) not in N_Entity then + -- Must be N_Defining_Program_Unit_Name + Entity := Defining_Identifier (Entity); + end if; + + if Is_Generic_Instance (Entity) then + Do_Action (CU, Unit (Library_Unit (CU))); + end if; + end; + + if CU = Cunit (Main_Unit) then + -- Must come last + + pragma Assert (No (Next_Elmt (Cur))); + + Do_Action (CU, N); + end if; + + -- It's a spec, so just do it + + when others => + Do_Action (CU, N); + end case; + end; + + Next_Elmt (Cur); + end loop; + + if Enable_Output then + Outdent; + Write_Line ("end Walk_Library_Items."); + end if; + end Walk_Library_Items; + end Sem; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index f6aabfb..544178b 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -640,4 +640,20 @@ package Sem is -- is False, then the status of the check can be determined simply by -- examining Scope_Checks (C), so this routine is not called in that case. + generic + with procedure Action (Item : Node_Id); + procedure Walk_Library_Items; + -- Primarily for use by SofCheck Inspector. Must be called after semantic + -- analysis (and expansion) are complete. Walks each relevant library item, + -- calling Action for each, in an order such that one will not run across + -- forward references. Each Item passed to Action is the declaration or + -- body of a library unit, including generics and renamings. The first item + -- is the N_Package_Declaration node for package Standard. Bodies are not + -- included, except for the main unit itself, which always comes last. + -- + -- Item is never a subunit. + -- + -- Item is never an instantiation. Instead, the instance declaration is + -- passed, and (if the instantiation is the main unit), the instance body. + end Sem; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 47bc662..4e03642 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -312,8 +312,7 @@ package body Sem_Type is end loop; All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op); - All_Interp.Increment_Last; - All_Interp.Table (All_Interp.Last) := No_Interp; + All_Interp.Append (No_Interp); end Add_Entry; ---------------------------- @@ -634,8 +633,7 @@ package body Sem_Type is then All_Interp.Table (All_Interp.Last) := (H, Etype (H), Empty); - All_Interp.Increment_Last; - All_Interp.Table (All_Interp.Last) := No_Interp; + All_Interp.Append (No_Interp); goto Next_Homograph; elsif Scope (H) /= Standard_Standard then @@ -2625,8 +2623,7 @@ package body Sem_Type is Map_Ptr : Int; begin - All_Interp.Increment_Last; - All_Interp.Table (All_Interp.Last) := No_Interp; + All_Interp.Append (No_Interp); Map_Ptr := Headers (Hash (N)); |