diff options
Diffstat (limited to 'gcc/ada/sem_attr.adb')
| -rw-r--r-- | gcc/ada/sem_attr.adb | 146 |
1 files changed, 103 insertions, 43 deletions
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index af08fdb..bf4d684 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1462,6 +1462,13 @@ package body Sem_Attr is then null; + -- Attribute 'Old is allowed to appear in Program_Exit + + elsif Prag_Nam = Name_Program_Exit + and then Aname = Name_Old + then + null; + elsif Prag_Nam = Name_Test_Case then Check_Placement_In_Test_Case (Prag); @@ -3317,7 +3324,7 @@ package body Sem_Attr is E1 := Empty; E2 := Empty; - else + elsif Aname /= Name_Make then E1 := First (Exprs); -- Skip analysis for case of Restriction_Set, we do not expect @@ -5164,6 +5171,36 @@ package body Sem_Attr is Check_Not_Incomplete_Type; Set_Etype (N, Universal_Integer); + ---------- + -- Make -- + ---------- + + when Attribute_Make => declare + Expr : Entity_Id; + begin + -- Should this be assert? Parsing should fail if it hits 'Make + -- and all extensions aren't enabled ??? + + if not All_Extensions_Allowed then + return; + end if; + + Set_Etype (N, Etype (P)); + + if Present (Expressions (N)) then + Expr := First (Expressions (N)); + while Present (Expr) loop + if Nkind (Expr) = N_Parameter_Association then + Analyze (Explicit_Actual_Parameter (Expr)); + else + Analyze (Expr); + end if; + + Next (Expr); + end loop; + end if; + end; + -------------- -- Mantissa -- -------------- @@ -7511,13 +7548,14 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); Validate_Non_Static_Attribute_Function_Call; - if P_Type in Standard_Boolean + if Root_Type (P_Type) in Standard_Boolean | Standard_Character | Standard_Wide_Character | Standard_Wide_Wide_Character then Error_Attr_P - ("prefix of % attribute must not be a type in Standard"); + ("prefix of % attribute must not be a type originating from " & + "Standard"); end if; if Discard_Names (First_Subtype (P_Type)) then @@ -8712,6 +8750,13 @@ package body Sem_Attr is Set_Etype (N, C_Type); return; + -- Handle 'Make constructor calls + + elsif All_Extensions_Allowed + and then Id = Attribute_Make + then + P_Type := P_Entity; + -- No other cases are foldable (they certainly aren't static, and at -- the moment we don't try to fold any cases other than the ones above). @@ -8723,9 +8768,10 @@ package body Sem_Attr is -- If either attribute or the prefix is Any_Type, then propagate -- Any_Type to the result and don't do anything else at all. - if P_Type = Any_Type + if Id /= Attribute_Make + and then (P_Type = Any_Type or else (Present (E1) and then Etype (E1) = Any_Type) - or else (Present (E2) and then Etype (E2) = Any_Type) + or else (Present (E2) and then Etype (E2) = Any_Type)) then Set_Etype (N, Any_Type); return; @@ -8838,7 +8884,9 @@ package body Sem_Attr is Static := False; Set_Is_Static_Expression (N, False); - elsif Id /= Attribute_Max_Alignment_For_Allocation then + elsif Id not in Attribute_Max_Alignment_For_Allocation + | Attribute_Make + then if not Is_Constrained (P_Type) or else (Id /= Attribute_First and then Id /= Attribute_Last and then @@ -8914,53 +8962,55 @@ package body Sem_Attr is -- of the expressions to be scalar in order for the attribute to be -- considered to be static. - declare - E : Node_Id; + if Id /= Attribute_Make then + declare + E : Node_Id; - begin - E := E1; + begin + E := E1; - while Present (E) loop + while Present (E) loop - -- If expression is not static, then the attribute reference - -- result certainly cannot be static. + -- If expression is not static, then the attribute reference + -- result certainly cannot be static. - if not Is_Static_Expression (E) then - Static := False; - Set_Is_Static_Expression (N, False); - end if; + if not Is_Static_Expression (E) then + Static := False; + Set_Is_Static_Expression (N, False); + end if; - if Raises_Constraint_Error (E) then - Set_Raises_Constraint_Error (N); - end if; + if Raises_Constraint_Error (E) then + Set_Raises_Constraint_Error (N); + end if; - -- If the result is not known at compile time, or is not of - -- a scalar type, then the result is definitely not static, - -- so we can quit now. + -- If the result is not known at compile time, or is not of + -- a scalar type, then the result is definitely not static, + -- so we can quit now. - if not Compile_Time_Known_Value (E) - or else not Is_Scalar_Type (Etype (E)) - then - Check_Expressions; - return; + if not Compile_Time_Known_Value (E) + or else not Is_Scalar_Type (Etype (E)) + then + Check_Expressions; + return; - -- If the expression raises a constraint error, then so does - -- the attribute reference. We keep going in this case because - -- we are still interested in whether the attribute reference - -- is static even if it is not static. + -- If the expression raises a constraint error, then so does + -- the attribute reference. We keep going in this case because + -- we are still interested in whether the attribute reference + -- is static even if it is not static. - elsif Raises_Constraint_Error (E) then - Set_Raises_Constraint_Error (N); - end if; + elsif Raises_Constraint_Error (E) then + Set_Raises_Constraint_Error (N); + end if; - Next (E); - end loop; + Next (E); + end loop; - if Raises_Constraint_Error (Prefix (N)) then - Set_Is_Static_Expression (N, False); - return; - end if; - end; + if Raises_Constraint_Error (Prefix (N)) then + Set_Is_Static_Expression (N, False); + return; + end if; + end; + end if; -- Deal with the case of a static attribute reference that raises -- constraint error. The Raises_Constraint_Error flag will already @@ -9778,6 +9828,13 @@ package body Sem_Attr is end if; end Machine_Size; + ---------- + -- Make -- + ---------- + + when Attribute_Make => + Set_Etype (N, Etype (Prefix (N))); + -------------- -- Mantissa -- -------------- @@ -11095,7 +11152,9 @@ package body Sem_Attr is -- If this is still an attribute reference, then it has not been folded -- and that means that its expressions are in a non-static context. - elsif Nkind (N) = N_Attribute_Reference then + elsif Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) /= Name_Make + then Check_Expressions; -- Note: the else case not covered here are odd cases where the @@ -12960,6 +13019,7 @@ package body Sem_Attr is if Expander_Active and then Present (Expressions (N)) + and then Attr_Id /= Attribute_Make then declare Expr : Node_Id := First (Expressions (N)); |