mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-26 03:45:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-10-04  Vincent Celier  <celier@adacore.com>

	* a-direct.adb (Copy_File): Interpret the Form parameter and call
	System.OS_Lib.Copy_File to do the work accordingly. Raise Use_Error if
	the Form parameter contains an incorrect value for field preserve= or
	mode=.
	* a-direct.ads (Create_Directory, Create_Path): Indicate that the Form
	parameter is ignored.
	(Copy_File): Indicate the interpretation of the Form parameter.

2010-10-04  Vincent Celier  <celier@adacore.com>

	* make.adb (Gnatmake): When there are no foreign languages declared and
	a main in attribute Main of the main project does not exist or is a
	source of another project, fail immediately before attempting
	compilation.

2010-10-04  Javier Miranda  <miranda@adacore.com>

	* exp_disp.ads (Convert_Tag_To_Interface): New function which must be
	used to convert a node referencing a tag to a class-wide interface type.
	* exp_disp.adb (Convert_Tag_To_Interface): New function.
	(Expand_Interface_Conversion): Replace invocation of
	Unchecked_Conversion by new function Convert_Tag_To_Interface.
	(Write_DT): Add support for null primitives.
	* exp_ch3.adb (Expand_N_Object_Declaration): For tagged type objects,
	cleanup code that handles interface conversions and avoid unchecked
	conversion of referenced tag components.
	* exp_ch5.adb (Expand_N_Assignment_Statement): Code cleanup. Avoid
	unrequired conversions when generating a dispatching call to _assign.
	* sprint.adb (Write_Itype): Fix wrong output of not null access itypes.

2010-10-04  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_N_Op_Not): Handle properly both operands when the
	parent is a binary boolean operation and the operand is an unpacked
	array.
	(Build_Boolean_Array_Proc_Call): If the operands are both negations, the
	operands of the rewritten node are the operands of the negations, not
	the negations themselves.

From-SVN: r164942
This commit is contained in:
Arnaud Charlet 2010-10-04 17:07:59 +02:00
parent c452684d45
commit bed8af19ec
10 changed files with 379 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -1,3 +1,44 @@
2010-10-04 Vincent Celier <celier@adacore.com>
* a-direct.adb (Copy_File): Interpret the Form parameter and call
System.OS_Lib.Copy_File to do the work accordingly. Raise Use_Error if
the Form parameter contains an incorrect value for field preserve= or
mode=.
* a-direct.ads (Create_Directory, Create_Path): Indicate that the Form
parameter is ignored.
(Copy_File): Indicate the interpretation of the Form parameter.
2010-10-04 Vincent Celier <celier@adacore.com>
* make.adb (Gnatmake): When there are no foreign languages declared and
a main in attribute Main of the main project does not exist or is a
source of another project, fail immediately before attempting
compilation.
2010-10-04 Javier Miranda <miranda@adacore.com>
* exp_disp.ads (Convert_Tag_To_Interface): New function which must be
used to convert a node referencing a tag to a class-wide interface type.
* exp_disp.adb (Convert_Tag_To_Interface): New function.
(Expand_Interface_Conversion): Replace invocation of
Unchecked_Conversion by new function Convert_Tag_To_Interface.
(Write_DT): Add support for null primitives.
* exp_ch3.adb (Expand_N_Object_Declaration): For tagged type objects,
cleanup code that handles interface conversions and avoid unchecked
conversion of referenced tag components.
* exp_ch5.adb (Expand_N_Assignment_Statement): Code cleanup. Avoid
unrequired conversions when generating a dispatching call to _assign.
* sprint.adb (Write_Itype): Fix wrong output of not null access itypes.
2010-10-04 Ed Schonberg <schonberg@adacore.com>
* exp_ch4.adb (Expand_N_Op_Not): Handle properly both operands when the
parent is a binary boolean operation and the operand is an unpacked
array.
(Build_Boolean_Array_Proc_Call): If the operands are both negations, the
operands of the rewritten node are the operands of the negations, not
the negations themselves.
2010-10-04 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb (Set_Biased): New procedure, now used throughout, adds

73
gcc/ada/a-direct.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -42,6 +42,7 @@ with Ada.Characters.Handling; use Ada.Characters.Handling;
with System.CRTL; use System.CRTL;
with System.OS_Lib; use System.OS_Lib;
with System.Regexp; use System.Regexp;
with System.File_IO; use System.File_IO;
with System;
@ -301,9 +302,11 @@ package body Ada.Directories is
Target_Name : String;
Form : String := "")
is
pragma Unreferenced (Form);
Success : Boolean;
Mode : Copy_Mode := Overwrite;
Preserve : Attribute := None;
begin
-- First, the invalid cases
@ -322,10 +325,70 @@ package body Ada.Directories is
raise Use_Error with "target """ & Target_Name & """ is a directory";
else
-- The implementation uses System.OS_Lib.Copy_File, with parameters
-- suitable for all platforms.
if Form'Length > 0 then
declare
Formstr : String (1 .. Form'Length + 1);
V1, V2 : Natural;
Copy_File (Source_Name, Target_Name, Success, Overwrite, None);
begin
-- Acquire form string, setting required NUL terminator
Formstr (1 .. Form'Length) := Form;
Formstr (Formstr'Last) := ASCII.NUL;
-- Convert form string to lower case
for J in Formstr'Range loop
if Formstr (J) in 'A' .. 'Z' then
Formstr (J) :=
Character'Val (Character'Pos (Formstr (J)) + 32);
end if;
end loop;
-- Check Form
Form_Parameter (Formstr, "mode", V1, V2);
if V1 = 0 then
Mode := Overwrite;
elsif Formstr (V1 .. V2) = "copy" then
Mode := Copy;
elsif Formstr (V1 .. V2) = "overwrite" then
Mode := Overwrite;
elsif Formstr (V1 .. V2) = "append" then
Mode := Append;
else
raise Use_Error with "invalid Form";
end if;
Form_Parameter (Formstr, "preserve", V1, V2);
if V1 = 0 then
Preserve := None;
elsif Formstr (V1 .. V2) = "timestamps" then
Preserve := Time_Stamps;
elsif Formstr (V1 .. V2) = "all_attributes" then
Preserve := Full;
elsif Formstr (V1 .. V2) = "no_attributes" then
Preserve := None;
else
raise Use_Error with "invalid Form";
end if;
end;
end if;
-- The implementation uses System.OS_Lib.Copy_File
Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
if not Success then
raise Use_Error with "copy of """ & Source_Name & """ failed";

41
gcc/ada/a-direct.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
-- --
-- This specification is derived for use with GNAT from AI-00248, which is --
-- expected to be a part of a future expected revised Ada Reference Manual. --
@ -104,6 +104,8 @@ package Ada.Directories is
-- identification of a directory. The exception Use_Error is propagated if
-- the external environment does not support the creation of a directory
-- with the given name (in the absence of Name_Error) and form.
--
-- The Form parameter is ignored.
procedure Delete_Directory (Directory : String);
-- Deletes an existing empty directory with name Directory. The exception
@ -129,6 +131,8 @@ package Ada.Directories is
-- The exception Use_Error is propagated if the external environment does
-- not support the creation of any directories with the given name (in the
-- absence of Name_Error) and form.
--
-- The Form parameter is ignored.
procedure Delete_Tree (Directory : String);
-- Deletes an existing directory with name Directory. The directory and
@ -172,6 +176,41 @@ package Ada.Directories is
-- not support the creating of the file with the name given by Target_Name
-- and form given by Form, or copying of the file with the name given by
-- Source_Name (in the absence of Name_Error).
--
-- Interpretation of the Form parameter:
-- The Form parameter is case-insensitive.
-- Two fields are recognized in the Form parameter:
-- preserve=<value>
-- mode=<value>
-- <value> starts immediatey after the character '=' and ends with the
-- character immediatey preceding the next comma (',') or with the last
-- character of the parameter.
-- The only possible values for preserve= are:
-- no_attributes: do not try to preserve any file attributes. This is
-- the default if no preserve= is found in Form.
-- all_attributes: try to preserve all file attributes (timestamps,
-- access rights).
-- timestamps: preserve the timestamp of the copied file, but not the
-- other file attributes.
-- The only possible values for mode= are:
-- copy: only do the copy if the destination file does not already
-- exist. If it already exist, Copy_File fails.
-- overwrite: copy the file in all cases. Overwite an aready existing
-- destination file.
-- append: append the original file to the destination file. If the
-- destination file does not exist, the destination file is
-- a copy of the source file.
-- When mode=append, the field preserve=, if it exists, is not
-- taken into account.
-- If the Form parameter includes one or both of the fields and the value
-- or values are incorrect, Copy_file fails with Use_Error.
-- Examples of correct Forms:
-- Form => "preserve=no_attributes,mode=overwrite" (the default)
-- Form => "mode=append"
-- Form => "mode=copy, preserve=all_attributes"
-- Examples of incorrect Forms
-- Form => "preserve=junk"
-- Form => "mode=internal, preserve=timestamps"
----------------------------------------
-- File and directory name operations --

157
gcc/ada/exp_ch3.adb
View File

@ -4809,20 +4809,20 @@ package body Exp_Ch3 is
Iface : constant Entity_Id := Root_Type (Typ);
Expr_N : Node_Id := Expr;
Expr_Typ : Entity_Id;
Decl_1 : Node_Id;
Decl_2 : Node_Id;
New_Expr : Node_Id;
Obj_Id : Entity_Id;
Tag_Comp : Node_Id;
begin
-- If the original node of the expression was a conversion
-- to this specific class-wide interface type then we
-- restore the original node to generate code that
-- statically displaces the pointer to the interface
-- component.
-- restore the original node because we must copy the object
-- before displacing the pointer to reference the secondary
-- tag component. This code must be kept synchronized with
-- the expansion done by routine Expand_Interface_Conversion
if not Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
and then Nkind (Expr_N) = N_Explicit_Dereference
and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
and then Etype (Original_Node (Expr_N)) = Typ
then
@ -4839,6 +4839,7 @@ package body Exp_Ch3 is
Set_Expression (N, Expr_N);
end if;
Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
Expr_Typ := Base_Type (Etype (Expr_N));
if Is_Class_Wide_Type (Expr_Typ) then
@ -4849,122 +4850,114 @@ package body Exp_Ch3 is
-- CW : I'Class := Obj;
-- by
-- Tmp : T := Obj;
-- CW : I'Class renames TiC!(Tmp.I_Tag);
-- type Ityp is not null access I'Class;
-- CW : I'Class renames Ityp(Tmp.I_Tag'Address).all;
if Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Identifier
and then not Is_Interface (Expr_Typ)
and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
and then (Expr_Typ = Etype (Expr_Typ)
or else not
Is_Variable_Size_Record (Etype (Expr_Typ)))
then
Decl_1 :=
-- Copy the object
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Temporary (Loc, 'D', Expr_N),
Defining_Identifier => Obj_Id,
Object_Definition =>
New_Occurrence_Of (Expr_Typ, Loc),
Expression =>
Unchecked_Convert_To (Expr_Typ,
Relocate_Node (Expr_N)));
Relocate_Node (Expr_N)));
-- Statically reference the tag associated with the
-- interface
Decl_2 :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'D'),
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name =>
Unchecked_Convert_To (Typ,
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of
(Defining_Identifier (Decl_1), Loc),
Selector_Name =>
New_Reference_To
(Find_Interface_Tag (Expr_Typ, Iface),
Loc))));
-- General case:
Tag_Comp :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc),
Selector_Name =>
New_Reference_To
(Find_Interface_Tag (Expr_Typ, Iface), Loc));
-- Replace
-- IW : I'Class := Obj;
-- by
-- type Equiv_Record is record ... end record;
-- implicit subtype CW is <Class_Wide_Subtype>;
-- Temp : CW := CW!(Obj'Address);
-- IW : I'Class renames Displace (Temp, I'Tag);
-- Tmp : CW := CW!(Obj);
-- type Ityp is not null access I'Class;
-- IW : I'Class renames
-- Ityp!(Displace (Temp'Address, I'Tag)).all;
else
-- Generate the equivalent record type
-- Generate the equivalent record type and update
-- the subtype indication to reference it
Expand_Subtype_From_Expr
(N => N,
Unc_Type => Typ,
Subtype_Indic => Object_Definition (N),
Exp => Expression (N));
Exp => Expr_N);
if not Is_Interface (Etype (Expr_N)) then
New_Expr := Relocate_Node (Expr_N);
-- For interface types we use 'Address which displaces
-- the pointer to the base of the object (if required)
if not Is_Interface (Etype (Expression (N))) then
New_Expr := Relocate_Node (Expression (N));
else
New_Expr :=
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expression (N)),
Attribute_Name => Name_Address)));
Unchecked_Convert_To (Etype (Object_Definition (N)),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expr_N),
Attribute_Name => Name_Address))));
end if;
Decl_1 :=
-- Copy the object
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Temporary (Loc, 'D', New_Expr),
Object_Definition =>
Defining_Identifier => Obj_Id,
Object_Definition =>
New_Occurrence_Of
(Etype (Object_Definition (N)), Loc),
Expression =>
Unchecked_Convert_To
(Etype (Object_Definition (N)), New_Expr));
(Etype (Object_Definition (N)), Loc),
Expression => New_Expr));
Decl_2 :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'D'),
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name =>
Unchecked_Convert_To (Typ,
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Defining_Identifier (Decl_1), Loc),
Attribute_Name => Name_Address),
-- Dynamically reference the tag associated with the
-- interface
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table (Iface))),
Loc))))))));
Tag_Comp :=
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc),
Attribute_Name => Name_Address),
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Iface))),
Loc)));
end if;
Insert_Action (N, Decl_1);
Rewrite (N, Decl_2);
Analyze (N);
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'D'),
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name => Convert_Tag_To_Interface (Typ, Tag_Comp)));
-- Replace internal identifier of Decl_2 by the identifier
-- found in the sources. We also have to exchange entities
-- containing their defining identifiers to ensure the
-- correct replacement of the object declaration by this
-- object renaming declaration (because such definings
-- identifier have been previously added by Enter_Name to
-- the current scope). We must preserve the homonym chain
-- of the source entity as well.
Analyze (N, Suppress => All_Checks);
-- Replace internal identifier of rewriten node by the
-- identifier found in the sources. We also have to exchange
-- entities containing their defining identifiers to ensure
-- the correct replacement of the object declaration by this
-- object renaming declaration ---because these identifiers
-- were previously added by Enter_Name to the current scope.
-- We must preserve the homonym chain of the source entity
-- as well.
Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));

7
gcc/ada/exp_ch4.adb
View File

@ -255,7 +255,7 @@ package body Exp_Ch4 is
Prefix => Name (N),
Attribute_Name => Name_Address);
Arg1 : constant Node_Id := Op1;
Arg1 : Node_Id := Op1;
Arg2 : Node_Id := Op2;
Call_Node : Node_Id;
Proc_Name : Entity_Id;
@ -321,6 +321,8 @@ package body Exp_Ch4 is
-- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
if Nkind (Op1) = N_Op_Not then
Arg1 := Right_Opnd (Op1);
Arg2 := Right_Opnd (Op2);
if Kind = N_Op_And then
Proc_Name := RTE (RE_Vector_Nor);
elsif Kind = N_Op_Or then
@ -7032,6 +7034,9 @@ package body Exp_Ch4 is
if N = Op1 and then Nkind (Op2) = N_Op_Not then
return;
elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
return;
-- A xor (not B) can also be special-cased
elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then

31
gcc/ada/exp_ch5.adb
View File

@ -1976,14 +1976,29 @@ package body Exp_Ch5 is
Reason => CE_Tag_Check_Failed));
end if;
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Op, Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (F_Typ,
Duplicate_Subexpr (Lhs)),
Unchecked_Convert_To (F_Typ,
Duplicate_Subexpr (Rhs)))));
declare
Left_N : Node_Id := Duplicate_Subexpr (Lhs);
Right_N : Node_Id := Duplicate_Subexpr (Rhs);
begin
-- In order to dispatch the call to _assign the type of
-- the actuals must match. Add conversion (if required).
if Etype (Lhs) /= F_Typ then
Left_N := Unchecked_Convert_To (F_Typ, Left_N);
end if;
if Etype (Rhs) /= F_Typ then
Right_N := Unchecked_Convert_To (F_Typ, Right_N);
end if;
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Op, Loc),
Parameter_Associations => New_List (
Node1 => Left_N,
Node2 => Right_N)));
end;
end;
else

67
gcc/ada/exp_disp.adb
View File

@ -464,6 +464,57 @@ package body Exp_Disp is
end if;
end Build_Static_Dispatch_Tables;
------------------------------
-- Convert_Tag_To_Interface --
------------------------------
function Convert_Tag_To_Interface
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
Anon_Type : Entity_Id;
Result : Node_Id;
begin
pragma Assert (Is_Class_Wide_Type (Typ)
and then Is_Interface (Typ)
and then
((Nkind (Expr) = N_Selected_Component
and then Is_Tag (Entity (Selector_Name (Expr))))
or else
(Nkind (Expr) = N_Function_Call
and then RTE_Available (RE_Displace)
and then Entity (Name (Expr)) = RTE (RE_Displace))));
Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
Set_Directly_Designated_Type (Anon_Type, Typ);
Set_Etype (Anon_Type, Anon_Type);
Set_Can_Never_Be_Null (Anon_Type);
-- Decorate the size and alignment attributes of the anonymous access
-- type, as required by gigi.
Layout_Type (Anon_Type);
if Nkind (Expr) = N_Selected_Component
and then Is_Tag (Entity (Selector_Name (Expr)))
then
Result :=
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (Anon_Type,
Make_Attribute_Reference (Loc,
Prefix => Expr,
Attribute_Name => Name_Address)));
else
Result :=
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (Anon_Type, Expr));
end if;
return Result;
end Convert_Tag_To_Interface;
-------------------
-- CPP_Num_Prims --
-------------------
@ -1152,15 +1203,18 @@ package body Exp_Disp is
pragma Assert (Iface_Tag /= Empty);
-- Keep separate access types to interfaces because one internal
-- function is used to handle the null value (see following comment)
-- function is used to handle the null value (see following comments)
if not Is_Access_Type (Etype (N)) then
-- Statically displace the pointer to the object to reference
-- the component containing the secondary dispatch table.
Rewrite (N,
Unchecked_Convert_To (Etype (N),
Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expression (N)),
Selector_Name =>
New_Occurrence_Of (Iface_Tag, Loc))));
Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
else
-- Build internal function to handle the case in which the
@ -7976,6 +8030,11 @@ package body Exp_Disp is
if Present (Interface_Alias (Prim)) then
Write_Str (", AI_Alias of ");
if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
Write_Str ("null primitive ");
end if;
Write_Name
(Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
Write_Char (':');

27
gcc/ada/exp_disp.ads
View File

@ -186,6 +186,33 @@ package Exp_Disp is
-- bodies they are added to the end of the list of declarations of the
-- package body.
function Convert_Tag_To_Interface
(Typ : Entity_Id; Expr : Node_Id) return Node_Id;
pragma Inline (Convert_Tag_To_Interface);
-- This function is used in class-wide interface conversions; the expanded
-- code generated to convert a tagged object to a class-wide interface type
-- involves referencing the tag component containing the secondary dispatch
-- table associated with the interface. Given the expression Expr that
-- references a tag component, we cannot generate an unchecked conversion
-- to leave the expression decorated with the class-wide interface type Typ
-- because an unchecked conversion cannot be seen as a no-op. An unchecked
-- conversion is conceptually a function call and therefore the RM allows
-- the backend to obtain a copy of the value of the actual object and store
-- it in some other place (like a register); in such case the interface
-- conversion is not equivalent to a displacement of the pointer to the
-- interface and any further displacement fails. Although the functionality
-- of this function is simple and could be done directly, the purpose of
-- this routine is to leave well documented in the sources these
-- occurrences.
-- If Expr is an N_Selected_Component that references a tag generate:
-- type ityp is non null access Typ;
-- ityp!(Expr'Address).all
-- if Expr is an N_Function_Call to Ada.Tags.Displace then generate:
-- type ityp is non null access Typ;
-- ityp!(Expr).all
function CPP_Num_Prims (Typ : Entity_Id) return Nat;
-- Return the number of primitives of the C++ part of the dispatch table.
-- For types that are not derivations of CPP types return 0.

50
gcc/ada/make.adb
View File

@ -4468,29 +4468,41 @@ package body Make is
-- language, all the Ada mains.
while Value /= Prj.Nil_String loop
Get_Name_String
(Project_Tree.String_Elements.Table (Value).Value);
-- To know if a main is an Ada main, get its project.
-- It should be the project specified on the command
-- line.
if (not Foreign_Language) or else
Prj.Env.Project_Of
(Name_Buffer (1 .. Name_Len),
Main_Project,
Project_Tree) =
Main_Project
then
At_Least_One_Main := True;
Osint.Add_File
(Get_Name_String
(Project_Tree.String_Elements.Table
(Value).Value),
Index =>
Project_Tree.String_Elements.Table
(Value).Index);
end if;
Get_Name_String
(Project_Tree.String_Elements.Table (Value).Value);
declare
Main_Name : constant String :=
Get_Name_String
(Project_Tree.String_Elements.Table
(Value).Value);
Proj : constant Project_Id :=
Prj.Env.Project_Of
(Main_Name, Main_Project, Project_Tree);
begin
if Proj = Main_Project then
At_Least_One_Main := True;
Osint.Add_File
(Get_Name_String
(Project_Tree.String_Elements.Table
(Value).Value),
Index =>
Project_Tree.String_Elements.Table
(Value).Index);
elsif not Foreign_Language then
Make_Failed
("""" & Main_Name &
""" is not a source of project " &
Get_Name_String (Main_Project.Display_Name));
end if;
end;
Value := Project_Tree.String_Elements.Table
(Value).Next;

7
gcc/ada/sprint.adb
View File

@ -3760,12 +3760,15 @@ package body Sprint is
when Access_Kind =>
Write_Header (Ekind (Typ) = E_Access_Type);
if Can_Never_Be_Null (Typ) then
Write_Str ("not null ");
end if;
Write_Str ("access ");
if Is_Access_Constant (Typ) then
Write_Str ("constant ");
elsif Can_Never_Be_Null (Typ) then
Write_Str ("not null ");
end if;
Write_Id (Directly_Designated_Type (Typ));