+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * g-forstr.adb: Minor code reorganization (use J rather than I
+ as a variable name).
+ * gnat_rm.texi, sem_prag.adb, sem_util.adb, sem_ch13.adb,
+ g-forstr.ads: Minor reformatting.
+
+2014-07-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sprint.adb (Set_Debug_Sloc): Also reset the end location if
+ we are debugging the generated code.
+
+2014-07-30 Yannick Moy <moy@adacore.com>
+
+ * sinput.ads, sinput.adb (Comes_From_Inlined_Body): New function that
+ returns True for source pointer for an inlined body.
+
+2014-07-30 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch4.adb (Apply_Accessibility_Check): Add
+ missing calls to Base_Address().
+
+2014-07-30 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Hanalyze_Subprogram_Body_Helper): In GNATprove
+ mode, subprogram bodies without a previous declaration are also
+ candidates for front-end inlining.
+
2014-07-30 Hristian Kirtchev <kirtchev@adacore.com>
* aspects.ads Aspects Async_Readers, Async_Writers,
Obj_Ref := New_Occurrence_Of (Ref, Loc);
end if;
+ -- For access to interface types we must generate code to displace
+ -- the pointer to the base of the object since the subsequent code
+ -- references components located in the TSD of the object (which
+ -- is associated with the primary dispatch table --see a-tags.ads)
+ -- and also generates code invoking Free, which requires also a
+ -- reference to the base of the unallocated object.
+
+ if Is_Interface (DesigT) then
+ Obj_Ref :=
+ Unchecked_Convert_To (Etype (Obj_Ref),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ New_Copy_Tree (Obj_Ref)))));
+ end if;
+
-- Step 1: Create the object clean up code
Stmts := New_List;
-- Step 2: Create the accessibility comparison
- -- Reference the tag: for a renaming of an access to an interface
- -- object Obj_Ref already references the tag of the secondary
- -- dispatch table.
-
- if Nkind (Obj_Ref) in N_Has_Entity
- and then Present (Entity (Obj_Ref))
- and then Present (Renamed_Object (Entity (Obj_Ref)))
- and then Is_Interface (DesigT)
- then
- null;
-
-- Generate:
-- Ref'Tag
- else
- Obj_Ref :=
- Make_Attribute_Reference (Loc,
- Prefix => Obj_Ref,
- Attribute_Name => Name_Tag);
- end if;
+ Obj_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Obj_Ref,
+ Attribute_Name => Name_Tag);
-- For tagged types, determine the accessibility level by looking
-- at the type specific data of the dispatch table. Generate:
type F_Base is (None, C_Style, Ada_Style) with Default_Value => None;
- Unset : constant Integer := -1;
+ Unset : constant Integer := -1;
type F_Data is record
Kind : F_Kind;
end record;
procedure Next_Format
- (Format : Formatted_String; F_Spec : out F_Data; Start : out Positive);
+ (Format : Formatted_String;
+ F_Spec : out F_Data;
+ Start : out Positive);
-- Parse the next format specifier, a format specifier has the following
-- syntax: %[flags][width][.precision][length]specifier
function Get_Formatted
- (F_Spec : F_Data; Value : String; Len : Positive) return String;
+ (F_Spec : F_Data;
+ Value : String;
+ Len : Positive) return String;
-- Returns Value formatted given the information in F_Spec
procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return;
Aft : Text_IO.Field;
Exp : Text_IO.Field);
function P_Flt_Format
- (Format : Formatted_String; Var : Flt) return Formatted_String;
+ (Format : Formatted_String;
+ Var : Flt) return Formatted_String;
-- Generic routine which handles all floating point numbers
generic
Item : Int;
Base : Text_IO.Number_Base);
function P_Int_Format
- (Format : Formatted_String; Var : Int) return Formatted_String;
+ (Format : Formatted_String;
+ Var : Int) return Formatted_String;
-- Generic routine which handles all the integer numbers
---------
function "-" (Format : Formatted_String) return String is
F : String renames Format.D.Format;
- I : Natural renames Format.D.Index;
+ J : Natural renames Format.D.Index;
R : Unbounded_String := Format.D.Result;
+
begin
-- Make sure we get the remaining character up to the next unhandled
-- format specifier.
- while (I <= F'Length and then F (I) /= '%')
- or else (I < F'Length - 1 and then F (I + 1) = '%')
+ while (J <= F'Length and then F (J) /= '%')
+ or else (J < F'Length - 1 and then F (J + 1) = '%')
loop
- Append (R, F (I));
+ Append (R, F (J));
-- If we have two consecutive %, skip the second one
- if F (I) = '%' and then I < F'Length - 1 and then F (I + 1) = '%' then
- I := I + 1;
+ if F (J) = '%' and then J < F'Length - 1 and then F (J + 1) = '%' then
+ J := J + 1;
end if;
- I := I + 1;
+ J := J + 1;
end loop;
return To_String (R);
is
F : F_Data;
Start : Positive;
+
begin
Next_Format (Format, F, Start);
is
F : F_Data;
Start : Positive;
+
begin
Next_Format (Format, F, Start);
A_Img : constant String := System.Address_Image (Var);
F : F_Data;
Start : Positive;
+
begin
Next_Format (Format, F, Start);
--------------
overriding procedure Finalize (F : in out Formatted_String) is
-
procedure Unchecked_Free is
new Unchecked_Deallocation (Data, Data_Access);
D : Data_Access := F.D;
+
begin
F.D := null;
Res : Unbounded_String;
S : Positive := Value'First;
+
begin
- -- Let's hanfles the flags
+ -- Handle the flags
if F_Spec.Kind in Is_Number then
if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then
(Format : Formatted_String;
Var : Int) return Formatted_String
is
- function Sign (Var : Int) return Sign_Kind
- is (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
- function To_Integer (Var : Int) return Integer is (Integer (Var));
+ function Sign (Var : Int) return Sign_Kind is
+ (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
+
+ function To_Integer (Var : Int) return Integer is
+ (Integer (Var));
+
function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
+
begin
return Int_Format (Format, Var);
end Int_Format;
(Format : Formatted_String;
Var : Int) return Formatted_String
is
- function Sign (Var : Int) return Sign_Kind
- is (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
- function To_Integer (Var : Int) return Integer is (Integer (Var));
+ function Sign (Var : Int) return Sign_Kind is
+ (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
+
+ function To_Integer (Var : Int) return Integer is
+ (Integer (Var));
+
function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
+
begin
return Int_Format (Format, Var);
end Mod_Format;
F_Spec : out F_Data;
Start : out Positive)
is
- F : String renames Format.D.Format;
- I : Natural renames Format.D.Index;
+ F : String renames Format.D.Format;
+ J : Natural renames Format.D.Index;
S : Natural;
Width_From_Var : Boolean := False;
+
begin
Format.D.Current := Format.D.Current + 1;
F_Spec.Value_Needed := 0;
-- Got to next %
- while (I <= F'Last and then F (I) /= '%')
- or else (I < F'Last - 1 and then F (I + 1) = '%')
+ while (J <= F'Last and then F (J) /= '%')
+ or else (J < F'Last - 1 and then F (J + 1) = '%')
loop
- Append (Format.D.Result, F (I));
+ Append (Format.D.Result, F (J));
-- If we have two consecutive %, skip the second one
- if F (I) = '%' and then I < F'Last - 1 and then F (I + 1) = '%' then
- I := I + 1;
+ if F (J) = '%' and then J < F'Last - 1 and then F (J + 1) = '%' then
+ J := J + 1;
end if;
- I := I + 1;
+ J := J + 1;
end loop;
- if F (I) /= '%' or else I = F'Last then
+ if F (J) /= '%' or else J = F'Last then
raise Format_Error with "no format specifier found for parameter"
& Positive'Image (Format.D.Current);
end if;
- Start := I;
+ Start := J;
- I := I + 1;
+ J := J + 1;
-- Check for any flags
- Flags_Check : while I < F'Last loop
- if F (I) = '-' then
+ Flags_Check : while J < F'Last loop
+ if F (J) = '-' then
F_Spec.Left_Justify := True;
- elsif F (I) = '+' then
- F_Spec.Sign := Forced;
- elsif F (I) = ' ' then
- F_Spec.Sign := Space;
- elsif F (I) = '#' then
- F_Spec.Base := C_Style;
- elsif F (I) = '~' then
- F_Spec.Base := Ada_Style;
- elsif F (I) = '0' then
- F_Spec.Zero_Pad := True;
+ elsif F (J) = '+' then
+ F_Spec.Sign := Forced;
+ elsif F (J) = ' ' then
+ F_Spec.Sign := Space;
+ elsif F (J) = '#' then
+ F_Spec.Base := C_Style;
+ elsif F (J) = '~' then
+ F_Spec.Base := Ada_Style;
+ elsif F (J) = '0' then
+ F_Spec.Zero_Pad := True;
else
exit Flags_Check;
end if;
- I := I + 1;
+ J := J + 1;
end loop Flags_Check;
-- Check width if any
- if F (I) in '0' .. '9' then
+ if F (J) in '0' .. '9' then
+
-- We have a width parameter
- S := I;
+ S := J;
- while I < F'Last and then F (I + 1) in '0' .. '9' loop
- I := I + 1;
+ while J < F'Last and then F (J + 1) in '0' .. '9' loop
+ J := J + 1;
end loop;
- F_Spec.Width := Natural'Value (F (S .. I));
+ F_Spec.Width := Natural'Value (F (S .. J));
+
+ J := J + 1;
- I := I + 1;
+ elsif F (J) = '*' then
- elsif F (I) = '*' then
-- The width will be taken from the integer parameter
F_Spec.Value_Needed := 1;
Width_From_Var := True;
- I := I + 1;
+ J := J + 1;
end if;
- if F (I) = '.' then
+ if F (J) = '.' then
+
-- We have a precision parameter
- I := I + 1;
+ J := J + 1;
- if F (I) in '0' .. '9' then
- S := I;
+ if F (J) in '0' .. '9' then
+ S := J;
- while I < F'Length and then F (I + 1) in '0' .. '9' loop
- I := I + 1;
+ while J < F'Length and then F (J + 1) in '0' .. '9' loop
+ J := J + 1;
end loop;
- if F (I) = '.' then
+ if F (J) = '.' then
+
-- No precision, 0 is assumed
+
F_Spec.Precision := 0;
+
else
- F_Spec.Precision := Natural'Value (F (S .. I));
+ F_Spec.Precision := Natural'Value (F (S .. J));
end if;
- I := I + 1;
+ J := J + 1;
+
+ elsif F (J) = '*' then
- elsif F (I) = '*' then
-- The prevision will be taken from the integer parameter
F_Spec.Value_Needed := F_Spec.Value_Needed + 1;
- I := I + 1;
+ J := J + 1;
end if;
end if;
-- but yet for compatibility reason it is handled.
Length_Check :
- while I <= F'Last
- and then F (I) in 'h' | 'l' | 'j' | 'z' | 't' | 'L'
+ while J <= F'Last
+ and then F (J) in 'h' | 'l' | 'j' | 'z' | 't' | 'L'
loop
- I := I + 1;
+ J := J + 1;
end loop Length_Check;
- if I > F'Last then
+ if J > F'Last then
Raise_Wrong_Format (Format);
end if;
-- Read next character which should be the expected type
- case F (I) is
+ case F (J) is
when 'c' => F_Spec.Kind := Char;
when 's' => F_Spec.Kind := Str;
when 'd' | 'i' => F_Spec.Kind := Decimal_Int;
& Positive'Image (Format.D.Current);
end case;
- I := I + 1;
+ J := J + 1;
if F_Spec.Value_Needed > 0
and then F_Spec.Value_Needed = Format.D.Stored_Value
S, E : Positive := 1;
Start : Positive;
Aft : Text_IO.Field;
+
begin
Next_Format (Format, F, Start);
end if;
when Shortest_Decimal_Float | Shortest_Decimal_Float_Up =>
+
-- Without exponent
Put (Buffer, Var, Aft, Exp => 0);
declare
Buffer2 : String (1 .. 50);
S2, E2 : Positive;
+
begin
Put (Buffer2, Var, Aft, Exp => 3);
S2 := Strings.Fixed.Index_Non_Blank (Buffer2);
end case;
Append (Format.D.Result,
- Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length));
+ Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length));
return Format;
end P_Flt_Format;
(Format : Formatted_String;
Var : Int) return Formatted_String
is
-
function Handle_Precision return Boolean;
-- Return True if nothing else to do
return False;
end Handle_Precision;
+ -- Start of processing for P_Int_Format
+
begin
Next_Format (Format, F, Start);
-- Then add base if needed
declare
- N : String :=
- Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len);
+ N : String := Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len);
P : constant Positive :=
(if F.Left_Justify
then N'First
N (N'First .. N'First + 1) := "8#";
N (N'Last) := '#';
- when Unsigned_Hexadecimal_Int
- | Unsigned_Hexadecimal_Int_Up
- =>
+ when Unsigned_Hexadecimal_Int |
+ Unsigned_Hexadecimal_Int_Up =>
if F.Left_Justify then
N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3);
else
procedure Raise_Wrong_Format (Format : Formatted_String) is
begin
- raise Format_Error with "wrong format specified for parameter"
+ raise Format_Error with
+ "wrong format specified for parameter"
& Positive'Image (Format.D.Current);
end Raise_Wrong_Format;
------------------------------------------------------------------------------
-- This package add support for formatted string as supported by C printf().
---
+
-- A simple usage is:
---
+
-- declare
-- F : Formatted_String := +"['%c' ; %10d]";
-- C : Character := 'v';
-- begin
-- F := F & C & I;
-- Put_Line (-F);
---
-- end;
---
+
-- Which will display:
---
+
-- ['v' ; 98]
---
---
+
-- Each format specifier is: %[flags][width][.precision][length]specifier
---
+
-- Specifiers:
-- d or i Signed decimal integer
-- u Unsigned decimal integer
-- s String of characters
-- p Pointer address
-- % A % followed by another % character will write a single %
---
+
-- Flags:
+
-- - Left-justify within the given field width;
--- Right justification is the default
+-- Right justification is the default.
+
-- + Forces to preceed the result with a plus or minus sign (+ or -)
-- even for positive numbers. By default, only negative numbers
-- are preceded with a - sign.
+
-- (space) If no sign is going to be written, a blank space is inserted
-- before the value.
+
-- # Used with o, x or X specifiers the value is preceeded with
-- 0, 0x or 0X respectively for values different than zero.
-- Used with a, A, e, E, f, F, g or G it forces the written
-- output to contain a decimal point even if no more digits
-- follow. By default, if no digits follow, no decimal point is
-- written.
+
-- ~ As above, but using Ada style based <base>#<number>#
+
-- 0 Left-pads the number with zeroes (0) instead of spaces when
-- padding is specified.
+
-- Width:
-- number Minimum number of characters to be printed. If the value to
-- be printed is shorter than this number, the result is padded
-- with blank spaces. The value is not truncated even if the
-- result is larger.
+
-- * The width is not specified in the format string, but as an
-- additional integer value argument preceding the argument that
-- has to be formatted.
-- leading zeros. The value is not truncated even if the result
-- is longer. A precision of 0 means that no character is written
-- for the value 0.
+
-- For e, E, f and F specifiers: this is the number of digits to
-- be printed after the decimal point (by default, this is 6).
-- For g and G specifiers: This is the maximum number of
-- significant digits to be printed.
+
-- For s: this is the maximum number of characters to be printed.
-- By default all characters are printed until the ending null
-- character is encountered.
+
-- If the period is specified without an explicit value for
-- precision, 0 is assumed.
+
-- .* The precision is not specified in the format string, but as an
-- additional integer value argument preceding the argument that
-- has to be formatted.
private with Ada.Strings.Unbounded;
package GNAT.Formatted_String is
-
use Ada;
type Formatted_String (<>) is private;
generic
type Enum is (<>);
function Enum_Format
- (Format : Formatted_String; Var : Enum) return Formatted_String;
+ (Format : Formatted_String;
+ Var : Enum) return Formatted_String;
-- As for String above, output the string representation of the enumeration
private
-
use Ada.Strings.Unbounded;
type I_Vars is array (Positive range 1 .. 2) of Integer;
@cindex Formatted String
@noindent
-Provides support for C/C++ printf() formatted string. The format is
+Provides support for C/C++ printf() formatted strings. The format is
copied from the printf() routine and should therefore gives identical
output. Some generic routines are provided to be able to use types
derived from Integer, Float or enumerations as values for the
-- their pragmas must contain two arguments, the second
-- being the optional Boolean expression.
- if A_Id = Aspect_Async_Readers
- or else A_Id = Aspect_Async_Writers
- or else A_Id = Aspect_Effective_Reads
- or else A_Id = Aspect_Effective_Writes
+ if A_Id = Aspect_Async_Readers or else
+ A_Id = Aspect_Async_Writers or else
+ A_Id = Aspect_Effective_Reads or else
+ A_Id = Aspect_Effective_Writes
then
declare
Args : List_Id;
-- The first argument of the external property pragma
-- is the related object.
- Args := New_List (
- Make_Pragma_Argument_Association (Sloc (Ent),
- Expression => Ent));
+ Args :=
+ New_List (
+ Make_Pragma_Argument_Association (Sloc (Ent),
+ Expression => Ent));
-- The second argument is the optional Boolean
-- expression which must be propagated even if it
Spec_Id := Disambiguate_Spec;
else
Spec_Id := Find_Corresponding_Spec (N);
+
+ -- In GNATprove mode, if the body has no previous spec, create
+ -- one so that the inlining machinery can operate properly.
+ -- Transfer aspects, if any, to the new spec, so that they
+ -- are legal and can be processed ahead of the body.
+ -- We make two copies of the given spec, one for the new
+ -- declaration, and one for the body.
+
+ -- This cannot be done for a compilation unit, which is not
+ -- in a context where we can insert a new spec.
+
+ if No (Spec_Id)
+ and then GNATprove_Mode
+ and then Debug_Flag_QQ
+ and then Full_Analysis
+ and then Comes_From_Source (Body_Id)
+ and then Is_List_Member (N)
+ then
+ declare
+ Body_Spec : constant Node_Id :=
+ Copy_Separate_Tree (Specification (N));
+ New_Decl : constant Node_Id :=
+ Make_Subprogram_Declaration
+ (Loc, Copy_Separate_Tree (Specification (N)));
+
+ begin
+ Insert_Before (N, New_Decl);
+ Move_Aspects (From => N, To => New_Decl);
+ Analyze (New_Decl);
+ Spec_Id := Defining_Entity (New_Decl);
+
+ Set_Specification (N, Body_Spec);
+ Body_Id := Analyze_Subprogram_Specification (Body_Spec);
+ Set_Corresponding_Spec (N, Spec_Id);
+ end;
+ end if;
end if;
-- If this is a duplicate body, no point in analyzing it
-- than a formal subprogram parameter (SPARK RM 7.1.3(2)). The check
-- is performed at the end of the declarative region due to a possible
-- out-of-order arrangement of pragmas:
- --
+
-- Obj : ...;
-- pragma Async_Readers (Obj);
-- pragma Volatile (Obj);
or else (Present (Full_View (Etype (Typ)))
and then Full_View (Etype (Typ)) = Typ)
- -- Protect the frontend against wrong source with cyclic
- -- derivations
+ -- Protect frontend against wrong sources with cyclic derivations
or else Etype (Typ) = T;
end case;
end Check_For_BOM;
+ -----------------------------
+ -- Comes_From_Inlined_Body --
+ -----------------------------
+
+ function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is
+ SIE : Source_File_Record renames
+ Source_File.Table (Get_Source_File_Index (S));
+ begin
+ return SIE.Inlined_Body;
+ end Comes_From_Inlined_Body;
+
-----------------------
-- Get_Column_Number --
-----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- value of the instantiation if this location is within an instance.
-- If S is not within an instance, then this returns No_Location.
+ function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean;
+ pragma Inline (Comes_From_Inlined_Body);
+ -- Given a source pointer S, returns whether it comes from an inlined body.
+ -- This allows distinguishing these source pointers from those that come
+ -- from instantiation of generics, since Instantiation_Location returns a
+ -- valid location in both cases.
+
function Top_Level_Location (S : Source_Ptr) return Source_Ptr;
-- Given a source pointer S, returns the argument unchanged if it is
-- not in an instantiation. If S is in an instantiation, then it returns
begin
if Debug_Generated_Code and then Present (Dump_Node) then
Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
+
+ -- We do not know the actual end location in the generated code and
+ -- it could be much closer than in the source code, so play safe.
+
+ if Nkind_In (Dump_Node, N_Case_Statement, N_If_Statement) then
+ Set_End_Location (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
+ end if;
+
Dump_Node := Empty;
end if;
end Set_Debug_Sloc;
projects / gcc.git / commitdiff