From f93e7257bb0e43fbe124ae9b95b8619db94d3499 Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 22 Oct 2010 08:51:09 +0000 Subject: [PATCH] 2010-10-22 Robert Dewar * einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities (simplifies code). * exp_ch13.adb (Build_Predicate_Function): Output info msgs for inheritance. * sem_ch13.adb (Analyze_Aspect_Specifications): Make sure we have a freeze node for entities for which a predicate is specified. (Analyze_Aspect_Specifications): Avoid duplicate calls * sem_ch3.adb (Analyze_Full_Type_Declaration): Remove attempt to avoid duplicate calls to Analye_Aspect_Specifications. 2010-10-22 Thomas Quinot * a-exextr.adb, atree.ads, freeze.adb: Minor reformatting. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165804 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 16 ++++++++++++++++ gcc/ada/a-exextr.adb | 5 ++--- gcc/ada/atree.ads | 5 ++--- gcc/ada/einfo.adb | 4 ---- gcc/ada/einfo.ads | 15 ++++++--------- gcc/ada/exp_ch13.adb | 45 +++++++++++++++++++++++++++++++-------------- gcc/ada/freeze.adb | 6 +++--- gcc/ada/sem_ch13.adb | 17 +++++++++++++++++ gcc/ada/sem_ch3.adb | 8 +++----- 9 files changed, 80 insertions(+), 41 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1770e47..b396ff6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2010-10-22 Robert Dewar + + * einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities + (simplifies code). + * exp_ch13.adb (Build_Predicate_Function): Output info msgs for + inheritance. + * sem_ch13.adb (Analyze_Aspect_Specifications): Make sure we have a + freeze node for entities for which a predicate is specified. + (Analyze_Aspect_Specifications): Avoid duplicate calls + * sem_ch3.adb (Analyze_Full_Type_Declaration): Remove attempt to avoid + duplicate calls to Analye_Aspect_Specifications. + +2010-10-22 Thomas Quinot + + * a-exextr.adb, atree.ads, freeze.adb: Minor reformatting. + 2010-10-21 Robert Dewar * sem_ch3.adb: Minor reformatting. diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb index 2ea9a3a..26567b3 100644 --- a/gcc/ada/a-exextr.adb +++ b/gcc/ada/a-exextr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -53,8 +53,7 @@ package body Exception_Traces is pragma Export (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized"); - procedure Last_Chance_Handler - (Except : Exception_Occurrence); + procedure Last_Chance_Handler (Except : Exception_Occurrence); pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler"); pragma No_Return (Last_Chance_Handler); -- Users can replace the default version of this routine, diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 904c637..31b4391 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -537,9 +537,8 @@ package Atree is function Parent (N : Node_Id) return Node_Id; pragma Inline (Parent); - -- Returns the parent of a node if the node is not a list member, or - -- else the parent of the list containing the node if the node is a - -- list member. + -- Returns the parent of a node if the node is not a list member, or else + -- the parent of the list containing the node if the node is a list member. function No (N : Node_Id) return Boolean; pragma Inline (No); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 96f1e52..68eedfd 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -1411,7 +1411,6 @@ package body Einfo is function Has_Predicates (Id : E) return B is begin - pragma Assert (Is_Type (Id) or else Is_Subprogram (Id)); return Flag250 (Id); end Has_Predicates; @@ -3863,9 +3862,6 @@ package body Einfo is procedure Set_Has_Predicates (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Function - or else Ekind (Id) = E_Void); Set_Flag250 (Id, V); end Set_Has_Predicates; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 1d3c9cb..febac6d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1674,11 +1674,11 @@ package Einfo is -- such an object and no warning is generated. -- Has_Predicates (Flag250) --- Present in type and subtype entities and in subprogram entities. Set --- if a pragma Predicate or Predicate aspect applies to the type, or if --- it inherits a Predicate aspect from its parent or progenitor types. --- Also set in the predicate function entity, to distinguish it among --- entries in the Subprograms_For_Type. +-- Present in all entities. Set in type and subtype entities if a pragma +-- Predicate or Predicate aspect applies to the type, or if it inherits a +-- Predicate aspect from its parent or progenitor types. Also set in the +-- predicate function entity, to distinguish it among entries in the +-- Subprograms_For_Type. -- Has_Primitive_Operations (Flag120) [base type only] -- Present in all type entities. Set if at least one primitive operation @@ -4666,6 +4666,7 @@ package Einfo is -- Has_Pragma_Thread_Local_Storage (Flag169) -- Has_Pragma_Unmodified (Flag233) -- Has_Pragma_Unreferenced (Flag180) + -- Has_Predicates (Flag250) -- Has_Private_Declaration (Flag155) -- Has_Qualified_Name (Flag161) -- Has_Stream_Size_Clause (Flag184) @@ -4778,7 +4779,6 @@ package Einfo is -- Has_Object_Size_Clause (Flag172) -- Has_Pragma_Preelab_Init (Flag221) -- Has_Pragma_Unreferenced_Objects (Flag212) - -- Has_Predicates (Flag250) -- Has_Primitive_Operations (Flag120) (base type only) -- Has_Size_Clause (Flag29) -- Has_Specified_Layout (Flag100) (base type only) @@ -5138,7 +5138,6 @@ package Einfo is -- Has_Missing_Return (Flag142) -- Has_Nested_Block_With_Handler (Flag101) -- Has_Postconditions (Flag240) - -- Has_Predicates (Flag250) -- Has_Recursive_Call (Flag143) -- Has_Subprogram_Descriptor (Flag93) -- Is_Abstract_Subprogram (Flag19) (non-generic case only) @@ -5271,7 +5270,6 @@ package Einfo is -- Subprograms_For_Type (Node29) -- Has_Invariants (Flag232) -- Has_Postconditions (Flag240) - -- Has_Predicates (Flag250) -- Is_Machine_Code_Subprogram (Flag137) -- Is_Pure (Flag44) -- Is_Intrinsic_Subprogram (Flag64) @@ -5403,7 +5401,6 @@ package Einfo is -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) -- Has_Postconditions (Flag240) - -- Has_Predicates (Flag250) -- Has_Subprogram_Descriptor (Flag93) -- Is_Abstract_Subprogram (Flag19) (non-generic case only) -- Is_Asynchronous (Flag81) diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index eaf90f7..8e9d2ca 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -27,6 +27,7 @@ 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_Ch6; use Exp_Ch6; with Exp_Imgv; use Exp_Imgv; @@ -126,12 +127,17 @@ package body Exp_Ch13 is begin if Present (T) and then Present (Predicate_Function (T)) then + + -- Build the call to the predicate function of T + Exp := Make_Predicate_Call (T, Convert_To (T, Make_Identifier (Loc, Chars => Object_Name))); + -- Add call to evolving expression, using AND THEN if needed + if No (Expr) then Expr := Exp; else @@ -140,6 +146,14 @@ package body Exp_Ch13 is Left_Opnd => Relocate_Node (Expr), Right_Opnd => Exp); end if; + + -- Output info message on inheritance if required + + if Opt.List_Inherited_Aspects then + Error_Msg_Sloc := Sloc (Predicate_Function (T)); + Error_Msg_Node_2 := T; + Error_Msg_N ("?info: & inherits predicate from & at #", Typ); + end if; end if; end Add_Call; @@ -200,24 +214,27 @@ package body Exp_Ch13 is Arg1 := Get_Pragma_Arg (Arg1); Arg2 := Get_Pragma_Arg (Arg2); - -- We need to replace any occurrences of the name of the type - -- with references to the object. We do this by first doing a - -- preanalysis, to identify all the entities, then we traverse - -- looking for the type entity, doing the needed substitution. - -- The preanalysis is done with the special OK_To_Reference - -- flag set on the type, so that if we get an occurrence of - -- this type, it will be recognized as legitimate. - - Set_OK_To_Reference (Typ, True); - Preanalyze_Spec_Expression (Arg2, Standard_Boolean); - Set_OK_To_Reference (Typ, False); - Replace_Type (Arg2); - -- See if this predicate pragma is for the current type if Entity (Arg1) = Typ then - -- We have a match, add the expression + -- We have a match, this entry is for our subtype + + -- First We need to replace any occurrences of the name of + -- the type with references to the object. We do this by + -- first doing a preanalysis, to identify all the entities, + -- then we traverse looking for the type entity, doing the + -- needed substitution. The preanalysis is done with the + -- special OK_To_Reference flag set on the type, so that if + -- we get an occurrence of this type, it will be recognized + -- as legitimate. + + Set_OK_To_Reference (Typ, True); + Preanalyze_Spec_Expression (Arg2, Standard_Boolean); + Set_OK_To_Reference (Typ, False); + Replace_Type (Arg2); + + -- OK, replacement complete, now we can add the expression if No (Expr) then Expr := Relocate_Node (Arg2); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5bbcab0..236ee27 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3464,9 +3464,9 @@ package body Freeze is 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 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)); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index b1f619c..58150a3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -658,10 +658,21 @@ package body Sem_Ch13 is -- Set True if delay is required begin + -- Return if no aspects + if L = No_List then return; end if; + -- Return if already analyzed (avoids duplicate calls in some cases + -- where type declarations get rewritten and proessed twice). + + if Analyzed (N) then + return; + end if; + + -- Loop through apsects + Aspect := First (L); while Present (Aspect) loop declare @@ -1068,6 +1079,12 @@ package body Sem_Ch13 is Set_From_Aspect_Specification (Aitem, True); + -- Make sure we have a freeze node (it might otherwise be + -- missing in cases like subtype X is Y, and we would not + -- have a place to build the predicate function). + + Ensure_Freeze_Node (E); + -- For Predicate case, insert immediately after the entity -- declaration. We do not have to worry about delay issues -- since the pragma processing takes care of this. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f0e4c49..335d348 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2403,9 +2403,7 @@ package body Sem_Ch3 is Set_Optimize_Alignment_Flags (Def_Id); Check_Eliminated (Def_Id); - if Nkind (N) = N_Full_Type_Declaration then - Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); - end if; + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); end Analyze_Full_Type_Declaration; ---------------------------------- @@ -4215,8 +4213,8 @@ package body Sem_Ch3 is Set_Optimize_Alignment_Flags (Id); Check_Eliminated (Id); - <> - Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Subtype_Declaration; -------------------------------- -- 2.7.4