diff options
Diffstat (limited to 'gcc/ada/sem_attr.adb')
| -rw-r--r-- | gcc/ada/sem_attr.adb | 57 |
1 files changed, 57 insertions, 0 deletions
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 005add8c..160a206 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -391,6 +391,9 @@ package body Sem_Attr is -- corresponding possible defined attribute function (e.g. for the -- Read attribute, Nam will be TSS_Stream_Read). + procedure Check_Put_Image_Attribute; + -- Validity checking for Put_Image attribute + procedure Check_System_Prefix; -- Verify that prefix of attribute N is package System @@ -2323,6 +2326,49 @@ package body Sem_Attr is end if; end Check_Standard_Prefix; + ------------------------------- + -- Check_Put_Image_Attribute -- + ------------------------------- + + procedure Check_Put_Image_Attribute is + begin + -- Put_Image is a procedure, and can only appear at the position of a + -- procedure call. If it's a list member and it's parent is a + -- procedure call or aggregate, then this is appearing as an actual + -- parameter or component association, which is wrong. + + if Is_List_Member (N) + and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Aggregate) + then + null; + else + Error_Attr + ("invalid context for attribute%, which is a procedure", N); + end if; + + Check_Type; + Analyze_And_Resolve (E1); + + -- Check that the first argument is + -- Ada.Strings.Text_Output.Sink'Class. + + -- Note: the double call to Root_Type here is needed because the + -- root type of a class-wide type is the corresponding type (e.g. + -- X for X'Class, and we really want to go to the root.) + + if Root_Type (Root_Type (Etype (E1))) /= RTE (RE_Sink) then + Error_Attr + ("expected Ada.Strings.Text_Output.Sink''Class", E1); + end if; + + -- Check that the second argument is of the right type + + Analyze (E2); + Resolve (E2, P_Type); + Check_Not_CPP_Type; + end Check_Put_Image_Attribute; + ---------------------------- -- Check_Stream_Attribute -- ---------------------------- @@ -5281,6 +5327,16 @@ package body Sem_Attr is Validate_Non_Static_Attribute_Function_Call; + --------------- + -- Put_Image -- + --------------- + + when Attribute_Put_Image => + Check_E2; + Check_Put_Image_Attribute; + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + ----------- -- Range -- ----------- @@ -10262,6 +10318,7 @@ package body Sem_Attr is | Attribute_Pool_Address | Attribute_Position | Attribute_Priority + | Attribute_Put_Image | Attribute_Read | Attribute_Result | Attribute_Scalar_Storage_Order |