diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 47 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 79 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 77 | ||||
| -rw-r--r-- | gcc/ada/lib-load.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/lib.ads | 36 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/restrict.adb | 147 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/s-restri.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/sem.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 174 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 76 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 2 |
22 files changed, 608 insertions, 238 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0ce9b2e..ac3876e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,52 @@ 2013-07-08 Robert Dewar <dewar@adacore.com> + * sem.ads: Minor comment updates. + * s-restri.ads, exp_ch6.adb, lib-load.ads, exp_ch3.adb, sem_ch10.adb: + Minor reformatting. + +2013-07-08 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Add dummy entry + for Restriction_Set. + * gnat_rm.texi: Add missing menu entry for Attribute Ref Add + documentation for attribute Restriction_Set. + * lib-writ.adb (Write_With_Lines): Generate special W lines + for Restriction_Set. + * lib-writ.ads: Document special use of W lines for + Restriction_Set. + * lib.ads (Restriction_Set_Dependences): New table. + * par-ch4.adb (Is_Parameterless_Attribute): Add Loop_Entry to + list (Scan_Name_Extension_Apostrophe): Remove kludge test for + Loop_Entry (Scan_Name_Extension_Apostrophe): Handle No_Dependence + for Restricton_Set. + * restrict.adb (Check_SPARK_Restriction): Put in Alfa order + (OK_No_Dependence_Unit_Name): New function. + * restrict.ads (OK_No_Dependence_Unit_Name): New function. + * rtsfind.adb: Minor reformatting Minor code reorganization. + * sem_attr.adb (Analyze_Attribute): Add processing for + Restriction_Set. + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): + Remove Check_Unit_Name and use new function + OK_No_Dependence_Unit_Name instead. + * sinfo.ads: Minor comment updates. + * snames.ads-tmpl: Add entry for Restriction_Set attribute. + +2013-07-08 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Apply_Accessibility_Check): Remove local constant + Pool_Id and local variable Free_Stmt. Do not deallocate the faulty + object as "free" is not available on all targets/profiles. + +2013-07-08 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Handle + Storage_Size aspect for task type in case discriminant is + referenced. + (Analyze_Attribute_Definition_Clause): Do not flag Storage_Size + attribute definition clause as obsolescent if from aspect. + +2013-07-08 Robert Dewar <dewar@adacore.com> + * gnat_rm.texi: Add documentation for Img returning a function. * par-prag.adb: Minor reformatting. * restrict.adb: Minor reformatting and code reorganization. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 9e48afe..0034767 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6500,6 +6500,7 @@ package body Exp_Attr is Attribute_Modulus | Attribute_Partition_ID | Attribute_Range | + Attribute_Restriction_Set | Attribute_Safe_Emax | Attribute_Safe_First | Attribute_Safe_Large | diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 102cb65..a21de7e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8609,8 +8609,8 @@ package body Exp_Ch3 is -- end case; function Make_Eq_Case - (E : Entity_Id; - CL : Node_Id; + (E : Entity_Id; + CL : Node_Id; Discrs : Elist_Id := New_Elmt_List) return List_Id is Loc : constant Source_Ptr := Sloc (E); @@ -8661,6 +8661,8 @@ package body Exp_Ch3 is return Name_Find; end External_Name; + -- Start of processing for Make_Eq_Case + begin Append_To (Result, Make_Eq_If (E, Component_Items (CL))); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 46cf44b..6fec955 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -725,11 +725,9 @@ package body Exp_Ch4 is (Ref : Node_Id; Built_In_Place : Boolean := False) is - Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); - Cond : Node_Id; - Free_Stmt : Node_Id; - Obj_Ref : Node_Id; - Stmts : List_Id; + Cond : Node_Id; + Obj_Ref : Node_Id; + Stmts : List_Id; begin if Ada_Version >= Ada_2005 @@ -761,70 +759,27 @@ package body Exp_Ch4 is Stmts := New_List; - -- If the target does not support allocation/deallocation, simply - -- finalize the object (if applicable). Generate: + -- Why don't we free the object ??? discussion and explanation + -- needed of why old approach did not work ??? + -- Generate: -- [Deep_]Finalize (Obj_Ref.all); - if Restriction_Active (No_Implicit_Heap_Allocations) then - if Needs_Finalization (DesigT) then - Append_To (Stmts, - Make_Final_Call ( - Obj_Ref => - Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), - Typ => DesigT)); - end if; - - -- Finalize (if applicable) and deallocate the object in case the - -- accessibility check fails. - - else - -- Create an explicit free statement to clean up the allocated - -- object in case the accessibility check fails. Generate: - - -- Free (Obj_Ref); - - Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref)); - Set_Storage_Pool (Free_Stmt, Pool_Id); - - Append_To (Stmts, Free_Stmt); - - -- Finalize the object (if applicable), but wrap the call - -- inside a block to ensure that the object would still be - -- deallocated in case the finalization fails. Generate: - - -- begin - -- [Deep_]Finalize (Obj_Ref.all); - -- exception - -- when others => - -- Free (Obj_Ref); - -- raise; - -- end; - - if Needs_Finalization (DesigT) then - Prepend_To (Stmts, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Final_Call ( - Obj_Ref => - Make_Explicit_Dereference (Loc, - Prefix => New_Copy (Obj_Ref)), - Typ => DesigT)), - - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List ( - Make_Others_Choice (Loc)), - Statements => New_List ( - New_Copy_Tree (Free_Stmt), - Make_Raise_Statement (Loc))))))); - end if; + if Needs_Finalization (DesigT) then + Append_To (Stmts, + Make_Final_Call ( + Obj_Ref => + Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), + Typ => DesigT)); end if; -- Signal the accessibility failure through a Program_Error + -- Since we may have a storage leak, I would be inclined to + -- define a new PE_ code that warns of this possibility where + -- the message would be Accessibility_Check_Failed (causing + -- storage leak) ??? + Append_To (Stmts, Make_Raise_Program_Error (Loc, Condition => New_Reference_To (Standard_True, Loc), diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 34f61c8..d944ac9 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3782,7 +3782,7 @@ package body Exp_Ch6 is -- We perform these optimization regardless of whether we are in the -- main unit or in a unit in the context of the main unit, to ensure - -- that tree generated is the same in both cases, for Inspector use. + -- that tree generated is the same in both cases, for CodePeer use. if Is_RTE (Subp, RE_To_Address) then Rewrite (Call_Node, diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 85bc98f..03bf611 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -343,6 +343,8 @@ Implementation Defined Attributes * Attribute Passed_By_Reference:: * Attribute Pool_Address:: * Attribute Range_Length:: +* Attribute Ref:: +* Attribute Restriction_Set:: * Attribute Result:: * Attribute Safe_Emax:: * Attribute Safe_Large:: @@ -7645,6 +7647,7 @@ consideration, you should minimize the use of these attributes. * Attribute Pool_Address:: * Attribute Range_Length:: * Attribute Ref:: +* Attribute Restriction_Set:: * Attribute Result:: * Attribute Safe_Emax:: * Attribute Safe_Large:: @@ -8332,11 +8335,75 @@ same result as @code{Length} applied to the array itself. @unnumberedsec Attribute Ref @findex Ref @noindent -The @code{System.Address'Ref} -(@code{System.Address} is the only permissible prefix) -denotes a function identical to -@code{System.Storage_Elements.To_Address} except that -it is a static attribute. See @ref{Attribute To_Address} for more details. + + +@node Attribute Restriction_Set +@unnumberedsec Attribute Restriction_Set +@findex Restriction_Set +@cindex Restrictions +@noindent +This attribute allows compile time testing of restrictions that +are currently in effect. It is primarily intended for specializing +code in the run-time based on restrictions that are active (e.g. +don't need to save fpt registers if restriction No_Floating_Point +is known to be in effect), but can be used anywhere. + +There are two forms: + +@smallexample @c ada +System'Restriction_Set (partition_boolean_restriction_NAME) +System'Restriction_Set (No_Dependence => library_unit_NAME); +@end smallexample + +@noindent +In the case of the first form, the only restriction names +allowed are parameterless restrictions that are checked +for consistency at bind time. For a complete list see the +subtype @code{System.Rident.Partition_Boolean_Restrictions}. + +The result returned is True if the restriction is known to +be in effect, and False if the restriction is known not to +be in effect. An important guarantee is that the value of +a Restriction_Set attribute is known to be consistent throughout +all the code of a partition. + +This is trivially achieved if the entire partition is compiled +with a consistent set of restriction pragmas. However, the +compilation model does not require this. It is possible to +compile one set of units with one set of pragmas, and another +set of units with another set of pragmas. It is even possible +to compile a spec with one set of pragmas, and then WITH the +same spec with a different set of pragmas. Inconsistencies +in the actual use of the restriction are checked at bind time. + +In order to achieve the guarantee of consistency for the +Restriction_Set pragma, we consider that a use of the pragma +that yields False is equivalent to a violation of the +restriction. + +So for example if you write + +@smallexample @c ada +if System'Restriction_Set (No_Floating_Point) then + ... +else + ... +end if; +@end smallexample + +@noindent +And the result is False, so that the else branch is executed, +you can assume that this restriction is not set for any unit +in the partition. This is checked by considering this use of +the restriction pragma to be a violation of the restriction +No_Floating_Point. This means that no other unit can attempt +to set this restriction (if some unit does attempt to set it, +the binder will refuse to bind the partition). + +Technical note: The restriction name and the unit name are +intepreted entirely syntactically, as in the corresponding +Restrictions pragma, they are not analyzed semantically, +so they do not have a type. @node Attribute Result @unnumberedsec Attribute Result diff --git a/gcc/ada/lib-load.ads b/gcc/ada/lib-load.ads index a029d37..3ae9cca 100644 --- a/gcc/ada/lib-load.ads +++ b/gcc/ada/lib-load.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -193,7 +193,7 @@ package Lib.Load is -- generate a compilation unit node for it, and we need to make an entry -- for it in the units table, so as to maintain a one-to-one mapping -- between table and nodes. The table entry is used among other things to - -- provide a canonical traversal order for context units for Inspector. + -- provide a canonical traversal order for context units for CodePeer. -- The flag In_Main indicates whether the instance is the main unit. procedure Version_Update (U : Node_Id; From : Node_Id); diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index e5c0912..c95b9dc 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -882,6 +882,38 @@ package body Lib.Writ is Write_Info_EOL; end loop; + + -- Finally generate the special lines for cases of Restriction_Set + -- with No_Dependence and no restriction present. + + declare + Unam : Unit_Name_Type; + + begin + for J in Restriction_Set_Dependences.First .. + Restriction_Set_Dependences.Last + loop + Unam := Restriction_Set_Dependences.Table (J); + + -- Don't need an entry if already in the unit table + + for U in 0 .. Last_Unit loop + if Unit_Name (U) = Unam then + goto Continue; + end if; + end loop; + + -- Otherwise generate the entry + + Write_Info_Initiate ('W'); + Write_Info_Char (' '); + Write_Info_Name (Unam); + Write_Info_EOL; + + <<Continue>> + null; + end loop; + end; end Write_With_Lines; -- Start of processing for Write_ALI diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index b631b2a..b9d69c2 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -402,7 +402,9 @@ package Lib.Writ is -- No restriction pragma is present for the named boolean restriction. -- However, the compiler did detect one or more violations of this - -- restriction, which may require a binder consistency check. + -- restriction, which may require a binder consistency check. Note that + -- one case of a violation is the use of a Restriction_Set attribute for + -- the restriction that yielded False. -- For the case of restrictions that take a parameter, we need both the -- information from pragma if present, and the actual information about @@ -618,9 +620,9 @@ package Lib.Writ is -- Following each U line, is a series of lines of the form -- W unit-name [source-name lib-name] [E] [EA] [ED] [AD] - -- or + -- or -- Y unit-name [source-name lib-name] [E] [EA] [ED] [AD] - -- or + -- or -- Z unit-name [source-name lib-name] [E] [EA] [ED] [AD] -- -- One W line is present for each unit that is mentioned in an explicit @@ -655,6 +657,14 @@ package Lib.Writ is -- The parameter source-name and lib-name are omitted for the case of a -- generic unit compiled with earlier versions of GNAT which did not -- generate object or ali files for generics. + -- + -- The parameter source-name and lib-name are also omitted for the W + -- lines that result from use of a Restriction_Set attribute which gets + -- a result of False from a No_Dependence check, in the case where the + -- unit is not in the semantic closure. In such a case, the bare W + -- line is generated, but no D (dependency) line. This will make the + -- binder do the consistency check, but not include the unit in the + -- partition closure (unless it is properly With'ed somewhere). -- ----------------------- -- -- L Linker_Options -- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index ac1945e..5370e4a 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -688,6 +688,42 @@ package Lib is -- of the printout. If Withs is True, we print out units with'ed by this -- unit (not counting limited withs). + --------------------------------------------------------------- + -- Special Handling for Restriction_Set (No_Dependence) Case -- + --------------------------------------------------------------- + + -- If we have a Restriction_Set attribute for No_Dependence => unit, + -- and the unit is not given in a No_Dependence restriction that we + -- can see, the attribute will return False. + + -- We have to ensure in this case that the binder will reject any attempt + -- to set a No_Dependence restriction in some other unit in the partition. + + -- If the unit is in the semantic closure, then of course it is properly + -- WITH'ed by someone, and the binder will do this job automatically as + -- part of its normal processing. + + -- But if the unit is not in the semantic closure, we must make sure the + -- binder knows about it. The use of the Restriction_Set attribute giving + -- a result of False does not mean of itself that we have to include the + -- unit in the partition. So what we do is to generate a with (W) line in + -- the ali file (with no file name information), but no corresponding D + -- (dependency) line. This is recognized by the binder as meaning "Don't + -- let anyone specify No_Dependence for this unit, but you don't have to + -- include it if there is no real W line for the unit". + + -- The following table keeps track of relevant units. It is used in the + -- Lib.Writ circuit for outputting With lines to output the special with + -- line with RA if the unit is not in the semantic closure. + + package Restriction_Set_Dependences is new Table.Table ( + Table_Component_Type => Unit_Name_Type, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Restriction_Attribute_Dependences"); + private pragma Inline (Cunit); pragma Inline (Cunit_Entity); diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index e1e634a..38fd00e 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -40,6 +40,7 @@ package body Ch4 is Attribute_Class => True, Attribute_External_Tag => True, Attribute_Img => True, + Attribute_Loop_Entry => True, Attribute_Stub_Type => True, Attribute_Version => True, Attribute_Type_Key => True, @@ -50,6 +51,13 @@ package body Ch4 is -- list because it may denote a slice operation (X'Img (1 .. 2)) or -- a type conversion (X'Class (Y)). + -- Note: Loop_Entry is in this list because, although it can take an + -- optional argument (the loop name), we can't distinguish that at parse + -- time from the case where no loop name is given and a legitimate index + -- expression is present. So we parse the argument as an indexed component + -- and the semantic analysis sorts out this syntactic ambiguity based on + -- the type and form of the expression. + -- Note that this map designates the minimum set of attributes where a -- construct in parentheses that is not an argument can appear right -- after the attribute. For attributes like 'Size, we do not put them @@ -503,29 +511,24 @@ package body Ch4 is Set_Attribute_Name (Name_Node, Attr_Name); -- Scan attribute arguments/designator. We skip this if we know - -- that the attribute cannot have an argument. + -- that the attribute cannot have an argument (see documentation + -- of Is_Parameterless_Attribute for further details). if Token = Tok_Left_Paren and then not Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name)) then - -- Attribute Loop_Entry has no effect on the name extension - -- parsing logic, as if the attribute never existed in the - -- source. Continue parsing the subsequent expressions or - -- ranges. - - if Attr_Name = Name_Loop_Entry then - Scan; -- past left paren - goto Scan_Name_Extension_Left_Paren; - -- Attribute Update contains an array or record association -- list which provides new values for various components or - -- elements. The list is parsed as an aggregate. + -- elements. The list is parsed as an aggregate, and we get + -- better error handling by knowing that in the parser. - elsif Attr_Name = Name_Update then + if Attr_Name = Name_Update then Set_Expressions (Name_Node, New_List); Append (P_Aggregate, Expressions (Name_Node)); + -- All other cases of parsing attribute arguments + else Set_Expressions (Name_Node, New_List); Scan; -- past left paren @@ -533,12 +536,40 @@ package body Ch4 is loop declare Expr : constant Node_Id := P_Expression_If_OK; + Rnam : Node_Id; begin + -- Case of => for named notation + if Token = Tok_Arrow then - Error_Msg_SC - ("named parameters not permitted for attributes"); - Scan; -- past junk arrow + + -- Named notation allowed only for the special + -- case of System'Restriction_Set (No_Dependence => + -- unit_NAME), in which case construct a parameter + -- assocation node and append to the arguments. + + if Attr_Name = Name_Restriction_Set + and then Nkind (Expr) = N_Identifier + and then Chars (Expr) = Name_No_Dependence + then + Scan; -- past arrow + Rnam := P_Name; + Append_To (Expressions (Name_Node), + Make_Parameter_Association (Sloc (Rnam), + Selector_Name => Expr, + Explicit_Actual_Parameter => Rnam)); + exit; + + -- For all other cases named notation is illegal + + else + Error_Msg_SC + ("named parameters not permitted " + & "for attributes"); + Scan; -- past junk arrow + end if; + + -- Here for normal case (not => for named parameter) else Append (Expr, Expressions (Name_Node)); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index a90cf1a..ea0f89c 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -184,69 +184,6 @@ package body Restrict is Check_Restriction (No_Elaboration_Code, N); end Check_Elaboration_Code_Allowed; - ----------------------------- - -- Check_SPARK_Restriction -- - ----------------------------- - - procedure Check_SPARK_Restriction - (Msg : String; - N : Node_Id; - Force : Boolean := False) - is - Msg_Issued : Boolean; - Save_Error_Msg_Sloc : Source_Ptr; - - begin - if Force or else Comes_From_Source (Original_Node (N)) then - if Restriction_Check_Required (SPARK_05) - and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) - then - return; - end if; - - -- Since the call to Restriction_Msg from Check_Restriction may set - -- Error_Msg_Sloc to the location of the pragma restriction, save and - -- restore the previous value of the global variable around the call. - - Save_Error_Msg_Sloc := Error_Msg_Sloc; - Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); - Error_Msg_Sloc := Save_Error_Msg_Sloc; - - if Msg_Issued then - Error_Msg_F ("\\| " & Msg, N); - end if; - end if; - end Check_SPARK_Restriction; - - procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is - Msg_Issued : Boolean; - Save_Error_Msg_Sloc : Source_Ptr; - - begin - pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\'); - - if Comes_From_Source (Original_Node (N)) then - if Restriction_Check_Required (SPARK_05) - and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) - then - return; - end if; - - -- Since the call to Restriction_Msg from Check_Restriction may set - -- Error_Msg_Sloc to the location of the pragma restriction, save and - -- restore the previous value of the global variable around the call. - - Save_Error_Msg_Sloc := Error_Msg_Sloc; - Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); - Error_Msg_Sloc := Save_Error_Msg_Sloc; - - if Msg_Issued then - Error_Msg_F ("\\| " & Msg1, N); - Error_Msg_F (Msg2, N); - end if; - end if; - end Check_SPARK_Restriction; - -------------------------------- -- Check_No_Implicit_Aliasing -- -------------------------------- @@ -883,6 +820,27 @@ package body Restrict is and then Restriction_Active (No_Exception_Propagation); end No_Exception_Propagation_Active; + -------------------------------- + -- OK_No_Dependence_Unit_Name -- + -------------------------------- + + function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Selected_Component then + return + OK_No_Dependence_Unit_Name (Prefix (N)) + and then + OK_No_Dependence_Unit_Name (Selector_Name (N)); + + elsif Nkind (N) = N_Identifier then + return True; + + else + Error_Msg_N ("wrong form for unit name for No_Dependence", N); + return False; + end if; + end OK_No_Dependence_Unit_Name; + ---------------------------------- -- Process_Restriction_Synonyms -- ---------------------------------- @@ -1437,6 +1395,69 @@ package body Restrict is end if; end Set_Restriction_No_Use_Of_Pragma; + ----------------------------- + -- Check_SPARK_Restriction -- + ----------------------------- + + procedure Check_SPARK_Restriction + (Msg : String; + N : Node_Id; + Force : Boolean := False) + is + Msg_Issued : Boolean; + Save_Error_Msg_Sloc : Source_Ptr; + + begin + if Force or else Comes_From_Source (Original_Node (N)) then + if Restriction_Check_Required (SPARK_05) + and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) + then + return; + end if; + + -- Since the call to Restriction_Msg from Check_Restriction may set + -- Error_Msg_Sloc to the location of the pragma restriction, save and + -- restore the previous value of the global variable around the call. + + Save_Error_Msg_Sloc := Error_Msg_Sloc; + Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); + Error_Msg_Sloc := Save_Error_Msg_Sloc; + + if Msg_Issued then + Error_Msg_F ("\\| " & Msg, N); + end if; + end if; + end Check_SPARK_Restriction; + + procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is + Msg_Issued : Boolean; + Save_Error_Msg_Sloc : Source_Ptr; + + begin + pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\'); + + if Comes_From_Source (Original_Node (N)) then + if Restriction_Check_Required (SPARK_05) + and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) + then + return; + end if; + + -- Since the call to Restriction_Msg from Check_Restriction may set + -- Error_Msg_Sloc to the location of the pragma restriction, save and + -- restore the previous value of the global variable around the call. + + Save_Error_Msg_Sloc := Error_Msg_Sloc; + Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); + Error_Msg_Sloc := Save_Error_Msg_Sloc; + + if Msg_Issued then + Error_Msg_F ("\\| " & Msg1, N); + Error_Msg_F (Msg2, N); + end if; + end if; + end Check_SPARK_Restriction; + ---------------------------------- -- Suppress_Restriction_Message -- ---------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 7d6dcc1..1943973 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -302,6 +302,11 @@ package Restrict is -- identifier, and if so returns the corresponding Restriction_Id value, -- otherwise returns Not_A_Restriction_Id. + function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean; + -- Used in checking No_Dependence argument of pragma Restrictions or + -- pragma Restrictions_Warning, or attribute Restriction_Set. Returns + -- True if N has the proper form for a unit name, False otherwise. + function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean; -- Determine if given location is covered by a hidden region range in the -- SPARK hides table. diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 382d2d1..ecd1cd6 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -82,7 +82,7 @@ package body Rtsfind is -- A unit retrieved through rtsfind may end up in the context of several -- other units, in addition to the main unit. These additional with_clauses - -- are needed to generate a proper traversal order for Inspector. To + -- are needed to generate a proper traversal order for CodePeer. To -- minimize somewhat the redundancy created by numerous calls to rtsfind -- from different units, we keep track of the list of implicit with_clauses -- already created for the current loaded unit. @@ -123,7 +123,7 @@ package body Rtsfind is -- with_clauses to the extended main unit if needed, and also to whatever -- unit needs them, which is not necessarily the main unit. The former -- ensures that the object is correctly loaded by the binder. The latter - -- is necessary for SofCheck Inspector. + -- is necessary for CodePeer. -- The field First_Implicit_With in the unit table record are used to -- avoid creating duplicate with_clauses. @@ -827,10 +827,9 @@ package body Rtsfind is -- We do not need to generate a with_clause for a call issued from -- RTE_Component_Available. However, for CodePeer, we need these -- additional with's, because for a sequence like "if RTE_Available (X) - -- then ... RTE (X)" the RTE call fails to create some necessary - -- with's. + -- then ... RTE (X)" the RTE call fails to create some necessary with's. - if RTE_Available_Call and then not Generate_SCIL then + if RTE_Available_Call and not Generate_SCIL then return; end if; @@ -840,8 +839,8 @@ package body Rtsfind is return; end if; - -- Add the with_clause, if not already in the context of the - -- current compilation unit. + -- Add the with_clause, if not already in the context of the current + -- compilation unit. declare LibUnit : constant Node_Id := Unit (Cunit (U.Unum)); diff --git a/gcc/ada/s-restri.ads b/gcc/ada/s-restri.ads index 0085548..a0cb1e9 100644 --- a/gcc/ada/s-restri.ads +++ b/gcc/ada/s-restri.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -47,6 +47,7 @@ package System.Restrictions is pragma Discard_Names; package Rident is new System.Rident; + -- Instantiate a copy of System.Rident without enumeration image names Run_Time_Restrictions : Rident.Restrictions_Info; -- Restrictions as set by the user, or detected by the binder. See details @@ -54,8 +55,8 @@ package System.Restrictions is -- and the format of the information. -- -- Note that a restriction which is both Set and Violated at run-time means - -- that the violation was detected as part of the Ada run-time and not - -- as part of user code. + -- that the violation was detected as part of the Ada run-time and not as + -- part of user code. ------------------ -- Subprograms -- @@ -64,13 +65,13 @@ package System.Restrictions is function Abort_Allowed return Boolean; pragma Inline (Abort_Allowed); -- Tests to see if abort is allowed by the current restrictions settings. - -- For abort to be allowed, either No_Abort_Statements must be False, - -- or Max_Asynchronous_Select_Nesting must be non-zero. + -- For abort to be allowed, either No_Abort_Statements must be False, or + -- Max_Asynchronous_Select_Nesting must be non-zero. function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); -- Tests to see if tasking operations are allowed by the current - -- restrictions settings. For tasking to be allowed, No_Tasking - -- must be False, and Max_Tasks must not be set to zero. + -- restrictions settings. For tasking to be allowed, No_Tasking must + -- be False, and Max_Tasks must not be set to zero. end System.Restrictions; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 57d5d91..9bc7ff7 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -654,12 +654,12 @@ package Sem is 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 + -- Primarily for use by CodePeer. 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 @@ -667,7 +667,9 @@ package Sem is -- Item is never an instantiation. Instead, the instance declaration is -- passed, and (if the instantiation is the main unit), the instance body. - -- Debugging: + ------------------------ + -- Debugging Routines -- + ------------------------ function ss (Index : Int) return Scope_Stack_Entry; pragma Export (Ada, ss); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f52abe9..f5d12ed 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -72,6 +72,7 @@ with Targparm; use Targparm; with Ttypes; use Ttypes; with Tbuild; use Tbuild; with Uintp; use Uintp; +with Uname; use Uname; with Urealp; use Urealp; package body Sem_Attr is @@ -1642,9 +1643,7 @@ package body Sem_Attr is begin Check_E0; - if Nkind (P) /= N_Identifier - or else Chars (P) /= Name_Standard - then + if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then Error_Attr ("only allowed prefix for % attribute is Standard", P); end if; end Check_Standard_Prefix; @@ -1658,12 +1657,11 @@ package body Sem_Attr is Btyp : Entity_Id; In_Shared_Var_Procs : Boolean; - -- True when compiling the body of System.Shared_Storage. - -- Shared_Var_Procs. For this runtime package (always compiled in - -- GNAT mode), we allow stream attributes references for limited - -- types for the case where shared passive objects are implemented - -- using stream attributes, which is the default in GNAT's persistent - -- storage implementation. + -- True when compiling System.Shared_Storage.Shared_Var_Procs body. + -- For this runtime package (always compiled in GNAT mode), we allow + -- stream attributes references for limited types for the case where + -- shared passive objects are implemented using stream attributes, + -- which is the default in GNAT's persistent storage implementation. begin Validate_Non_Static_Attribute_Function_Call; @@ -2049,16 +2047,11 @@ package body Sem_Attr is -- some attributes for which we do not analyze the prefix, since the -- prefix is not a normal name, or else needs special handling. - if Aname /= Name_Elab_Body - and then - Aname /= Name_Elab_Spec - and then - Aname /= Name_Elab_Subp_Body - and then - Aname /= Name_UET_Address - and then - Aname /= Name_Enabled - and then + if Aname /= Name_Elab_Body and then + Aname /= Name_Elab_Spec and then + Aname /= Name_Elab_Subp_Body and then + Aname /= Name_UET_Address and then + Aname /= Name_Enabled and then Aname /= Name_Old then Analyze (P); @@ -2122,12 +2115,18 @@ package body Sem_Attr is else E1 := First (Exprs); - Analyze (E1); - -- Check for missing/bad expression (result of previous error) + -- Skip analysis for case of Restriction_Set, we do not expect + -- the argument to be analyzed in this case. - if No (E1) or else Etype (E1) = Any_Type then - raise Bad_Attribute; + if Aname /= Name_Restriction_Set then + Analyze (E1); + + -- Check for missing/bad expression (result of previous error) + + if No (E1) or else Etype (E1) = Any_Type then + raise Bad_Attribute; + end if; end if; E2 := Next (E1); @@ -4832,6 +4831,121 @@ package body Sem_Attr is Resolve (E1, P_Base_Type); Resolve (E2, P_Base_Type); + --------------------- + -- Restriction_Set -- + --------------------- + + when Attribute_Restriction_Set => Restriction_Set : declare + R : Restriction_Id; + U : Node_Id; + Unam : Unit_Name_Type; + + procedure Set_Result (B : Boolean); + -- Replace restriction node by static constant False or True, + -- depending on the value of B. + + ---------------- + -- Set_Result -- + ---------------- + + procedure Set_Result (B : Boolean) is + begin + if B then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + + Set_Is_Static_Expression (N); + end Set_Result; + + -- Start of processing for Restriction_Set + + begin + Check_E1; + Analyze (P); + + if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then + Set_Result (False); + Error_Attr_P ("prefix of % attribute must be System"); + end if; + + -- No_Dependence case + + if Nkind (E1) = N_Parameter_Association then + pragma Assert (Chars (Selector_Name (E1)) = Name_No_Dependence); + U := Explicit_Actual_Parameter (E1); + + if not OK_No_Dependence_Unit_Name (U) then + Set_Result (False); + Error_Attr; + end if; + + -- See if there is an entry already in the table. That's the + -- case in which we can return True. + + for J in No_Dependences.First .. No_Dependences.Last loop + if Designate_Same_Unit (U, No_Dependences.Table (J).Unit) + and then No_Dependences.Table (J).Warn = False + then + Set_Result (True); + return; + end if; + end loop; + + -- If not in the No_Dependence table, result is False + + Set_Result (False); + + -- In this case, we must ensure that the binder will reject any + -- other unit in the partition that sets No_Dependence for this + -- unit. We do that by making an entry in the special table kept + -- for this purpose (if the entry is not there already). + + Unam := Get_Spec_Name (Get_Unit_Name (U)); + + for J in Restriction_Set_Dependences.First .. + Restriction_Set_Dependences.Last + loop + if Restriction_Set_Dependences.Table (J) = Unam then + return; + end if; + end loop; + + Restriction_Set_Dependences.Append (Unam); + + -- Normal restriction case + + else + if Nkind (E1) /= N_Identifier then + Set_Result (False); + Error_Attr ("attribute % requires restriction identifier", E1); + + else + R := Get_Restriction_Id (Process_Restriction_Synonyms (E1)); + + if R = Not_A_Restriction_Id then + Set_Result (False); + Error_Msg_Node_1 := E1; + Error_Attr ("invalid restriction identifier &", E1); + + elsif R not in Partition_Boolean_Restrictions then + Set_Result (False); + Error_Msg_Node_1 := E1; + Error_Attr + ("& is not a boolean partition-wide restriction", E1); + end if; + + if Restriction_Active (R) then + Set_Result (True); + else + Check_Restriction (R, N); + Set_Result (False); + end if; + end if; + end if; + end Restriction_Set; + ----------- -- Round -- ----------- @@ -5334,9 +5448,7 @@ package body Sem_Attr is Check_E1; Analyze (P); - if Nkind (P) /= N_Identifier - or else Chars (P) /= Name_System - then + if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then Error_Attr_P ("prefix of % attribute must be System"); end if; @@ -8072,6 +8184,16 @@ package body Sem_Attr is Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static); end Remainder; + ----------------- + -- Restriction -- + ----------------- + + when Attribute_Restriction_Set => Restriction_Set : declare + begin + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + Set_Is_Static_Expression (N); + end Restriction_Set; + ----------- -- Round -- ----------- diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 98b0d57..87d2ab3 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -3000,7 +3000,7 @@ package body Sem_Ch10 is Set_First_Name (Withn, True); Set_Implicit_With (Withn, True); - -- If the unit is a package or generic package declaration, a private_ + -- If the unit is a package or generic package declaration, a private_ -- with_clause on a child unit implies that the implicit with on the -- parent is also private. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index abf415f..37fd722 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1310,7 +1310,6 @@ package body Sem_Ch13 is Aspect_Small | Aspect_Simple_Storage_Pool | Aspect_Storage_Pool | - Aspect_Storage_Size | Aspect_Stream_Size | Aspect_Value_Size | Aspect_Variable_Indexing | @@ -1751,7 +1750,7 @@ package body Sem_Ch13 is Analyze_Aspect_Dimension_System (N, Id, Expr); goto Continue; - -- Case 4: Special handling for aspects + -- Case 4: Aspects requiring special handling -- Pre/Post/Test_Case/Contract_Cases whose corresponding -- pragmas take care of the delay. @@ -2028,6 +2027,62 @@ package body Sem_Ch13 is else Aitem := Empty; end if; + + -- Storage_Size + + -- This is special because for access types we need to generate + -- an attribute definition clause. This also works for single + -- task declarations, but it does not work for task type + -- declarations, because we have the case where the expression + -- references a discriminant of the task type. That can't use + -- an attribute definition clause because we would not have + -- visibility on the discriminant. For that case we must + -- generate a pragma in the task definition. + + when Aspect_Storage_Size => + + -- Task type case + + if Ekind (E) = E_Task_Type then + declare + Decl : constant Node_Id := Declaration_Node (E); + + begin + pragma Assert (Nkind (Decl) = N_Task_Type_Declaration); + + -- If no task definition, create one + + if No (Task_Definition (Decl)) then + Set_Task_Definition (Decl, + Make_Task_Definition (Loc, + Visible_Declarations => Empty_List, + End_Label => Empty)); + end if; + + -- Create a pragma and put it at the start of the + -- task definition for the task type declaration. + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Storage_Size); + + Prepend + (Aitem, + Visible_Declarations (Task_Definition (Decl))); + goto Continue; + end; + + -- All other cases, generate attribute definition + + else + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + end if; end case; -- Attach the corresponding pragma/attribute definition clause to @@ -4067,13 +4122,18 @@ package body Sem_Ch13 is begin if Is_Task_Type (U_Ent) then - Check_Restriction (No_Obsolescent_Features, N); - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("?j?storage size clause for task is an " & - "obsolescent feature (RM J.9)", N); - Error_Msg_N ("\?j?use Storage_Size pragma instead", N); + -- Check obsolescent (but never obsolescent if from aspect!) + + if not From_Aspect_Specification (N) then + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("?j?storage size clause for task is an " & + "obsolescent feature (RM J.9)", N); + Error_Msg_N ("\?j?use Storage_Size pragma instead", N); + end if; end if; FOnly := True; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9a68720..a18b874 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6990,31 +6990,6 @@ package body Sem_Prag is Expr : Node_Id; Val : Uint; - procedure Check_Unit_Name (N : Node_Id); - -- Checks unit name parameter for No_Dependence. Returns if it has - -- an appropriate form, otherwise raises pragma argument error. - - --------------------- - -- Check_Unit_Name -- - --------------------- - - procedure Check_Unit_Name (N : Node_Id) is - begin - if Nkind (N) = N_Selected_Component then - Check_Unit_Name (Prefix (N)); - Check_Unit_Name (Selector_Name (N)); - - elsif Nkind (N) = N_Identifier then - return; - - else - Error_Pragma_Arg - ("wrong form for unit name for No_Dependence", N); - end if; - end Check_Unit_Name; - - -- Start of processing for Process_Restrictions_Or_Restriction_Warnings - begin -- Ignore all Restrictions pragmas in CodePeer mode @@ -7174,7 +7149,9 @@ package body Sem_Prag is -- already made the necessary entry in the No_Dependence table. elsif Id = Name_No_Dependence then - Check_Unit_Name (Expr); + if not OK_No_Dependence_Unit_Name (Expr) then + raise Pragma_Exit; + end if; -- Case of No_Specification_Of_Aspect => Identifier. diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index f66aeee..e8c9805 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1516,14 +1516,14 @@ package Sinfo is -- in rtsfind to indicate implicit dependencies on predefined units. Used -- to prevent multiple with_clauses for the same unit in a given context. -- A postorder traversal of the tree whose nodes are units and whose - -- links are with_clauses defines the order in which Inspector must + -- links are with_clauses defines the order in which CodePeer must -- examine a compiled unit and its full context. This ordering ensures -- that any subprogram call is examined after the subprogram declaration -- has been seen. -- Next_Named_Actual (Node4-Sem) - -- Present in parameter association node. Set during semantic analysis to - -- point to the next named parameter, where parameters are ordered by + -- Present in parameter association nodes. Set during semantic analysis + -- to point to the next named parameter, where parameters are ordered by -- declaration order (as opposed to the actual order in the call, which -- may be different due to named associations). Not that this field -- points to the explicit actual parameter itself, not to the diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 40823d4..70afdb7 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -903,6 +903,7 @@ package Snames is Name_Range : constant Name_Id := N + $; Name_Range_Length : constant Name_Id := N + $; -- GNAT Name_Ref : constant Name_Id := N + $; -- GNAT + Name_Restriction_Set : constant Name_Id := N + $; -- GNAT Name_Result : constant Name_Id := N + $; -- GNAT Name_Round : constant Name_Id := N + $; Name_Safe_Emax : constant Name_Id := N + $; -- Ada 83 @@ -1519,6 +1520,7 @@ package Snames is Attribute_Range, Attribute_Range_Length, Attribute_Ref, + Attribute_Restriction_Set, Attribute_Result, Attribute_Round, Attribute_Safe_Emax, |