From fe0ec02f9397eeb71a4ecb1a6fb2b67cfdb9378c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 4 Aug 2011 11:42:31 +0200 Subject: [PATCH] [multiple changes] 2011-08-04 Robert Dewar * sem_aggr.adb, par_sco.adb, sem_type.adb, exp_util.adb, exp_ch9.adb, prj-nmsc.adb, sem_ch13.adb, exp_strm.adb: Minor reformatting. 2011-08-04 Robert Dewar * gnat_rm.texi: Minor documentation fix for pragma Annotate. 2011-08-04 Yannick Moy * sem_attr.adb (Analyze_Attribute): add check during pre-analysis that 'Result only appears in postcondition of function. 2011-08-04 Thomas Quinot * a-tags.adb (Check_TSD): When raising PROGRAM_ERROR for a duplicated external tag, include the value of the external tag in the exception message. From-SVN: r177344 --- gcc/ada/ChangeLog | 20 ++++++++++++++++++++ gcc/ada/a-tags.adb | 11 ++++++++++- gcc/ada/exp_ch9.adb | 3 +-- gcc/ada/exp_strm.adb | 16 +++++++++++----- gcc/ada/exp_util.adb | 7 +++---- gcc/ada/gnat_rm.texi | 7 +++++-- gcc/ada/par_sco.adb | 2 +- gcc/ada/prj-nmsc.adb | 3 +-- gcc/ada/sem_aggr.adb | 1 + gcc/ada/sem_attr.adb | 20 ++++++++++++++++++++ gcc/ada/sem_ch13.adb | 8 ++++---- gcc/ada/sem_type.adb | 12 +++++++----- 12 files changed, 84 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9e5ec15de31..ed0bfd7bc07 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2011-08-04 Robert Dewar + + * sem_aggr.adb, par_sco.adb, sem_type.adb, exp_util.adb, exp_ch9.adb, + prj-nmsc.adb, sem_ch13.adb, exp_strm.adb: Minor reformatting. + +2011-08-04 Robert Dewar + + * gnat_rm.texi: Minor documentation fix for pragma Annotate. + +2011-08-04 Yannick Moy + + * sem_attr.adb (Analyze_Attribute): add check during pre-analysis that + 'Result only appears in postcondition of function. + +2011-08-04 Thomas Quinot + + * a-tags.adb (Check_TSD): When raising PROGRAM_ERROR for a duplicated + external tag, include the value of the external tag in the exception + message. + 2011-08-04 Yannick Moy * sem_attr.adb (Result): modify error message for misplaced 'Result diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 3473b4d5f99..7070fa792b8 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -310,6 +310,13 @@ package body Ada.Tags is procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is T : Tag; + E_Tag_Len : constant Integer := Length (TSD.External_Tag); + E_Tag : String (1 .. E_Tag_Len); + for E_Tag'Address use TSD.External_Tag.all'Address; + pragma Import (Ada, E_Tag); + + -- Start of processing for Check_TSD + begin -- Verify that the external tag of this TSD is not registered in the -- runtime hash table. @@ -317,7 +324,7 @@ package body Ada.Tags is T := External_Tag_HTable.Get (To_Address (TSD.External_Tag)); if T /= null then - raise Program_Error with "duplicated external tag"; + raise Program_Error with "duplicated external tag " & E_Tag; end if; end Check_TSD; @@ -718,6 +725,8 @@ package body Ada.Tags is -- Length -- ------------ + -- Should this be reimplemented using the strlen GCC builtin??? + function Length (Str : Cstring_Ptr) return Natural is Len : Integer; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 13396c993bc..fa193832a59 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -949,8 +949,7 @@ package body Exp_Ch9 is if Opt.Suppress_Control_Flow_Optimizations then Stmt := Make_Implicit_If_Statement (Cond, - Condition => - Cond, + Condition => Cond, Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, New_Occurrence_Of (Standard_True, Loc))), diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index d3d4751c645..f70ec41eac6 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -203,6 +203,7 @@ package body Exp_Strm is Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), Object_Definition => New_Occurrence_Of (Typ, Loc)); + else Odecl := Make_Object_Declaration (Loc, @@ -270,10 +271,10 @@ package body Exp_Strm is for J in 1 .. Number_Dimensions (Typ) loop Append_To (Stms, Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), Attribute_Name => Name_Write, - Expressions => New_List ( + Expressions => New_List ( Make_Identifier (Loc, Name_S), Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_V), @@ -283,10 +284,10 @@ package body Exp_Strm is Append_To (Stms, Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), Attribute_Name => Name_Write, - Expressions => New_List ( + Expressions => New_List ( Make_Identifier (Loc, Name_S), Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_V), @@ -301,7 +302,7 @@ package body Exp_Strm is Append_To (Stms, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Write, Expressions => New_List ( Make_Identifier (Loc, Name_S), @@ -566,6 +567,10 @@ package body Exp_Strm is -- then the representation is unsigned elsif not Is_Unsigned_Type (FST) + + -- The following set of tests gets repeated many times, we should + -- have an abstraction defined ??? + and then (Is_Fixed_Point_Type (U_Type) or else @@ -573,6 +578,7 @@ package body Exp_Strm is 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; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c8411f94480..72831936483 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3888,13 +3888,13 @@ package body Exp_Util is N_Selected_Component) then Ren_Obj := Prefix (Ren_Obj); - Change := True; + Change := True; elsif Nkind_In (Ren_Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then Ren_Obj := Expression (Ren_Obj); - Change := True; + Change := True; end if; end loop; @@ -3909,8 +3909,7 @@ package body Exp_Util is begin -- If a previous invocation of this routine has determined that a - -- list has no renamings, there is no point in repeating the same - -- scan. + -- list has no renamings, then no point in repeating the same scan. if not Has_Rens then return False; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 9d3730de492..3a3c86c0d75 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1003,8 +1003,11 @@ All other kinds of arguments are analyzed as expressions, and must be unambiguous. The analyzed pragma is retained in the tree, but not otherwise processed -by any part of the GNAT compiler. This pragma is intended for use by -external tools, including ASIS@. +by any part of the GNAT compiler, except to generate corresponding note +lines in the generated ALI file. For the format of these note lines, see +the compiler source file lib-writ.ads. This pragma is intended for use by +external tools, including ASIS@. The use of pragma Annotate does not +affect the compilation process in any way. @node Pragma Assert @unnumberedsec Pragma Assert diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index b4d2a83925c..f42300ada1f 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -575,7 +575,7 @@ package body Par_SCO is when N_Case_Expression => return OK; -- ??? - -- Conditional expression, processed like an IF statement + -- Conditional expression, processed like an if statement when N_Conditional_Expression => declare diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 70d0b2b91a7..ba3b683ec04 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -7820,8 +7820,7 @@ package body Prj.Nmsc is begin Debug_Output ("Path_Name_Of file_name=", Name_Id (File_Name)); - Debug_Output ("Path_Name_Of directory=", - Name_Id (Directory)); + Debug_Output ("Path_Name_Of directory=", Name_Id (Directory)); Get_Name_String (File_Name); Result := Locate_Regular_File diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 948410db579..e8ce47de534 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -997,6 +997,7 @@ package body Sem_Aggr is Insert_Actions (N, Freeze_Entity (Typ, N)); exit; end if; + Next (Comp); end loop; end; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 70c745d6c54..3e653a7335a 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3990,6 +3990,9 @@ package body Sem_Attr is -- source subprogram to which the postcondition applies. During -- pre-analysis, CS is the scope of the subprogram declaration. + Prag : Node_Id; + -- During pre-analysis, Prag is the enclosing pragma node if any + begin -- Find enclosing scopes, excluding loops @@ -4029,6 +4032,23 @@ package body Sem_Attr is Error_Attr; end if; + -- Check in postcondition of function + + Prag := N; + while not Nkind_In (Prag, N_Pragma, N_Function_Specification, + N_Subprogram_Body) + loop + Prag := Parent (Prag); + end loop; + + if Nkind (Prag) /= N_Pragma + or else Get_Pragma_Id (Prag) /= Pragma_Postcondition + then + Error_Attr + ("% attribute can only appear in postcondition of function", + P); + end if; + -- The attribute reference is a primary. If expressions follow, -- the attribute reference is really an indexable object, so -- rewrite and analyze as an indexed component. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ffc4723a4d9..0e5833351ed 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4228,10 +4228,10 @@ package body Sem_Ch13 is Arg1 := Get_Pragma_Arg (Arg1); Arg2 := Get_Pragma_Arg (Arg2); - -- See if this predicate pragma is for the current type - -- or for its full view. A predicate on a private completion - -- is placed on the partial view beause this is the visible - -- entity that is frozen.. + -- See if this predicate pragma is for the current type or for + -- its full view. A predicate on a private completion is placed + -- on the partial view beause this is the visible entity that + -- is frozen. if Entity (Arg1) = Typ or else Full_View (Entity (Arg1)) = Typ diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 4e2a0de9ed6..91d7a9dd0df 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1208,7 +1208,7 @@ package body Sem_Type is function Operand_Type return Entity_Id; -- Determine type of operand for an equality operation, to apply - -- Ada2005 rules to equality on anonymous access types. + -- Ada 2005 rules to equality on anonymous access types. function Standard_Operator return Boolean; -- Check whether subprogram is predefined operator declared in Standard. @@ -1287,14 +1287,15 @@ package body Sem_Type is function Operand_Type return Entity_Id is Opnd : Node_Id; + begin if Nkind (N) = N_Function_Call then Opnd := First_Actual (N); else Opnd := Left_Opnd (N); end if; - return Etype (Opnd); + return Etype (Opnd); end Operand_Type; ------------------------ @@ -1927,14 +1928,14 @@ package body Sem_Type is -- may be an operator or a function call. elsif (Chars (Nam1) = Name_Op_Eq - or else - Chars (Nam1) = Name_Op_Ne) + or else + Chars (Nam1) = Name_Op_Ne) and then Ada_Version >= Ada_2005 and then Etype (User_Subp) = Standard_Boolean and then Ekind (Operand_Type) = E_Anonymous_Access_Type and then In_Same_List (Parent (Designated_Type (Operand_Type)), - Unit_Declaration_Node (User_Subp)) + Unit_Declaration_Node (User_Subp)) then if It2.Nam = Predef_Subp then return It1; @@ -2675,6 +2676,7 @@ package body Sem_Type is end if; Par := Etype (Full_View (BT2)); + else Par := Etype (BT2); end if; -- 2.30.2