Commit d7761b2d by Arnaud Charlet

[multiple changes]

2013-02-06  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, sem_ch10.adb: Minor reformatting.
	* exp_disp.adb: Minor comment update.
	* comperr.ads, osint.ads, rtsfind.adb, sem_prag.adb: Minor addition of
	No_Return pragmas.

2013-02-06  Thomas Quinot  <quinot@adacore.com>

	* targparm.ads, sem_ch13.adb (Support_Nondefault_SSO): New target
	parameter, defaulted to False for now, indicates targets where
	non-default scalar storage order may be specified.

2013-02-06  Thomas Quinot  <quinot@adacore.com>

	* sprint.adb (Write_Itype): Treat E_Record_Subtype_With_Private
	same as E_Record_Subtype.  Display E_Class_Wide_Subtype as
	subtype, not type.

From-SVN: r195797
parent 6d840d99
2013-02-06 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sem_ch10.adb: Minor reformatting.
* exp_disp.adb: Minor comment update.
* comperr.ads, osint.ads, rtsfind.adb, sem_prag.adb: Minor addition of
No_Return pragmas.
2013-02-06 Thomas Quinot <quinot@adacore.com>
* targparm.ads, sem_ch13.adb (Support_Nondefault_SSO): New target
parameter, defaulted to False for now, indicates targets where
non-default scalar storage order may be specified.
2013-02-06 Thomas Quinot <quinot@adacore.com>
* sprint.adb (Write_Itype): Treat E_Record_Subtype_With_Private
same as E_Record_Subtype. Display E_Class_Wide_Subtype as
subtype, not type.
2013-02-06 Hristian Kirtchev <kirtchev@adacore.com> 2013-02-06 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb (Complete_Private_Subtype): Inherit the * sem_ch3.adb (Complete_Private_Subtype): Inherit the
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -33,6 +33,7 @@ package Comperr is ...@@ -33,6 +33,7 @@ package Comperr is
(X : String; (X : String;
Code : Integer := 0; Code : Integer := 0;
Fallback_Loc : String := ""); Fallback_Loc : String := "");
pragma No_Return (Compiler_Abort);
-- Signals an internal compiler error. Never returns control. Depending on -- Signals an internal compiler error. Never returns control. Depending on
-- processing may end up raising Unrecoverable_Error, or exiting directly. -- processing may end up raising Unrecoverable_Error, or exiting directly.
-- The message output is a "bug box" containing the first string passed as -- The message output is a "bug box" containing the first string passed as
......
...@@ -4181,9 +4181,7 @@ package body Exp_Ch6 is ...@@ -4181,9 +4181,7 @@ package body Exp_Ch6 is
if Is_Entity_Name (N) and then Present (Entity (N)) then if Is_Entity_Name (N) and then Present (Entity (N)) then
E := Entity (N); E := Entity (N);
if Is_Formal (E) if Is_Formal (E) and then Scope (E) = Subp then
and then Scope (E) = Subp
then
A := Renamed_Object (E); A := Renamed_Object (E);
-- Rewrite the occurrence of the formal into an occurrence of -- Rewrite the occurrence of the formal into an occurrence of
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -4132,6 +4132,9 @@ package body Exp_Disp is ...@@ -4132,6 +4132,9 @@ package body Exp_Disp is
-- Nb_Prim. If the tagged type has no primitives we add a dummy -- Nb_Prim. If the tagged type has no primitives we add a dummy
-- slot whose address will be the tag of this type. -- slot whose address will be the tag of this type.
-- ???codepeer???
-- Nb_Prim cannot be zero here, so this test is wrong
if Nb_Prim = 0 then if Nb_Prim = 0 then
New_Node := Make_Integer_Literal (Loc, 1); New_Node := Make_Integer_Literal (Loc, 1);
else else
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -637,6 +637,7 @@ package Osint is ...@@ -637,6 +637,7 @@ package Osint is
-- Set_Exit_Status as the last action of the program. -- Set_Exit_Status as the last action of the program.
procedure OS_Exit_Through_Exception (Status : Integer); procedure OS_Exit_Through_Exception (Status : Integer);
pragma No_Return;
-- Set the Current_Exit_Status, then raise Types.Terminate_Program -- Set the Current_Exit_Status, then raise Types.Terminate_Program
type Exit_Code_Type is ( type Exit_Code_Type is (
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -148,6 +148,7 @@ package body Rtsfind is ...@@ -148,6 +148,7 @@ package body Rtsfind is
-- value in RTU_Id. -- value in RTU_Id.
procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id);
pragma No_Return (Load_Fail);
-- Internal procedure called if we can't successfully locate or process a -- Internal procedure called if we can't successfully locate or process a
-- run-time unit. The parameters give information about the error message -- run-time unit. The parameters give information about the error message
-- to be given. S is a reason for failing to compile the file and U_Id is -- to be given. S is a reason for failing to compile the file and U_Id is
......
...@@ -4741,11 +4741,10 @@ package body Sem_Ch10 is ...@@ -4741,11 +4741,10 @@ package body Sem_Ch10 is
-- compiling the body of the child unit. -- compiling the body of the child unit.
if P = Cunit_Entity (Current_Sem_Unit) if P = Cunit_Entity (Current_Sem_Unit)
or else or else (Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
(Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body and then P = Main_Unit_Entity
and then P = Main_Unit_Entity and then Is_Ancestor_Unit
and then (Cunit (Main_Unit), Cunit (Current_Sem_Unit)))
Is_Ancestor_Unit (Cunit (Main_Unit), Cunit (Current_Sem_Unit)))
then then
return; return;
end if; end if;
......
...@@ -3622,9 +3622,17 @@ package body Sem_Ch13 is ...@@ -3622,9 +3622,17 @@ package body Sem_Ch13 is
Flag_Non_Static_Expr Flag_Non_Static_Expr
("Scalar_Storage_Order requires static expression!", Expr); ("Scalar_Storage_Order requires static expression!", Expr);
else elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
-- Here for the case of a non-default (i.e. non-confirming)
-- Scalar_Storage_Order attribute definition.
if Support_Nondefault_SSO_On_Target then
Set_Reverse_Storage_Order (Base_Type (U_Ent), True); Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
else
Error_Msg_N
("non-default Scalar_Storage_Order "
& "not supported on target", Expr);
end if; end if;
end if; end if;
end if; end if;
......
...@@ -10255,21 +10255,23 @@ package body Sem_Ch3 is ...@@ -10255,21 +10255,23 @@ package body Sem_Ch3 is
Protected_Kind => Protected_Kind =>
Copy_Node (Priv, Full); Copy_Node (Priv, Full);
Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); Set_Has_Discriminants
(Full, Has_Discriminants (Full_Base));
Set_Has_Unknown_Discriminants Set_Has_Unknown_Discriminants
(Full, Has_Unknown_Discriminants (Full_Base)); (Full, Has_Unknown_Discriminants (Full_Base));
Set_First_Entity (Full, First_Entity (Full_Base)); Set_First_Entity (Full, First_Entity (Full_Base));
Set_Last_Entity (Full, Last_Entity (Full_Base)); Set_Last_Entity (Full, Last_Entity (Full_Base));
when others => when others =>
Copy_Node (Full_Base, Full); Copy_Node (Full_Base, Full);
Set_Chars (Full, Chars (Priv)); Set_Chars (Full, Chars (Priv));
Conditional_Delay (Full, Priv); Conditional_Delay (Full, Priv);
Set_Sloc (Full, Sloc (Priv)); Set_Sloc (Full, Sloc (Priv));
end case; end case;
Set_Next_Entity (Full, Save_Next_Entity); Set_Next_Entity (Full, Save_Next_Entity);
Set_Homonym (Full, Save_Homonym); Set_Homonym (Full, Save_Homonym);
Set_Associated_Node_For_Itype (Full, Related_Nod); Set_Associated_Node_For_Itype (Full, Related_Nod);
-- Set common attributes for all subtypes: kind, convention, etc. -- Set common attributes for all subtypes: kind, convention, etc.
......
...@@ -1924,6 +1924,7 @@ package body Sem_Prag is ...@@ -1924,6 +1924,7 @@ package body Sem_Prag is
procedure Check_Loop_Invariant_Variant_Placement is procedure Check_Loop_Invariant_Variant_Placement is
procedure Placement_Error (Constr : Node_Id); procedure Placement_Error (Constr : Node_Id);
pragma No_Return (Placement_Error);
-- Node Constr denotes the last loop restricted construct before we -- Node Constr denotes the last loop restricted construct before we
-- encountered an illegal relation between enclosing constructs. Emit -- encountered an illegal relation between enclosing constructs. Emit
-- an error depending on what Constr was. -- an error depending on what Constr was.
...@@ -6049,6 +6050,7 @@ package body Sem_Prag is ...@@ -6049,6 +6050,7 @@ package body Sem_Prag is
S2 : constant String_Id := Strval (New_Name); S2 : constant String_Id := Strval (New_Name);
procedure Mismatch; procedure Mismatch;
pragma No_Return (Mismatch);
-- Called if names do not match -- Called if names do not match
-------------- --------------
...@@ -6154,9 +6156,11 @@ package body Sem_Prag is ...@@ -6154,9 +6156,11 @@ package body Sem_Prag is
Mech_Name_Id : Name_Id; Mech_Name_Id : Name_Id;
procedure Bad_Class; procedure Bad_Class;
pragma No_Return (Bad_Class);
-- Signal bad descriptor class name -- Signal bad descriptor class name
procedure Bad_Mechanism; procedure Bad_Mechanism;
pragma No_Return (Bad_Mechanism);
-- Signal bad mechanism name -- Signal bad mechanism name
--------------- ---------------
......
...@@ -4145,7 +4145,7 @@ package body Sprint is ...@@ -4145,7 +4145,7 @@ package body Sprint is
-- Record subtypes -- Record subtypes
when E_Record_Subtype => when E_Record_Subtype | E_Record_Subtype_With_Private =>
Write_Header (False); Write_Header (False);
Write_Str ("record"); Write_Str ("record");
Indent_Begin; Indent_Begin;
...@@ -4170,7 +4170,7 @@ package body Sprint is ...@@ -4170,7 +4170,7 @@ package body Sprint is
when E_Class_Wide_Type | when E_Class_Wide_Type |
E_Class_Wide_Subtype => E_Class_Wide_Subtype =>
Write_Header; Write_Header (Ekind (Typ) = E_Class_Wide_Type);
Write_Name_With_Col_Check (Chars (Etype (Typ))); Write_Name_With_Col_Check (Chars (Etype (Typ)));
Write_Str ("'Class"); Write_Str ("'Class");
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1999-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -436,6 +436,11 @@ package Targparm is ...@@ -436,6 +436,11 @@ package Targparm is
-- the source program may not contain explicit 64-bit shifts. In addition, -- the source program may not contain explicit 64-bit shifts. In addition,
-- the code generated for packed arrays will avoid the use of long shifts. -- the code generated for packed arrays will avoid the use of long shifts.
Support_Nondefault_SSO_On_Target : Boolean := False;
-- If True, the back end supports the non-default Scalar_Storage_Order
-- (i.e. allows non-confirming Scalar_Storage_Order attribute definition
-- clauses).
-------------------- --------------------
-- Indirect Calls -- -- Indirect Calls --
-------------------- --------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment