diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 47 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 32 | ||||
| -rw-r--r-- | gcc/ada/s-solita.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/s-tarest.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/s-tassta.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 369 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/tree_io.ads | 4 |
11 files changed, 310 insertions, 284 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3e5597a..cfa0ea7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Add a predicate check on an + actual the related type has a predicate function. + * sem_ch3.adb (Constant_Redeclaration): Ensure that the related + type has an invariant procedure before building a call to it. + * sem_ch6.adb (Append_Enabled_Item): New routine. + (Check_Access_Invariants): Use routine + Append_Enabled_Item to chain onto the list of postconditions. + (Contains_Enabled_Pragmas): Removed. + (Expand_Contract_Cases): Use routine Append_Enabled_Item to chain onto + the list of postconditions. + (Invariants_Or_Predicates_Present): Removed. + (Process_PPCs): Partially reimplemented. + +2013-04-24 Sergey Rybin <rybin@adacore.com frybin> + + * tree_io.ads: Update ASIS_Version_Number because of changes + in the way how entities are chained in a scope by means of + Next_Entity link. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case + Storage_Size): If the clause is not from an aspect, insert + assignment to size variable of task type at the point of the + clause, not after the task definition, to prevent access before + elaboration in the back-end. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Sig_Flags): Set correct value for Pragma_Assume. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * gnat_rm.texi: Document 'Loop_Entry. + +2013-04-24 Jose Ruiz <ruiz@adacore.com> + + * s-tassta.adb, s-tarest.adb (Task_Wrapper): Start looking for + fall-back termination handlers from the parents, because they apply + only to dependent tasks. + * s-solita.adb (Task_Termination_Handler_T): Do not look for fall-back + termination handlers because the environment task has no parent, + and if it defines one of these handlers it does not apply to + itself because they apply only to dependent tasks. + 2013-04-24 Robert Dewar <dewar@adacore.com> * sem_type.adb, exp_attr.adb, exp_ch4.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 364401d..295d4ad 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -184,8 +184,19 @@ package body Exp_Ch13 is Expression => Convert_To (RTE (RE_Size_Type), Expression (N))); - Insert_After - (Parent (Storage_Size_Variable (Entity (N))), Assign); + -- If the clause is not generated by an aspect, insert + -- the assignment here. Freezing rules ensure that this + -- is safe, or clause will have been rejected already. + + if Is_List_Member (N) then + Insert_After (N, Assign); + + -- Otherwise, insert assignment after task declaration. + + else + Insert_After + (Parent (Storage_Size_Variable (Entity (N))), Assign); + end if; Analyze (Assign); end; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3e33ed8..5b97739 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1728,17 +1728,19 @@ package body Exp_Ch6 is -- procedure does not include a predicate call, so it has to be -- generated explicitly. - if (Has_Aspect (E_Actual, Aspect_Predicate) - or else - Has_Aspect (E_Actual, Aspect_Dynamic_Predicate) - or else - Has_Aspect (E_Actual, Aspect_Static_Predicate)) - and then not Is_Init_Proc (Subp) + if not Is_Init_Proc (Subp) + and then (Has_Aspect (E_Actual, Aspect_Predicate) + or else + Has_Aspect (E_Actual, Aspect_Dynamic_Predicate) + or else + Has_Aspect (E_Actual, Aspect_Static_Predicate)) + and then Present (Predicate_Function (E_Actual)) then - if (Is_Derived_Type (E_Actual) - and then Is_Overloadable (Subp) - and then Is_Inherited_Operation_For_Type (Subp, E_Actual)) - or else Is_Entity_Name (Actual) + if Is_Entity_Name (Actual) + or else + (Is_Derived_Type (E_Actual) + and then Is_Overloadable (Subp) + and then Is_Inherited_Operation_For_Type (Subp, E_Actual)) then Append_To (Post_Call, Make_Predicate_Check (E_Actual, Actual)); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 1c7133c..6b2574b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -277,6 +277,7 @@ Implementation Defined Attributes * Integer_Value:: * Invalid_Value:: * Large:: +* Loop_Entry:: * Machine_Size:: * Mantissa:: * Max_Interrupt_Priority:: @@ -6682,6 +6683,7 @@ consideration, you should minimize the use of these attributes. * Integer_Value:: * Invalid_Value:: * Large:: +* Loop_Entry:: * Machine_Size:: * Mantissa:: * Max_Interrupt_Priority:: @@ -7173,6 +7175,36 @@ The @code{Large} attribute is provided for compatibility with Ada 83. See the Ada 83 reference manual for an exact description of the semantics of this attribute. +@node Loop_Entry +@unnumberedsec Loop_Entry +@findex Loop_Entry +@noindent +Syntax: + +@smallexample @c ada +X'Loop_Entry [(loop_name)] +@end smallexample + +@noindent +The @code{Loop_Entry} attribute is used to refer to the value that an +expression had upon entry to a given loop in much the same way that the +@code{Old} attribute in a subprogram postcondition can be used to refer +to the value an expression had upon entry to the subprogram. The +relevant loop is either identified by the given loop name, or it is the +innermost enclosing loop when no loop name is given. + +@noindent +A @code{Loop_Entry} attribute can only occur within a +@code{Loop_Variant} or @code{Loop_Invariant} pragma. A common use of +@code{Loop_Entry} is to compare the current value of objects with their +initial value at loop entry, in a @code{Loop_Invariant} pragma. + +@noindent +The effect of using @code{X'Loop_Entry} is the same as declaring +a constant initialized with the initial value of @code{X} at loop +entry. This copy is not performed if the loop is not entered, or if the +corresponding pragmas are ignored or disabled. + @node Machine_Size @unnumberedsec Machine_Size @findex Machine_Size diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index a222c87..19a422a 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -181,12 +181,13 @@ package body System.Soft_Links.Tasking is -- There is no need for explicit protection against race conditions for -- this part because it can only be executed by the environment task - -- after all the other tasks have been finalized. + -- after all the other tasks have been finalized. Note that there is no + -- fall-back handler which could apply to this environment task because + -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the + -- fall-back handler applies only to the dependent tasks of the task". if Self_Id.Common.Specific_Handler /= null then Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); - elsif Self_Id.Common.Fall_Back_Handler /= null then - Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO); end if; end Task_Termination_Handler_T; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index c765cc0..399437f 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -268,49 +268,45 @@ package body System.Tasking.Restricted.Stages is Save_Occurrence (EO, E); end; - -- Look for a fall-back handler. It can be either in the task itself - -- or in the environment task. Note that this code is always executed - -- by a task whose master is the environment task. The task termination - -- code for the environment task is executed by - -- SSL.Task_Termination_Handler. + -- Look for a fall-back handler. -- This package is part of the restricted run time which supports -- neither task hierarchies (No_Task_Hierarchy) nor specific task -- termination handlers (No_Specific_Termination_Handlers). - -- There is no need for explicit protection against race conditions - -- for Self_ID.Common.Fall_Back_Handler because this procedure can - -- only be executed by Self, and the Fall_Back_Handler can only be - -- modified by Self. + -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies + -- only to the dependent tasks of the task". Hence, if the terminating + -- tasks (Self_ID) had a fall-back handler, it would not apply to + -- itself. This code is always executed by a task whose master is the + -- environment task (the task termination code for the environment task + -- is executed by SSL.Task_Termination_Handler), so the fall-back + -- handler to execute for this task can only be defined by its parent + -- (there is no grandparent). - if Self_ID.Common.Fall_Back_Handler /= null then - Self_ID.Common.Fall_Back_Handler (Cause, Self_ID, EO); - else - declare - TH : Termination_Handler := null; + declare + TH : Termination_Handler := null; - begin - if Single_Lock then - Lock_RTS; - end if; + begin + if Single_Lock then + Lock_RTS; + end if; - Write_Lock (Self_ID.Common.Parent); + Write_Lock (Self_ID.Common.Parent); - TH := Self_ID.Common.Parent.Common.Fall_Back_Handler; + TH := Self_ID.Common.Parent.Common.Fall_Back_Handler; - Unlock (Self_ID.Common.Parent); + Unlock (Self_ID.Common.Parent); - if Single_Lock then - Unlock_RTS; - end if; + if Single_Lock then + Unlock_RTS; + end if; - -- Execute the task termination handler if we found it + -- Execute the task termination handler if we found it - if TH /= null then - TH.all (Cause, Self_ID, EO); - end if; - end; - end if; + if TH /= null then + TH.all (Cause, Self_ID, EO); + end if; + end; Terminate_Task (Self_ID); end Task_Wrapper; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 75f4e2c..487bf8d 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -1075,7 +1075,7 @@ package body System.Tasking.Stages is procedure Search_Fall_Back_Handler (ID : Task_Id); -- Procedure that searches recursively a fall-back handler through the -- master relationship. If the handler is found, its pointer is stored - -- in TH. + -- in TH. It stops when the handler is found or when the ID is null. ------------------------------ -- Search_Fall_Back_Handler -- @@ -1083,21 +1083,22 @@ package body System.Tasking.Stages is procedure Search_Fall_Back_Handler (ID : Task_Id) is begin + -- A null Task_Id indicates that we have reached the root of the + -- task hierarchy and no handler has been found. + + if ID = null then + return; + -- If there is a fall back handler, store its pointer for later -- execution. - if ID.Common.Fall_Back_Handler /= null then + elsif ID.Common.Fall_Back_Handler /= null then TH := ID.Common.Fall_Back_Handler; -- Otherwise look for a fall back handler in the parent - elsif ID.Common.Parent /= null then - Search_Fall_Back_Handler (ID.Common.Parent); - - -- Otherwise, do nothing - else - return; + Search_Fall_Back_Handler (ID.Common.Parent); end if; end Search_Fall_Back_Handler; @@ -1331,9 +1332,12 @@ package body System.Tasking.Stages is TH := Self_ID.Common.Specific_Handler; else -- Look for a fall-back handler following the master relationship - -- for the task. + -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back + -- handler applies only to the dependent tasks of the task". Hence, + -- if the terminating tasks (Self_ID) had a fall-back handler, it + -- would not apply to itself, so we start the search with the parent. - Search_Fall_Back_Handler (Self_ID); + Search_Fall_Back_Handler (Self_ID.Common.Parent); end if; Unlock (Self_ID); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 89f11dc..9e5b8de 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10761,13 +10761,9 @@ package body Sem_Ch3 is -- A deferred constant is a visible entity. If type has invariants, -- verify that the initial value satisfies them. - if Expander_Active and then Has_Invariants (T) then - declare - Call : constant Node_Id := - Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))); - begin - Insert_After (N, Call); - end; + if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then + Insert_After (N, + Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); end if; end if; end Constant_Redeclaration; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index c6db452..b9be549 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -332,14 +332,14 @@ package body Sem_Ch6 is end; end if; - Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); + Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); -- If there are previous overloadable entities with the same name, -- check whether any of them is completed by the expression function. if Present (Prev) and then Is_Overloadable (Prev) then - Def_Id := Analyze_Subprogram_Specification (Spec); - Prev := Find_Corresponding_Spec (N); + Def_Id := Analyze_Subprogram_Specification (Spec); + Prev := Find_Corresponding_Spec (N); end if; Ret := Make_Simple_Return_Statement (LocX, Expression (N)); @@ -11198,18 +11198,17 @@ package body Sem_Ch6 is Plist : List_Id := No_List; -- List of generated postconditions + procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id); + -- Append a node to a list. If there is no list, create a new one. When + -- the item denotes a pragma, it is added to the list only when it is + -- enabled. + procedure Check_Access_Invariants (E : Entity_Id); -- If the subprogram returns an access to a type with invariants, or -- has access parameters whose designated type has an invariant, then -- under the same visibility conditions as for other invariant checks, -- the type invariant must be applied to the returned value. - function Contains_Enabled_Pragmas (L : List_Id) return Boolean; - -- Determine whether list L has at least one enabled pragma. The routine - -- ignores other non-pragma elements. - -- This is NOT what the routine does??? It returns False if there is - -- one ignored pragma ??? - procedure Expand_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id); -- Given pragma Contract_Cases CCs, create the circuitry needed to -- evaluate case guards and trigger consequence expressions. Subp_Id @@ -11226,11 +11225,6 @@ package body Sem_Ch6 is procedure Insert_After_Last_Declaration (Nod : Node_Id); -- Insert node Nod after the last declaration of the context - function Invariants_Or_Predicates_Present return Boolean; - -- Determines if any invariants or predicates are present for any OUT - -- or IN OUT parameters of the subprogram, or (for a function) if the - -- return value has an invariant. - function Is_Public_Subprogram_For (T : Entity_Id) return Boolean; -- T is the entity for a private type for which invariants are defined. -- This function returns True if the procedure corresponding to the @@ -11240,6 +11234,30 @@ package body Sem_Ch6 is -- that an invariant check is required (for an IN OUT parameter, or -- the returned value of a function. + ------------------------- + -- Append_Enabled_Item -- + ------------------------- + + procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id) is + begin + -- Do not chain ignored or disabled pragmas + + if Nkind (Item) = N_Pragma + and then (Is_Ignored (Item) or else Is_Disabled (Item)) + then + null; + + -- Add the item + + else + if No (List) then + List := New_List; + end if; + + Append (Item, List); + end if; + end Append_Enabled_Item; + ----------------------------- -- Check_Access_Invariants -- ----------------------------- @@ -11266,39 +11284,18 @@ package body Sem_Ch6 is Call := Make_Invariant_Call (Obj); - Append_To (Plist, - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => Make_Null (Loc), - Right_Opnd => New_Occurrence_Of (E, Loc)), - Then_Statements => New_List (Call))); + Append_Enabled_Item + (Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => Make_Null (Loc), + Right_Opnd => New_Occurrence_Of (E, Loc)), + Then_Statements => New_List (Call)), + List => Plist); end if; end if; end Check_Access_Invariants; - ------------------------------ - -- Contains_Enabled_Pragmas -- - ------------------------------ - - -- This routine does not implement its documented spec ??? - - function Contains_Enabled_Pragmas (L : List_Id) return Boolean is - Prag : Node_Id; - - begin - Prag := First (L); - while Present (Prag) loop - if Nkind (Prag) = N_Pragma and then Is_Ignored (Prag) then - return False; - end if; - - Next (Prag); - end loop; - - return True; - end Contains_Enabled_Pragmas; - --------------------------- -- Expand_Contract_Cases -- --------------------------- @@ -11759,11 +11756,7 @@ package body Sem_Ch6 is -- Raise Assertion_Error when the corresponding consequence of a case -- guard that evaluated to True fails. - if No (Plist) then - Plist := New_List; - end if; - - Append_To (Plist, Conseq_Checks); + Append_Enabled_Item (Conseq_Checks, Plist); end Expand_Contract_Cases; -------------- @@ -11889,51 +11882,6 @@ package body Sem_Ch6 is end if; end Insert_After_Last_Declaration; - -------------------------------------- - -- Invariants_Or_Predicates_Present -- - -------------------------------------- - - function Invariants_Or_Predicates_Present return Boolean is - Formal : Entity_Id; - - begin - -- Check function return result. If result is an access type there - -- may be invariants on the designated type. - - if Ekind (Designator) /= E_Procedure - and then Has_Invariants (Etype (Designator)) - then - return True; - - elsif Ekind (Designator) /= E_Procedure - and then Is_Access_Type (Etype (Designator)) - and then Has_Invariants (Designated_Type (Etype (Designator))) - then - return True; - end if; - - -- Check parameters - - Formal := First_Formal (Designator); - while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter - and then (Has_Invariants (Etype (Formal)) - or else Present (Predicate_Function (Etype (Formal)))) - then - return True; - - elsif Is_Access_Type (Etype (Formal)) - and then Has_Invariants (Designated_Type (Etype (Formal))) - then - return True; - end if; - - Next_Formal (Formal); - end loop; - - return False; - end Invariants_Or_Predicates_Present; - ------------------------------ -- Is_Public_Subprogram_For -- ------------------------------ @@ -11986,6 +11934,14 @@ package body Sem_Ch6 is end if; end Is_Public_Subprogram_For; + -- Local variables + + Formal : Node_Id; + Formal_Typ : Entity_Id; + Func_Typ : Entity_Id; + Post_Proc : Entity_Id; + Result : Node_Id; + -- Start of processing for Process_PPCs begin @@ -11997,10 +11953,18 @@ package body Sem_Ch6 is Designator := Body_Id; end if; + -- Do not process a predicate function as its body will contain a + -- recursive call to itself and blow up the stack. + + if Ekind (Designator) = E_Function + and then Is_Predicate_Function (Designator) + then + return; + -- Internally generated subprograms, such as type-specific functions, -- don't get assertion checks. - if Get_TSS_Name (Designator) /= TSS_Null then + elsif Get_TSS_Name (Designator) /= TSS_Null then return; end if; @@ -12153,10 +12117,6 @@ package body Sem_Ch6 is -- Capture postcondition pragmas if Pragma_Name (Prag) = Name_Postcondition then - if Plist = No_List then - Plist := Empty_List; - end if; - Analyze (Prag); -- If expansion is disabled, as in a generic unit, save @@ -12165,7 +12125,7 @@ package body Sem_Ch6 is if not Expander_Active then Prepend (Grab_PPC, Declarations (N)); else - Append (Grab_PPC, Plist); + Append_Enabled_Item (Grab_PPC, Plist); end if; end if; @@ -12244,14 +12204,10 @@ package body Sem_Ch6 is if Pragma_Name (Prag) = Name_Postcondition and then (not Class or else Class_Present (Prag)) then - if Plist = No_List then - Plist := Empty_List; - end if; - if not Expander_Active then Prepend (Grab_PPC (Pspec), Declarations (N)); else - Append (Grab_PPC (Pspec), Plist); + Append_Enabled_Item (Grab_PPC (Pspec), Plist); end if; end if; @@ -12285,147 +12241,126 @@ package body Sem_Ch6 is end Spec_Postconditions; end if; - -- If we had any postconditions and expansion is enabled, or if the - -- subprogram has invariants, then build the _Postconditions procedure. + -- Add an invariant call to check the result of a function - if Expander_Active - and then (Invariants_Or_Predicates_Present - or else (Present (Plist) - and then Contains_Enabled_Pragmas (Plist))) + if Ekind (Designator) /= E_Procedure + and then Expander_Active + and then Assertions_Enabled then - if No (Plist) then - Plist := Empty_List; - end if; + Func_Typ := Etype (Designator); + Result := Make_Defining_Identifier (Loc, Name_uResult); - -- Special processing for function return + Set_Etype (Result, Func_Typ); - if Ekind (Designator) /= E_Procedure then - declare - Rent : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_uResult); - Ftyp : constant Entity_Id := Etype (Designator); + -- Add argument for return - begin - Set_Etype (Rent, Ftyp); + Parms := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Result, + Parameter_Type => New_Occurrence_Of (Func_Typ, Loc))); - -- Add argument for return + -- Add invariant call if returning type with invariants and this is a + -- public function, i.e. a function declared in the visible part of + -- the package defining the private type. - Parms := - New_List ( - Make_Parameter_Specification (Loc, - Parameter_Type => New_Occurrence_Of (Ftyp, Loc), - Defining_Identifier => Rent)); + if Has_Invariants (Func_Typ) + and then Present (Invariant_Procedure (Func_Typ)) + and then Is_Public_Subprogram_For (Func_Typ) + then + Append_Enabled_Item + (Make_Invariant_Call (New_Occurrence_Of (Result, Loc)), Plist); + end if; - -- Add invariant call if returning type with invariants and - -- this is a public function, i.e. a function declared in the - -- visible part of the package defining the private type. + -- Same if return value is an access to type with invariants - if Has_Invariants (Etype (Rent)) - and then Present (Invariant_Procedure (Etype (Rent))) - and then Is_Public_Subprogram_For (Etype (Rent)) - then - Append_To (Plist, - Make_Invariant_Call (New_Occurrence_Of (Rent, Loc))); - end if; + Check_Access_Invariants (Result); - -- Same if return value is an access to type with invariants + -- Procedure case - Check_Access_Invariants (Rent); - end; + else + Parms := No_List; + end if; - -- Procedure rather than a function + -- Add invariant calls and predicate calls for parameters. Note that + -- this is done for functions as well, since in Ada 2012 they can have + -- IN OUT args. - else - Parms := No_List; - end if; + if Expander_Active and then Assertions_Enabled then + Formal := First_Formal (Designator); + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter + or else Is_Access_Type (Etype (Formal)) + then + Formal_Typ := Etype (Formal); - -- Add invariant calls and predicate calls for parameters. Note that - -- this is done for functions as well, since in Ada 2012 they can - -- have IN OUT args. + if Has_Invariants (Formal_Typ) + and then Present (Invariant_Procedure (Formal_Typ)) + and then Is_Public_Subprogram_For (Formal_Typ) + then + Append_Enabled_Item + (Make_Invariant_Call (New_Occurrence_Of (Formal, Loc)), + Plist); + end if; - declare - Formal : Entity_Id; - Ftype : Entity_Id; + Check_Access_Invariants (Formal); - begin - Formal := First_Formal (Designator); - while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter - or else Is_Access_Type (Etype (Formal)) - then - Ftype := Etype (Formal); + if Present (Predicate_Function (Formal_Typ)) then + Append_Enabled_Item + (Make_Predicate_Check + (Formal_Typ, New_Occurrence_Of (Formal, Loc)), + Plist); + end if; + end if; - if Has_Invariants (Ftype) - and then Present (Invariant_Procedure (Ftype)) - and then Is_Public_Subprogram_For (Ftype) - then - Append_To (Plist, - Make_Invariant_Call - (New_Occurrence_Of (Formal, Loc))); - end if; + Next_Formal (Formal); + end loop; + end if; - Check_Access_Invariants (Formal); + -- Build and insert postcondition procedure - if Present (Predicate_Function (Ftype)) then - Append_To (Plist, - Make_Predicate_Check - (Ftype, New_Occurrence_Of (Formal, Loc))); - end if; - end if; + if Expander_Active and then Present (Plist) then + Post_Proc := + Make_Defining_Identifier (Loc, Chars => Name_uPostconditions); - Next_Formal (Formal); - end loop; - end; + -- Insert the corresponding body of a post condition pragma after the + -- last declaration of the context. This ensures that the body will + -- not cause any premature freezing as it may mention types: - -- Build and insert postcondition procedure + -- procedure Proc (Obj : Array_Typ) is + -- procedure _postconditions is + -- begin + -- ... Obj ... + -- end _postconditions; - declare - Post_Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars => Name_uPostconditions); - -- The entity for the _Postconditions procedure + -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); + -- begin - begin - -- Insert the corresponding body of a post condition pragma after - -- the last declaration of the context. This ensures that the body - -- will not cause any premature freezing as it may mention types: - - -- procedure Proc (Obj : Array_Typ) is - -- procedure _postconditions is - -- begin - -- ... Obj ... - -- end _postconditions; - - -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); - -- begin - - -- In the example above, Obj is of type T but the incorrect - -- placement of _postconditions will cause a crash in gigi due to - -- an out of order reference. The body of _postconditions must be - -- placed after the declaration of Temp to preserve correct - -- visibility. - - Insert_After_Last_Declaration ( - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Post_Proc, - Parameter_Specifications => Parms), + -- In the example above, Obj is of type T but the incorrect placement + -- of _postconditions will cause a crash in gigi due to an out of + -- order reference. The body of _postconditions must be placed after + -- the declaration of Temp to preserve correct visibility. - Declarations => Empty_List, + Insert_After_Last_Declaration ( + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Post_Proc, + Parameter_Specifications => Parms), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Plist))); + Declarations => Empty_List, - Set_Ekind (Post_Proc, E_Procedure); + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Plist))); - -- If this is a procedure, set the Postcondition_Proc attribute on - -- the proper defining entity for the subprogram. + Set_Ekind (Post_Proc, E_Procedure); - if Ekind (Designator) = E_Procedure then - Set_Postcondition_Proc (Designator, Post_Proc); - end if; - end; + -- If this is a procedure, set the Postcondition_Proc attribute on + -- the proper defining entity for the subprogram. + + if Ekind (Designator) = E_Procedure then + Set_Postcondition_Proc (Designator, Post_Proc); + end if; Set_Has_Postconditions (Designator); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a356704..18fd9ea 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -18218,7 +18218,7 @@ package body Sem_Prag is Pragma_Assert => -1, Pragma_Assert_And_Cut => -1, Pragma_Assertion_Policy => 0, - Pragma_Assume => 0, + Pragma_Assume => -1, Pragma_Assume_No_Invalid_Values => 0, Pragma_Attribute_Definition => +3, Pragma_Asynchronous => -1, diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index 25e24c3..3692d1e 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -47,7 +47,7 @@ package Tree_IO is Tree_Format_Error : exception; -- Raised if a format error is detected in the input file - ASIS_Version_Number : constant := 31; + ASIS_Version_Number : constant := 32; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree @@ -60,6 +60,8 @@ package Tree_IO is -- for concurrent types). -- 30 Add Check_Float_Overflow boolean to tree file -- 31 Remove read/write of Debug_Pragmas_Disabled/Debug_Pragmas_Enabled + -- 32 Change the way entities are changed through Next_Entity field in + -- the hierarchy of child units procedure Tree_Read_Initialize (Desc : File_Descriptor); -- Called to initialize reading of a tree file. This call must be made |