2012-03-19 Yannick Moy <moy@adacore.com>
+ * sem_ch6.adb: Minor code clean up.
+
+2012-03-19 Vincent Celier <celier@adacore.com>
+
+ * make.adb (Scan_Make_Arg): Make sure all significant -m switches
+ on the command line are counted.
+
+2012-03-19 Robert Dewar <dewar@adacore.com>
+
+ * sem_elab.adb (Generate_Elab_Warnings): Fix spec, fix attribute
+ reference case
+
+2012-03-19 Robert Dewar <dewar@adacore.com>
+
+ * par-ch4.adb (Check_Bad_Exp): New procedure
+
+2012-03-19 Robert Dewar <dewar@adacore.com>
+
+ * exp_attr.adb, sem_attr.adb, sem_attr.ads, snames.ads-tmpl: Add
+ initial framework for Valid_Scalars attribute.
+
+2012-03-19 Robert Dewar <dewar@adacore.com>
+
+ * scng.adb (Scan): Recognize incorrect preprocessor directive
+
+2012-03-19 Robert Dewar <dewar@adacore.com>
+
+ * atree.adb (Allocate_Initialize_Node): Use Num_Extension_Nodes
+ * atree.ads (Num_Extension_Nodes): New variable
+ * debug.adb: New debug flag -gnatd.N
+ * gnat1drv.adb (Adjust_Global_Switches): Adjust
+ Num_Extension_Nodes if -gnatd.N set
+
+2012-03-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads: Minor update to First_Rep_Item and Has_Gigi_Rep_Item
+ descriptions.
+
+2012-03-19 Robert Dewar <dewar@adacore.com>
+
+ * opt.ads: Remove HLO_Active flag.
+ * sem.adb: Remove call of high level optimizer.
+ * sem.ads (New_Nodes_OK): Removed.
+ * sem_ch10.adb: Remove references to New_Nodes_OK.
+ * switch-c.adb: Remove handling of -gnatH switch.
+
+2012-03-19 Yannick Moy <moy@adacore.com>
+
* sem_ch6.adb (Check_Subprogram_Contract): Do not emit warnings
on trivially True or False postconditions and Ensures components
of contract-cases.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
if With_Extension then
if Present (Src) and then Has_Extension (Src) then
- for J in 1 .. 4 loop
+ for J in 1 .. Num_Extension_Nodes loop
Nodes.Append (Nodes.Table (Src + Node_Id (J)));
end loop;
else
- for J in 1 .. 4 loop
+ for J in 1 .. Num_Extension_Nodes loop
Nodes.Append (Default_Node_Extension);
end loop;
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- syntax tree format. Subsequent processing in the front end traverses the
-- tree, transforming it in various ways and adding semantic information.
+ ----------------------
+ -- Size of Entities --
+ ----------------------
+
+ -- Currently entities are composed of 5 sequentially allocated 32-byte
+ -- nodes, considered as a single record. The following definition gives
+ -- the number of extension nodes.
+
+ Num_Extension_Nodes : Int := 4;
+ -- This value is increased by one if debug flag -gnatd.N is set
+
----------------------------------------
-- Definitions of Fields in Tree Node --
----------------------------------------
-- d.K Alfa detection only mode for gnat2why
-- d.L Depend on back end for limited types in conditional expressions
-- d.M
- -- d.N
+ -- d.N Add node to all entities
-- d.O Dump internal SCO tables
-- d.P Previous (non-optimized) handling of length comparisons
-- d.Q
-- case expansion, leaving it up to the back end to handle conditional
-- expressions correctly.
+ -- d.N Enlarge entities by one node (but don't attempt to use this extra
+ -- node for storage of any flags or fields). This can be used to do
+ -- experiments on the impact of increasing entity sizes.
+
-- d.O Dump internal SCO tables. Before outputting the SCO information to
-- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table)
-- are dumped for debugging purposes.
-- reflect the specified information. However, there are some items that
-- are only reflected in the chain. These include:
--
--- Alignment attribute definition clause
-- Machine_Attribute pragma
-- Link_Alias pragma
-- Linker_Section pragma
+-- Linker_Constructor pragma
+-- Linker_Destructor pragma
-- Weak_External pragma
+-- Thread_Local_Storage pragma
--
-- If any of these items are present, then the flag Has_Gigi_Rep_Item is
-- set, indicating that Gigi should search the chain.
-- Linker_Constructor pragma
-- Linker_Destructor pragma
-- Weak_External pragma
+-- Thread_Local_Storage pragma
--
-- If this flag is set, then Gigi should scan the rep item chain to
-- process any of these items that appear. At least one such item will
Validity_Checks_On := Save_Validity_Checks_On;
end Valid;
+ -------------------
+ -- Valid_Scalars --
+ -------------------
+
+ when Attribute_Valid_Scalars => Valid_Scalars : declare
+ begin
+ raise Program_Error;
+ end Valid_Scalars;
+
-----------
-- Value --
-----------
Ttypes.Target_Strict_Alignment := True;
end if;
+ -- Increase size of allocated entities if debug flag -gnatd.N is set
+
+ if Debug_Flag_Dot_NN then
+ Atree.Num_Extension_Nodes := Atree.Num_Extension_Nodes + 1;
+ end if;
+
-- Disable static allocation of dispatch tables if -gnatd.t or if layout
-- is enabled. The front end's layout phase currently treats types that
-- have discriminant-dependent arrays as not being static even when a
Add_Switch (Argv, Program_Args, And_Save => And_Save);
+ -- Make sure that all significant switches -m on the command line
+ -- are counted.
+
+ if Argv'Length > 2
+ and then Argv (1 .. 2) = "-m"
+ and then Argv /= "-mieee"
+ then
+ N_M_Switch := N_M_Switch + 1;
+ end if;
+
-- Handle non-default compiler, binder, linker, and handle --RTS switch
elsif Argv'Length > 2 and then Argv (1 .. 2) = "--" then
-- Heap size for memory allocations. Valid values are 32 and 64. Only
-- available on VMS.
- HLO_Active : Boolean := False;
- -- GNAT
- -- True if High Level Optimizer is activated (-gnatH switch)
-
Identifier_Character_Set : Character;
-- GNAT
-- This variable indicates the character set to be used for identifiers.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- Called to place complaint about bad range attribute at the given
-- source location. Terminates by raising Error_Resync.
+ procedure Check_Bad_Exp;
+ -- Called after scanning a**b, posts error if ** detected
+
procedure P_Membership_Test (N : Node_Id);
-- N is the node for a N_In or N_Not_In node whose right operand has not
-- yet been processed. It is called just after scanning out the IN keyword.
Resync_Expression;
end Bad_Range_Attribute;
+ -------------------
+ -- Check_Bad_Exp --
+ -------------------
+
+ procedure Check_Bad_Exp is
+ begin
+ if Token = Tok_Double_Asterisk then
+ Error_Msg_SC ("parenthesization required for '*'*");
+ Scan; -- past **
+ Discard_Junk_Node (P_Primary);
+ Check_Bad_Exp;
+ end if;
+ end Check_Bad_Exp;
+
--------------------------
-- 4.1 Name (also 6.4) --
--------------------------
Scan; -- past **
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Primary);
+ Check_Bad_Exp;
Node1 := Node2;
end if;
Scan; -- past **
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Primary);
+ Check_Bad_Exp;
return Node2;
else
return Node1;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
Scan_Ptr := Scan_Ptr + 1;
return;
+ -- Check for something looking like a preprocessor directive
+
+ elsif Source (Scan_Ptr) = '#'
+ and then (Source (Scan_Ptr + 1 .. Scan_Ptr + 2) = "if"
+ or else
+ Source (Scan_Ptr + 1 .. Scan_Ptr + 5) = "elsif"
+ or else
+ Source (Scan_Ptr + 1 .. Scan_Ptr + 4) = "else"
+ or else
+ Source (Scan_Ptr + 1 .. Scan_Ptr + 3) = "end")
+ then
+ Error_Msg_S
+ ("preprocessor directive ignored, preprocessor not active");
+
+ -- Skip to end of line
+
+ loop
+ if Source (Scan_Ptr) in Graphic_Character
+ or else
+ Source (Scan_Ptr) = HT
+ then
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Done if line terminator or EOF
+
+ elsif Source (Scan_Ptr) in Line_Terminator
+ or else
+ Source (Scan_Ptr) = EOF
+ then
+ exit;
+
+ -- If we have a wide character, we have to scan it out,
+ -- because it might be a legitimate line terminator
+
+ elsif Start_Of_Wide_Character then
+ declare
+ Wptr : constant Source_Ptr := Scan_Ptr;
+ Code : Char_Code;
+ Err : Boolean;
+
+ begin
+ Scan_Wide (Source, Scan_Ptr, Code, Err);
+
+ -- If not well formed wide character, then just skip
+ -- past it and ignore it.
+
+ if Err then
+ Scan_Ptr := Wptr + 1;
+
+ -- If UTF_32 terminator, terminate comment scan
+
+ elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
+ Scan_Ptr := Wptr;
+ exit;
+ end if;
+ end;
+
+ -- Else keep going (don't worry about bad comment chars
+ -- in this context, we just want to find the end of line.
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+ end loop;
+
-- Otherwise, this is an illegal character
else
with Errout; use Errout;
with Expander; use Expander;
with Fname; use Fname;
-with HLO; use HLO;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Nlists; use Nlists;
S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
- S_New_Nodes_OK : constant Int := New_Nodes_OK;
S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
Generic_Main : constant Boolean :=
-- and we need to restore these saved values at the end.
procedure Do_Analyze;
- -- Procedure to analyze the compilation unit. This is called more than
- -- once when the high level optimizer is activated.
+ -- Procedure to analyze the compilation unit
----------------
-- Do_Analyze --
if not Analyzed (Comp_Unit) then
Initialize_Version (Current_Sem_Unit);
- if HLO_Active then
- Expander_Mode_Save_And_Set (False);
- New_Nodes_OK := 1;
- Do_Analyze;
- Reset_Analyzed_Flags (Comp_Unit);
- Expander_Mode_Restore;
- High_Level_Optimize (Comp_Unit);
- New_Nodes_OK := 0;
- end if;
-- Do analysis, and then append the compilation unit onto the
-- Comp_Unit_List, if appropriate. This is done after analysis,
GNAT_Mode := S_GNAT_Mode;
In_Spec_Expression := S_In_Spec_Expr;
Inside_A_Generic := S_Inside_A_Generic;
- New_Nodes_OK := S_New_Nodes_OK;
Outer_Generic_Scope := S_Outer_Gen_Scope;
Restore_Opt_Config_Switches (Save_Config_Switches);
package Sem is
- New_Nodes_OK : Int := 1;
- -- Temporary flag for use in checking out HLO. Set non-zero if it is
- -- OK to generate new nodes.
-
-----------------------------
-- Semantic Analysis Flags --
-----------------------------
Set_Etype (N, Standard_Boolean);
+ -------------------
+ -- Valid_Scalars --
+ -------------------
+
+ when Attribute_Valid_Scalars =>
+ Check_E0;
+ Check_Type;
+ -- More stuff TBD ???
+
-----------
-- Value --
-----------
return;
-- No other cases are foldable (they certainly aren't static, and at
- -- the moment we don't try to fold any cases other than these three).
+ -- the moment we don't try to fold any cases other than the ones above).
else
Check_Expressions;
Attribute_Universal_Literal_String |
Attribute_Unrestricted_Access |
Attribute_Valid |
+ Attribute_Valid_Scalars |
Attribute_Value |
Attribute_Wchar_T_Size |
Attribute_Wide_Value |
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- Natural'Size is typically 31, the value of Natural'VADS_Size is 32.
-- For all other types, Size and VADS_Size yield the same value.
+ -------------------
+ -- Valid_Scalars --
+ -------------------
+
+ Attribute_Valid_Scalars => True,
+ -- Typ'Valid_Scalars applies to ???
+
----------------
-- Value_Size --
----------------
-- Start of processing for Expand_With_Clause
begin
- New_Nodes_OK := New_Nodes_OK + 1;
Withn :=
Make_With_Clause (Loc,
Name => Build_Unit_Name (Nam));
if Nkind (Nam) = N_Expanded_Name then
Expand_With_Clause (Item, Prefix (Nam), N);
end if;
-
- New_Nodes_OK := New_Nodes_OK - 1;
end Expand_With_Clause;
-----------------------
return;
end if;
- New_Nodes_OK := New_Nodes_OK + 1;
Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
Set_Library_Unit (Withn, P);
if Is_Child_Spec (P_Unit) then
Implicit_With_On_Parent (P_Unit, N);
end if;
-
- New_Nodes_OK := New_Nodes_OK - 1;
end Implicit_With_On_Parent;
--------------
-- Start of processing for Expand_Limited_With_Clause
begin
- New_Nodes_OK := New_Nodes_OK + 1;
-
if Nkind (Nam) = N_Identifier then
-- Create node for name of withed unit
Install_Limited_Withed_Unit (Withn);
end if;
end if;
-
- New_Nodes_OK := New_Nodes_OK - 1;
end Expand_Limited_With_Clause;
----------------------
-- is precisely evaluated in the pre-state. Otherwise return OK.
function Is_Trivial_Post_Or_Ensures (N : Node_Id) return Boolean;
- -- Return whether node N is trivially "True" or "False"
+ -- Return True if node N is trivially "True" or "False", and it comes
+ -- from source. In particular, nodes that are statically known "True" or
+ -- "False" by the compiler but not written as such in source code are
+ -- not considered as trivial.
procedure Process_Contract_Cases (Spec : Node_Id);
-- This processes the Spec_CTC_List from Spec, processing any contract
return Is_Entity_Name (N)
and then (Entity (N) = Standard_True
or else
- Entity (N) = Standard_False);
+ Entity (N) = Standard_False)
+ and then Comes_From_Source (N);
end Is_Trivial_Post_Or_Ensures;
----------------------------
In_Init_Proc : Boolean := False);
-- This is the internal recursive routine that is called to check for
-- possible elaboration error. The argument N is a subprogram call or
- -- generic instantiation to be checked, and E is the entity of the called
- -- subprogram, or instantiated generic unit. The flag Outer_Scope is the
- -- outer level scope for the original call. Inter_Unit_Only is set if the
- -- call is only to be checked in the case where it is to another unit (and
- -- skipped if within a unit). Generate_Warnings is set to False to suppress
- -- warning messages about missing pragma Elaborate_All's. These messages
- -- are not wanted for inner calls in the dynamic model. Note that an
- -- instance of the Access attribute applied to a subprogram also generates
- -- a call to this procedure (since the referenced subprogram may be called
- -- later indirectly). Flag In_Init_Proc should be set whenever the current
+ -- generic instantiation, or 'Access attribute reference to be checked, and
+ -- E is the entity of the called subprogram, or instantiated generic unit,
+ -- or subprogram referenced by 'Access.
+ --
+ -- The flag Outer_Scope is the outer level scope for the original call.
+ -- Inter_Unit_Only is set if the call is only to be checked in the
+ -- case where it is to another unit (and skipped if within a unit).
+ -- Generate_Warnings is set to False to suppress warning messages about
+ -- missing pragma Elaborate_All's. These messages are not wanted for
+ -- inner calls in the dynamic model. Note that an instance of the Access
+ -- attribute applied to a subprogram also generates a call to this
+ -- procedure (since the referenced subprogram may be called later
+ -- indirectly). Flag In_Init_Proc should be set whenever the current
-- context is a type init proc.
procedure Check_Bad_Instantiation (N : Node_Id);
Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
-- Indicates if we have instantiation case
+ Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
+ -- Indicates if we have Access attribute case
+
Caller_Unit_Internal : Boolean;
Callee_Unit_Internal : Boolean;
Is_Internal_File_Name
(Unit_File_Name (Get_Source_Unit (E_Scope)));
- -- Do not give a warning if the with'ed unit is internal
- -- and this is the generic instantiation case (this saves a
- -- lot of hassle dealing with the Text_IO special child units)
+ -- Do not give a warning if the with'ed unit is internal and this is
+ -- the generic instantiation case (this saves a lot of hassle dealing
+ -- with the Text_IO special child units)
if Callee_Unit_Internal and Inst_Case then
return;
(Unit_File_Name (Get_Source_Unit (C_Scope)));
end if;
- -- Do not give a warning if the with'ed unit is internal
- -- and the caller is not internal (since the binder always
- -- elaborates internal units first).
+ -- Do not give a warning if the with'ed unit is internal and the
+ -- caller is not internal (since the binder always elaborates
+ -- internal units first).
if Callee_Unit_Internal and (not Caller_Unit_Internal) then
return;
end if;
-- If the call is in an instance, and the called entity is not
- -- defined in the same instance, then the elaboration issue
- -- focuses around the unit containing the template, it is
- -- this unit which requires an Elaborate_All.
+ -- defined in the same instance, then the elaboration issue focuses
+ -- around the unit containing the template, it is this unit which
+ -- requires an Elaborate_All.
- -- However, if we are doing dynamic elaboration, we need to
- -- chase the call in the usual manner.
+ -- However, if we are doing dynamic elaboration, we need to chase the
+ -- call in the usual manner.
- -- We do not handle the case of calling a generic formal correctly
- -- in the static case. See test 4703-004 to explore this gap ???
+ -- We do not handle the case of calling a generic formal correctly in
+ -- the static case.???
Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
Ent : Node_Or_Entity_Id);
-- Generate a call to Error_Msg_NE with parameters Msg_D or
-- Msg_S (for dynamic or static elaboration model), N and Ent.
+ -- Msg_D is suppressed for the attribute reference case, since
+ -- we never raise Program_Error for an attribute reference.
------------------
-- Elab_Warning --
is
begin
if Dynamic_Elaboration_Checks then
- Error_Msg_NE (Msg_D, N, Ent);
+ if not Access_Case then
+ Error_Msg_NE (Msg_D, N, Ent);
+ end if;
else
Error_Msg_NE (Msg_S, N, Ent);
end if;
-- Start of processing for Generate_Elab_Warnings
begin
+ -- Instantiation case
+
if Inst_Case then
Elab_Warning
("instantiation of& may raise Program_Error?",
"info: instantiation of& during elaboration?", Ent);
+ -- Indirect call case, warning only in static elaboration
+ -- case, because the attribute reference itself cannot raise
+ -- an exception.
+
+ elsif Access_Case then
+ Elab_Warning
+ ("", "info: access to& during elaboration?", Ent);
+
+ -- Subprogram call case
+
else
if Nkind (Name (N)) in N_Has_Entity
and then Is_Init_Proc (Entity (Name (N)))
("\missing pragma Elaborate for&?",
"\info: implicit pragma Elaborate for& generated?",
W_Scope);
+
else
Elab_Warning
("\missing pragma Elaborate_All for&?",
Insert_Elab_Check (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
- Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
+ Prefix =>
+ New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
-- Prevent duplicate elaboration checks on the same call,
-- which can happen if the body enclosing the call appears
-- Do not generate an Elaborate_All for finalization routines
-- which perform partial clean up as part of initialization.
- elsif In_Init_Proc
- and then Is_Finalization_Procedure (Ent)
- then
+ elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then
null;
-- Here we need to generate an implicit elaborate all
Name_VADS_Size : constant Name_Id := N + $; -- GNAT
Name_Val : constant Name_Id := N + $;
Name_Valid : constant Name_Id := N + $;
+ Name_Valid_Scalars : constant Name_Id := N + $; -- GNAT
Name_Value_Size : constant Name_Id := N + $; -- GNAT
Name_Variable_Indexing : constant Name_Id := N + $; -- GNAT
Name_Version : constant Name_Id := N + $;
Attribute_VADS_Size,
Attribute_Val,
Attribute_Valid,
+ Attribute_Valid_Scalars,
Attribute_Value_Size,
Attribute_Variable_Indexing,
Attribute_Version,
Ptr := Ptr + 1;
Usage_Requested := True;
- -- Processing for H switch
-
- when 'H' =>
- Ptr := Ptr + 1;
- HLO_Active := True;
-
-- Processing for i switch
when 'i' =>
projects / platform / upstream / linaro-gcc.git / commitdiff