+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * debug.adb: Document that d7 suppresses compilation time output.
+ * errout.adb (Write_Header): Include compilation time in
+ header output.
+ * exp_intr.adb (Expand_Intrinsic_Call): Add
+ Compilation_Date/Compilation_Time (Expand_Source_Info): Expand
+ Compilation_Date/Compilation_Time.
+ * g-souinf.ads (Compilation_Date): New function
+ (Compilation_Time): New function.
+ * gnat1drv.adb (Gnat1drv): Set Opt.Compilation_Time.
+ * gnat_rm.texi (Compilation_Date): New function
+ (Compilation_Time): New function.
+ * opt.ads (Compilation_Time): New variable.
+ * s-os_lib.ads, s-os_lib.adb (Current_Time_String): New function.
+ * sem_intr.adb (Compilation_Date): New function.
+ (Compilation_Time): New function.
+ * snames.ads-tmpl (Name_Compilation_Date): New entry.
+ (Name_Compilation_Time): New entry.
+
+2014-07-30 Yannick Moy <moy@adacore.com>
+
+ * inline.adb: Add comment.
+
+2014-07-30 Ed Schonberg <schonberg@adacore.com>
+
+ * par-ch4.adb (Is_Parameterless_Attribute): 'Result is a
+ parameterless attribute, and a postondition can mention an
+ indexed component or a slice whose prefix is an attribute
+ reference F'Result.
+
+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * sprint.adb (Sprint_Node_Actual, case Object_Declaration):
+ Avoid bomb when printing package Standard.
+
+2014-07-30 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_elab.adb (Check_Internal_Call_Continue): If an elaboration
+ entity is created at this point, ensure that the name of the
+ flag is unique, because the subprogram may be overloaded and
+ other homonyms may also have elaboration flags created on the fly.
+
+2014-07-30 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_attr.adb (Analyze_Array_Component_Update): New routine.
+ (Analyze_Attribute): Major cleanup of attribute
+ 'Update. The logic is now split into two distinct routines
+ depending on the type of the prefix. The use of <> is now illegal
+ in attribute 'Update.
+ (Analyze_Record_Component_Update): New routine.
+ (Check_Component_Reference): Removed.
+ (Resolve_Attribute): Remove the return statement and ??? comment
+ following the processing for attribute 'Update. As a result,
+ the attribute now freezes its prefix.
+
+2014-07-30 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch4.adb (Apply_Accessibility_Check): Do
+ not call Base_Address() in VM targets.
+
2014-07-30 Yannick Moy <moy@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Set
-- d4 Inhibit automatic krunch of predefined library unit files
-- d5 Debug output for tree read/write
-- d6 Default access unconstrained to thin pointers
- -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode
+ -- d7 Suppress version/source stamp/compilation time for -gnatv/-gnatl
-- d8 Force opposite endianness in packed stuff
-- d9 Allow lock free implementation
-- implications of using thin pointers, and also to test that the
-- compiler functions correctly with this choice.
- -- d7 Normally a -gnatl or -gnatv listing includes the time stamp
- -- of the source file. This debug flag suppresses this output,
- -- and also suppresses the message with the version number.
- -- This is useful in certain regression tests.
+ -- d7 Normally a -gnatl or -gnatv listing includes the time stamp of the
+ -- source file and the time of the compilation. This debug flag can
+ -- be used to suppress this output, and also suppresses the message
+ -- with the version of the compiler. This is useful for regression
+ -- tests which need to have consistent output.
-- d8 This forces the packed stuff to generate code assuming the
-- opposite endianness from the actual correct value. Useful in
Write_Name (Full_File_Name (Sfile));
if not Debug_Flag_7 then
- Write_Str (" (source file time stamp: ");
+ Write_Eol;
+ Write_Str ("Source file time stamp: ");
Write_Time_Stamp (Sfile);
- Write_Char (')');
+ Write_Eol;
+ Write_Str ("Compiled at: " & Compilation_Time);
end if;
Write_Eol;
-- and also generates code invoking Free, which requires also a
-- reference to the base of the unallocated object.
- if Is_Interface (DesigT) then
+ if Is_Interface (DesigT) and then Tagged_Type_Expansion then
Obj_Ref :=
Unchecked_Convert_To (Etype (Obj_Ref),
Make_Function_Call (Loc,
if Needs_Finalization (DesigT) then
Fin_Call :=
- Make_Final_Call (
- Obj_Ref =>
- Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
- Typ => DesigT);
+ Make_Final_Call
+ (Obj_Ref =>
+ Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
+ Typ => DesigT);
-- When the target or profile supports deallocation, wrap the
-- finalization call in a block to ensure proper deallocation
and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
- Make_Attach_Call (
- Obj_Ref => New_Occurrence_Of (Temp, Loc),
- Ptr_Typ => PtrT));
+ Make_Attach_Call
+ (Obj_Ref => New_Occurrence_Of (Temp, Loc),
+ Ptr_Typ => PtrT));
end if;
else
and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
- Make_Attach_Call (
- Obj_Ref =>
- New_Occurrence_Of (Temp, Loc),
- Ptr_Typ => PtrT));
+ Make_Attach_Call
+ (Obj_Ref => New_Occurrence_Of (Temp, Loc),
+ Ptr_Typ => PtrT));
end if;
end if;
New_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Def_Id,
- Type_Definition =>
+ Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
begin
Tag_Assign :=
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix => TagR,
+ Prefix => TagR,
Selector_Name =>
New_Occurrence_Of
(First_Tag_Component (Full_T), Loc)),
then
-- Apply constraint to designated subtype indication
- Apply_Constraint_Check (Expression (Exp),
- Designated_Type (DesigT),
- No_Sliding => True);
+ Apply_Constraint_Check
+ (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
begin
return
Make_Attribute_Reference (Loc,
- Attribute_Name => Nam,
- Prefix => New_Occurrence_Of (Arr, Loc),
- Expressions => New_List (Make_Integer_Literal (Loc, Num)));
+ Attribute_Name => Nam,
+ Prefix => New_Occurrence_Of (Arr, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, Num)));
end Arr_Attr;
------------------------
else
return
Make_Implicit_If_Statement (Nod,
- Condition => Make_Op_Not (Loc, Right_Opnd => Test),
+ Condition => Make_Op_Not (Loc, Right_Opnd => Test),
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd => New_Occurrence_Of (An, Loc),
+ Left_Opnd => New_Occurrence_Of (An, Loc),
Right_Opnd => Arr_Attr (A, Name_Last, N))));
Append_To (Stm_List,
Statements => New_List (
Make_Implicit_If_Statement (Nod,
- Condition => Test_Empty_Arrays,
+ Condition => Test_Empty_Arrays,
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_True, Loc)))),
Make_Implicit_If_Statement (Nod,
- Condition => Test_Lengths_Correspond,
+ Condition => Test_Lengths_Correspond,
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
- Expression =>
- New_Occurrence_Of (Standard_False, Loc)))),
+ Expression => New_Occurrence_Of (Standard_False, Loc)))),
Handle_One_Dimension (1, First_Index (Ltyp)),
elsif Nkind (Parent (N)) = N_Op_Not
and then Nkind (N) = N_Op_And
- and then
- Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
+ and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
then
return;
else
-- Low_Bound + Length - 1.
High_Bound :=
- To_Ityp (
- Make_Op_Add (Loc,
- Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => New_Copy (Aggr_Length (NN)),
- Right_Opnd => Make_Artyp_Literal (1))));
+ To_Ityp
+ (Make_Op_Add (Loc,
+ Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => New_Copy (Aggr_Length (NN)),
+ Right_Opnd => Make_Artyp_Literal (1))));
-- Note that calculation of the high bound may cause overflow in some
-- very weird cases, so in the general case we need an overflow check on
if Atyp = Standard_String
and then NN in 2 .. 9
and then (Lib_Level_Target
- or else
- ((Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC)
- and then not Debug_Flag_Dot_C))
+ or else ((Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC)
+ and then not Debug_Flag_Dot_C))
then
declare
RR : constant array (Nat range 2 .. 9) of RE_Id :=
begin
Rewrite (Rop,
Make_Range (Loc,
- Low_Bound =>
+ Low_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Occurrence_Of (Rtyp, Loc)),
Name => New_Occurrence_Of (Bnn, Loc),
Expression =>
Make_And_Then (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Big_GE), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (L, Loc),
Lbound)),
+
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
-- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
-- and then T'Base (Lnn) in T;
-- end if;
- --
- -- SS_Release (M);
+
+ -- SS_Release (M);
-- end
-- in
-- Bnn
Convert_To (LLIB,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (TB, Loc))),
+ Prefix =>
+ New_Occurrence_Of (TB, Loc))),
High_Bound =>
Convert_To (LLIB,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
- Prefix => New_Occurrence_Of (TB, Loc))))),
+ Prefix =>
+ New_Occurrence_Of (TB, Loc))))),
Right_Opnd => Nin));
Set_Analyzed (N, False);
Analyze_And_Resolve (N, Restype);
if Compile_Time_Known_Value (Cond) then
if Is_True (Expr_Value (Cond)) then
- Expr := Thenx;
+ Expr := Thenx;
Actions := Then_Actions (N);
else
- Expr := Elsex;
+ Expr := Elsex;
Actions := Else_Actions (N);
end if;
and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
and then Entity (Prefix (Lo_Orig)) = Ltyp
- -- Same tests for right operand
+ -- Same tests for right operand
and then Nkind (Hi_Orig) = N_Attribute_Reference
and then Attribute_Name (Hi_Orig) = Name_Last
if Is_Acc then
Cond :=
Make_Or_Else (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
if Is_Acc then
Cond := Make_Or_Else (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
if Nkind (P) = N_Slice then
Rewrite (N,
Make_Indexed_Component (Loc,
- Prefix => Prefix (P),
+ Prefix => Prefix (P),
Expressions => New_List (
Convert_To
(Etype (First_Index (Etype (P))),
procedure Expand_N_Op_Abs (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Expr : constant Node_Id := Right_Opnd (N);
+ Expr : constant Node_Id := Right_Opnd (N);
begin
Unary_Op_Validity_Checks (N);
Left_Opnd => Duplicate_Subexpr (Expr),
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
Attribute_Name => Name_First)),
Reason => CE_Overflow_Check_Failed));
procedure Build_Equality_Call (Eq : Entity_Id) is
Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
- L_Exp : Node_Id := Relocate_Node (Lhs);
- R_Exp : Node_Id := Relocate_Node (Rhs);
+ L_Exp : Node_Id := Relocate_Node (Lhs);
+ R_Exp : Node_Id := Relocate_Node (Rhs);
begin
-- Adjust operands if necessary to comparison type
First_Discriminant
(Scope (Entity (Selector_Name (Lhs))));
while Present (Discr) loop
- Append_Elmt (
- Make_Identifier (Loc,
- Chars => New_External_Name (Chars (Discr), 'A')),
- To => Lhs_Discr_Vals);
+ Append_Elmt
+ (Make_Identifier (Loc,
+ Chars => New_External_Name (Chars (Discr), 'A')),
+ To => Lhs_Discr_Vals);
Next_Discriminant (Discr);
end loop;
else
Discr := First_Discriminant (Lhs_Type);
while Present (Discr) loop
- Append_Elmt (
- Make_Selected_Component (Loc,
- Prefix => Prefix (Lhs),
- Selector_Name =>
- New_Copy
- (Get_Discriminant_Value (Discr,
- Lhs_Type,
- Stored_Constraint (Lhs_Type)))),
- To => Lhs_Discr_Vals);
+ Append_Elmt
+ (Make_Selected_Component (Loc,
+ Prefix => Prefix (Lhs),
+ Selector_Name =>
+ New_Copy
+ (Get_Discriminant_Value (Discr,
+ Lhs_Type,
+ Stored_Constraint (Lhs_Type)))),
+ To => Lhs_Discr_Vals);
Next_Discriminant (Discr);
end loop;
end if;
Discr := First_Discriminant (Lhs_Type);
while Present (Discr) loop
- Append_Elmt (
- New_Copy
- (Get_Discriminant_Value (Discr,
+ Append_Elmt
+ (New_Copy
+ (Get_Discriminant_Value (Discr,
Lhs_Type,
Stored_Constraint (Lhs_Type))),
- To => Lhs_Discr_Vals);
+ To => Lhs_Discr_Vals);
Next_Discriminant (Discr);
end loop;
end if;
Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
then
if Is_Unchecked_Union
- (Scope (Entity (Selector_Name (Rhs))))
+ (Scope (Entity (Selector_Name (Rhs))))
then
Discr :=
First_Discriminant
(Scope (Entity (Selector_Name (Rhs))));
while Present (Discr) loop
- Append_Elmt (
- Make_Identifier (Loc,
- Chars => New_External_Name (Chars (Discr), 'B')),
- To => Rhs_Discr_Vals);
+ Append_Elmt
+ (Make_Identifier (Loc,
+ Chars => New_External_Name (Chars (Discr), 'B')),
+ To => Rhs_Discr_Vals);
Next_Discriminant (Discr);
end loop;
else
Discr := First_Discriminant (Rhs_Type);
while Present (Discr) loop
- Append_Elmt (
- Make_Selected_Component (Loc,
- Prefix => Prefix (Rhs),
- Selector_Name =>
- New_Copy (Get_Discriminant_Value
- (Discr,
- Rhs_Type,
- Stored_Constraint (Rhs_Type)))),
- To => Rhs_Discr_Vals);
+ Append_Elmt
+ (Make_Selected_Component (Loc,
+ Prefix => Prefix (Rhs),
+ Selector_Name =>
+ New_Copy (Get_Discriminant_Value
+ (Discr,
+ Rhs_Type,
+ Stored_Constraint (Rhs_Type)))),
+ To => Rhs_Discr_Vals);
Next_Discriminant (Discr);
end loop;
end if;
else
Discr := First_Discriminant (Rhs_Type);
while Present (Discr) loop
- Append_Elmt (
- New_Copy (Get_Discriminant_Value
- (Discr,
- Rhs_Type,
- Stored_Constraint (Rhs_Type))),
- To => Rhs_Discr_Vals);
+ Append_Elmt
+ (New_Copy (Get_Discriminant_Value
+ (Discr,
+ Rhs_Type,
+ Stored_Constraint (Rhs_Type))),
+ To => Rhs_Discr_Vals);
Next_Discriminant (Discr);
end loop;
end if;
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
Parameter_Associations => New_List (
Convert_To (RTE (RE_Unsigned), Base),
Make_Integer_Literal (Loc, Modulus (Rtyp)),
Rewrite (N,
Convert_To (Typ,
Make_Op_And (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Ent, Loc),
+ Name => New_Occurrence_Of (Ent, Loc),
Parameter_Associations => New_List (
Convert_To (Etype (First_Formal (Ent)), Base),
Exp)),
if (LOK and ROK)
and then ((Llo >= 0 and then Rlo >= 0)
- or else
+ or else
(Lhi <= 0 and then Rhi <= 0))
then
Rewrite (N,
procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
-- Rewrite the node by the appropriate string or positive constant.
-- Nam can be one of the following:
- -- Name_File - expand string that is the name of source file
- -- Name_Line - expand integer line number
- -- Name_Source_Location - expand string of form file:line
- -- Name_Enclosing_Entity - expand string with name of enclosing entity
+ -- Name_File - expand string name of source file
+ -- Name_Line - expand integer line number
+ -- Name_Source_Location - expand string of form file:line
+ -- Name_Enclosing_Entity - expand string name of enclosing entity
+ -- Name_Compilation_Date - expand string with compilation date
+ -- Name_Compilation_Time - expand string with compilation time
---------------------------------
-- Expand_Binary_Operator_Call --
elsif Nam_In (Nam, Name_File,
Name_Line,
Name_Source_Location,
- Name_Enclosing_Entity)
+ Name_Enclosing_Entity,
+ Name_Compilation_Date,
+ Name_Compilation_Time)
then
Expand_Source_Info (N, Nam);
Write_Entity_Name (Ent);
+ when Name_Compilation_Date =>
+ declare
+ subtype S13 is String (1 .. 3);
+ Months : constant array (1 .. 12) of S13 :=
+ ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
+
+ M1 : constant Character := Opt.Compilation_Time (6);
+ M2 : constant Character := Opt.Compilation_Time (7);
+
+ MM : constant Natural range 1 .. 12 :=
+ (Character'Pos (M1) - Character'Pos ('0')) * 10 +
+ (Character'Pos (M2) - Character'Pos ('0'));
+
+ begin
+ -- Reformat ISO date into MMM DD YYYY (__DATE__) format
+
+ Name_Buffer (1 .. 3) := Months (MM);
+ Name_Buffer (4) := ' ';
+ Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10);
+ Name_Buffer (7) := ' ';
+ Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4);
+ Name_Len := 11;
+ end;
+
+ when Name_Compilation_Time =>
+ Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19);
+ Name_Len := 8;
+
when others =>
raise Program_Error;
end case;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2014, 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- --
-- Historical note: this used to be Pure, but that was when we marked all
-- intrinsics as not Pure, even in Pure units, so no problems arose.
- function File return String;
+ function File return String with
+ Import, Convention => Intrinsic;
-- Return the name of the current file, not including the path information.
-- The result is considered to be a static string constant.
- function Line return Positive;
+ function Line return Positive with
+ Import, Convention => Intrinsic;
-- Return the current input line number. The result is considered to be a
-- static expression.
- function Source_Location return String;
+ function Source_Location return String with
+ Import, Convention => Intrinsic;
-- Return a string literal of the form "name:line", where name is the
-- current source file name without path information, and line is the
-- current line number. In the event that instantiations are involved,
-- string " instantiated at ". The result is considered to be a static
-- string constant.
- function Enclosing_Entity return String;
+ function Enclosing_Entity return String with
+ Import, Convention => Intrinsic;
-- Return the name of the current subprogram, package, task, entry or
-- protected subprogram. The string is in exactly the form used for the
-- declaration of the entity (casing and encoding conventions), and is
-- package itself. This is useful in identifying and logging information
-- from within generic templates.
-private
- pragma Import (Intrinsic, File);
- pragma Import (Intrinsic, Line);
- pragma Import (Intrinsic, Source_Location);
- pragma Import (Intrinsic, Enclosing_Entity);
+ function Compilation_Date return String with
+ Import, Convention => Intrinsic;
+ -- Returns date of compilation as a static string "mmm dd yyyy". This is
+ -- in local time form, and is exactly compatible with C macro __DATE__.
+
+ function Compilation_Time return String with
+ Import, Convention => Intrinsic;
+ -- Returns GMT time of compilation as a static string "hh:mm:ss". This is
+ -- in local time form, and is exactly compatible with C macro __TIME__.
+
end GNAT.Source_Info;
with Validsw; use Validsw;
with System.Assertions;
+with System.OS_Lib;
--------------
-- Gnat1drv --
Sem_Eval.Initialize;
Sem_Type.Init_Interp_Tables;
+ -- Capture compilation date and time
+
+ Opt.Compilation_Time := System.OS_Lib.Current_Time_String;
+
-- Acquire target parameters from system.ads (source of package System)
Targparm_Acquire : declare
@menu
* Intrinsic Operators::
+* Compilation_Date::
+* Compilation_Time::
* Enclosing_Entity::
* Exception_Information::
* Exception_Message::
It is also possible to specify such operators for private types, if the
full views are appropriate arithmetic types.
+@node Compilation_Date
+@section Compilation_Date
+@cindex Compilation_Date
+@noindent
+This intrinsic subprogram is used in the implementation of the
+library package @code{GNAT.Source_Info}. The only useful use of the
+intrinsic import in this case is the one in this unit, so an
+application program should simply call the function
+@code{GNAT.Source_Info.Compilation_Date} to obtain the date of
+the current compilation (in local time format MMM DD YYYY).
+
+@node Compilation_Time
+@section Compilation_Time
+@cindex Compilation_Time
+@noindent
+This intrinsic subprogram is used in the implementation of the
+library package @code{GNAT.Source_Info}. The only useful use of the
+intrinsic import in this case is the one in this unit, so an
+application program should simply call the function
+@code{GNAT.Source_Info.Compilation_Time} to obtain the time of
+the current compilation (in local time format HH:MM:SS).
+
@node Enclosing_Entity
@section Enclosing_Entity
@cindex Enclosing_Entity
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Source_Info}. The only useful use of the
+library package @code{GNAT.Source_Info}. The only useful use of the
intrinsic import in this case is the one in this unit, so an
application program should simply call the function
@code{GNAT.Source_Info.Enclosing_Entity} to obtain the name of
@cindex Exception_Information'
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Current_Exception}. The only useful
+library package @code{GNAT.Current_Exception}. The only useful
use of the intrinsic import in this case is the one in this unit,
so an application program should simply call the function
@code{GNAT.Current_Exception.Exception_Information} to obtain
@cindex Exception_Message
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Current_Exception}. The only useful
+library package @code{GNAT.Current_Exception}. The only useful
use of the intrinsic import in this case is the one in this unit,
so an application program should simply call the function
@code{GNAT.Current_Exception.Exception_Message} to obtain
@cindex Exception_Name
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Current_Exception}. The only useful
+library package @code{GNAT.Current_Exception}. The only useful
use of the intrinsic import in this case is the one in this unit,
so an application program should simply call the function
@code{GNAT.Current_Exception.Exception_Name} to obtain
@cindex File
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Source_Info}. The only useful use of the
+library package @code{GNAT.Source_Info}. The only useful use of the
intrinsic import in this case is the one in this unit, so an
application program should simply call the function
@code{GNAT.Source_Info.File} to obtain the name of the current
@cindex Line
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Source_Info}. The only useful use of the
+library package @code{GNAT.Source_Info}. The only useful use of the
intrinsic import in this case is the one in this unit, so an
application program should simply call the function
@code{GNAT.Source_Info.Line} to obtain the number of the current
@noindent
Provides subprograms that give access to source code information known at
-compile time, such as the current file name and line number.
+compile time, such as the current file name and line number. Also provides
+subprograms yielding the date and time of the current compilation (like the
+C macros @code{__DATE__} and @code{__TIME__})
@node GNAT.Spelling_Checker (g-speche.ads)
@section @code{GNAT.Spelling_Checker} (@file{g-speche.ads})
Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
+ -- Do not issue errors/warnings when compiling with optimizations. Note
+ -- that GNATprove mode is only set when we are analyzing (not compiling)
+ -- the program, so in that case the value of optimization level does not
+ -- matter.
+
elsif Optimization_Level = 0 or else GNATprove_Mode then
-- Do not emit warning if this is a predefined unit which is not
-- True if source lines removed by the preprocessor should be commented
-- in the output file.
+ Compilation_Time : String (1 .. 19);
+ -- GNAT
+ -- Compilation date and time in form YYYY-MM-DD HH:MM:SS
+
Compile_Only : Boolean := False;
-- GNATMAKE, GNATCLEAN, GPRMAKE, GPBUILD, GPRCLEAN
-- GNATMAKE, GPRMAKE, GPRMAKE:
- -- set to True to skip bind and link steps (except when Bind_Only is
- -- True).
+ -- set True to skip bind and link steps (except when Bind_Only is True)
-- GNATCLEAN, GPRCLEAN:
- -- set to True to delete only the files produced by the compiler but not
- -- the library files or the executable files.
+ -- set True to delete only the files produced by the compiler but not the
+ -- library files or the executable files.
Compiler_Unit : Boolean := False;
-- GNAT1
-- use of pragma Implicit_Packing.
Ineffective_Inline_Warnings : Boolean := False;
- -- GNAT Set True to activate warnings if front-end inlining (-gnatN) is
- -- not able to actually inline a particular call (or all calls). Can be
- -- controlled by use of -gnatwp/-gnatwP. Also set True to activate warnings
- -- if frontend inlining is not able to inline a subprogram expected to be
- -- inlined in GNATprove mode.
+ -- GNAT
+ -- Set True to activate warnings if front-end inlining (-gnatN) is not able
+ -- to actually inline a particular call (or all calls). Can be controlled
+ -- by use of -gnatwp/-gnatwP. Also set True to activate warnings if
+ -- frontend inlining is not able to inline a subprogram expected to
+ -- be inlined in GNATprove mode.
Init_Or_Norm_Scalars : Boolean := False;
-- GNAT, GANTBIND
Attribute_Img => True,
Attribute_Loop_Entry => True,
Attribute_Old => True,
+ Attribute_Result => True,
Attribute_Stub_Type => True,
Attribute_Version => True,
Attribute_Type_Key => True,
end loop File_Loop;
end Create_Temp_File_Internal;
+ -------------------------
+ -- Current_Time_String --
+ -------------------------
+
+ function Current_Time_String return String is
+ subtype S23 is String (1 .. 23);
+ -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL
+
+ procedure Current_Time_String (Time : System.Address);
+ pragma Import (C, Current_Time_String, "__gnat_current_time_string");
+ -- Puts current time into Time in above ISO 8601 format
+
+ Result23 : aliased S23;
+ -- Current time in ISO 8601 format
+
+ begin
+ Current_Time_String (Result23'Address);
+ return Result23 (1 .. 19);
+ end Current_Time_String;
+
-----------------
-- Delete_File --
-----------------
---------------------
type OS_Time is private;
- -- The OS's notion of time is represented by the private type OS_Time.
- -- This is the type returned by the File_Time_Stamp functions to obtain
- -- the time stamp of a specified file. Functions and a procedure (modeled
- -- after the similar subprograms in package Calendar) are provided for
- -- extracting information from a value of this type. Although these are
- -- called GM, the intention is not that they provide GMT times in all
- -- cases but rather the actual (time-zone independent) time stamp of the
- -- file (of course in Unix systems, this *is* in GMT form).
+ -- The OS's notion of time is represented by the private type OS_Time. This
+ -- is the type returned by the File_Time_Stamp functions to obtain the time
+ -- stamp of a specified file. Functions and a procedure (modeled after the
+ -- similar subprograms in package Calendar) are provided for extracting
+ -- information from a value of this type. Although these are called GM, the
+ -- intention in the case of time stamps is not that they provide GMT times
+ -- in all cases but rather the actual (time-zone independent) time stamp of
+ -- the file (of course in Unix systems, this *is* in GMT form).
Invalid_Time : constant OS_Time;
-- A special unique value used to flag an invalid time stamp value
function GM_Hour (Date : OS_Time) return Hour_Type;
function GM_Minute (Date : OS_Time) return Minute_Type;
function GM_Second (Date : OS_Time) return Second_Type;
- -- Functions to extract information from OS_Time value
+ -- Functions to extract information from OS_Time value in GMT form
function "<" (X, Y : OS_Time) return Boolean;
function ">" (X, Y : OS_Time) return Boolean;
-- component parts and returns an OS_Time. Returns Invalid_Time if the
-- creation fails.
+ function Current_Time_String return String;
+ -- Returns current local time in the form YYYY-MM-DD HH:MM:SS. The result
+ -- has bounds 1 .. 19.
+
----------------
-- File Stuff --
----------------
------------
when Attribute_Update => Update : declare
+ Common_Typ : Entity_Id;
+ -- The common type of a multiple component update for a record
+
Comps : Elist_Id := No_Elist;
- Expr : Node_Id;
+ -- A list used in the resolution of a record update. It contains the
+ -- entities of all record components processed so far.
- procedure Check_Component_Reference
- (Comp : Entity_Id;
- Typ : Entity_Id);
- -- Comp is a record component (possibly a discriminant) and Typ is a
- -- record type. Determine whether Comp is a legal component of Typ.
- -- Emit an error if Comp mentions a discriminant or is not a unique
- -- component reference in the update aggregate.
+ procedure Analyze_Array_Component_Update (Assoc : Node_Id);
+ -- Analyze and resolve array_component_association Assoc against the
+ -- index of array type P_Type.
- -------------------------------
- -- Check_Component_Reference --
- -------------------------------
+ procedure Analyze_Record_Component_Update (Comp : Node_Id);
+ -- Analyze and resolve record_component_association Comp against
+ -- record type P_Type.
- procedure Check_Component_Reference
- (Comp : Entity_Id;
- Typ : Entity_Id)
- is
- Comp_Name : constant Name_Id := Chars (Comp);
+ ------------------------------------
+ -- Analyze_Array_Component_Update --
+ ------------------------------------
- function Is_Duplicate_Component return Boolean;
- -- Determine whether component Comp already appears in list Comps
+ procedure Analyze_Array_Component_Update (Assoc : Node_Id) is
+ Expr : Node_Id;
+ High : Node_Id;
+ Index : Node_Id;
+ Index_Typ : Entity_Id;
+ Low : Node_Id;
- ----------------------------
- -- Is_Duplicate_Component --
- ----------------------------
+ begin
+ -- The current association contains a sequence of indexes denoting
+ -- an element of a multidimensional array:
- function Is_Duplicate_Component return Boolean is
- Comp_Elmt : Elmt_Id;
+ -- (Index_1, ..., Index_N)
- begin
- if Present (Comps) then
- Comp_Elmt := First_Elmt (Comps);
- while Present (Comp_Elmt) loop
- if Chars (Node (Comp_Elmt)) = Comp_Name then
- return True;
+ -- Examine each individual index and resolve it against the proper
+ -- index type of the array.
+
+ if Nkind (First (Choices (Assoc))) = N_Aggregate then
+ Expr := First (Choices (Assoc));
+ while Present (Expr) loop
+
+ -- The use of others is illegal (SPARK RM 4.4.1(12))
+
+ if Nkind (Expr) = N_Others_Choice then
+ Error_Attr
+ ("others choice not allowed in attribute %", Expr);
+
+ -- Otherwise analyze and resolve all indexes
+
+ else
+ Index := First (Expressions (Expr));
+ Index_Typ := First_Index (P_Type);
+ while Present (Index) and then Present (Index_Typ) loop
+ Analyze_And_Resolve (Index, Etype (Index_Typ));
+ Next (Index);
+ Next_Index (Index_Typ);
+ end loop;
+
+ -- Detect a case where the association either lacks an
+ -- index or contains an extra index.
+
+ if Present (Index) or else Present (Index_Typ) then
+ Error_Msg_N
+ ("dimension mismatch in index list", Assoc);
end if;
+ end if;
- Next_Elmt (Comp_Elmt);
- end loop;
+ Next (Expr);
+ end loop;
+
+ -- The current association denotes either a single component or a
+ -- range of components of a one dimensional array:
+
+ -- 1, 2 .. 5
+
+ -- Resolve the index or its high and low bounds (if range) against
+ -- the proper index type of the array.
+
+ else
+ Index := First (Choices (Assoc));
+ Index_Typ := First_Index (P_Type);
+
+ if Present (Next_Index (Index_Typ)) then
+ Error_Msg_N ("too few subscripts in array reference", Assoc);
end if;
- return False;
- end Is_Duplicate_Component;
+ while Present (Index) loop
- -- Local variables
+ -- The use of others is illegal (SPARK RM 4.4.1(12))
- Comp_Or_Discr : Entity_Id;
+ if Nkind (Index) = N_Others_Choice then
+ Error_Attr
+ ("others choice not allowed in attribute %", Index);
+
+ -- The index denotes a range of elements
+
+ elsif Nkind (Index) = N_Range then
+ Low := Low_Bound (Index);
+ High := High_Bound (Index);
+
+ Analyze_And_Resolve (Low, Etype (Index_Typ));
+ Analyze_And_Resolve (High, Etype (Index_Typ));
+
+ -- Add a range check to ensure that the bounds of the
+ -- range are within the index type when this cannot be
+ -- determined statically.
+
+ if not Is_OK_Static_Expression (Low) then
+ Set_Do_Range_Check (Low);
+ end if;
+
+ if not Is_OK_Static_Expression (High) then
+ Set_Do_Range_Check (High);
+ end if;
+
+ -- Otherwise the index denotes a single element
+
+ else
+ Analyze_And_Resolve (Index, Etype (Index_Typ));
+
+ -- Add a range check to ensure that the index is within
+ -- the index type when it is not possible to determine
+ -- this statically.
+
+ if not Is_OK_Static_Expression (Index) then
+ Set_Do_Range_Check (Index);
+ end if;
+ end if;
+
+ Next (Index);
+ end loop;
+ end if;
+ end Analyze_Array_Component_Update;
+
+ -------------------------------------
+ -- Analyze_Record_Component_Update --
+ -------------------------------------
- -- Start of processing for Check_Component_Reference
+ procedure Analyze_Record_Component_Update (Comp : Node_Id) is
+ Comp_Name : constant Name_Id := Chars (Comp);
+ Base_Typ : Entity_Id;
+ Comp_Or_Discr : Entity_Id;
begin
-- Find the discriminant or component whose name corresponds to
-- Comp. A simple character comparison is sufficient because all
-- visible names within a record type are unique.
- Comp_Or_Discr := First_Entity (Typ);
+ Comp_Or_Discr := First_Entity (P_Type);
while Present (Comp_Or_Discr) loop
if Chars (Comp_Or_Discr) = Comp_Name then
- -- Record component entity and type in the given aggregate
- -- choice, for subsequent resolution.
+ -- Decorate the component reference by setting its entity
+ -- and type for resolution purposes.
Set_Entity (Comp, Comp_Or_Discr);
Set_Etype (Comp, Etype (Comp_Or_Discr));
Comp_Or_Discr := Next_Entity (Comp_Or_Discr);
end loop;
- -- Diagnose possible illegal references
+ -- Diagnose an illegal reference
if Present (Comp_Or_Discr) then
if Ekind (Comp_Or_Discr) = E_Discriminant then
("attribute % may not modify record discriminants", Comp);
else pragma Assert (Ekind (Comp_Or_Discr) = E_Component);
- if Is_Duplicate_Component then
- Error_Msg_NE ("component & already updated", Comp, Comp);
+ if Contains (Comps, Comp_Or_Discr) then
+ Error_Msg_N ("component & already updated", Comp);
-- Mark this component as processed
Comps := New_Elmt_List;
end if;
- Append_Elmt (Comp, Comps);
+ Append_Elmt (Comp_Or_Discr, Comps);
end if;
end if;
-- the record type.
else
- Error_Msg_NE
- ("& is not a component of aggregate subtype", Comp, Comp);
+ Error_Msg_N ("& is not a component of aggregate subtype", Comp);
+ end if;
+
+ -- Verify the consistency of types when the current component is
+ -- part of a miltiple component update.
+
+ -- Comp_1, ..., Comp_N => <value>
+
+ if Present (Etype (Comp)) then
+ Base_Typ := Base_Type (Etype (Comp));
+
+ -- Save the type of the first component reference as the
+ -- remaning references (if any) must resolve to this type.
+
+ if No (Common_Typ) then
+ Common_Typ := Base_Typ;
+
+ elsif Base_Typ /= Common_Typ then
+ Error_Msg_N
+ ("components in choice list must have same type", Comp);
+ end if;
end if;
- end Check_Component_Reference;
+ end Analyze_Record_Component_Update;
-- Local variables
- Assoc : Node_Id;
- Comp : Node_Id;
- Comp_Type : Entity_Id;
+ Assoc : Node_Id;
+ Comp : Node_Id;
-- Start of processing for Update
-- choices. Perform the following checks:
-- 1) Legality of "others" in all cases
- -- 2) Component legality for records
+ -- 2) Legality of <>
+ -- 3) Component legality for arrays
+ -- 4) Component legality for records
-- The remaining checks are performed on the expanded attribute
Assoc := First (Component_Associations (E1));
while Present (Assoc) loop
- Comp := First (Choices (Assoc));
- Analyze (Expression (Assoc));
- Comp_Type := Empty;
- while Present (Comp) loop
- if Nkind (Comp) = N_Others_Choice then
- Error_Attr
- ("others choice not allowed in attribute %", Comp);
-
- elsif Is_Array_Type (P_Type) then
- declare
- Index : Node_Id;
- Index_Type : Entity_Id;
- Lo, Hi : Node_Id;
-
- begin
- if Nkind (First (Choices (Assoc))) /= N_Aggregate then
- -- Choices denote separate components of one-
- -- dimensional array.
+ -- The use of <> is illegal (SPARK RM 4.4.1(1))
- Index_Type := First_Index (P_Type);
+ if Box_Present (Assoc) then
+ Error_Attr
+ ("default initialization not allowed in attribute %", Assoc);
- if Present (Next_Index (Index_Type)) then
- Error_Msg_N
- ("too few subscripts in array reference", Comp);
- end if;
+ -- Otherwise process the association
- Index := First (Choices (Assoc));
- while Present (Index) loop
- if Nkind (Index) = N_Range then
- Lo := Low_Bound (Index);
- Hi := High_Bound (Index);
+ else
+ Analyze (Expression (Assoc));
- Analyze_And_Resolve (Lo, Etype (Index_Type));
+ if Is_Array_Type (P_Type) then
+ Analyze_Array_Component_Update (Assoc);
- if not Is_OK_Static_Expression (Lo) then
- Set_Do_Range_Check (Lo);
- end if;
+ elsif Is_Record_Type (P_Type) then
- Analyze_And_Resolve (Hi, Etype (Index_Type));
+ -- Reset the common type used in a multiple component update
+ -- as we are processing the contents of a new association.
- if not Is_OK_Static_Expression (Hi) then
- Set_Do_Range_Check (Hi);
- end if;
+ Common_Typ := Empty;
- else
- Analyze_And_Resolve (Index, Etype (Index_Type));
+ Comp := First (Choices (Assoc));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Identifier then
+ Analyze_Record_Component_Update (Comp);
- if not Is_OK_Static_Expression (Index) then
- Set_Do_Range_Check (Index);
- end if;
- end if;
+ -- The use of others is illegal (SPARK RM 4.4.1(5))
- Next (Index);
- end loop;
+ elsif Nkind (Comp) = N_Others_Choice then
+ Error_Attr
+ ("others choice not allowed in attribute %", Comp);
- -- Choice is a sequence of indexes for each dimension
+ -- The name of a record component cannot appear in any
+ -- other form.
else
- Expr := First (Choices (Assoc));
- while Present (Expr) loop
- Index_Type := First_Index (P_Type);
- Index := First (Expressions (Expr));
- while Present (Index_Type)
- and then Present (Index)
- loop
- Analyze_And_Resolve (Index, Etype (Index_Type));
- Next_Index (Index_Type);
- Next (Index);
- end loop;
-
- if Present (Index) or else Present (Index_Type) then
- Error_Msg_N
- ("dimension mismatch in index list", Assoc);
- end if;
-
- Next (Expr);
- end loop;
- end if;
- end;
-
- elsif Is_Record_Type (P_Type) then
-
- -- Make sure we have an identifier. Old SPARK allowed
- -- a component selection e.g. A.B in the corresponding
- -- context, but we do not yet permit this for 'Update.
-
- if Nkind (Comp) /= N_Identifier then
- Error_Msg_N ("name should be identifier or OTHERS", Comp);
- else
- Check_Component_Reference (Comp, P_Type);
-
- -- Verify that all choices in an association denote
- -- components of the same type.
-
- if No (Etype (Comp)) then
- null;
-
- elsif No (Comp_Type) then
- Comp_Type := Base_Type (Etype (Comp));
-
- elsif Comp_Type /= Base_Type (Etype (Comp)) then
Error_Msg_N
- ("components in choice list must have same type",
- Assoc);
+ ("name should be identifier or OTHERS", Comp);
end if;
- end if;
- end if;
- Next (Comp);
- end loop;
+ Next (Comp);
+ end loop;
+ end if;
+ end if;
Next (Assoc);
end loop;
- -- The type of attribute Update is that of the prefix
+ -- The type of attribute 'Update is that of the prefix
Set_Etype (N, P_Type);
end Update;
if Is_Array_Type (Typ) then
Assoc := First (Component_Associations (Aggr));
while Present (Assoc) loop
- Expr := Expression (Assoc);
+ Expr := Expression (Assoc);
Resolve (Expr, Component_Type (Typ));
-- For scalar array components set Do_Range_Check when
end if;
end;
- -- Premature return requires comment ???
-
- return;
-
---------
-- Val --
---------
-- Create object declaration for elaboration entity, and put it
-- just in front of the spec of the subprogram or generic unit,
- -- in the same scope as this unit.
+ -- in the same scope as this unit. The subprogram may be over-
+ -- loaded, so make the name of elaboration entity unique by
+ -- means of a numeric suffix.
declare
Loce : constant Source_Ptr := Sloc (E);
Ent : constant Entity_Id :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (E), 'E'));
+ Chars => New_External_Name (Chars (E), 'E', -1));
begin
Set_Elaboration_Entity (E, Ent);
-- Source_Location and navigation functions
- elsif Nam_In (Nam, Name_File, Name_Line, Name_Source_Location,
- Name_Enclosing_Entity)
+ elsif Nam_In (Nam, Name_File,
+ Name_Line,
+ Name_Source_Location,
+ Name_Enclosing_Entity,
+ Name_Compilation_Date,
+ Name_Compilation_Time)
then
null;
-- convention name. So is To_Address, which is a GNAT attribute.
First_Intrinsic_Name : constant Name_Id := N + $;
+ Name_Compilation_Date : constant Name_Id := N + $;
+ Name_Compilation_Time : constant Name_Id := N + $;
Name_Divide : constant Name_Id := N + $;
Name_Enclosing_Entity : constant Name_Id := N + $;
Name_Exception_Information : constant Name_Id := N + $;
begin
if Nkind (Odef) = N_Identifier
+ and then Present (Etype (Odef))
and then Is_Array_Type (Etype (Odef))
and then not Is_Constrained (Etype (Odef))
and then Present (Etype (Def_Id))
projects / platform / upstream / gcc.git / commitdiff