+2013-04-11 Robert Dewar <dewar@adacore.com>
+
+ * s-osprim-mingw.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb.
+ makeutl.adb, sem_ch8.adb: Minor reformatting.
+
+2013-04-11 Vincent Celier <celier@adacore.com>
+
+ * gnat_ugn.texi: Minor fixes for VMS.
+ * ug_words: Minor addition: -gnato? => /OVERFLOW_CHECKS=?.
+
+2013-04-11 Robert Dewar <dewar@adacore.com>
+
+ * usage.adb (Usage): Minor edit to -gnatW message
+
+2013-04-11 Robert Dewar <dewar@adacore.com>
+
+ * exp_aggr.adb (Expand_N_Aggregate): Add circuit for handling
+ others for string literal case. Also add big ??? comment about
+ this new code, which should be redundant, but is not.
+ * sem_eval.adb (Eval_Concatenation): Handle non-static case
+ properly (Eval_String_Literal): Handle non-static literal properly
+
2013-03-20 Tobias Burnus <burnus@net-b.de>
* i-fortra.ads: Update comment, add Ada 2012's optional
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
procedure Expand_N_Aggregate (N : Node_Id) is
begin
+ -- Record aggregate case
+
if Is_Record_Type (Etype (N)) then
Expand_Record_Aggregate (N);
+
+ -- Array aggregate case
+
else
+ -- A special case, if we have a string subtype with bounds 1 .. N,
+ -- where N is known at compile time, and the aggregate is of the
+ -- form (others => 'x'), and N is less than 80 (an arbitrary limit
+ -- for now), then replace the aggregate by the equivalent string
+ -- literal (but do not mark it as static since it is not!)
+
+ -- Note: this entire circuit is redundant with respect to code in
+ -- Expand_Array_Aggregate that collapses others choices to positional
+ -- form, but there are two problems with that circuit:
+
+ -- a) It is limited to very small cases due to ill-understood
+ -- interations with bootstrapping. That limit is removed by
+ -- use of the No_Implicit_Loops restriction.
+
+ -- b) It erroneously ends up with the resulting expressions being
+ -- considered static when they are not. For example, the
+ -- following test should fail:
+
+ -- pragma Restrictions (No_Implicit_Loops);
+ -- package NonSOthers4 is
+ -- B : constant String (1 .. 6) := (others => 'A');
+ -- DH : constant String (1 .. 8) := B & "BB";
+ -- X : Integer;
+ -- pragma Export (C, X, Link_Name => DH);
+ -- end;
+
+ -- But it succeeds (DH looks static to pragma Export)
+
+ -- To be sorted out! ???
+
+ if Present (Component_Associations (N)) then
+ declare
+ CA : constant Node_Id := First (Component_Associations (N));
+ MX : constant := 80;
+
+ begin
+ if Nkind (First (Choices (CA))) = N_Others_Choice
+ and then Nkind (Expression (CA)) = N_Character_Literal
+ then
+ declare
+ T : constant Entity_Id := Etype (N);
+ X : constant Node_Id := First_Index (T);
+ EC : constant Node_Id := Expression (CA);
+ CV : constant Uint := Char_Literal_Value (EC);
+ CC : constant Int := UI_To_Int (CV);
+
+ begin
+ if Nkind (X) = N_Range
+ and then Compile_Time_Known_Value (Low_Bound (X))
+ and then Expr_Value (Low_Bound (X)) = 1
+ and then Compile_Time_Known_Value (High_Bound (X))
+ then
+ declare
+ Hi : constant Uint := Expr_Value (High_Bound (X));
+
+ begin
+ if Hi <= MX then
+ Start_String;
+
+ for J in 1 .. UI_To_Int (Hi) loop
+ Store_String_Char (Char_Code (CC));
+ end loop;
+
+ Rewrite (N,
+ Make_String_Literal (Sloc (N),
+ Strval => End_String));
+
+ if CC >= Int (2 ** 16) then
+ Set_Has_Wide_Wide_Character (N);
+ elsif CC >= Int (2 ** 8) then
+ Set_Has_Wide_Character (N);
+ end if;
+
+ Analyze_And_Resolve (N, T);
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+
+ -- Not that special case, so normal expansion of array aggregate
+
Expand_Array_Aggregate (N);
end if;
exception
assertions, and the second within assertions.
If no digits follow the @option{-gnato}, then it is equivalent to
-@option{-gnato11},
+@option{^-gnato11^/OVERFLOW_CHECKS=11^},
causing all intermediate overflows to be handled in strict mode.
This switch also causes arithmetic overflow checking to be performed
@findex Machine_Overflows
Note that the @option{-gnato??} switch does not affect the code generated
-for any floating-point operations; it applies only to integer
-semantics.
+for any floating-point operations; it applies only to integer semantics.
For floating-point, @value{EDITION} has the @code{Machine_Overflows}
attribute set to @code{False} and the normal mode of operation is to
generate IEEE NaN and infinite values on overflow or invalid operations
checking is also quite expensive in time and space, since in general it
requires the use of double length arithmetic.
-Note again that the default is @option{-gnato00}, so overflow checking is
-not performed in default mode. This means that out of the box, with the
-default settings, @value{EDITION} does not do all the checks expected from the
-language description in the Ada Reference Manual. If you want all constraint
-checks to be performed, as described in this Manual, then you must
-explicitly use the @option{-gnato??} switch either on the @command{gnatmake} or
-@command{gcc} command.
+Note again that the default is @option{^-gnato00^/OVERFLOW_CHECKS=00^},
+so overflow checking is not performed in default mode. This means that out of
+the box, with the default settings, @value{EDITION} does not do all the checks
+expected from the language description in the Ada Reference Manual.
+If you want all constraint checks to be performed, as described in this Manual,
+then you must explicitly use the @option{-gnato??}
+switch either on the @command{gnatmake} or @command{gcc} command.
@item -gnatE
@cindex @option{-gnatE} (@command{gcc})
The default indentation is 3.
@item ^-gnatyo^/ORDERED_SUBPROGRAMS^
-@cindex @option{^-gnato^/ORDERED_SUBPROGRAMS^} (@command{gnatstub})
+@cindex @option{^-gnatyo^/ORDERED_SUBPROGRAMS^} (@command{gnatstub})
Order local bodies alphabetically. (By default local bodies are ordered
in the same way as the corresponding local specs in the argument spec file.)
As with the pragma, if only one digit appears then it applies to all
cases; if two digits are given, then the first applies outside
assertions, and the second within assertions. Thus the equivalent
-of the example pragma above would be @option{-gnato23}.
+of the example pragma above would be
+@option{^-gnato23^/OVERFLOW_CHECKS=23^}.
If no digits follow the @option{-gnato}, then it is equivalent to
-@option{-gnato11},
+@option{^-gnato11^/OVERFLOW_CHECKS=11^},
causing all intermediate operations to be computed using the base
type (@code{STRICT} mode).
Status : Boolean;
-- For call to Close
- Iter : Source_Iterator :=
- For_Each_Source
- (In_Tree => Project_Tree,
- Language => Name_Ada,
- Encapsulated_Libs => False,
- Locally_Removed => False);
+ Iter : Source_Iterator := For_Each_Source
+ (In_Tree => Project_Tree,
+ Language => Name_Ada,
+ Encapsulated_Libs => False,
+ Locally_Removed => False);
+
Source : Prj.Source_Id;
begin
-- found.
if ALI_Name /= No_File then
+
-- Look in the project and the projects that are extending it
-- to find the real ALI file.
declare
- ALI : constant String := Get_Name_String (ALI_Name);
+ ALI : constant String := Get_Name_String (ALI_Name);
+ ALI_Path : Name_Id := No_Name;
- ALI_Path : Name_Id := No_Name;
begin
loop
-- For library projects, use the library ALI directory,
end loop;
if ALI_Path /= No_Name then
+
-- First line is the unit name
Get_Name_String (ALI_Unit);
exit when not OK;
- -- Second line it the ALI file name
+ -- Second line is the ALI file name
Get_Name_String (ALI_Name);
Add_Char_To_Name_Buffer (ASCII.LF);
exit when not OK;
- -- Third line it the ALI path name
+ -- Third line is the ALI path name
Get_Name_String (ALI_Path);
Add_Char_To_Name_Buffer (ASCII.LF);
if Sw'Length >= 3
and then (Sw (2) = 'I'
or else (not For_Gnatbind
- and then (Sw (2) = 'L'
- or else Sw (2) = 'A')))
+ and then (Sw (2) = 'L'
+ or else
+ Sw (2) = 'A')))
then
Start := 3;
or else
Sw (2 .. 3) = "aI"
or else
- (For_Gnatbind and then Sw (2 .. 3) = "A="))
+ (For_Gnatbind and then Sw (2 .. 3) = "A="))
then
Start := 4;
type Clock_Data_Access is access all Clock_Data;
- -- Two base clock buffers. This is used to be able to update a buffer
- -- while the other buffer is read. The point is that we do not want to
- -- use a lock inside the Clock routine for performance reasons. We still
- -- use a lock in the Get_Base_Time which is called very rarely. Current
- -- is a pointer, the pragma Atomic is there to ensure that the value can
- -- be set or read atomically. That's it, when Get_Base_Time has updated
- -- a buffer the switch to the new value is done by changing Current
- -- pointer.
+ -- Two base clock buffers. This is used to be able to update a buffer while
+ -- the other buffer is read. The point is that we do not want to use a lock
+ -- inside the Clock routine for performance reasons. We still use a lock
+ -- in the Get_Base_Time which is called very rarely. Current is a pointer,
+ -- the pragma Atomic is there to ensure that the value can be set or read
+ -- atomically. That's it, when Get_Base_Time has updated a buffer the
+ -- switch to the new value is done by changing Current pointer.
First, Second : aliased Clock_Data;
- Current : Clock_Data_Access := First'Access;
+
+ Current : Clock_Data_Access := First'Access;
pragma Atomic (Current);
-- The following signature is to detect change on the base clock data
epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
system_time_ns : constant := 100; -- 100 ns per tick
Sec_Unit : constant := 10#1#E9;
- Max_Elapsed : constant LARGE_INTEGER :=
+
+ Max_Elapsed : constant LARGE_INTEGER :=
LARGE_INTEGER (Tick_Frequency / 100_000);
-- Look for a precision of 0.01 ms
+
Sig : constant Signature_Type := Signature;
Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER;
end if;
end loop;
- New_Data.Base_Clock := Duration
- (Long_Long_Float ((New_Data.Base_Time - epoch_1970) * system_time_ns) /
- Long_Long_Float (Sec_Unit));
+ New_Data.Base_Clock :=
+ Duration
+ (Long_Long_Float
+ ((New_Data.Base_Time - epoch_1970) * system_time_ns) /
+ Long_Long_Float (Sec_Unit));
-- At this point all the base values have been set into the new data
- -- record. We just change the pointer (atomic operation) to this new
- -- values.
+ -- record. Change the pointer (atomic operation) to these new values.
Current := New_Data;
Data := New_Data.all;
and then Present (Full_View (T))
then
Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check);
-
else
Analyze_And_Resolve (Expr, BDT);
end if;
and then Entity (Prefix (Nam)) = Current_Scope
and then Chars (Selector_Name (Nam)) = Chars (New_S)
then
- if Overriding_Renamings then
- null;
+ -- This is an error, but we overlook the error and accept the
+ -- renaming if the special Overriding_Renamings mode is in effect.
- else
+ if not Overriding_Renamings then
Error_Msg_NE
- ("implicit operation& is not visible (RM 8.3 (15))",
- Nam, Old_S);
+ ("implicit operation& is not visible (RM 8.3 (15))",
+ Nam, Old_S);
end if;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
Set_Is_Static_Expression (N, Stat);
- if Stat then
+ -- If left operand is the empty string, the result is the
+ -- right operand, including its bounds if anomalous.
- -- If left operand is the empty string, the result is the
- -- right operand, including its bounds if anomalous.
-
- if Left_Len = 0
- and then Is_Array_Type (Etype (Right))
- and then Etype (Right) /= Any_String
- then
- Set_Etype (N, Etype (Right));
- end if;
-
- Fold_Str (N, Folded_Val, Static => True);
+ if Left_Len = 0
+ and then Is_Array_Type (Etype (Right))
+ and then Etype (Right) /= Any_String
+ then
+ Set_Etype (N, Etype (Right));
end if;
+
+ Fold_Str (N, Folded_Val, Static => Stat);
end;
end Eval_Concatenation;
-- is too long, or it is null, and the lower bound is type'First. In
-- either case it is the upper bound that is out of range of the index
-- type.
-
if Ada_Version >= Ada_95 then
if Root_Type (Bas) = Standard_String
or else
Root_Type (Bas) = Standard_Wide_String
+ or else
+ Root_Type (Bas) = Standard_Wide_Wide_String
then
Xtp := Standard_Positive;
else
Lo := Type_Low_Bound (Etype (First_Index (Typ)));
end if;
+ -- Check for string too long
+
Len := String_Length (Strval (N));
if UI_From_Int (Len) > String_Type_Len (Bas) then
- Apply_Compile_Time_Constraint_Error
- (N, "string literal too long for}", CE_Length_Check_Failed,
- Ent => Bas,
- Typ => First_Subtype (Bas));
+
+ -- Issue message. Note that this message is a warning if the
+ -- string literal is not marked as static (happens in some cases
+ -- of folding strings known at compile time, but not static).
+ -- Furthermore in such cases, we reword the message, since there
+ -- is no string literal in the source program!
+
+ if Is_Static_Expression (N) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "string literal too long for}", CE_Length_Check_Failed,
+ Ent => Bas,
+ Typ => First_Subtype (Bas));
+ else
+ Apply_Compile_Time_Constraint_Error
+ (N, "string value too long for}", CE_Length_Check_Failed,
+ Ent => Bas,
+ Typ => First_Subtype (Bas),
+ Warn => True);
+ end if;
+
+ -- Test for null string not allowed
elsif Len = 0
and then not Is_Generic_Type (Xtp)
and then
Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
then
- Apply_Compile_Time_Constraint_Error
- (N, "null string literal not allowed for}",
- CE_Length_Check_Failed,
- Ent => Bas,
- Typ => First_Subtype (Bas));
+ -- Same specialization of message
+
+ if Is_Static_Expression (N) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "null string literal not allowed for}",
+ CE_Length_Check_Failed,
+ Ent => Bas,
+ Typ => First_Subtype (Bas));
+ else
+ Apply_Compile_Time_Constraint_Error
+ (N, "null string value not allowed for}",
+ CE_Length_Check_Failed,
+ Ent => Bas,
+ Typ => First_Subtype (Bas),
+ Warn => True);
+ end if;
end if;
end if;
end Eval_String_Literal;
-- Note that we have to reset Is_Static_Expression both after the
-- analyze step (because Resolve will evaluate the literal, which
-- will cause semantic errors if it is marked as static), and after
- -- the Resolve step (since Resolve in some cases sets this flag).
+ -- the Resolve step (since Resolve in some cases resets this flag).
Analyze (N);
Set_Is_Static_Expression (N, Static);
elsif not Effective
and then Warn_On_Redundant_Constructs
- and then not (Status = Suppressed or Suppress_All_Inlining)
+ and then not (Status = Suppressed or else Suppress_All_Inlining)
then
if Inlining_Not_Possible (Subp) then
Error_Msg_NE
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_No_Identifiers;
+
Hint := First (Pragma_Argument_Associations (N));
while Present (Hint) loop
Check_Arg_Is_One_Of (Hint,
Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector);
Next (Hint);
end loop;
+
Check_Loop_Pragma_Placement;
end Loop_Optimize;
function Is_Interface_Conversion (N : Node_Id) return Boolean;
-- Determine whether N is a construct of the form
-- Some_Type (Operand._tag'Address)
- -- This construct appears in the context of dispatching calls
+ -- This construct appears in the context of dispatching calls.
function Reference_To (Obj : Node_Id) return Node_Id;
-- An explicit dereference is created when removing side-effects from
-gnatn2 ^ /INLINE=PRAGMA_LEVEL_2
-gnatN ^ /INLINE=FULL
-gnato ^ /CHECKS=OVERFLOW
+-gnato? ^ /OVERFLOW_CHECKS=?
-gnato?? ^ /OVERFLOW_CHECKS=??
-gnatp ^ /CHECKS=SUPPRESS_ALL
-gnat-p ^ /CHECKS=UNSUPPRESS_ALL
-- Line for -gnatW switch
- Write_Switch_Char ("W");
- Write_Str ("Wide character encoding method (");
+ Write_Switch_Char ("W?");
+ Write_Str ("Wide character encoding method (?=");
for J in WC_Encoding_Method loop
Write_Char (WC_Encoding_Letters (J));
projects / platform / upstream / linaro-gcc.git / commitdiff