diff options
Diffstat (limited to 'gcc/ada/sem_ch6.adb')
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 263 |
1 files changed, 134 insertions, 129 deletions
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5e84889..2e0df1d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -886,6 +886,8 @@ package body Sem_Ch6 is Designated_Type (Etype (Expr))) then Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); + Flag_Interface_Pointer_Displacement (Expr); + Analyze (Expr); end if; @@ -1609,9 +1611,7 @@ package body Sem_Ch6 is procedure Analyze_Procedure_Call (N : Node_Id) is procedure Analyze_Call_And_Resolve; - -- Do Analyze and Resolve calls for procedure call. At the end, check - -- for illegal order dependence. - -- ??? where is the check for illegal order dependencies? + -- Do Analyze and Resolve for procedure call ------------------------------ -- Analyze_Call_And_Resolve -- @@ -1619,12 +1619,8 @@ package body Sem_Ch6 is procedure Analyze_Call_And_Resolve is begin - if Nkind (N) = N_Procedure_Call_Statement then - Analyze_Call (N); - Resolve (N, Standard_Void_Type); - else - Analyze (N); - end if; + Analyze_Call (N); + Resolve (N, Standard_Void_Type); end Analyze_Call_And_Resolve; -- Local variables @@ -1899,6 +1895,7 @@ package body Sem_Ch6 is <<Leave>> Restore_Ghost_Region (Saved_Ghost_Config); + Check_Procedure_Call_Argument_Levels (N); end Analyze_Procedure_Call; ------------------------------ @@ -2431,11 +2428,11 @@ package body Sem_Ch6 is procedure Build_Subprogram_Declaration; -- Create a matching subprogram declaration for subprogram body N - procedure Check_Anonymous_Return; - -- Ada 2005: if a function returns an access type that denotes a task, - -- or a type that contains tasks, we must create a master entity for - -- the anonymous type, which typically will be used in an allocator - -- in the body of the function. + procedure Check_Anonymous_Access_Return_With_Tasks; + -- If a function returns an anonymous access type that designates a task + -- or a type that contains tasks, create a master entity in the function + -- for the anonymous access type, and also mark the construct enclosing + -- the function as a task master. procedure Check_Inline_Pragma (Spec : in out Node_Id); -- Look ahead to recognize a pragma that may appear after the body. @@ -2792,13 +2789,12 @@ package body Sem_Ch6 is Body_Id := Analyze_Subprogram_Specification (Body_Spec); end Build_Subprogram_Declaration; - ---------------------------- - -- Check_Anonymous_Return -- - ---------------------------- + ---------------------------------------------- + -- Check_Anonymous_Access_Return_With_Tasks -- + ---------------------------------------------- - procedure Check_Anonymous_Return is + procedure Check_Anonymous_Access_Return_With_Tasks is Decl : Node_Id; - Par : Node_Id; Scop : Entity_Id; begin @@ -2834,29 +2830,14 @@ package body Sem_Ch6 is Set_Declarations (N, New_List (Decl)); end if; - Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); Set_Has_Master_Entity (Scop); + Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); - -- Now mark the containing scope as a task master - - Par := N; - while Nkind (Par) /= N_Compilation_Unit loop - Par := Parent (Par); - pragma Assert (Present (Par)); - - -- If we fall off the top, we are at the outer level, and - -- the environment task is our effective master, so nothing - -- to mark. + -- Now mark the enclosing construct as a task master - if Nkind (Par) - in N_Task_Body | N_Block_Statement | N_Subprogram_Body - then - Set_Is_Task_Master (Par, True); - exit; - end if; - end loop; + Mark_Construct_As_Task_Master (Parent (N)); end if; - end Check_Anonymous_Return; + end Check_Anonymous_Access_Return_With_Tasks; ------------------------- -- Check_Inline_Pragma -- @@ -3843,7 +3824,8 @@ package body Sem_Ch6 is -- user entities, as internally generated entitities might still need -- to be expanded (e.g. those generated for types). - if Present (Ghost_Config.Ignored_Ghost_Region) + if not CodePeer_Mode + and then Present (Ghost_Config.Ignored_Ghost_Region) and then Comes_From_Source (Body_Id) then Expander_Active := False; @@ -4472,7 +4454,12 @@ package body Sem_Ch6 is Install_Private_With_Clauses (Body_Id); end if; - Check_Anonymous_Return; + -- If a function returns an anonymous access type that designates a task + -- or a type that contains tasks, we must create a master entity for the + -- anonymous access type, which typically will be used for an allocator + -- in the body of the function. + + Check_Anonymous_Access_Return_With_Tasks; -- Set the Protected_Formal field of each extra formal of the protected -- subprogram to reference the corresponding extra formal of the @@ -5029,7 +5016,9 @@ package body Sem_Ch6 is end if; <<Leave>> - if Present (Ghost_Config.Ignored_Ghost_Region) then + if not CodePeer_Mode + and then Present (Ghost_Config.Ignored_Ghost_Region) + then Expander_Active := Saved_EA; end if; @@ -5270,10 +5259,96 @@ package body Sem_Ch6 is -- both subprogram bodies and subprogram declarations (specs). function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is + procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id); + -- This procedure checks whether the direct attribute definition for N + -- is correct for the given attribute name, and analyzes it. + function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean; -- Determine whether entity E denotes the spec or body of an invariant -- procedure. + ----------------------------------------- + -- Analyze_Direct_Attribute_Definition -- + ----------------------------------------- + + procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id) is + Att_N : constant Node_Id := Original_Node (N); + Prefix_E : constant Entity_Id := + Get_Name_Entity_Id (Chars (Prefix (Defining_Unit_Name (Att_N)))); + Att_Name : constant Name_Id := + Attribute_Name (Defining_Unit_Name (Att_N)); + begin + pragma Assert (N /= Att_N); + + if not Is_Direct_Attribute_Definition_Name (Att_Name) then + Error_Msg_Name_1 := Att_Name; + Error_Msg_N + ("direct definition syntax not supported for attribute%", + Designator); + end if; + + -- Handle each kind of attribute separately + + case Att_Name is + + when Name_Constructor => + Error_Msg_Name_1 := Att_Name; + + -- No further action required in a subprogram body + + if Parent_Kind (N) not in N_Subprogram_Declaration then + return; + + elsif No (Prefix_E) or else not Is_Type (Prefix_E) then + Error_Msg_N + ("prefix& of attribute% must be a type", + Prefix (Defining_Unit_Name (Att_N))); + + elsif Ekind (Designator) /= E_Procedure then + Error_Msg_N + ("attribute% can only be specified to a procedure", N); + + elsif No (First_Formal (Designator)) + or else Etype (First_Formal (Designator)) /= Prefix_E + or else Ekind (First_Formal (Designator)) + /= E_In_Out_Parameter + then + declare + Problem : constant Source_Ptr := + (if No (First_Formal (Designator)) + then Sloc (N) + else Sloc (First_Formal (Designator))); + begin + Error_Msg_Node_1 := Defining_Unit_Name (Att_N); + Error_Msg_Node_2 := Prefix_E; + Error_Msg + ("& must have a first IN OUT formal of type&", Problem); + end; + + elsif Is_Frozen (Prefix_E) + or else Current_Scope /= Scope (Prefix_E) + then + Error_Msg_Sloc := Sloc (Freeze_Node (Prefix_E)); + Error_Msg_N + ("& must be defined before freezing#", Designator); + + elsif Parent_Kind (Enclosing_Package_Or_Subprogram (Designator)) + /= N_Package_Specification + then + Error_Msg_N + ("& is required to be a primitive operation", Designator); + + else + Set_Needs_Construction (Prefix_E); + Set_Is_Constructor (Designator); + end if; + + when others => + null; + + end case; + end Analyze_Direct_Attribute_Definition; + ------------------------------------ -- Is_Invariant_Procedure_Or_Body -- ------------------------------------ @@ -5416,89 +5491,6 @@ package body Sem_Ch6 is End_Scope; - -- Register the subprogram in a Constructor_List when it is a valid - -- constructor. - - if All_Extensions_Allowed - and then Present (First_Formal (Designator)) - then - - declare - First_Form_Type : constant Entity_Id := - Etype (First_Formal (Designator)); - - Construct : Elmt_Id; - begin - -- Valid constructors have a "controlling" formal of a type - -- with the Constructor aspect specified. Additionally, the - -- subprogram name must match value described by the aspect. - - -- Additionally, constructor declarations must exist within the - -- same scope as the type declaration and before the type is - -- frozen. - - -- For example: - -- - -- type Foo is null record with Constructor => Bar; - -- - -- procedure Bar (Self : in out Foo); - -- - - if Present (Constructor_Name (First_Form_Type)) - and then Current_Scope = Scope (First_Form_Type) - and then Chars (Constructor_Name (First_Form_Type)) - = Chars (Designator) - and then Ekind (Designator) = E_Procedure - and then Nkind (Parent (N)) = N_Subprogram_Declaration - then - -- If the constructor list is empty than we don't have to - -- look for duplicates - we simply create the list and - -- add it. - - if No (Constructor_List (First_Form_Type)) then - Set_Constructor_List - (First_Form_Type, New_Elmt_List (Designator)); - - -- Otherwise, we need to check the constructor hasen't - -- already been added (e.g. a specification and body) and - -- that there isn't a constructor with the same number of - -- type of formals. - - -- NOTE: The Constructor_List is sorted by the number of - -- parameters. - - else - Construct := First_Elmt - (Constructor_List (First_Form_Type)); - - -- Skip over constructors with less than the number of - -- parameters than Designator ??? - - -- Loop through the constructors looking for ones which - -- "match." - - Outter : loop - - -- When we are at the end of the constructor list we - -- know there are no matches, so it is safe to add. - - if No (Construct) then - Append_Elmt - (Designator, - Constructor_List (First_Form_Type)); - exit Outter; - end if; - - -- Loop through the formals and check the formals - -- match on type ??? - - Next_Elmt (Construct); - end loop Outter; - end if; - end if; - end; - end if; - -- The subprogram scope is pushed and popped around the processing of -- the return type for consistency with call above to Process_Formals -- (which itself can call Analyze_Return_Type), and to ensure that any @@ -5511,6 +5503,12 @@ package body Sem_Ch6 is End_Scope; end if; + -- Handle subprogram specification directly referencing an attribute + + if Is_Direct_Attribute_Subp_Spec (N) then + Analyze_Direct_Attribute_Definition (Designator); + end if; + -- Function case if Nkind (N) = N_Function_Specification then @@ -5719,7 +5717,7 @@ package body Sem_Ch6 is declare D : constant Entity_Id := Directly_Designated_Type (Etype (F1)); Partial_View_Of_Desig : constant Entity_Id := - Incomplete_Or_Partial_View (D); + Incomplete_Or_Partial_View (D, Partial_Only => True); begin return No (Partial_View_Of_Desig) or else Is_Tagged_Type (Partial_View_Of_Desig) @@ -9062,6 +9060,17 @@ package body Sem_Ch6 is then Freeze_Extra_Formals (E); return; + + elsif Ekind (Ref_E) in E_Subprogram_Type + and then Is_Itype (Ref_E) + and then Nkind (Associated_Node_For_Itype (Ref_E)) in + N_Function_Specification + | N_Procedure_Specification + and then Has_Foreign_Convention + (Defining_Entity (Associated_Node_For_Itype (Ref_E))) + then + Freeze_Extra_Formals (E); + return; end if; -- If the subprogram is a predefined dispatching subprogram then don't @@ -9394,10 +9403,6 @@ package body Sem_Ch6 is (E, Standard_Integer, E, BIP_Formal_Suffix (BIP_Task_Master)); - if Needs_BIP_Task_Actuals (Ref_E) then - Set_Has_Master_Entity (E); - end if; - Discard := Add_Extra_Formal (E, RTE (RE_Activation_Chain_Access), |