+2015-11-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Find_Selected_Component): In a synchronized
+ body, a reference to an operation of an object of the same
+ synchronized type was always interpreted as a reference to the
+ current instance. This is not always the case, as the prefix of
+ the reference may designate an object of the same type declared
+ in the enclosing context prior to the body.
+
+2015-11-12 Arnaud Charlet <charlet@adacore.com>
+
+ * impunit.ads, impunit.adb (Get_Kind_Of_File): New. Cleaned up
+ implementation from previous Get_Kind_Of_Unit.
+ (Get_Kind_Of_Unit): Reimplemented using Get_Kind_Of_File.
+ * debug.adb: Remove d.4 switch, no longer used.
+ * opt.ads: Update doc on Debugger_Level.
+ * gnat1drv.adb: Code clean ups.
+ * sinput.ads: minor fix in comment
+
+2015-11-12 Bob Duff <duff@adacore.com>
+
+ * sinfo.adb, sinfo.ads, sem_ch6.adb, atree.ads: Add
+ Was_Expression_Function flag, which is set in sem_ch6.adb when
+ converting an Expression_Function into a Subprogram_Body.
+
+2015-11-12 Pascal Obry <obry@adacore.com>
+
+ * usage.adb: Update overflow checking documentation.
+
2015-11-12 Tristan Gingold <gingold@adacore.com>
* snames.ads-tmpl: Name_Gnat_Extended_Ravenscar: New identifier.
-- Flag10
-- Flag11 Note that Flag0-3 are stored separately in the Flags
-- Flag12 table, but that's a detail of the implementation which
- -- Flag13 is entirely hidden by the funcitonal interface.
+ -- Flag13 is entirely hidden by the functional interface.
-- Flag14
-- Flag15
-- Flag16
Generate_C_Code := True;
Modify_Tree_For_C := True;
Unnest_Subprogram_Mode := True;
- Back_Annotate_Rep_Info := True;
-- Set operating mode to Generate_Code to benefit from full front-end
-- expansion (e.g. generics).
Operating_Mode := Generate_Code;
+
+ -- Suppress alignment checks since we do not have access to alignment
+ -- info on the target
+
+ Suppress_Options.Suppress (Alignment_Check) := False;
end if;
-- -gnatd.E sets Error_To_Warning mode, causing selected error messages
Back_End.Call_Back_End (Back_End_Mode);
-- Once the backend is complete, we unlock the names table. This call
- -- allows a few extra entries, needed for example for the file name for
- -- the library file output.
+ -- allows a few extra entries, needed for example for the file name
+ -- for the library file output.
Namet.Unlock;
("utf_32", Sutf_32'Access));
----------------------
- -- Get_Kind_Of_Unit --
+ -- Get_Kind_Of_File --
----------------------
- function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit is
- Fname : constant File_Name_Type := Unit_File_Name (U);
+ function Get_Kind_Of_File (File : String) return Kind_Of_Unit is
+ pragma Assert (File'First = 1);
+
+ Buffer : String (1 .. 8);
begin
Error_Msg_Strlen := 0;
- Get_Name_String (Fname);
-- Ada/System/Interfaces are all Ada 95 units
- if (Name_Len = 7 and then Name_Buffer (1 .. 7) = "ada.ads")
- or else
- (Name_Len = 10 and then Name_Buffer (1 .. 10) = "system.ads")
- or else
- (Name_Len = 12 and then Name_Buffer (1 .. 12) = "interfac.ads")
+ if File = "ada.ads"
+ or else File = "system.ads"
+ or else File = "interfac.ads"
then
return Ada_95_Unit;
end if;
-- If length of file name is greater than 12, not predefined. The value
-- 12 here is an 8 char name with extension .ads.
- if Name_Len > 12 then
+ if File'Length > 12 then
return Not_Predefined_Unit;
end if;
-- Not predefined if file name does not start with a- g- s- i-
- if Name_Len < 3
- or else Name_Buffer (2) /= '-'
- or else (Name_Buffer (1) /= 'a'
- and then
- Name_Buffer (1) /= 'g'
- and then
- Name_Buffer (1) /= 'i'
- and then
- Name_Buffer (1) /= 's')
+ if File'Length < 3
+ or else File (2) /= '-'
+ or else
+ (File (1) /= 'a'
+ and then File (1) /= 'g'
+ and then File (1) /= 'i'
+ and then File (1) /= 's')
then
return Not_Predefined_Unit;
end if;
-- this routine to detect when a construct comes from an instance of
-- a generic defined in a predefined unit.
- if Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
+ if File (File'Last - 3 .. File'Last) /= ".ads"
and then
- Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb"
+ File (File'Last - 3 .. File'Last) /= ".adb"
then
return Not_Predefined_Unit;
end if;
-- Otherwise normalize file name to 8 characters
- Name_Len := Name_Len - 4;
- while Name_Len < 8 loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ' ';
+ Buffer (1 .. File'Length - 4) := File (1 .. File'Length - 4);
+
+ for J in File'Length - 3 .. 8 loop
+ Buffer (J) := ' ';
end loop;
-- See if name is in 95 list
for J in Non_Imp_File_Names_95'Range loop
- if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J).Fname then
+ if Buffer = Non_Imp_File_Names_95 (J).Fname then
return Ada_95_Unit;
end if;
end loop;
-- See if name is in 2005 list
for J in Non_Imp_File_Names_05'Range loop
- if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J).Fname then
+ if Buffer = Non_Imp_File_Names_05 (J).Fname then
return Ada_2005_Unit;
end if;
end loop;
-- See if name is in 2012 list
for J in Non_Imp_File_Names_12'Range loop
- if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then
+ if Buffer = Non_Imp_File_Names_12 (J).Fname then
return Ada_2012_Unit;
end if;
end loop;
-- Only remaining special possibilities are children of System.RPC and
-- System.Garlic and special files of the form System.Aux...
- Get_Name_String (Unit_Name (U));
-
- if Name_Len > 12
- and then Name_Buffer (1 .. 11) = "system.rpc."
- then
- return Ada_95_Unit;
- end if;
-
- if Name_Len > 15
- and then Name_Buffer (1 .. 14) = "system.garlic."
- then
- return Ada_95_Unit;
- end if;
-
- if Name_Len > 11
- and then Name_Buffer (1 .. 10) = "system.aux"
+ if File (1 .. 5) = "s-rpc"
+ or else File (1 .. 5) = "s-gar"
+ or else File (1 .. 5) = "s-aux"
then
return Ada_95_Unit;
end if;
-- All tests failed, this is definitely an implementation unit. See if
-- we have an alternative name.
- Get_Name_String (Fname);
-
- if Name_Len in 11 .. 12
- and then Name_Buffer (1 .. 2) = "s-"
- and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads"
+ if File'Length in 11 .. 12
+ and then File (1 .. 2) = "s-"
+ and then File (File'Last - 3 .. File'Last) = ".ads"
then
for J in Map_Array'Range loop
- if (Name_Len = 12 and then
- Name_Buffer (3 .. 8) = Map_Array (J).Fname)
+ if (File'Length = 12 and then
+ File (3 .. 8) = Map_Array (J).Fname)
or else
- (Name_Len = 11 and then
- Name_Buffer (3 .. 7) = Map_Array (J).Fname (1 .. 5))
+ (File'Length = 11 and then
+ File (3 .. 7) = Map_Array (J).Fname (1 .. 5))
then
Error_Msg_Strlen := Map_Array (J).Aname'Length;
Error_Msg_String (1 .. Error_Msg_Strlen) :=
end if;
return Implementation_Unit;
+ end Get_Kind_Of_File;
+
+ ----------------------
+ -- Get_Kind_Of_Unit --
+ ----------------------
+
+ function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit is
+ begin
+ Get_Name_String (Unit_File_Name (U));
+ return Get_Kind_Of_File (Name_Buffer (1 .. Name_Len));
end Get_Kind_Of_Unit;
-------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2015, 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- --
function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit;
-- Given the unit number of a unit, this function determines the type
-- of the unit, as defined above. If the result is Implementation_Unit,
- -- then the name of a possible atlernative equivalent unit is placed in
+ -- then the name of a possible alternative equivalent unit is placed in
-- Error_Msg_String/Slen on return. If there is no alternative name, or if
-- the result is not Implementation_Unit, then Error_Msg_Slen is zero on
-- return, indicating that no alternative name was found.
+ function Get_Kind_Of_File (File : String) return Kind_Of_Unit;
+ -- Same as Get_Kind_Of_Unit, for a given filename
+
function Is_Known_Unit (Nam : Node_Id) return Boolean;
-- Nam is the possible name of a child unit, represented as a selected
-- component node. This function determines whether the name matches one of
subtype Debug_Level_Value is Nat range 0 .. 3;
Debugger_Level : Debug_Level_Value := 0;
-- The value given to the -g parameter. The default value for -g with
- -- no value is 2. This is not currently used but is retained for possible
- -- future use.
+ -- no value is 2. If no -g is specified, defaults to 0.
+ -- Note that the generated code should never depend on this variable,
+ -- since we want debug info to be non intrusive on the generate code.
Default_Exit_Status : Int := 0;
-- GNATBIND
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (LocX,
Statements => New_List (Ret)));
+ Set_Was_Expression_Function (New_Body);
-- If the expression completes a generic subprogram, we must create a
-- separate node for the body, because at instantiation the original
-- Prefix denotes an enclosing loop, block, or task, i.e. an
-- enclosing construct that is not a subprogram or accept.
- Find_Expanded_Name (N);
+ -- A special case: a protected body may call an operation
+ -- on an external object of the same type, in which case it
+ -- is not an expanded name. If the prefix is the type itself,
+ -- or the context is a single synchronized object it can only
+ -- be interpreted as an expanded name.
+
+ if Is_Concurrent_Type (Etype (P_Name)) then
+ if Is_Type (P_Name)
+ or else Present (Anonymous_Object (Etype (P_Name)))
+ then
+ Find_Expanded_Name (N);
+
+ else
+ Analyze_Selected_Component (N);
+ return;
+ end if;
+
+ else
+ Find_Expanded_Name (N);
+ end if;
elsif Ekind (P_Name) = E_Package then
Find_Expanded_Name (N);
return Elist5 (N);
end Used_Operations;
+ function Was_Expression_Function
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ return Flag18 (N);
+ end Was_Expression_Function;
+
function Was_Originally_Stub
(N : Node_Id) return Boolean is
begin
Set_Elist5 (N, Val);
end Set_Used_Operations;
+ procedure Set_Was_Expression_Function
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ Set_Flag18 (N, Val);
+ end Set_Was_Expression_Function;
+
procedure Set_Was_Originally_Stub
(N : Node_Id; Val : Boolean := True) is
begin
-- on exit from the scope of the use_type_clause, in particular in the
-- case of Use_All_Type, when those operations several scopes.
+ -- Was_Expression_Function (Flag18-Sem)
+ -- Present in N_Subprogram_Body. True if the original source had an
+ -- N_Expression_Function, which was converted to the N_Subprogram_Body
+ -- by Analyze_Expression_Function. This is needed by ASIS to correctly
+ -- recreate the expression function (for the instance body) when the
+ -- completion of a generic function declaration is an expression
+ -- function.
+
-- Was_Originally_Stub (Flag13-Sem)
-- This flag is set in the node for a proper body that replaces stub.
-- During the analysis procedure, stubs in some situations get rewritten
-- Is_Task_Master (Flag5-Sem)
-- Was_Originally_Stub (Flag13-Sem)
-- Has_Relative_Deadline_Pragma (Flag9-Sem)
+ -- Was_Expression_Function (Flag18-Sem)
-------------------------
-- Expression Function --
function Used_Operations
(N : Node_Id) return Elist_Id; -- Elist5
+ function Was_Expression_Function
+ (N : Node_Id) return Boolean; -- Flag18
+
function Was_Originally_Stub
(N : Node_Id) return Boolean; -- Flag13
procedure Set_Used_Operations
(N : Node_Id; Val : Elist_Id); -- Elist5
+ procedure Set_Was_Expression_Function
+ (N : Node_Id; Val : Boolean := True); -- Flag18
+
procedure Set_Was_Originally_Stub
(N : Node_Id; Val : Boolean := True); -- Flag13
pragma Inline (Variants);
pragma Inline (Visible_Declarations);
pragma Inline (Used_Operations);
+ pragma Inline (Was_Expression_Function);
pragma Inline (Was_Originally_Stub);
pragma Inline (Withed_Body);
pragma Inline (Set_Variant_Part);
pragma Inline (Set_Variants);
pragma Inline (Set_Visible_Declarations);
+ pragma Inline (Set_Was_Expression_Function);
pragma Inline (Set_Was_Originally_Stub);
pragma Inline (Set_Withed_Body);
function Num_Source_Lines (S : Source_File_Index) return Nat;
-- Returns the number of source lines (this is equivalent to reading
-- the value of Last_Source_Line, but returns Nat rather than a
- -- physical line number.
+ -- physical line number).
procedure Register_Source_Ref_Pragma
(File_Name : File_Name_Type;
-- Line for -gnato switch
+ Write_Switch_Char ("o0");
+ Write_Line ("Disable overflow checking (on by default)");
+
Write_Switch_Char ("o");
- Write_Line ("Enable overflow checking mode to CHECKED (off by default)");
+ Write_Line ("Enable overflow checking in STRICT (-gnato1) mode (default)");
-- Lines for -gnato? switches
projects / thirdparty / gcc.git / commitdiff
