2014-10-10 Robert Dewar <dewar@adacore.com>
+ * freeze.adb, sem_attr.adb: Minor reformatting.
+
+2014-10-10 Johannes Kanig <kanig@adacore.com>
+
+ * a-cfdlli.ads, a-cfhama.ads, a-cfhase.ads, a-cforma.ads,
+ a-cforse.ads, a-cofove.ads: add "Default_Initial_Condition"
+ to container type.
+
+2014-10-10 Vincent Celier <celier@adacore.com>
+
+ * prj-conf.adb (Do_Autoconf): In Codepeer mode, do not try to get
+ any configuration switches from the project file.
+
+2014-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Build_Wrapper): Renamed as Build_Operator_Wrapper.
+ (Build_Function_Wrapper): New function, to construct a wrapper
+ function for actuals that are functions with an arbitrary
+ number of parameters. Used in GNATProve mode to simplify proof
+ propagation in instantiations.
+
+2014-10-10 Robert Dewar <dewar@adacore.com>
+
* freeze.adb, gnat1drv.adb, sem_ch13.adb: Minor reformatting and
code clean up.
Iterable => (First => First,
Next => Next,
Has_Element => Has_Element,
- Element => Element);
+ Element => Element),
+ Default_Initial_Condition;
pragma Preelaborable_Initialization (List);
type Cursor is private;
Iterable => (First => First,
Next => Next,
Has_Element => Has_Element,
- Element => Element);
+ Element => Element),
+ Default_Initial_Condition;
pragma Preelaborable_Initialization (Map);
type Cursor is private;
Iterable => (First => First,
Next => Next,
Has_Element => Has_Element,
- Element => Element);
+ Element => Element),
+ Default_Initial_Condition;
pragma Preelaborable_Initialization (Set);
type Cursor is private;
Iterable => (First => First,
Next => Next,
Has_Element => Has_Element,
- Element => Element);
+ Element => Element),
+ Default_Initial_Condition;
pragma Preelaborable_Initialization (Map);
type Cursor is private;
Iterable => (First => First,
Next => Next,
Has_Element => Has_Element,
- Element => Element);
+ Element => Element),
+ Default_Initial_Condition;
pragma Preelaborable_Initialization (Set);
type Cursor is private;
Iterable => (First => First,
Next => Next,
Has_Element => Has_Element,
- Element => Element);
+ Element => Element),
+ Default_Initial_Condition;
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
-- 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.
+ -- 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
Attribute_Name => Name_Range_Length);
Analyze_And_Resolve (Ilen);
- -- No attempt is made to check number of elements
- -- if not compile time known.
+ -- No attempt is made to check number of elements if not
+ -- compile time known.
if Nkind (Ilen) /= N_Integer_Literal then
Elmts := Uint_0;
end if;
end if;
- -- If any of the index types was an enumeration type with a
- -- non-standard rep clause, then we indicate that the array type
- -- is always packed (even if it is not bit packed).
+ -- If any of the index types was an enumeration type with a non-
+ -- standard rep clause, then we indicate that the array type is
+ -- always packed (even if it is not bit packed).
if Non_Standard_Enum then
Set_Has_Non_Standard_Rep (Base_Type (Arr));
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.
+ -- 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 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 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);
then
Error_Msg_Node_1 := F_Type;
Error_Msg
- ("type& must be fully defined before this point",
- Loc);
+ ("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.
+ -- 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 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 "
+ 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))))
+ 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 "
+ 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 "
+ Error_Msg_N
+ ("?x?subprogram pointer & should "
& "have foreign convention!", Formal);
Error_Msg_Sloc := Sloc (F_Type);
Error_Msg_NE
Error_Msg_Qual_Level := 0;
end if;
- -- Check for unconstrained array in exported foreign
- -- convention case.
+ -- Check for unconstrained array in exported foreign convention
+ -- case.
if Has_Foreign_Convention (E)
and then not Is_Imported (E)
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 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);
+ Error_Msg_NE ("??in inherited operation&", Warn_Node, E);
end if;
else
Warn_Node := Formal;
end if;
-- Give warning for suspicious return of a result of an
- -- unconstrained array type in a foreign convention
- -- function.
+ -- unconstrained array type in a foreign convention function.
if Has_Foreign_Convention (E)
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.
+ -- 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.
+ -- 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.
+ -- 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)
begin
if Config_File = Empty_Node then
- -- Create a dummy config file is none was found
+ -- Create a dummy config file if none was found
Name_Len := Auto_Cgpr'Length;
Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
or else
(Tgt_Name /= No_Name
and then (Length_Of_Name (Tgt_Name) = 0
- or else Target = Get_Name_String (Tgt_Name)));
+ or else Target = Get_Name_String (Tgt_Name)));
if not OK then
if Autoconf_Specified then
declare
Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
- Config_Switches : Argument_List_Access;
+ Config_Switches : Argument_List_Access :=
+ new Argument_List'(1 .. 0 => null);
Db_Switches : Argument_List_Access;
Args : Argument_List (1 .. 5);
Arg_Last : Positive;
end case;
end if;
- -- Get the config switches. This should be done only now, as some
- -- runtimes may have been found if the Builder switches.
+ -- If not in Codepeer mode, get the config switches. This should
+ -- be done only now, as some runtimes may have been found if the
+ -- Builder switches.
- Config_Switches := Get_Config_Switches;
+ if not CodePeer_Mode then
+ Config_Switches := Get_Config_Switches;
+ end if;
-- Get eventual --db switches
Write_Eol;
elsif not Quiet_Output then
+
-- Display no message if we are creating auto.cgpr, unless in
- -- verbose mode
+ -- verbose mode.
- if Config_File_Name'Length > 0
- or else Verbose_Mode
- then
+ if Config_File_Name'Length > 0 or else Verbose_Mode then
Write_Str ("creating ");
Write_Str (Simple_Name (Args (3).all));
Write_Eol;
Config_Command : constant String :=
"--config=" & Get_Name_String (Name);
- Runtime_Name : constant String :=
- Runtime_Name_For (Name);
+ Runtime_Name : constant String := Runtime_Name_For (Name);
begin
if Variable = Nil_Variable_Value
if Is_Absolute_Path (Compiler_Command) then
Result (Count) :=
new String'
- (Config_Command & ",," & Runtime_Name & "," &
- Containing_Directory (Compiler_Command) & "," &
- Simple_Name (Compiler_Command));
+ (Config_Command & ",," & Runtime_Name & ","
+ & Containing_Directory (Compiler_Command) & ","
+ & Simple_Name (Compiler_Command));
else
Result (Count) :=
new String'
- (Config_Command & ",," & Runtime_Name & ",," &
- Compiler_Command);
+ (Config_Command & ",," & Runtime_Name & ",,"
+ & Compiler_Command);
end if;
end;
end if;
begin
Variable :=
- Value_Of
- (Name_Source_Dirs,
- Project.Decl.Attributes,
- Shared);
+ Value_Of (Name_Source_Dirs, Project.Decl.Attributes, Shared);
if Variable = Nil_Variable_Value
or else Variable.Default
or else Variable.Values /= Nil_String
then
Variable :=
- Value_Of
- (Name_Source_Files,
- Project.Decl.Attributes,
- Shared);
+ Value_Of (Name_Source_Files, Project.Decl.Attributes, Shared);
return Variable = Nil_Variable_Value
or else Variable.Default
or else Variable.Values /= Nil_String;
end if;
end Might_Have_Sources;
+ -- Local Variables
+
Success : Boolean;
Config_Project_Node : Project_Node_Id := Empty_Node;
+ -- Start of processing for Get_Or_Create_Configuration_File
+
begin
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
On_New_Tree_Loaded => null);
end if;
- if Config_Project_Node = Empty_Node
- or else Config = No_Project
- then
+ if Config_Project_Node = Empty_Node or else Config = No_Project then
Raise_Invalid_Config
("processing of configuration project """
& Config_File_Path.all & """ failed");
Implicit_Project => Implicit_Project);
if User_Project_Node = Empty_Node then
- User_Project_Node := Empty_Node;
return;
end if;
else
Assoc := First (Component_Associations (Aggr));
-
while Present (Assoc) loop
Comp := First (Choices (Assoc));
Expr := Expression (Assoc);
-- In Ada 2005, indicates partial parameterization of a formal
-- package. As usual an other association must be last in the list.
- function Build_Wrapper
+ function Build_Function_Wrapper
(Formal : Entity_Id;
Actual : Entity_Id := Empty) return Node_Id;
- -- In GNATProve mode, create a wrapper function for actuals that are
+ -- In GNATprove mode, create a wrapper function for actuals that are
+ -- functions with any number of formal parameters, in order to propagate
+ -- their contract to the renaming declarations generated for them.
+ -- If the actual is absent, the formal has a default, and the name of
+ -- the function is that of the formal.
+
+ function Build_Operator_Wrapper
+ (Formal : Entity_Id;
+ Actual : Entity_Id := Empty) return Node_Id;
+ -- In GNATprove mode, create a wrapper function for actuals that are
-- operators, in order to propagate their contract to the renaming
-- declarations generated for them. If the actual is absent, this is
-- a formal with a default, and the name of the operator is that of the
-- anonymous types, the presence a formal equality will introduce an
-- implicit declaration for the corresponding inequality.
- -------------------
- -- Build_Wrapper --
- -------------------
+ ----------------------------
+ -- Build_Function_Wrapper --
+ ----------------------------
- function Build_Wrapper
+ function Build_Function_Wrapper
+ (Formal : Entity_Id;
+ Actual : Entity_Id := Empty) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (I_Node);
+ Actuals : List_Id;
+ Decl : Node_Id;
+ Func_Name : Node_Id;
+ Func : Entity_Id;
+ N_Parms : Natural;
+ Profile : List_Id;
+ Spec : Node_Id;
+ F : Entity_Id;
+ New_F : Entity_Id;
+
+ begin
+ -- If there is no actual, the formal has a default and is retrieved
+ -- by name. Otherwise the wrapper encloses a call to the actual.
+
+ if No (Actual) then
+ Func_Name := Make_Identifier (Loc, Chars (Formal));
+ else
+ Func_Name := New_Occurrence_Of (Entity (Actual), Loc);
+ end if;
+
+ Func := Make_Defining_Identifier (Loc, Chars (Formal));
+ Set_Ekind (Func, E_Function);
+ Set_Is_Generic_Actual_Subprogram (Func);
+
+ Actuals := New_List;
+ Profile := New_List;
+
+ F := First_Formal (Formal);
+ N_Parms := 0;
+ while Present (F) loop
+
+ -- Create new formal for profile of wrapper, and add a reference
+ -- to it in the list of actuals for the enclosing call.
+
+ New_F := Make_Temporary
+ (Loc, Character'Val (Character'Pos ('A') + N_Parms));
+ Append_To (Profile,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => New_F,
+ Parameter_Type =>
+ Make_Identifier (Loc, Chars => Chars (Etype (F)))));
+
+ Append_To (Actuals, New_Occurrence_Of (New_F, Loc));
+ Next_Formal (F);
+ N_Parms := N_Parms + 1;
+ end loop;
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Func,
+ Parameter_Specifications => Profile,
+ Result_Definition =>
+ Make_Identifier (Loc, Chars (Etype (Formal))));
+ Decl :=
+ Make_Expression_Function (Loc,
+ Specification => Spec,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => Func_Name,
+ Parameter_Associations => Actuals));
+
+ return Decl;
+ end Build_Function_Wrapper;
+
+ ----------------------------
+ -- Build_Operator_Wrapper --
+ ----------------------------
+
+ function Build_Operator_Wrapper
(Formal : Entity_Id;
Actual : Entity_Id := Empty) return Node_Id
is
Func : Entity_Id;
Op_Name : Name_Id;
Spec : Node_Id;
-
- L, R : Node_Id;
+ L, R : Node_Id;
begin
if No (Actual) then
elsif Is_Binary then
if Op_Name = Name_Op_And then
- Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Or then
- Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Xor then
- Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Eq then
- Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Ne then
- Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Le then
- Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Gt then
- Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Ge then
- Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Lt then
- Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Add then
- Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Subtract then
Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Concat then
- Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Multiply then
Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Divide then
- Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Mod then
- Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Rem then
- Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Expon then
- Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R);
+ Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R);
end if;
-- Unary operators
else
if Op_Name = Name_Op_Add then
- Expr := Make_Op_Plus (Loc, Right_Opnd => L);
+ Expr := Make_Op_Plus (Loc, Right_Opnd => L);
elsif Op_Name = Name_Op_Subtract then
Expr := Make_Op_Minus (Loc, Right_Opnd => L);
elsif Op_Name = Name_Op_Abs then
- Expr := Make_Op_Abs (Loc, Right_Opnd => L);
+ Expr := Make_Op_Abs (Loc, Right_Opnd => L);
elsif Op_Name = Name_Op_Not then
- Expr := Make_Op_Not (Loc, Right_Opnd => L);
+ Expr := Make_Op_Not (Loc, Right_Opnd => L);
end if;
end if;
Expression => Expr);
return Decl;
- end Build_Wrapper;
+ end Build_Operator_Wrapper;
----------------------------------------
-- Check_Overloaded_Formal_Subprogram --
Append_To
(Assoc,
- Build_Wrapper
+ Build_Operator_Wrapper
(Defining_Entity (Analyzed_Formal), Match));
else
Append_To (Assoc,
- Instantiate_Formal_Subprogram
- (Formal, Match, Analyzed_Formal));
+ Build_Function_Wrapper
+ (Defining_Entity (Analyzed_Formal), Match));
end if;
-- Ditto if formal is an operator with a default.
N_Defining_Operator_Symbol
then
Append_To (Assoc,
- Build_Wrapper
+ Build_Operator_Wrapper
(Defining_Entity (Analyzed_Formal)));
-- Otherwise create renaming declaration.
else
Append_To (Assoc,
- Instantiate_Formal_Subprogram
- (Formal, Match, Analyzed_Formal));
+ Build_Function_Wrapper
+ (Defining_Entity (Analyzed_Formal)));
end if;
else
Loc := Sloc (Defining_Unit_Name (New_Spec));
- -- Create new entity for the actual (New_Copy_Tree does not)
+ -- Create new entity for the actual (New_Copy_Tree does not), and
+ -- indicate that it is an actual.
Set_Defining_Unit_Name
(New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
+ Set_Ekind (Defining_Unit_Name (New_Spec), Ekind (Analyzed_S));
+ Set_Is_Generic_Actual_Subprogram (Defining_Unit_Name (New_Spec));
-- Create new entities for the each of the formals in the specification
-- of the renaming declaration built for the actual.
projects / platform / upstream / gcc.git / commitdiff