-- Create Freeze_Generic_Entity nodes for types declared in a generic
-- package. Recurse on inner generic packages.
+ function Freeze_Profile (E : Entity_Id) return Boolean;
+ -- Freeze formals and return type of subprogram.
+ -- If some type in the profile is a limited view, freezing of the entity
+ -- will take place elsewhere, and the function returns False.
+ -- This routine will be modified if and when we can implement AI05-019
+ -- efficiently.
+
procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze record type, including freezing component types, and freezing
-- primitive operations if this is a tagged type.
return Flist;
end Freeze_Generic_Entities;
+ --------------------
+ -- Freeze_Profile --
+ --------------------
+
+ function Freeze_Profile (E : Entity_Id) return Boolean is
+ F_Type : Entity_Id;
+ R_Type : Entity_Id;
+ Warn_Node : Node_Id;
+
+ begin
+ -- Loop through formals
+
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+ F_Type := Etype (Formal);
+
+ -- AI05-0151: incomplete types can appear in a profile.
+ -- By the time the entity is frozen, the full view must
+ -- be available, unless it is a limited view.
+
+ if Is_Incomplete_Type (F_Type)
+ and then Present (Full_View (F_Type))
+ and then not From_Limited_With (F_Type)
+ then
+ F_Type := Full_View (F_Type);
+ Set_Etype (Formal, F_Type);
+ end if;
+
+ Freeze_And_Append (F_Type, N, Result);
+
+ if Is_Private_Type (F_Type)
+ and then Is_Private_Type (Base_Type (F_Type))
+ and then No (Full_View (Base_Type (F_Type)))
+ and then not Is_Generic_Type (F_Type)
+ and then not Is_Derived_Type (F_Type)
+ then
+ -- If the type of a formal is incomplete, subprogram
+ -- is being frozen prematurely. Within an instance
+ -- (but not within a wrapper package) this is an
+ -- artifact of our need to regard the end of an
+ -- instantiation as a freeze point. Otherwise it is
+ -- a definite error.
+
+ if In_Instance then
+ Set_Is_Frozen (E, False);
+ Result := No_List;
+ return False;
+
+ elsif not After_Last_Declaration
+ and then not Freezing_Library_Level_Tagged_Type
+ then
+ Error_Msg_Node_1 := F_Type;
+ Error_Msg
+ ("type& must be fully defined before this point",
+ Loc);
+ end if;
+ end if;
+
+ -- Check suspicious parameter for C function. These tests
+ -- apply only to exported/imported subprograms.
+
+ if Warn_On_Export_Import
+ and then Comes_From_Source (E)
+ and then (Convention (E) = Convention_C
+ or else
+ Convention (E) = Convention_CPP)
+ and then (Is_Imported (E) or else Is_Exported (E))
+ and then Convention (E) /= Convention (Formal)
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (F_Type)
+ and then not Has_Warnings_Off (Formal)
+ then
+ -- Qualify mention of formals with subprogram name
+
+ Error_Msg_Qual_Level := 1;
+
+ -- Check suspicious use of fat C pointer
+
+ if Is_Access_Type (F_Type)
+ and then Esize (F_Type) > Ttypes.System_Address_Size
+ then
+ Error_Msg_N
+ ("?x?type of & does not correspond to C pointer!", Formal);
+
+ -- Check suspicious return of boolean
+
+ elsif Root_Type (F_Type) = Standard_Boolean
+ and then Convention (F_Type) = Convention_Ada
+ and then not Has_Warnings_Off (F_Type)
+ and then not Has_Size_Clause (F_Type)
+ and then VM_Target = No_VM
+ then
+ Error_Msg_N ("& is an 8-bit Ada Boolean?x?", Formal);
+ Error_Msg_N ("\use appropriate corresponding type in C "
+ & "(e.g. char)?x?", Formal);
+
+ -- Check suspicious tagged type
+
+ elsif (Is_Tagged_Type (F_Type)
+ or else (Is_Access_Type (F_Type)
+ and then
+ Is_Tagged_Type
+ (Designated_Type (F_Type))))
+ and then Convention (E) = Convention_C
+ then
+ Error_Msg_N ("?x?& involves a tagged type which does not "
+ & "correspond to any C type!", Formal);
+
+ -- Check wrong convention subprogram pointer
+
+ elsif Ekind (F_Type) = E_Access_Subprogram_Type
+ and then not Has_Foreign_Convention (F_Type)
+ then
+ Error_Msg_N ("?x?subprogram pointer & should "
+ & "have foreign convention!", Formal);
+ Error_Msg_Sloc := Sloc (F_Type);
+ Error_Msg_NE
+ ("\?x?add Convention pragma to declaration of &#",
+ Formal, F_Type);
+ end if;
+
+ -- Turn off name qualification after message output
+
+ Error_Msg_Qual_Level := 0;
+ end if;
+
+ -- Check for unconstrained array in exported foreign
+ -- convention case.
+
+ if Has_Foreign_Convention (E)
+ and then not Is_Imported (E)
+ and then Is_Array_Type (F_Type)
+ and then not Is_Constrained (F_Type)
+ and then Warn_On_Export_Import
+
+ -- Exclude VM case, since both .NET and JVM can handle
+ -- unconstrained arrays without a problem.
+
+ and then VM_Target = No_VM
+ then
+ Error_Msg_Qual_Level := 1;
+
+ -- If this is an inherited operation, place the
+ -- warning on the derived type declaration, rather
+ -- than on the original subprogram.
+
+ if Nkind (Original_Node (Parent (E))) = N_Full_Type_Declaration
+ then
+ Warn_Node := Parent (E);
+
+ if Formal = First_Formal (E) then
+ Error_Msg_NE
+ ("??in inherited operation&", Warn_Node, E);
+ end if;
+ else
+ Warn_Node := Formal;
+ end if;
+
+ Error_Msg_NE ("?x?type of argument& is unconstrained array",
+ Warn_Node, Formal);
+ Error_Msg_NE ("?x?foreign caller must pass bounds explicitly",
+ Warn_Node, Formal);
+ Error_Msg_Qual_Level := 0;
+ end if;
+
+ if not From_Limited_With (F_Type) then
+ if Is_Access_Type (F_Type) then
+ F_Type := Designated_Type (F_Type);
+ end if;
+
+ -- If the formal is an anonymous_access_to_subprogram
+ -- freeze the subprogram type as well, to prevent
+ -- scope anomalies in gigi, because there is no other
+ -- clear point at which it could be frozen.
+
+ if Is_Itype (Etype (Formal))
+ and then Ekind (F_Type) = E_Subprogram_Type
+ then
+ Freeze_And_Append (F_Type, N, Result);
+ end if;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- Case of function: similar checks on return type
+
+ if Ekind (E) = E_Function then
+
+ -- Check whether function is declared elsewhere.
+
+ Late_Freezing :=
+ Get_Source_Unit (E) /= Get_Source_Unit (N)
+ and then Returns_Limited_View (E)
+ and then not In_Open_Scopes (Scope (E));
+
+ -- Freeze return type
+
+ R_Type := Etype (E);
+
+ -- AI05-0151: the return type may have been incomplete
+ -- at the point of declaration. Replace it with the full
+ -- view, unless the current type is a limited view. In
+ -- that case the full view is in a different unit, and
+ -- gigi finds the non-limited view after the other unit
+ -- is elaborated.
+
+ if Ekind (R_Type) = E_Incomplete_Type
+ and then Present (Full_View (R_Type))
+ and then not From_Limited_With (R_Type)
+ then
+ R_Type := Full_View (R_Type);
+ Set_Etype (E, R_Type);
+
+ -- If the return type is a limited view and the non-
+ -- limited view is still incomplete, the function has
+ -- to be frozen at a later time.
+
+ elsif Ekind (R_Type) = E_Incomplete_Type
+ and then From_Limited_With (R_Type)
+ and then
+ Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
+ then
+ Set_Is_Frozen (E, False);
+ Set_Returns_Limited_View (E);
+ return False;
+ end if;
+
+ Freeze_And_Append (R_Type, N, Result);
+
+ -- Check suspicious return type for C function
+
+ if Warn_On_Export_Import
+ and then (Convention (E) = Convention_C
+ or else
+ Convention (E) = Convention_CPP)
+ and then (Is_Imported (E) or else Is_Exported (E))
+ then
+ -- Check suspicious return of fat C pointer
+
+ if Is_Access_Type (R_Type)
+ and then Esize (R_Type) > Ttypes.System_Address_Size
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
+ then
+ Error_Msg_N ("?x?return type of& does not "
+ & "correspond to C pointer!", E);
+
+ -- Check suspicious return of boolean
+
+ elsif Root_Type (R_Type) = Standard_Boolean
+ and then Convention (R_Type) = Convention_Ada
+ and then VM_Target = No_VM
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
+ and then not Has_Size_Clause (R_Type)
+ then
+ declare
+ N : constant Node_Id :=
+ Result_Definition (Declaration_Node (E));
+ begin
+ Error_Msg_NE
+ ("return type of & is an 8-bit Ada Boolean?x?", N, E);
+ Error_Msg_NE
+ ("\use appropriate corresponding type in C "
+ & "(e.g. char)?x?", N, E);
+ end;
+
+ -- Check suspicious return tagged type
+
+ elsif (Is_Tagged_Type (R_Type)
+ or else (Is_Access_Type (R_Type)
+ and then
+ Is_Tagged_Type
+ (Designated_Type (R_Type))))
+ and then Convention (E) = Convention_C
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
+ then
+ Error_Msg_N ("?x?return type of & does not "
+ & "correspond to C type!", E);
+
+ -- Check return of wrong convention subprogram pointer
+
+ elsif Ekind (R_Type) = E_Access_Subprogram_Type
+ and then not Has_Foreign_Convention (R_Type)
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
+ then
+ Error_Msg_N ("?x?& should return a foreign "
+ & "convention subprogram pointer", E);
+ Error_Msg_Sloc := Sloc (R_Type);
+ Error_Msg_NE
+ ("\?x?add Convention pragma to declaration of& #",
+ E, R_Type);
+ end if;
+ end if;
+
+ -- Give warning for suspicious return of a result of an
+ -- unconstrained array type in a foreign convention
+ -- function.
+
+ if Has_Foreign_Convention (E)
+
+ -- We are looking for a return of unconstrained array
+
+ and then Is_Array_Type (R_Type)
+ and then not Is_Constrained (R_Type)
+
+ -- Exclude imported routines, the warning does not
+ -- belong on the import, but rather on the routine
+ -- definition.
+
+ and then not Is_Imported (E)
+
+ -- Exclude VM case, since both .NET and JVM can handle
+ -- return of unconstrained arrays without a problem.
+
+ and then VM_Target = No_VM
+
+ -- Check that general warning is enabled, and that it
+ -- is not suppressed for this particular case.
+
+ and then Warn_On_Export_Import
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
+ then
+ Error_Msg_N ("?x?foreign convention function& should not " &
+ "return unconstrained array!", E);
+ end if;
+ end if;
+
+ return True;
+ end Freeze_Profile;
+
------------------------
-- Freeze_Record_Type --
------------------------
-- reference is not a freezing point of the profile.
-- Other constructs that should not freeze ???
- if Ada_Version > Ada_2005
- and then Nkind (N) = N_Attribute_Reference
- then
- null;
-
- elsif not Is_Internal (E) then
- declare
- F_Type : Entity_Id;
- R_Type : Entity_Id;
- Warn_Node : Node_Id;
-
- begin
- -- Loop through formals
-
- Formal := First_Formal (E);
- while Present (Formal) loop
- F_Type := Etype (Formal);
-
- -- AI05-0151: incomplete types can appear in a profile.
- -- By the time the entity is frozen, the full view must
- -- be available, unless it is a limited view.
-
- if Is_Incomplete_Type (F_Type)
- and then Present (Full_View (F_Type))
- and then not From_Limited_With (F_Type)
- then
- F_Type := Full_View (F_Type);
- Set_Etype (Formal, F_Type);
- end if;
-
- Freeze_And_Append (F_Type, N, Result);
-
- if Is_Private_Type (F_Type)
- and then Is_Private_Type (Base_Type (F_Type))
- and then No (Full_View (Base_Type (F_Type)))
- and then not Is_Generic_Type (F_Type)
- and then not Is_Derived_Type (F_Type)
- then
- -- If the type of a formal is incomplete, subprogram
- -- is being frozen prematurely. Within an instance
- -- (but not within a wrapper package) this is an
- -- artifact of our need to regard the end of an
- -- instantiation as a freeze point. Otherwise it is
- -- a definite error.
-
- if In_Instance then
- Set_Is_Frozen (E, False);
- return No_List;
-
- elsif not After_Last_Declaration
- and then not Freezing_Library_Level_Tagged_Type
- then
- Error_Msg_Node_1 := F_Type;
- Error_Msg
- ("type& must be fully defined before this point",
- Loc);
- end if;
- end if;
-
- -- Check suspicious parameter for C function. These tests
- -- apply only to exported/imported subprograms.
-
- if Warn_On_Export_Import
- and then Comes_From_Source (E)
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
- and then (Is_Imported (E) or else Is_Exported (E))
- and then Convention (E) /= Convention (Formal)
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (F_Type)
- and then not Has_Warnings_Off (Formal)
- then
- -- Qualify mention of formals with subprogram name
-
- Error_Msg_Qual_Level := 1;
-
- -- Check suspicious use of fat C pointer
-
- if Is_Access_Type (F_Type)
- and then Esize (F_Type) > Ttypes.System_Address_Size
- then
- Error_Msg_N
- ("?x?type of & does not correspond to C pointer!",
- Formal);
-
- -- Check suspicious return of boolean
-
- elsif Root_Type (F_Type) = Standard_Boolean
- and then Convention (F_Type) = Convention_Ada
- and then not Has_Warnings_Off (F_Type)
- and then not Has_Size_Clause (F_Type)
- and then VM_Target = No_VM
- then
- Error_Msg_N
- ("& is an 8-bit Ada Boolean?x?", Formal);
- Error_Msg_N
- ("\use appropriate corresponding type in C "
- & "(e.g. char)?x?", Formal);
-
- -- Check suspicious tagged type
-
- elsif (Is_Tagged_Type (F_Type)
- or else (Is_Access_Type (F_Type)
- and then
- Is_Tagged_Type
- (Designated_Type (F_Type))))
- and then Convention (E) = Convention_C
- then
- Error_Msg_N
- ("?x?& involves a tagged type which does not "
- & "correspond to any C type!", Formal);
-
- -- Check wrong convention subprogram pointer
-
- elsif Ekind (F_Type) = E_Access_Subprogram_Type
- and then not Has_Foreign_Convention (F_Type)
- then
- Error_Msg_N
- ("?x?subprogram pointer & should "
- & "have foreign convention!", Formal);
- Error_Msg_Sloc := Sloc (F_Type);
- Error_Msg_NE
- ("\?x?add Convention pragma to declaration of &#",
- Formal, F_Type);
- end if;
-
- -- Turn off name qualification after message output
-
- Error_Msg_Qual_Level := 0;
- end if;
+ -- This processing doesn't apply to internal entities (see below)
- -- Check for unconstrained array in exported foreign
- -- convention case.
-
- if Has_Foreign_Convention (E)
- and then not Is_Imported (E)
- and then Is_Array_Type (F_Type)
- and then not Is_Constrained (F_Type)
- and then Warn_On_Export_Import
-
- -- Exclude VM case, since both .NET and JVM can handle
- -- unconstrained arrays without a problem.
-
- and then VM_Target = No_VM
- then
- Error_Msg_Qual_Level := 1;
-
- -- If this is an inherited operation, place the
- -- warning on the derived type declaration, rather
- -- than on the original subprogram.
-
- if Nkind (Original_Node (Parent (E))) =
- N_Full_Type_Declaration
- then
- Warn_Node := Parent (E);
-
- if Formal = First_Formal (E) then
- Error_Msg_NE
- ("??in inherited operation&", Warn_Node, E);
- end if;
- else
- Warn_Node := Formal;
- end if;
-
- Error_Msg_NE
- ("?x?type of argument& is unconstrained array",
- Warn_Node, Formal);
- Error_Msg_NE
- ("?x?foreign caller must pass bounds explicitly",
- Warn_Node, Formal);
- Error_Msg_Qual_Level := 0;
- end if;
-
- if not From_Limited_With (F_Type) then
- if Is_Access_Type (F_Type) then
- F_Type := Designated_Type (F_Type);
- end if;
-
- -- If the formal is an anonymous_access_to_subprogram
- -- freeze the subprogram type as well, to prevent
- -- scope anomalies in gigi, because there is no other
- -- clear point at which it could be frozen.
-
- if Is_Itype (Etype (Formal))
- and then Ekind (F_Type) = E_Subprogram_Type
- then
- Freeze_And_Append (F_Type, N, Result);
- end if;
- end if;
-
- Next_Formal (Formal);
- end loop;
-
- -- Case of function: similar checks on return type
-
- if Ekind (E) = E_Function then
-
- -- Check whether function is declared elsewhere.
-
- Late_Freezing :=
- Get_Source_Unit (E) /= Get_Source_Unit (N)
- and then Returns_Limited_View (E)
- and then not In_Open_Scopes (Scope (E));
-
- -- Freeze return type
-
- R_Type := Etype (E);
-
- -- AI05-0151: the return type may have been incomplete
- -- at the point of declaration. Replace it with the full
- -- view, unless the current type is a limited view. In
- -- that case the full view is in a different unit, and
- -- gigi finds the non-limited view after the other unit
- -- is elaborated.
-
- if Ekind (R_Type) = E_Incomplete_Type
- and then Present (Full_View (R_Type))
- and then not From_Limited_With (R_Type)
- then
- R_Type := Full_View (R_Type);
- Set_Etype (E, R_Type);
-
- -- If the return type is a limited view and the non-
- -- limited view is still incomplete, the function has
- -- to be frozen at a later time.
-
- elsif Ekind (R_Type) = E_Incomplete_Type
- and then From_Limited_With (R_Type)
- and then
- Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
- then
- Set_Is_Frozen (E, False);
- Set_Returns_Limited_View (E);
- return Result;
- end if;
-
- Freeze_And_Append (R_Type, N, Result);
-
- -- Check suspicious return type for C function
-
- if Warn_On_Export_Import
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
- and then (Is_Imported (E) or else Is_Exported (E))
- then
- -- Check suspicious return of fat C pointer
-
- if Is_Access_Type (R_Type)
- and then Esize (R_Type) > Ttypes.System_Address_Size
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (R_Type)
- then
- Error_Msg_N
- ("?x?return type of& does not "
- & "correspond to C pointer!", E);
-
- -- Check suspicious return of boolean
-
- elsif Root_Type (R_Type) = Standard_Boolean
- and then Convention (R_Type) = Convention_Ada
- and then VM_Target = No_VM
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (R_Type)
- and then not Has_Size_Clause (R_Type)
- then
- declare
- N : constant Node_Id :=
- Result_Definition (Declaration_Node (E));
- begin
- Error_Msg_NE
- ("return type of & is an 8-bit Ada Boolean?x?",
- N, E);
- Error_Msg_NE
- ("\use appropriate corresponding type in C "
- & "(e.g. char)?x?", N, E);
- end;
-
- -- Check suspicious return tagged type
-
- elsif (Is_Tagged_Type (R_Type)
- or else (Is_Access_Type (R_Type)
- and then
- Is_Tagged_Type
- (Designated_Type (R_Type))))
- and then Convention (E) = Convention_C
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (R_Type)
- then
- Error_Msg_N
- ("?x?return type of & does not "
- & "correspond to C type!", E);
-
- -- Check return of wrong convention subprogram pointer
-
- elsif Ekind (R_Type) = E_Access_Subprogram_Type
- and then not Has_Foreign_Convention (R_Type)
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (R_Type)
- then
- Error_Msg_N
- ("?x?& should return a foreign "
- & "convention subprogram pointer", E);
- Error_Msg_Sloc := Sloc (R_Type);
- Error_Msg_NE
- ("\?x?add Convention pragma to declaration of& #",
- E, R_Type);
- end if;
- end if;
-
- -- Give warning for suspicious return of a result of an
- -- unconstrained array type in a foreign convention
- -- function.
-
- if Has_Foreign_Convention (E)
-
- -- We are looking for a return of unconstrained array
-
- and then Is_Array_Type (R_Type)
- and then not Is_Constrained (R_Type)
-
- -- Exclude imported routines, the warning does not
- -- belong on the import, but rather on the routine
- -- definition.
-
- and then not Is_Imported (E)
-
- -- Exclude VM case, since both .NET and JVM can handle
- -- return of unconstrained arrays without a problem.
-
- and then VM_Target = No_VM
-
- -- Check that general warning is enabled, and that it
- -- is not suppressed for this particular case.
-
- and then Warn_On_Export_Import
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (R_Type)
- then
- Error_Msg_N
- ("?x?foreign convention function& should not " &
- "return unconstrained array!", E);
- end if;
- end if;
- end;
+ if not Is_Internal (E) then
+ if not Freeze_Profile (E) then
+ return Result;
+ end if;
end if;
-- Must freeze its parent first if it is a derived subprogram
projects / platform / upstream / gcc.git / commitdiff