+2011-08-02 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch3.adb, sem_ch5.adb, sem_type.adb, switch-c.adb, switch-c.ads,
+ sem_prag.adb, sem_util.adb, sem_util.ads, sem_res.adb, warnsw.ads,
+ prepcomp.ads, cstand.adb, stand.ads, a-calfor.adb, s-stusta.adb:
+ Minor reformatting.
+
+2011-08-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb: handle properly 'Result when it is a prefix of an
+ indexed component.
+
+2011-08-02 Javier Miranda <miranda@adacore.com>
+
+ * einfo.ads, einfo.adb
+ (Original_Access_Type): Move this attribute to Node26 since there was
+ an undocumented use of Node21 in E_Access_Subprogram_Type entities
+ which causes conflicts and breaks the generation of the .NET compiler.
+ (Interface_Name): Add missing documentation on JGNAT only uses of
+ this attribute.
+
2011-08-02 Javier Miranda <miranda@adacore.com>
* exp_pakd.adb (Expand_Packed_Element_Reference): Disable this routine
Include_Time_Fraction : Boolean := False;
Time_Zone : Time_Zones.Time_Offset := 0) return String
is
- To_Char : constant array (0 .. 9) of Character := "0123456789";
+ To_Char : constant array (0 .. 9) of Character := "0123456789";
Year : Year_Number;
Month : Month_Number;
-- The result length depends on whether fractions are requested.
Result : String := "0000-00-00 00:00:00.00";
- Last : constant Positive
- := Result'Last - (if Include_Time_Fraction then 0 else 3);
+ Last : constant Positive :=
+ Result'Last - (if Include_Time_Fraction then 0 else 3);
begin
Split (Date, Year, Month, Day,
begin
-- Validity checks
- if not Hour'Valid
+ if not Hour'Valid
or else not Minute'Valid
or else not Second'Valid
or else not Sub_Second'Valid
Set_Size_Known_At_Compile_Time (E);
end Build_Float_Type;
- ------------------------
+ ------------------------------
-- Find_Back_End_Float_Type --
- ------------------------
+ ------------------------------
function Find_Back_End_Float_Type (Name : String) return Entity_Id is
- N : Elmt_Id := First_Elmt (Back_End_Float_Types);
+ N : Elmt_Id;
begin
+ N := First_Elmt (Back_End_Float_Types);
while Present (N) and then Get_Name_String (Chars (Node (N))) /= Name
loop
Next_Elmt (N);
-- Default_Expr_Function Node21
-- Discriminant_Constraint Elist21
-- Interface_Name Node21
- -- Original_Access_Type Node21
-- Original_Array_Type Node21
-- Small_Value Ureal21
-- Dispatch_Table_Wrappers Elist26
-- Last_Assignment Node26
+ -- Original_Access_Type Node26
-- Overridden_Operation Node26
-- Package_Instantiation Node26
-- Relative_Deadline_Variable Node26
function Original_Access_Type (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
- return Node21 (Id);
+ return Node26 (Id);
end Original_Access_Type;
function Original_Array_Type (Id : E) return E is
procedure Set_Original_Access_Type (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
- Set_Node21 (Id, V);
+ Set_Node26 (Id, V);
end Set_Original_Access_Type;
procedure Set_Original_Array_Type (Id : E; V : E) is
when Fixed_Point_Kind =>
Write_Str ("Small_Value");
- when E_Access_Subprogram_Type =>
- Write_Str ("Original_Access_Type");
-
when E_In_Parameter =>
Write_Str ("Default_Expr_Function");
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Access_Subprogram_Type =>
+ Write_Str ("Original_Access_Type");
+
when E_Generic_Package |
E_Package =>
Write_Str ("Package_Instantiation");
-- instantiations.
-- Interface_Name (Node21)
--- Present in exceptions, functions, procedures, variables, constants,
--- and packages. Set to Empty unless an export, import, or interface
--- name pragma has explicitly specified an external name, in which
--- case it references an N_String_Literal node for the specified
--- external name. In the case of exceptions, the field is set by
--- Import_Exception/Export_Exception (which can be used in OpenVMS
+-- Present in constants, variables, exceptions, functions, procedures,
+-- packages, components (JGNAT only), discriminants (JGNAT only), and
+-- access to subprograms (JGNAT only). Set to Empty unless an export,
+-- import, or interface name pragma has explicitly specified an external
+-- name, in which case it references an N_String_Literal node for the
+-- specified external name. In the case of exceptions, the field is set
+-- by Import_Exception/Export_Exception (which can be used in OpenVMS
-- versions only). Note that if this field is Empty, and Is_Imported
-- or Is_Exported is set, then the default interface name is the name
-- of the entity, cased in a manner that is appropriate to the system
-- Optimize_Alignment (Off) mode applies to the type/object, then neither
-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
--- Original_Access_Type (Node21)
+-- Original_Access_Type (Node26)
-- Present in E_Access_Subprogram_Type entities. Set only if the access
-- type was generated by the expander as part of processing an access
-- to protected subprogram type. Points to the access to protected
-- E_Access_Subprogram_Type
-- Equivalent_Type (Node18) (remote types only)
-- Directly_Designated_Type (Node20)
- -- Original_Access_Type (Node21)
+ -- Interface_Name (Node21) (JGNAT usage only)
-- Needs_No_Actuals (Flag22)
+ -- Original_Access_Type (Node26)
-- Can_Use_Internal_Rep (Flag229)
-- (plus type attributes)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19) (constants only)
-- Prival_Link (Node20) (privals only)
- -- Interface_Name (Node21)
+ -- Interface_Name (Node21) (constants only)
-- Related_Type (Node27) (constants only)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
package Prepcomp is
procedure Add_Dependencies;
- -- Add dependencies on the preprocessing data file and the
- -- preprocessing definition files, if any.
+ -- Add dependencies on the preprocessing data file and the preprocessing
+ -- definition files, if any.
procedure Check_Symbols;
- -- Check if there are preprocessing symbols on the command line and
- -- set preprocessing if there are some: all files are preprocessed with
- -- these symbols. This procedure should not be called if there is a
- -- preprocessing data file specified on the command line. Procedure
- -- Parse_Preprocessing_Data_File should be called instead.
+ -- Check if there are preprocessing symbols on the command line and set
+ -- preprocessing if there are some: all files are preprocessed with these
+ -- symbols. This procedure should not be called if there is a preprocessing
+ -- data file specified on the command line. Instead a call should be made
+ -- to Parse_Preprocessing_Data_File.
procedure Parse_Preprocessing_Data_File (N : File_Name_Type);
-- Parse a preprocessing data file, specified with a -gnatep= switch
procedure Prepare_To_Preprocess
(Source : File_Name_Type;
Preprocessing_Needed : out Boolean);
- -- Prepare, if necessary, the preprocessor for a source file.
- -- If the source file needs to be preprocessed, Preprocessing_Needed
- -- is set to True. Otherwise, Preprocessing_Needed is set to False
- -- and no preprocessing needs to be done.
+ -- Prepare, if necessary, the preprocessor for a source file. If the source
+ -- file needs to be preprocessed, Preprocessing_Needed is set to True.
+ -- Otherwise, Preprocessing_Needed is set to False and no preprocessing
+ -- needs to be done.
procedure Process_Command_Line_Symbol_Definitions;
-- Check symbol definitions that have been added by calls to procedure
procedure Print (Obj : Stack_Usage_Result) is
Pos : Positive := Obj.Task_Name'Last;
- begin
+ begin
-- Simply trim the string containing the task name
for S in Obj.Task_Name'Range loop
end loop;
declare
- T_Name : constant String := Obj.Task_Name
- (Obj.Task_Name'First .. Pos);
+ T_Name : constant String :=
+ Obj.Task_Name (Obj.Task_Name'First .. Pos);
begin
Put_Line
("| " & T_Name & " | " & Natural'Image (Obj.Max_Size) &
Error_Attr;
end if;
+ -- The attribute reference is a primary. If expressions follow,
+ -- the attribute reference is really an indexable object, so
+ -- rewrite and analyze as an indexed component.
+
+ if Present (E1) then
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Prefix (N)),
+ Attribute_Name => Name_Result),
+ Expressions => Expressions (N)));
+ Analyze (N);
+ return;
+ end if;
+
Set_Etype (N, Etype (CS));
-- If several functions with that name are visible,
declare
Max_Base_Digits : constant Uint :=
- Expr_Value (Expression (Parent (RTE (RE_Max_Base_Digits))));
+ Expr_Value
+ (Expression
+ (Parent (RTE (RE_Max_Base_Digits))));
+
begin
if Digs_Val > Max_Base_Digits then
Error_Msg_Uint_1 := Max_Base_Digits;
Is_Constrained (Priv_Parent)
or else
Nkind (Priv_Indic) = N_Subtype_Indication
- or else
- Is_Constrained (Entity (Priv_Indic));
+ or else
+ Is_Constrained (Entity (Priv_Indic));
Full_Constr : constant Boolean :=
Is_Constrained (Full_Parent)
or else
Nkind (Full_Indic) = N_Subtype_Indication
- or else
- Is_Constrained (Entity (Full_Indic));
+ or else
+ Is_Constrained (Entity (Full_Indic));
Priv_Discr : Entity_Id;
Full_Discr : Entity_Id;
Full_Discr := First_Discriminant (Full_Parent);
while Present (Priv_Discr) and then Present (Full_Discr) loop
if Original_Record_Component (Priv_Discr) =
- Original_Record_Component (Full_Discr)
+ Original_Record_Component (Full_Discr)
or else
Corresponding_Discriminant (Priv_Discr) =
Corresponding_Discriminant (Full_Discr)
return;
end;
- else
-
- -- Domain of iteration is not a function call, and is
- -- side-effect free.
+ -- Domain of iteration is not a function call, and is
+ -- side-effect free.
+ else
Analyze (DS);
end if;
end if;
then
declare
Id : constant Entity_Id := Make_Temporary (Loc, 'R', Container);
+
Decl : Node_Id;
Assign : Node_Id;
Assign :=
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Id, Loc),
- Expression => Relocate_Node (Container));
+ Name => New_Occurrence_Of (Id, Loc),
+ Expression => Relocate_Node (Container));
Insert_Actions (Parent (N), New_List (Decl, Assign));
end;
procedure Process_Import_Predefined_Type is
Loc : constant Source_Ptr := Sloc (N);
- Elmt : Elmt_Id := First_Elmt (Predefined_Float_Types);
+ Elmt : Elmt_Id;
Ftyp : Node_Id := Empty;
Decl : Node_Id;
Def : Node_Id;
Nam : Name_Id;
+
begin
String_To_Name_Buffer (Strval (Expression (Arg3)));
Nam := Name_Find;
+ Elmt := First_Elmt (Predefined_Float_Types);
while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
Next_Elmt (Elmt);
end loop;
Ftyp := Node (Elmt);
if Present (Ftyp) then
+
-- Don't build a derived type declaration, because predefined C
-- types have no declaration anywhere, so cannot really be named.
-- Instead build a full type declaration, starting with an
Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
+ -- Should never have a predefined type we cannot handle
+
else
- -- Should never have a predefined type we cannot handle
raise Program_Error;
end if;
-- Commented out as the call to Is_Inherited_Operation_For_Type may
-- cause an error because the type entity of the parent node of
- -- Entity (Name (N) may not be set.
+ -- Entity (Name (N) may not be set. ???
+ -- So why not just add a guard ???
-- if Nkind (N) = N_Function_Call
-- and then Is_Tagged_Type (Etype (N))
-- and then Is_Entity_Name (Name (N))
-- and then Is_Inherited_Operation_For_Type
--- (Entity (Name (N)), Etype (N))
+-- (Entity (Name (N)), Etype (N))
-- then
-- Check_Formal_Restriction ("function not inherited", N);
-- end if;
and then Is_Interface (Etype (T1))
and then Is_Concurrent_Type (T2)
and then Interface_Present_In_Ancestor
- (Typ => BT2,
- Iface => Etype (T1))
+ (Typ => BT2, Iface => Etype (T1))
then
return True;
-- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
- -- object T2 implementing T1
+ -- object T2 implementing T1.
elsif Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (T1)
-------------------------------------
function Is_Inherited_Operation_For_Type
- (E, Typ : Entity_Id) return Boolean
+ (E : Entity_Id; Typ : Entity_Id) return Boolean
is
begin
return Is_Inherited_Operation (E)
----------------------------------
function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
- Is_Ok : Boolean;
+ Is_Ok : Boolean;
+ Expr : Node_Id;
+ Comp_Assn : Node_Id;
+ Choice : Node_Id;
- Expr, Comp_Assn, Choice : Node_Id;
begin
Is_Ok := True;
Is_Ok := False;
end case;
- <<Done>>
+ <<Done>>
return Is_Ok;
end Is_SPARK_Initialization_Expr;
-- if it is False (i.e. zero).
function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean;
- -- Returns True iff the number U is a model number of the fixed-
- -- point type T, i.e. if it is an exact multiple of Small.
+ -- Returns True iff the number U is a model number of the fixed-point type
+ -- T, i.e. if it is an exact multiple of Small.
function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean;
-- Typ is a type entity. This function returns true if this type is fully
-- by a derived type declaration.
function Is_Inherited_Operation_For_Type
- (E, Typ : Entity_Id) return Boolean;
+ (E : Entity_Id; Typ : Entity_Id) return Boolean;
-- E is a subprogram. Return True is E is an implicit operation inherited
-- by the derived type declaration for type Typ.
type Standard_Entity_Array_Type is array (Standard_Entity_Type) of Node_Id;
Standard_Entity : Standard_Entity_Array_Type;
- -- This array contains pointers to the Defining Identifier nodes for
- -- each of the visible entities defined in Standard_Entities_Type. It is
+ -- This array contains pointers to the Defining Identifier nodes for each
+ -- of the visible entities defined in Standard_Entities_Type. The array is
-- initialized by the Create_Standard procedure.
Standard_Package_Node : Node_Id;
-- carrying the enumeration literal names.
Standard_A_Char : Entity_Id;
- -- Access to character, used as a component of the exception type to
- -- denote a thin pointer component.
+ -- Access to character, used as a component of the exception type to denote
+ -- a thin pointer component.
Standard_Debug_Renaming_Type : Entity_Id;
- -- A zero-size subtype of Integer, used as the type of variables used
- -- to provide the debugger with name encodings for renaming declarations.
+ -- A zero-size subtype of Integer, used as the type of variables used to
+ -- provide the debugger with name encodings for renaming declarations.
Predefined_Float_Types : Elist_Id;
-- Entities for predefined floating point types. These are used by
-- Used to represent some unknown integer type
Any_Modular : Entity_Id;
- -- Used to represent the result type of a boolean operation on an
- -- integer literal. The result is not Universal_Integer, because it is
- -- only legal in a modular context.
+ -- Used to represent the result type of a boolean operation on an integer
+ -- literal. The result is not Universal_Integer, because it is only legal
+ -- in a modular context.
Any_Numeric : Entity_Id;
-- Used to represent some unknown numeric type
-- Used to represent some unknown scalar type
Any_String : Entity_Id;
- -- The type Any_String is used for string literals before type
- -- resolution. It corresponds to array (Positive range <>) of character
- -- where the component type is compatible with any character type,
- -- not just Standard_Character.
+ -- The type Any_String is used for string literals before type resolution.
+ -- It corresponds to array (Positive range <>) of character where the
+ -- component type is compatible with any character type, not just
+ -- Standard_Character.
Universal_Integer : Entity_Id;
-- Entity for universal integer type. The bounds of this type correspond
Standard_Integer_16 : Entity_Id;
Standard_Integer_32 : Entity_Id;
Standard_Integer_64 : Entity_Id;
- -- These are signed integer types with the indicated sizes, They are
- -- used for the underlying implementation types for fixed-point and
- -- enumeration types.
+ -- These are signed integer types with the indicated sizes, They are used
+ -- for the underlying implementation types for fixed-point and enumeration
+ -- types.
Standard_Unsigned : Entity_Id;
-- An unsigned type of the same size as Standard_Integer
-- initialization that is carried out by Create_Standard.
procedure Tree_Write;
- -- Writes out the entity values in this package to the current
- -- tree file using Osint.Tree_Write.
+ -- Writes out the entity values in this package to the current tree file
+ -- using Osint.Tree_Write.
end Stand;
end if;
Preprocessing_Symbol_Last := Preprocessing_Symbol_Last + 1;
- Preprocessing_Symbol_Defs (Preprocessing_Symbol_Last)
- := new String'(Def);
+ Preprocessing_Symbol_Defs (Preprocessing_Symbol_Last) :=
+ new String'(Def);
end Add_Symbol_Definition;
-----------------------------
------------------------------------------------------------------------------
-- This package scans front end switches. Note that the body of Usage must be
--- coordinated with the switches that are recognized by this package.
--- The Usage package also acts as the official documentation for the
--- switches that are recognized. In addition, package Debug documents
--- the otherwise undocumented debug switches that are also recognized.
+-- be coordinated with the switches that are recognized by this package.
+
+-- The Usage package also acts as the official documentation for the switches
+-- that are recognized. In addition, package Debug documents the otherwise
+-- undocumented debug switches that are also recognized.
with System.Strings; use System.Strings;
-- --
------------------------------------------------------------------------------
--- This unit contains the routines used to handle setting of warning options.
+-- This unit contains the routines used to handle setting of warning options
package Warnsw is
projects / gcc.git / commitdiff