diff options
Diffstat (limited to 'gcc/ada/sem_ch13.adb')
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 239 |
1 files changed, 188 insertions, 51 deletions
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1e88ef4..31735e4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -337,6 +337,13 @@ package body Sem_Ch13 is -- Resolve each one of the arguments specified in the specification of -- aspect Finalizable. + function Resolve_Finalization_Procedure + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- Resolve a procedure argument specified in the specification of one of + -- the finalization aspects, i.e. Finalizable and Destructor. Returns True + -- if successful, False otherwise. + procedure Resolve_Iterable_Operation (N : Node_Id; Cursor : Entity_Id; @@ -4634,6 +4641,7 @@ package body Sem_Ch13 is when Aspect_Designated_Storage_Model => if not All_Extensions_Allowed then + Error_Msg_Name_1 := Nam; Error_Msg_GNAT_Extension ("aspect %", Loc); goto Continue; @@ -4646,6 +4654,20 @@ package body Sem_Ch13 is goto Continue; end if; + when Aspect_Destructor => + if not All_Extensions_Allowed then + Error_Msg_Name_1 := Nam; + Error_Msg_GNAT_Extension ("aspect %", Loc); + goto Continue; + + elsif not Is_Type (E) then + Error_Msg_N ("can only be specified for a type", Aspect); + goto Continue; + end if; + + Set_Has_Destructor (E); + Set_Is_Controlled_Active (E); + when Aspect_Storage_Model_Type => if not All_Extensions_Allowed then Error_Msg_Name_1 := Nam; @@ -4777,7 +4799,7 @@ package body Sem_Ch13 is and then not Is_Ignored_Ghost_Entity (E) then if A_Id = Aspect_Pre then - if Is_Ignored (Aspect) then + if Is_Ignored_In_Codegen (Aspect) then Set_Ignored_Class_Preconditions (E, New_Copy_Tree (Expr)); else @@ -4791,7 +4813,7 @@ package body Sem_Ch13 is elsif No (Class_Postconditions (E)) and then No (Ignored_Class_Postconditions (E)) then - if Is_Ignored (Aspect) then + if Is_Ignored_In_Codegen (Aspect) then Set_Ignored_Class_Postconditions (E, New_Copy_Tree (Expr)); else @@ -5063,6 +5085,14 @@ package body Sem_Ch13 is Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean); end if; + -- Record the No_Task_Parts aspects as a rep item so it + -- can be consistently looked up on the full view of the + -- type. + + if Is_Private_Type (E) then + Record_Rep_Item (E, Aspect); + end if; + goto Continue; -- Ada 2022 (AI12-0075): static expression functions @@ -8861,6 +8891,43 @@ package body Sem_Ch13 is Num_Repped_Components : Nat := 0; Num_Unrepped_Components : Nat := 0; + function Unchecked_Union_Pragma_Pending return Boolean; + -- Return True in the corner case of an Unchecked_Union pragma + -- occuring after the record representation clause (which + -- means that Is_Unchecked_Union will return False for Rectype, + -- even though it would return True if called later after the + -- pragma is analyzed). + + ------------------------------------ + -- Unchecked_Union_Pragma_Pending -- + ------------------------------------ + + function Unchecked_Union_Pragma_Pending return Boolean is + Decl_List_Element : Node_Id := N; + Pragma_Arg : Node_Id; + begin + while Present (Decl_List_Element) loop + if Nkind (Decl_List_Element) = N_Pragma + and then Get_Pragma_Id (Decl_List_Element) = + Pragma_Unchecked_Union + and then not Is_Empty_List (Pragma_Argument_Associations + (Decl_List_Element)) + then + Pragma_Arg := Get_Pragma_Arg + (First (Pragma_Argument_Associations + (Decl_List_Element))); + if Nkind (Pragma_Arg) = N_Identifier + and then Chars (Pragma_Arg) = Chars (Rectype) + then + return True; + end if; + end if; + + Next (Decl_List_Element); + end loop; + return False; + end Unchecked_Union_Pragma_Pending; + begin -- First count number of repped and unrepped components @@ -8899,8 +8966,10 @@ package body Sem_Ch13 is -- Ignore discriminant in unchecked union, since it is -- not there, and cannot have a component clause. - and then (not Is_Unchecked_Union (Rectype) - or else Ekind (Comp) /= E_Discriminant) + and then (Ekind (Comp) /= E_Discriminant + or else not (Is_Unchecked_Union (Rectype) + or else + Unchecked_Union_Pragma_Pending)) then Error_Msg_Sloc := Sloc (Comp); Error_Msg_NE @@ -10213,8 +10282,7 @@ package body Sem_Ch13 is procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is Loc : constant Source_Ptr := Sloc (Typ); - Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; - Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + Saved_Ghost_Config : constant Ghost_Config_Type := Ghost_Config; -- Save the Ghost-related attributes to restore on exit Expr : Node_Id; @@ -10380,7 +10448,7 @@ package body Sem_Ch13 is -- which is needed to generate the corresponding predicate -- function. - if Is_Ignored_Ghost_Pragma (Prag) then + if Is_Ignored_Ghost_Pragma_In_Codegen (Prag) then Add_Condition (New_Occurrence_Of (Standard_True, Sloc (Prag))); else @@ -10421,7 +10489,8 @@ package body Sem_Ch13 is -- "and"-in the Arg2 condition to evolving expression - if not Is_Ignored_Ghost_Pragma (Prag) then + if not Is_Ignored_Ghost_Pragma_In_Codegen (Prag) + then Add_Condition (Arg2_Copy); end if; end; @@ -11021,7 +11090,7 @@ package body Sem_Ch13 is end; end if; - Restore_Ghost_Region (Saved_GM, Saved_IGR); + Restore_Ghost_Region (Saved_Ghost_Config); if Restore_Scope then Pop_Scope; @@ -11041,8 +11110,7 @@ package body Sem_Ch13 is is Loc : constant Source_Ptr := Sloc (Typ); - Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; - Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + Saved_Ghost_Config : constant Ghost_Config_Type := Ghost_Config; -- Save the Ghost-related attributes to restore on exit Func_Decl : Node_Id; @@ -11123,7 +11191,7 @@ package body Sem_Ch13 is Insert_After (Parent (Typ), Func_Decl); Analyze (Func_Decl); - Restore_Ghost_Region (Saved_GM, Saved_IGR); + Restore_Ghost_Region (Saved_Ghost_Config); return Func_Decl; end Build_Predicate_Function_Declaration; @@ -11201,6 +11269,13 @@ package body Sem_Ch13 is -- Start of processing for Check_Aspect_At_End_Of_Declarations begin + -- Indicate that the expression comes from an aspect specification, + -- which is used in subsequent analysis even if expansion is off. + + if Present (End_Decl_Expr) then + Set_Parent (End_Decl_Expr, ASN); + end if; + -- In an instance we do not perform the consistency check between freeze -- point and end of declarations, because it was done already in the -- analysis of the generic. Furthermore, the delayed analysis of an @@ -11230,6 +11305,7 @@ package body Sem_Ch13 is -- the one available at at the freeze point. elsif A_Id in Aspect_Constructor + | Aspect_Destructor | Aspect_Input | Aspect_Output | Aspect_Read @@ -11292,13 +11368,6 @@ package body Sem_Ch13 is end if; end if; - -- Indicate that the expression comes from an aspect specification, - -- which is used in subsequent analysis even if expansion is off. - - if Present (End_Decl_Expr) then - Set_Parent (End_Decl_Expr, ASN); - end if; - -- In a generic context the original aspect expressions have not -- been preanalyzed, so do it now. There are no conformance checks -- to perform in this case. As before, we have to make components @@ -11406,24 +11475,16 @@ package body Sem_Ch13 is ---------------------------------- procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is - Ident : constant Node_Id := Identifier (ASN); - -- Identifier (use Entity field to save expression) - Expr : constant Node_Id := Expression (ASN); - -- For cases where using Entity (Identifier) doesn't work - A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); + A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Identifier (ASN))); T : Entity_Id := Empty; -- Type required for preanalyze call begin - -- On entry to this procedure, Entity (Ident) contains a copy of the - -- original expression from the aspect, saved for this purpose. - - -- On exit from this procedure Entity (Ident) is unchanged, still - -- containing that copy, but Expression (Ident) is a preanalyzed copy - -- of the expression, preanalyzed just after the freeze point. + -- On exit from this procedure, Expression (ASN) is a copy of the + -- original expression, preanalyzed just after the freeze point. -- Make a copy of the expression to be preanalyzed @@ -11702,6 +11763,67 @@ package body Sem_Ch13 is Analyze (Expression (ASN)); return; + when Aspect_Destructor => + if not Is_Record_Type (Entity (ASN)) then + Error_Msg_N + ("aspect Destructor can only be specified for a " + & "record type", + ASN); + return; + end if; + + Set_Has_Destructor (Entity (ASN)); + Set_Is_Controlled_Active (Entity (ASN)); + + Analyze (Expression (ASN)); + + if not Resolve_Finalization_Procedure + (Expression (ASN), Entity (ASN)) + then + Error_Msg_N + ("destructor must be local procedure whose only formal " + & "parameter has mode `IN OUT` and is of the type the " + & "destructor is for", + Expression (ASN)); + end if; + + Set_Is_Destructor (Entity (Expression (ASN))); + + declare + Proc : constant Entity_Id := Entity (Expression (ASN)); + Overr : constant Opt_N_Entity_Id := + Overridden_Inherited_Operation (Proc); + Orig : constant Entity_Id := + (if Present (Overr) then Overr else Proc); + + Decl : constant Node_Id := + Parent + (if Nkind (Parent (Orig)) = N_Procedure_Specification + then Parent (Orig) + else Orig); + + Encl : constant Node_Id := Parent (Decl); + + Is_Private : constant Boolean := + Nkind (Encl) = N_Package_Specification + and then Is_List_Member (Decl) + and then List_Containing (Decl) = Private_Declarations (Encl); + + begin + + if Has_Private_Declaration (Entity (ASN)) + and then not Aspect_On_Partial_View (ASN) + and then not Is_Private + then + Error_Msg_N + ("aspect Destructor on full view cannot denote public " + & "primitive", + ASN); + end if; + end; + + return; + when Aspect_Storage_Model_Type => -- The aggregate argument of Storage_Model_Type is optional, and @@ -15855,6 +15977,8 @@ package body Sem_Ch13 is -- We may freeze Subp_Id immediately since Ent has just been frozen. -- This will help to shield us from potential late freezing issues. + Mutate_Ekind (Subp_Id, E_Procedure); + Freeze_Extra_Formals (Subp_Id); Set_Is_Frozen (Subp_Id); else @@ -17302,6 +17426,35 @@ package body Sem_Ch13 is Typ : Entity_Id; Nam : Name_Id) is + begin + if Nam = Name_Relaxed_Finalization then + Resolve (N, Any_Boolean); + + if Is_OK_Static_Expression (N) then + Set_Has_Relaxed_Finalization (Typ, Is_True (Static_Boolean (N))); + + else + Flag_Non_Static_Expr + ("expression of aspect Finalizable must be static!", N); + end if; + + return; + end if; + + if Resolve_Finalization_Procedure (N, Typ) then + return; + end if; + + Error_Msg_N + ("finalizable primitive must be local procedure whose only formal " & + "parameter has mode `IN OUT` and is of the finalizable type", N); + end Resolve_Finalizable_Argument; + + function Resolve_Finalization_Procedure + (N : Node_Id; + Typ : Entity_Id) + return Boolean + is function Is_Finalizable_Primitive (E : Entity_Id) return Boolean; -- Check whether E is a finalizable primitive for Typ @@ -17319,29 +17472,15 @@ package body Sem_Ch13 is and then No (Next_Formal (First_Formal (E))); end Is_Finalizable_Primitive; - -- Start of processing for Resolve_Finalizable_Argument + -- Start of processing for Resolve_Finalization_Procedure begin - if Nam = Name_Relaxed_Finalization then - Resolve (N, Any_Boolean); - - if Is_OK_Static_Expression (N) then - Set_Has_Relaxed_Finalization (Typ, Is_True (Static_Boolean (N))); - - else - Flag_Non_Static_Expr - ("expression of aspect Finalizable must be static!", N); - end if; - - return; - end if; - if not Is_Entity_Name (N) then null; elsif not Is_Overloaded (N) then if Is_Finalizable_Primitive (Entity (N)) then - return; + return True; end if; else @@ -17357,7 +17496,7 @@ package body Sem_Ch13 is while Present (It.Typ) loop if Is_Finalizable_Primitive (It.Nam) then Set_Entity (N, It.Nam); - return; + return True; end if; Get_Next_Interp (I, It); @@ -17365,10 +17504,8 @@ package body Sem_Ch13 is end; end if; - Error_Msg_N - ("finalizable primitive must be local procedure whose only formal " & - "parameter has mode `IN OUT` and is of the finalizable type", N); - end Resolve_Finalizable_Argument; + return False; + end Resolve_Finalization_Procedure; -------------------------------- -- Resolve_Iterable_Operation -- |