diff options
Diffstat (limited to 'gcc/ada/sem_ch13.adb')
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 308 |
1 files changed, 302 insertions, 6 deletions
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bdb2b6a..bd3010c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -186,6 +186,12 @@ package body Sem_Ch13 is -- We can't allow this, otherwise we have predicate-static applying to a -- larger class than static expressions, which was never intended. + procedure New_Put_Image_Subprogram + (N : Node_Id; + Ent : Entity_Id; + Subp : Entity_Id); + -- Similar to New_Stream_Subprogram, but for the Put_Image attribute + procedure New_Stream_Subprogram (N : Node_Id; Ent : Entity_Id; @@ -2227,6 +2233,7 @@ package body Sem_Ch13 is | Aspect_Machine_Radix | Aspect_Object_Size | Aspect_Output + | Aspect_Put_Image | Aspect_Read | Aspect_Scalar_Storage_Order | Aspect_Simple_Storage_Pool @@ -4149,6 +4156,8 @@ package body Sem_Ch13 is -- Storage_Size for derived task types, but that is also clearly -- unintentional. + procedure Analyze_Put_Image_TSS_Definition; + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); -- Common processing for 'Read, 'Write, 'Input and 'Output attribute -- definition clauses. @@ -4172,6 +4181,152 @@ package body Sem_Ch13 is -- Common legality check for the previous two ----------------------------------- + -- Analyze_Put_Image_TSS_Definition -- + ----------------------------------- + + procedure Analyze_Put_Image_TSS_Definition is + Subp : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + Pnam : Entity_Id; + + function Has_Good_Profile + (Subp : Entity_Id; + Report : Boolean := False) return Boolean; + -- Return true if the entity is a subprogram with an appropriate + -- profile for the attribute being defined. If result is False and + -- Report is True, function emits appropriate error. + + ---------------------- + -- Has_Good_Profile -- + ---------------------- + + function Has_Good_Profile + (Subp : Entity_Id; + Report : Boolean := False) return Boolean + is + F : Entity_Id; + Typ : Entity_Id; + + begin + if Ekind (Subp) /= E_Procedure then + return False; + end if; + + F := First_Formal (Subp); + + if No (F) or else Etype (F) /= Class_Wide_Type (RTE (RE_Sink)) then + return False; + end if; + + Next_Formal (F); + + if Parameter_Mode (F) /= E_In_Parameter then + return False; + end if; + + Typ := Etype (F); + + -- Verify that the prefix of the attribute and the local name for + -- the type of the formal match. + + if Typ /= Ent then + return False; + end if; + + if Present (Next_Formal (F)) then + return False; + + elsif not Is_Scalar_Type (Typ) + and then not Is_First_Subtype (Typ) + then + if Report and not Is_First_Subtype (Typ) then + Error_Msg_N + ("subtype of formal in Put_Image operation must be a " + & "first subtype", Parameter_Type (Parent (F))); + end if; + + return False; + + else + return True; + end if; + end Has_Good_Profile; + + -- Start of processing for Analyze_Put_Image_TSS_Definition + + begin + if not Is_Type (U_Ent) then + Error_Msg_N ("local name must be a subtype", Nam); + return; + + elsif not Is_First_Subtype (U_Ent) then + Error_Msg_N ("local name must be a first subtype", Nam); + return; + end if; + + Pnam := TSS (Base_Type (U_Ent), TSS_Put_Image); + + -- If Pnam is present, it can be either inherited from an ancestor + -- type (in which case it is legal to redefine it for this type), or + -- be a previous definition of the attribute for the same type (in + -- which case it is illegal). + + -- In the first case, it will have been analyzed already, and we can + -- check that its profile does not match the expected profile for the + -- Put_Image attribute of U_Ent. In the second case, either Pnam has + -- been analyzed (and has the expected profile), or it has not been + -- analyzed yet (case of a type that has not been frozen yet and for + -- which Put_Image has been set using Set_TSS). + + if Present (Pnam) + and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) + then + Error_Msg_Sloc := Sloc (Pnam); + Error_Msg_Name_1 := Attr; + Error_Msg_N ("% attribute already defined #", Nam); + return; + end if; + + Analyze (Expr); + + if Is_Entity_Name (Expr) then + if not Is_Overloaded (Expr) then + if Has_Good_Profile (Entity (Expr), Report => True) then + Subp := Entity (Expr); + end if; + + else + Get_First_Interp (Expr, I, It); + while Present (It.Nam) loop + if Has_Good_Profile (It.Nam) then + Subp := It.Nam; + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + + if Present (Subp) then + if Is_Abstract_Subprogram (Subp) then + Error_Msg_N ("Put_Image subprogram must not be abstract", Expr); + return; + end if; + + Set_Entity (Expr, Subp); + Set_Etype (Expr, Etype (Subp)); + + New_Put_Image_Subprogram (N, U_Ent, Subp); + + else + Error_Msg_Name_1 := Attr; + Error_Msg_N ("incorrect expression for% attribute", Expr); + end if; + end Analyze_Put_Image_TSS_Definition; + + ----------------------------------- -- Analyze_Stream_TSS_Definition -- ----------------------------------- @@ -4891,6 +5046,7 @@ package body Sem_Ch13 is when Attribute_External_Tag | Attribute_Input | Attribute_Output + | Attribute_Put_Image | Attribute_Read | Attribute_Simple_Storage_Pool | Attribute_Storage_Pool @@ -5892,6 +6048,13 @@ package body Sem_Ch13 is ("attribute& cannot be set with definition clause", N); end if; + --------------- + -- Put_Image -- + --------------- + + when Attribute_Put_Image => + Analyze_Put_Image_TSS_Definition; + ---------- -- Read -- ---------- @@ -9299,16 +9462,16 @@ package body Sem_Ch13 is elsif A_Id = Aspect_Synchronization then return; - -- Case of stream attributes, just have to compare entities. However, - -- the expression is just a name (possibly overloaded), and there may - -- be stream operations declared for unrelated types, so we just need - -- to verify that one of these interpretations is the one available at - -- at the freeze point. + -- Case of stream attributes and Put_Image, just have to compare + -- entities. However, the expression is just a possibly-overloaded + -- name, so we need to verify that one of these interpretations is + -- the one available at at the freeze point. elsif A_Id = Aspect_Input or else A_Id = Aspect_Output or else A_Id = Aspect_Read or else - A_Id = Aspect_Write + A_Id = Aspect_Write or else + A_Id = Aspect_Put_Image then Analyze (End_Decl_Expr); Check_Overloaded_Name; @@ -9564,6 +9727,7 @@ package body Sem_Ch13 is when Aspect_Input | Aspect_Output + | Aspect_Put_Image | Aspect_Read | Aspect_Suppress | Aspect_Unsuppress @@ -12515,6 +12679,138 @@ package body Sem_Ch13 is end Minimum_Size; --------------------------- + -- New_Put_Image_Subprogram -- + --------------------------- + + procedure New_Put_Image_Subprogram + (N : Node_Id; + Ent : Entity_Id; + Subp : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Sname : constant Name_Id := + Make_TSS_Name (Base_Type (Ent), TSS_Put_Image); + Subp_Id : Entity_Id; + Subp_Decl : Node_Id; + F : Entity_Id; + Etyp : Entity_Id; + + Defer_Declaration : constant Boolean := + Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); + -- For a tagged type, there is a declaration at the freeze point, and + -- we must generate only a completion of this declaration. We do the + -- same for private types, because the full view might be tagged. + -- Otherwise we generate a declaration at the point of the attribute + -- definition clause. If the attribute definition comes from an aspect + -- specification the declaration is part of the freeze actions of the + -- type. + + function Build_Spec return Node_Id; + -- Used for declaration and renaming declaration, so that this is + -- treated as a renaming_as_body. + + ---------------- + -- Build_Spec -- + ---------------- + + function Build_Spec return Node_Id is + Formals : List_Id; + Spec : Node_Id; + T_Ref : constant Node_Id := New_Occurrence_Of (Etyp, Loc); + + begin + Subp_Id := Make_Defining_Identifier (Loc, Sname); + + -- S : Sink'Class + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_S), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (Etype (F), Loc))); + + -- V : T + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Parameter_Type => T_Ref)); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals); + + return Spec; + end Build_Spec; + + -- Start of processing for New_Put_Image_Subprogram + + begin + F := First_Formal (Subp); + + Etyp := Etype (Next_Formal (F)); + + -- Prepare subprogram declaration and insert it as an action on the + -- clause node. The visibility for this entity is used to test for + -- visibility of the attribute definition clause (in the sense of + -- 8.3(23) as amended by AI-195). + + if not Defer_Declaration then + Subp_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Build_Spec); + + -- For a tagged type, there is always a visible declaration for the + -- Put_Image TSS (it is a predefined primitive operation), and the + -- completion of this declaration occurs at the freeze point, which is + -- not always visible at places where the attribute definition clause is + -- visible. So, we create a dummy entity here for the purpose of + -- tracking the visibility of the attribute definition clause itself. + + else + Subp_Id := + Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V')); + Subp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); + end if; + + if not Defer_Declaration + and then From_Aspect_Specification (N) + and then Has_Delayed_Freeze (Ent) + then + Append_Freeze_Action (Ent, Subp_Decl); + + else + Insert_Action (N, Subp_Decl); + Set_Entity (N, Subp_Id); + end if; + + Subp_Decl := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => Build_Spec, + Name => New_Occurrence_Of (Subp, Loc)); + + if Defer_Declaration then + Set_TSS (Base_Type (Ent), Subp_Id); + + else + if From_Aspect_Specification (N) then + Append_Freeze_Action (Ent, Subp_Decl); + else + Insert_Action (N, Subp_Decl); + end if; + + Copy_TSS (Subp_Id, Base_Type (Ent)); + end if; + end New_Put_Image_Subprogram; + + --------------------------- -- New_Stream_Subprogram -- --------------------------- |