diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 48 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/clean.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 74 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/interfac.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/prj-makr.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 12 |
16 files changed, 187 insertions, 82 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3a1a5f6..3e5597a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2013-04-24 Robert Dewar <dewar@adacore.com> + + * sem_type.adb, exp_attr.adb, exp_ch4.adb: Minor reformatting. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document 'Update attribute. + * sem_attr.adb (Analyze_Attribute, case Update): Remove call + to S14_Attribute (S14_Attribute): removed. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * interfac.ads: Add size clauses for IEEE_Float_32/64 + +2013-04-24 Claire Dross <dross@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Remove + special assignment of Use_Expression_With_Actions for SPARK_Mode. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Apply_Predicate_Check): Check for the presence + of the dynamic predicate aspect when trying to determine if the + predicate of a type is non-static. + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Check + for the presence of the dynamic predicate aspect when trying to + determine if the predicate of a type is non- static. + * sem_ch13.adb (Add_Call): Capture the nature of the + inherited ancestor predicate. + (Build_Predicate_Functions): Update comments. Rewrite the checks on + static predicate application. Complain about the form of a non-static + expression only when the type is static. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: Add guard to tree traversal. + +2013-04-24 Vincent Celier <celier@adacore.com> + + * clean.adb (Clean): Remove local variable Root_Environment, + use Makeutl.Root_Environment instead. + * gnatcmd.adb: Remove local variable Root_Environment, use + Makeutl.Root_Environment instead. + * make.adb (Gnatmake): Remove local variable Root_Environment, + use Makeutl.Root_Environment instead. + * prj-makr.adb: Remove local variable Root_Environment, use + Makeutl.Root_Environment instead. + 2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> * exp_attr.adb (Expand_Loop_Entry_Attribute): Clarify the diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8302b97..3cb1f95 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2499,26 +2499,30 @@ package body Checks is Make_Raise_Storage_Error (Sloc (N), Reason => SE_Infinite_Recursion)); - -- Here for normal case of predicate active. + -- Here for normal case of predicate active else -- If the predicate is a static predicate and the operand is -- static, the predicate must be evaluated statically. If the -- evaluation fails this is a static constraint error. This check -- is disabled in -gnatc mode, because the compiler is incapable - -- of evaluating static expressions in that case. - - if Is_OK_Static_Expression (N) then - if Present (Static_Predicate (Typ)) then - if Operating_Mode < Generate_Code - or else Eval_Static_Predicate_Check (N, Typ) - then - return; - else - Error_Msg_NE - ("static expression fails static predicate check on&", - N, Typ); - end if; + -- of evaluating static expressions in that case. Note that when + -- inherited predicates are involved, a type may have both static + -- and dynamic forms. Check the presence of a dynamic predicate + -- aspect. + + if Is_OK_Static_Expression (N) + and then Present (Static_Predicate (Typ)) + and then not Has_Dynamic_Predicate_Aspect (Typ) + then + if Operating_Mode < Generate_Code + or else Eval_Static_Predicate_Check (N, Typ) + then + return; + else + Error_Msg_NE + ("static expression fails static predicate check on&", + N, Typ); end if; end if; diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 0b3622c..cbaaa61 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -98,8 +98,6 @@ package body Clean is Project_Node_Tree : Project_Node_Tree_Ref; - Root_Environment : Prj.Tree.Environment; - Main_Project : Prj.Project_Id := Prj.No_Project; All_Projects : Boolean := False; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c009222..93f9b81 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -785,8 +785,7 @@ package body Exp_Attr is -- When the related loop name appears as the argument of attribute -- Loop_Entry, the corresponding label construct is the generated - -- block statement. This happens because the expander reuses the - -- label. + -- block statement. This is because the expander reuses the label. if Nkind (Loop_Stmt) = N_Block_Statement then Decls := Declarations (Loop_Stmt); @@ -797,8 +796,8 @@ package body Exp_Attr is else pragma Assert (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Parent (Loop_Stmt))) = - N_Block_Statement); + and then Nkind (Parent (Parent (Loop_Stmt))) = + N_Block_Statement); Decls := Declarations (Parent (Parent (Loop_Stmt))); end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 85a6496..12e7805 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4581,12 +4581,12 @@ package body Exp_Ch4 is Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT))); - else - -- If the type of the allocator is an itype, - -- the master must exist in the context. This - -- is the case when the allocator initializes - -- an access component in an init-proc. + -- The only other possibility is an itype. For this + -- case, the master must exist in the context. This is + -- the case when the allocator initializes an access + -- component in an init-proc. + else pragma Assert (Is_Itype (PtrT)); Build_Master_Renaming (PtrT, N); end if; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 4f1dde7..2128680 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -387,18 +387,6 @@ procedure Gnat1drv is Debug_Flag_HH := True; - -- Disable Expressions_With_Actions nodes - - -- The gnat2why backend does not deal with Expressions_With_Actions - -- in all places (in particular assertions). It is difficult to - -- determine in the frontend which cases are allowed, so we disable - -- Expressions_With_Actions entirely. Even in the cases where - -- gnat2why deals with Expressions_With_Actions, it is easier to - -- deal with the original constructs (quantified, conditional and - -- case expressions) instead of the rewritten ones. - - Use_Expression_With_Actions := False; - -- Enable assertions, since they give valuable extra information for -- formal verification. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 023cd12..1c7133c 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -305,6 +305,7 @@ Implementation Defined Attributes * Unconstrained_Array:: * Universal_Literal_String:: * Unrestricted_Access:: +* Update:: * Valid_Scalars:: * VADS_Size:: * Value_Size:: @@ -6710,6 +6711,7 @@ consideration, you should minimize the use of these attributes. * Unconstrained_Array:: * Universal_Literal_String:: * Unrestricted_Access:: +* Update:: * Valid_Scalars:: * VADS_Size:: * Value_Size:: @@ -7713,6 +7715,78 @@ scope. For instance, a function cannot use @code{Unrestricted_Access} to create a unconstrained pointer and then return that value to the caller. +@node Update +@unnumberedsec Update +@findex Update +@noindent +The @code{Update} attribute creates a copy of an array or record value +with one or more modified components. The syntax is: + +@smallexample @c ada +PREFIX'Update (AGGREGATE); +@end smallexample + +@noindent +where @code{PREFIX} is the name of an array or record object, and +@code{AGGREGATE} is a named aggregate that does not contain an @code{others} +choice. The effect is to yield a copy of the array or record value which +is unchanged apart from the components mentioned in the aggregate, which +are changed to the indicated value. The original value of the array or +record value is not affected. For example: + +@smallexample @c ada +type Arr is Array (1 .. 5) of Integer; +... +Avar1 : Arr := (1,2,3,4,5); +Avar2 : Arr := Avar1'Update ((2 => 10, 3 .. 4 => 20)); +@end smallexample + +@noindent +yields a value for @code{Avar2} of 1,10,20,20,5 with @code{Avar1} +begin unmodified. Similarly: + +@smallexample @c ada +type Rec is A, B, C : Integer; +... +Rvar1 : Rec := (A => 1, B => 2, C => 3); +Rvar2 : Rec := Rvar1'Update ((B => 20)); +@end smallexample + +@noindent +yields a value for @code{Rvar2} of (A => 1, B => 20, C => 3), +with @code{Rvar1} being unmodifed. +Note that the value of the attribute reference is computed +completely before it is used. This means that if you write: + +@smallexample @c ada +Avar1 := Avar1'Update ((1 => 10, 2 => Function_Call)); +@end smallexample + +@noindent +then the value of @code{Avar1} is not modified if @code{Function_Call} +raises an exception, unlike the effect of a series of direct assignments +to elements of @code{Avar1}. In general this requires that +two extra complete copies of the object are required, which should be +kept in mind when considering efficiency. + +The @code{Update} attribute cannot be applied to prefixes of a limited +type, and cannot reference discriminants in the case of a record type. + +In the record case, no component can be mentioned more than once. In +the array case, two overlapping ranges can appear in the aggregate, +in which case the modifications are processed left to right. + +Multi-dimensional arrays can be modified, as shown by this example: + +@smallexample @c ada +A : array (1 .. 10, 1 .. 10) of Integer; +.. +A := A'Update (1 => (2 => 20), 3 => (4 => 30)); +@end smallexample + +@noindent +which changes element (1,2) to 20 and (3,4) to 30. + @node Valid_Scalars @unnumberedsec Valid_Scalars @findex Valid_Scalars diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index d6fd28e..be15670 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -59,7 +59,6 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; procedure GNATCmd is Project_Node_Tree : Project_Node_Tree_Ref; - Root_Environment : Prj.Tree.Environment; Project_File : String_Access; Project : Prj.Project_Id; Current_Verbosity : Prj.Verbosity := Prj.Default; diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads index 810366d..57033a9 100644 --- a/gcc/ada/interfac.ads +++ b/gcc/ada/interfac.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -159,9 +159,11 @@ package Interfaces is type IEEE_Float_32 is digits 6; pragma Float_Representation (IEEE_Float, IEEE_Float_32); + for IEEE_Float_32'Size use 32; type IEEE_Float_64 is digits 15; pragma Float_Representation (IEEE_Float, IEEE_Float_64); + for IEEE_Float_64'Size use 64; -- If there is an IEEE extended float available on the machine, we assume -- that it is available as Long_Long_Float. diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 9b1f0e3..d9973b5 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -5475,7 +5475,6 @@ package body Make is -- is invoked with the -F switch to force checking of elaboration flags. Project_Node_Tree : Project_Node_Tree_Ref; - Root_Environment : Prj.Tree.Environment; Stop_Compile : Boolean; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index de55a74..7de4369 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -25,6 +25,7 @@ with Csets; with Hostparm; +with Makeutl; use Makeutl; with Opt; with Output; with Osint; use Osint; @@ -64,8 +65,6 @@ package body Prj.Makr is Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; -- The project tree where the project file is parsed - Root_Environment : Prj.Tree.Environment; - Args : Argument_List_Access; -- The list of arguments for calls to the compiler to get the unit names -- and kinds (spec or body) in the Ada sources. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 762015f..5ee023b 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -376,12 +376,6 @@ package body Sem_Attr is pragma No_Return (Error_Attr); -- Like Error_Attr, but error is posted at the start of the prefix - procedure S14_Attribute; - -- Called for all attributes defined for formal verification to check - -- that the S14_Extensions flag is set. - -- Bad name ??? - -- No such thing as S14_Extensions flag ??? - procedure Standard_Attribute (Val : Int); -- Used to process attributes whose prefix is package Standard which -- yield values of type Universal_Integer. The attribute reference @@ -1973,18 +1967,6 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); end Legal_Formal_Attribute; - ------------------- - -- S14_Attribute -- - ------------------- - - procedure S14_Attribute is - begin - if not Formal_Extensions then - Error_Attr - ("attribute % requires the use of debug switch -gnatd.V", N); - end if; - end S14_Attribute; - ------------------------ -- Standard_Attribute -- ------------------------ @@ -5667,7 +5649,6 @@ package body Sem_Attr is -- Start of processing for Update begin - S14_Attribute; Check_E1; if not Is_Object_Reference (P) then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 0d32aff..709947b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -5767,7 +5767,7 @@ package body Sem_Ch13 is Dynamic_Predicate_Present : Boolean := False; -- Set True if a dynamic predicate is present, results in the entire - -- predicate being considered dynamic even if it looks static + -- predicate being considered dynamic even if it looks static. Static_Predicate_Present : Node_Id := Empty; -- Set to N_Pragma node for a static predicate if one is encountered @@ -5783,6 +5783,12 @@ package body Sem_Ch13 is if Present (T) and then Present (Predicate_Function (T)) then Set_Has_Predicates (Typ); + -- Capture the nature of the inherited ancestor predicate + + if Has_Dynamic_Predicate_Aspect (T) then + Dynamic_Predicate_Present := True; + end if; + -- Build the call to the predicate function of T Exp := @@ -5866,6 +5872,8 @@ package body Sem_Ch13 is if Nkind (Ritem) = N_Pragma and then Pragma_Name (Ritem) = Name_Predicate then + -- Capture the nature of the predicate + if Present (Corresponding_Aspect (Ritem)) then case Chars (Identifier (Corresponding_Aspect (Ritem))) is when Name_Dynamic_Predicate => @@ -6199,25 +6207,28 @@ package body Sem_Ch13 is end; end if; - -- Deal with static predicate case + if Is_Scalar_Type (Typ) then - -- ??? We don't currently deal with real types - -- ??? Why requiring that Typ is static? + -- Attempt to build a static predicate for a discrete or a real + -- subtype. This action may fail because the actual expression may + -- not be static. - if Ekind (Typ) in Discrete_Kind - and then Is_Static_Subtype (Typ) - and then not Dynamic_Predicate_Present - then - -- Only build the predicate for subtypes - - if Ekind_In (Typ, E_Enumeration_Subtype, + if Ekind_In (Typ, E_Decimal_Fixed_Point_Subtype, + E_Enumeration_Subtype, + E_Floating_Point_Subtype, E_Modular_Integer_Subtype, + E_Ordinary_Fixed_Point_Subtype, E_Signed_Integer_Subtype) then Build_Static_Predicate (Typ, Expr, Object_Name); + -- The predicate is categorized as static but its expression is + -- dynamic. Note that the predicate may become non-static when + -- inherited dynamic predicates are involved. + if Present (Static_Predicate_Present) - and No (Static_Predicate (Typ)) + and then No (Static_Predicate (Typ)) + and then not Dynamic_Predicate_Present then Error_Msg_F ("expression does not have required form for " diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2e48721..b2ed158 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2298,11 +2298,15 @@ package body Sem_Ch5 is Set_Etype (DS, Entity (DS)); end if; - -- Attempt to iterate through non-static predicate + -- Attempt to iterate through non-static predicate. Note that a type + -- with inherited predicates may have both static and dynamic forms. + -- In this case it is not sufficent to check the static predicate + -- function only, look for a dynamic predicate aspect as well. if Is_Discrete_Type (Entity (DS)) and then Present (Predicate_Function (Entity (DS))) - and then No (Static_Predicate (Entity (DS))) + and then (No (Static_Predicate (Entity (DS))) + or else Has_Dynamic_Predicate_Aspect (Entity (DS))) then Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static predicate for loop " & diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0b23215..a356704 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1868,6 +1868,7 @@ package body Sem_Prag is begin if Is_Entity_Name (N) + and then Present (Entity (N)) and then Is_Formal (Entity (N)) and then Nkind (Parent (N)) /= N_Type_Conversion then diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index c6ad391..78e4922 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2028,7 +2028,7 @@ package body Sem_Type is elsif (Nkind (N) = N_Function_Call and then Nkind (Name (N)) = N_Expanded_Name and then (Chars (Predef_Subp) /= Name_Op_Expon - or else Hides_Op (User_Subp, Predef_Subp)) + or else Hides_Op (User_Subp, Predef_Subp)) and then Scope (User_Subp) = Entity (Prefix (Name (N)))) or else Hides_Op (User_Subp, Predef_Subp) then @@ -2060,12 +2060,10 @@ package body Sem_Type is and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide) and then (Ada_Version = Ada_83 - or else - (Ada_Version >= Ada_2012 - and then - In_Same_Declaration_List - (First_Subtype (Typ), - Unit_Declaration_Node (User_Subp)))) + or else (Ada_Version >= Ada_2012 + and then In_Same_Declaration_List + (First_Subtype (Typ), + Unit_Declaration_Node (User_Subp)))) then if It2.Nam = Predef_Subp then return It1; |