+2013-07-08 Robert Dewar <dewar@adacore.com>
+
+ * sem.ads: Minor comment updates.
+ * s-restri.ads, exp_ch6.adb, lib-load.ads, exp_ch3.adb, sem_ch10.adb:
+ Minor reformatting.
+
+2013-07-08 Robert Dewar <dewar@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Add dummy entry
+ for Restriction_Set.
+ * gnat_rm.texi: Add missing menu entry for Attribute Ref Add
+ documentation for attribute Restriction_Set.
+ * lib-writ.adb (Write_With_Lines): Generate special W lines
+ for Restriction_Set.
+ * lib-writ.ads: Document special use of W lines for
+ Restriction_Set.
+ * lib.ads (Restriction_Set_Dependences): New table.
+ * par-ch4.adb (Is_Parameterless_Attribute): Add Loop_Entry to
+ list (Scan_Name_Extension_Apostrophe): Remove kludge test for
+ Loop_Entry (Scan_Name_Extension_Apostrophe): Handle No_Dependence
+ for Restricton_Set.
+ * restrict.adb (Check_SPARK_Restriction): Put in Alfa order
+ (OK_No_Dependence_Unit_Name): New function.
+ * restrict.ads (OK_No_Dependence_Unit_Name): New function.
+ * rtsfind.adb: Minor reformatting Minor code reorganization.
+ * sem_attr.adb (Analyze_Attribute): Add processing for
+ Restriction_Set.
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Remove Check_Unit_Name and use new function
+ OK_No_Dependence_Unit_Name instead.
+ * sinfo.ads: Minor comment updates.
+ * snames.ads-tmpl: Add entry for Restriction_Set attribute.
+
+2013-07-08 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Apply_Accessibility_Check): Remove local constant
+ Pool_Id and local variable Free_Stmt. Do not deallocate the faulty
+ object as "free" is not available on all targets/profiles.
+
+2013-07-08 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Handle
+ Storage_Size aspect for task type in case discriminant is
+ referenced.
+ (Analyze_Attribute_Definition_Clause): Do not flag Storage_Size
+ attribute definition clause as obsolescent if from aspect.
+
2013-07-08 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Add documentation for Img returning a function.
Attribute_Modulus |
Attribute_Partition_ID |
Attribute_Range |
+ Attribute_Restriction_Set |
Attribute_Safe_Emax |
Attribute_Safe_First |
Attribute_Safe_Large |
-- end case;
function Make_Eq_Case
- (E : Entity_Id;
- CL : Node_Id;
+ (E : Entity_Id;
+ CL : Node_Id;
Discrs : Elist_Id := New_Elmt_List) return List_Id
is
Loc : constant Source_Ptr := Sloc (E);
return Name_Find;
end External_Name;
+ -- Start of processing for Make_Eq_Case
+
begin
Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
(Ref : Node_Id;
Built_In_Place : Boolean := False)
is
- Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
- Cond : Node_Id;
- Free_Stmt : Node_Id;
- Obj_Ref : Node_Id;
- Stmts : List_Id;
+ Cond : Node_Id;
+ Obj_Ref : Node_Id;
+ Stmts : List_Id;
begin
if Ada_Version >= Ada_2005
Stmts := New_List;
- -- If the target does not support allocation/deallocation, simply
- -- finalize the object (if applicable). Generate:
+ -- Why don't we free the object ??? discussion and explanation
+ -- needed of why old approach did not work ???
+ -- Generate:
-- [Deep_]Finalize (Obj_Ref.all);
- if Restriction_Active (No_Implicit_Heap_Allocations) then
- if Needs_Finalization (DesigT) then
- Append_To (Stmts,
- Make_Final_Call (
- Obj_Ref =>
- Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
- Typ => DesigT));
- end if;
-
- -- Finalize (if applicable) and deallocate the object in case the
- -- accessibility check fails.
-
- else
- -- Create an explicit free statement to clean up the allocated
- -- object in case the accessibility check fails. Generate:
-
- -- Free (Obj_Ref);
-
- Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
- Set_Storage_Pool (Free_Stmt, Pool_Id);
-
- Append_To (Stmts, Free_Stmt);
-
- -- Finalize the object (if applicable), but wrap the call
- -- inside a block to ensure that the object would still be
- -- deallocated in case the finalization fails. Generate:
-
- -- begin
- -- [Deep_]Finalize (Obj_Ref.all);
- -- exception
- -- when others =>
- -- Free (Obj_Ref);
- -- raise;
- -- end;
-
- if Needs_Finalization (DesigT) then
- Prepend_To (Stmts,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call (
- Obj_Ref =>
- Make_Explicit_Dereference (Loc,
- Prefix => New_Copy (Obj_Ref)),
- Typ => DesigT)),
-
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (
- New_Copy_Tree (Free_Stmt),
- Make_Raise_Statement (Loc)))))));
- end if;
+ if Needs_Finalization (DesigT) then
+ Append_To (Stmts,
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
+ Typ => DesigT));
end if;
-- Signal the accessibility failure through a Program_Error
+ -- Since we may have a storage leak, I would be inclined to
+ -- define a new PE_ code that warns of this possibility where
+ -- the message would be Accessibility_Check_Failed (causing
+ -- storage leak) ???
+
Append_To (Stmts,
Make_Raise_Program_Error (Loc,
Condition => New_Reference_To (Standard_True, Loc),
-- We perform these optimization regardless of whether we are in the
-- main unit or in a unit in the context of the main unit, to ensure
- -- that tree generated is the same in both cases, for Inspector use.
+ -- that tree generated is the same in both cases, for CodePeer use.
if Is_RTE (Subp, RE_To_Address) then
Rewrite (Call_Node,
* Attribute Passed_By_Reference::
* Attribute Pool_Address::
* Attribute Range_Length::
+* Attribute Ref::
+* Attribute Restriction_Set::
* Attribute Result::
* Attribute Safe_Emax::
* Attribute Safe_Large::
* Attribute Pool_Address::
* Attribute Range_Length::
* Attribute Ref::
+* Attribute Restriction_Set::
* Attribute Result::
* Attribute Safe_Emax::
* Attribute Safe_Large::
@unnumberedsec Attribute Ref
@findex Ref
@noindent
-The @code{System.Address'Ref}
-(@code{System.Address} is the only permissible prefix)
-denotes a function identical to
-@code{System.Storage_Elements.To_Address} except that
-it is a static attribute. See @ref{Attribute To_Address} for more details.
+
+
+@node Attribute Restriction_Set
+@unnumberedsec Attribute Restriction_Set
+@findex Restriction_Set
+@cindex Restrictions
+@noindent
+This attribute allows compile time testing of restrictions that
+are currently in effect. It is primarily intended for specializing
+code in the run-time based on restrictions that are active (e.g.
+don't need to save fpt registers if restriction No_Floating_Point
+is known to be in effect), but can be used anywhere.
+
+There are two forms:
+
+@smallexample @c ada
+System'Restriction_Set (partition_boolean_restriction_NAME)
+System'Restriction_Set (No_Dependence => library_unit_NAME);
+@end smallexample
+
+@noindent
+In the case of the first form, the only restriction names
+allowed are parameterless restrictions that are checked
+for consistency at bind time. For a complete list see the
+subtype @code{System.Rident.Partition_Boolean_Restrictions}.
+
+The result returned is True if the restriction is known to
+be in effect, and False if the restriction is known not to
+be in effect. An important guarantee is that the value of
+a Restriction_Set attribute is known to be consistent throughout
+all the code of a partition.
+
+This is trivially achieved if the entire partition is compiled
+with a consistent set of restriction pragmas. However, the
+compilation model does not require this. It is possible to
+compile one set of units with one set of pragmas, and another
+set of units with another set of pragmas. It is even possible
+to compile a spec with one set of pragmas, and then WITH the
+same spec with a different set of pragmas. Inconsistencies
+in the actual use of the restriction are checked at bind time.
+
+In order to achieve the guarantee of consistency for the
+Restriction_Set pragma, we consider that a use of the pragma
+that yields False is equivalent to a violation of the
+restriction.
+
+So for example if you write
+
+@smallexample @c ada
+if System'Restriction_Set (No_Floating_Point) then
+ ...
+else
+ ...
+end if;
+@end smallexample
+
+@noindent
+And the result is False, so that the else branch is executed,
+you can assume that this restriction is not set for any unit
+in the partition. This is checked by considering this use of
+the restriction pragma to be a violation of the restriction
+No_Floating_Point. This means that no other unit can attempt
+to set this restriction (if some unit does attempt to set it,
+the binder will refuse to bind the partition).
+
+Technical note: The restriction name and the unit name are
+intepreted entirely syntactically, as in the corresponding
+Restrictions pragma, they are not analyzed semantically,
+so they do not have a type.
@node Attribute Result
@unnumberedsec Attribute Result
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, 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- --
-- generate a compilation unit node for it, and we need to make an entry
-- for it in the units table, so as to maintain a one-to-one mapping
-- between table and nodes. The table entry is used among other things to
- -- provide a canonical traversal order for context units for Inspector.
+ -- provide a canonical traversal order for context units for CodePeer.
-- The flag In_Main indicates whether the instance is the main unit.
procedure Version_Update (U : Node_Id; From : Node_Id);
Write_Info_EOL;
end loop;
+
+ -- Finally generate the special lines for cases of Restriction_Set
+ -- with No_Dependence and no restriction present.
+
+ declare
+ Unam : Unit_Name_Type;
+
+ begin
+ for J in Restriction_Set_Dependences.First ..
+ Restriction_Set_Dependences.Last
+ loop
+ Unam := Restriction_Set_Dependences.Table (J);
+
+ -- Don't need an entry if already in the unit table
+
+ for U in 0 .. Last_Unit loop
+ if Unit_Name (U) = Unam then
+ goto Continue;
+ end if;
+ end loop;
+
+ -- Otherwise generate the entry
+
+ Write_Info_Initiate ('W');
+ Write_Info_Char (' ');
+ Write_Info_Name (Unam);
+ Write_Info_EOL;
+
+ <<Continue>>
+ null;
+ end loop;
+ end;
end Write_With_Lines;
-- Start of processing for Write_ALI
-- No restriction pragma is present for the named boolean restriction.
-- However, the compiler did detect one or more violations of this
- -- restriction, which may require a binder consistency check.
+ -- restriction, which may require a binder consistency check. Note that
+ -- one case of a violation is the use of a Restriction_Set attribute for
+ -- the restriction that yielded False.
-- For the case of restrictions that take a parameter, we need both the
-- information from pragma if present, and the actual information about
-- Following each U line, is a series of lines of the form
-- W unit-name [source-name lib-name] [E] [EA] [ED] [AD]
- -- or
+ -- or
-- Y unit-name [source-name lib-name] [E] [EA] [ED] [AD]
- -- or
+ -- or
-- Z unit-name [source-name lib-name] [E] [EA] [ED] [AD]
--
-- One W line is present for each unit that is mentioned in an explicit
-- The parameter source-name and lib-name are omitted for the case of a
-- generic unit compiled with earlier versions of GNAT which did not
-- generate object or ali files for generics.
+ --
+ -- The parameter source-name and lib-name are also omitted for the W
+ -- lines that result from use of a Restriction_Set attribute which gets
+ -- a result of False from a No_Dependence check, in the case where the
+ -- unit is not in the semantic closure. In such a case, the bare W
+ -- line is generated, but no D (dependency) line. This will make the
+ -- binder do the consistency check, but not include the unit in the
+ -- partition closure (unless it is properly With'ed somewhere).
-- -----------------------
-- -- L Linker_Options --
-- of the printout. If Withs is True, we print out units with'ed by this
-- unit (not counting limited withs).
+ ---------------------------------------------------------------
+ -- Special Handling for Restriction_Set (No_Dependence) Case --
+ ---------------------------------------------------------------
+
+ -- If we have a Restriction_Set attribute for No_Dependence => unit,
+ -- and the unit is not given in a No_Dependence restriction that we
+ -- can see, the attribute will return False.
+
+ -- We have to ensure in this case that the binder will reject any attempt
+ -- to set a No_Dependence restriction in some other unit in the partition.
+
+ -- If the unit is in the semantic closure, then of course it is properly
+ -- WITH'ed by someone, and the binder will do this job automatically as
+ -- part of its normal processing.
+
+ -- But if the unit is not in the semantic closure, we must make sure the
+ -- binder knows about it. The use of the Restriction_Set attribute giving
+ -- a result of False does not mean of itself that we have to include the
+ -- unit in the partition. So what we do is to generate a with (W) line in
+ -- the ali file (with no file name information), but no corresponding D
+ -- (dependency) line. This is recognized by the binder as meaning "Don't
+ -- let anyone specify No_Dependence for this unit, but you don't have to
+ -- include it if there is no real W line for the unit".
+
+ -- The following table keeps track of relevant units. It is used in the
+ -- Lib.Writ circuit for outputting With lines to output the special with
+ -- line with RA if the unit is not in the semantic closure.
+
+ package Restriction_Set_Dependences is new Table.Table (
+ Table_Component_Type => Unit_Name_Type,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Restriction_Attribute_Dependences");
+
private
pragma Inline (Cunit);
pragma Inline (Cunit_Entity);
Attribute_Class => True,
Attribute_External_Tag => True,
Attribute_Img => True,
+ Attribute_Loop_Entry => True,
Attribute_Stub_Type => True,
Attribute_Version => True,
Attribute_Type_Key => True,
-- list because it may denote a slice operation (X'Img (1 .. 2)) or
-- a type conversion (X'Class (Y)).
+ -- Note: Loop_Entry is in this list because, although it can take an
+ -- optional argument (the loop name), we can't distinguish that at parse
+ -- time from the case where no loop name is given and a legitimate index
+ -- expression is present. So we parse the argument as an indexed component
+ -- and the semantic analysis sorts out this syntactic ambiguity based on
+ -- the type and form of the expression.
+
-- Note that this map designates the minimum set of attributes where a
-- construct in parentheses that is not an argument can appear right
-- after the attribute. For attributes like 'Size, we do not put them
Set_Attribute_Name (Name_Node, Attr_Name);
-- Scan attribute arguments/designator. We skip this if we know
- -- that the attribute cannot have an argument.
+ -- that the attribute cannot have an argument (see documentation
+ -- of Is_Parameterless_Attribute for further details).
if Token = Tok_Left_Paren
and then not
Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
then
- -- Attribute Loop_Entry has no effect on the name extension
- -- parsing logic, as if the attribute never existed in the
- -- source. Continue parsing the subsequent expressions or
- -- ranges.
-
- if Attr_Name = Name_Loop_Entry then
- Scan; -- past left paren
- goto Scan_Name_Extension_Left_Paren;
-
-- Attribute Update contains an array or record association
-- list which provides new values for various components or
- -- elements. The list is parsed as an aggregate.
+ -- elements. The list is parsed as an aggregate, and we get
+ -- better error handling by knowing that in the parser.
- elsif Attr_Name = Name_Update then
+ if Attr_Name = Name_Update then
Set_Expressions (Name_Node, New_List);
Append (P_Aggregate, Expressions (Name_Node));
+ -- All other cases of parsing attribute arguments
+
else
Set_Expressions (Name_Node, New_List);
Scan; -- past left paren
loop
declare
Expr : constant Node_Id := P_Expression_If_OK;
+ Rnam : Node_Id;
begin
+ -- Case of => for named notation
+
if Token = Tok_Arrow then
- Error_Msg_SC
- ("named parameters not permitted for attributes");
- Scan; -- past junk arrow
+
+ -- Named notation allowed only for the special
+ -- case of System'Restriction_Set (No_Dependence =>
+ -- unit_NAME), in which case construct a parameter
+ -- assocation node and append to the arguments.
+
+ if Attr_Name = Name_Restriction_Set
+ and then Nkind (Expr) = N_Identifier
+ and then Chars (Expr) = Name_No_Dependence
+ then
+ Scan; -- past arrow
+ Rnam := P_Name;
+ Append_To (Expressions (Name_Node),
+ Make_Parameter_Association (Sloc (Rnam),
+ Selector_Name => Expr,
+ Explicit_Actual_Parameter => Rnam));
+ exit;
+
+ -- For all other cases named notation is illegal
+
+ else
+ Error_Msg_SC
+ ("named parameters not permitted "
+ & "for attributes");
+ Scan; -- past junk arrow
+ end if;
+
+ -- Here for normal case (not => for named parameter)
else
Append (Expr, Expressions (Name_Node));
Check_Restriction (No_Elaboration_Code, N);
end Check_Elaboration_Code_Allowed;
- -----------------------------
- -- Check_SPARK_Restriction --
- -----------------------------
-
- procedure Check_SPARK_Restriction
- (Msg : String;
- N : Node_Id;
- Force : Boolean := False)
- is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
-
- begin
- if Force or else Comes_From_Source (Original_Node (N)) then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg, N);
- end if;
- end if;
- end Check_SPARK_Restriction;
-
- procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
-
- begin
- pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
-
- if Comes_From_Source (Original_Node (N)) then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg1, N);
- Error_Msg_F (Msg2, N);
- end if;
- end if;
- end Check_SPARK_Restriction;
-
--------------------------------
-- Check_No_Implicit_Aliasing --
--------------------------------
and then Restriction_Active (No_Exception_Propagation);
end No_Exception_Propagation_Active;
+ --------------------------------
+ -- OK_No_Dependence_Unit_Name --
+ --------------------------------
+
+ function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Selected_Component then
+ return
+ OK_No_Dependence_Unit_Name (Prefix (N))
+ and then
+ OK_No_Dependence_Unit_Name (Selector_Name (N));
+
+ elsif Nkind (N) = N_Identifier then
+ return True;
+
+ else
+ Error_Msg_N ("wrong form for unit name for No_Dependence", N);
+ return False;
+ end if;
+ end OK_No_Dependence_Unit_Name;
+
----------------------------------
-- Process_Restriction_Synonyms --
----------------------------------
end if;
end Set_Restriction_No_Use_Of_Pragma;
+ -----------------------------
+ -- Check_SPARK_Restriction --
+ -----------------------------
+
+ procedure Check_SPARK_Restriction
+ (Msg : String;
+ N : Node_Id;
+ Force : Boolean := False)
+ is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+
+ begin
+ if Force or else Comes_From_Source (Original_Node (N)) then
+ if Restriction_Check_Required (SPARK_05)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg, N);
+ end if;
+ end if;
+ end Check_SPARK_Restriction;
+
+ procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+
+ begin
+ pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
+
+ if Comes_From_Source (Original_Node (N)) then
+ if Restriction_Check_Required (SPARK_05)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg1, N);
+ Error_Msg_F (Msg2, N);
+ end if;
+ end if;
+ end Check_SPARK_Restriction;
+
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
-- identifier, and if so returns the corresponding Restriction_Id value,
-- otherwise returns Not_A_Restriction_Id.
+ function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean;
+ -- Used in checking No_Dependence argument of pragma Restrictions or
+ -- pragma Restrictions_Warning, or attribute Restriction_Set. Returns
+ -- True if N has the proper form for a unit name, False otherwise.
+
function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean;
-- Determine if given location is covered by a hidden region range in the
-- SPARK hides table.
-- A unit retrieved through rtsfind may end up in the context of several
-- other units, in addition to the main unit. These additional with_clauses
- -- are needed to generate a proper traversal order for Inspector. To
+ -- are needed to generate a proper traversal order for CodePeer. To
-- minimize somewhat the redundancy created by numerous calls to rtsfind
-- from different units, we keep track of the list of implicit with_clauses
-- already created for the current loaded unit.
-- with_clauses to the extended main unit if needed, and also to whatever
-- unit needs them, which is not necessarily the main unit. The former
-- ensures that the object is correctly loaded by the binder. The latter
- -- is necessary for SofCheck Inspector.
+ -- is necessary for CodePeer.
-- The field First_Implicit_With in the unit table record are used to
-- avoid creating duplicate with_clauses.
-- We do not need to generate a with_clause for a call issued from
-- RTE_Component_Available. However, for CodePeer, we need these
-- additional with's, because for a sequence like "if RTE_Available (X)
- -- then ... RTE (X)" the RTE call fails to create some necessary
- -- with's.
+ -- then ... RTE (X)" the RTE call fails to create some necessary with's.
- if RTE_Available_Call and then not Generate_SCIL then
+ if RTE_Available_Call and not Generate_SCIL then
return;
end if;
return;
end if;
- -- Add the with_clause, if not already in the context of the
- -- current compilation unit.
+ -- Add the with_clause, if not already in the context of the current
+ -- compilation unit.
declare
LibUnit : constant Node_Id := Unit (Cunit (U.Unum));
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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- --
pragma Discard_Names;
package Rident is new System.Rident;
+ -- Instantiate a copy of System.Rident without enumeration image names
Run_Time_Restrictions : Rident.Restrictions_Info;
-- Restrictions as set by the user, or detected by the binder. See details
-- and the format of the information.
--
-- Note that a restriction which is both Set and Violated at run-time means
- -- that the violation was detected as part of the Ada run-time and not
- -- as part of user code.
+ -- that the violation was detected as part of the Ada run-time and not as
+ -- part of user code.
------------------
-- Subprograms --
function Abort_Allowed return Boolean;
pragma Inline (Abort_Allowed);
-- Tests to see if abort is allowed by the current restrictions settings.
- -- For abort to be allowed, either No_Abort_Statements must be False,
- -- or Max_Asynchronous_Select_Nesting must be non-zero.
+ -- For abort to be allowed, either No_Abort_Statements must be False, or
+ -- Max_Asynchronous_Select_Nesting must be non-zero.
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests to see if tasking operations are allowed by the current
- -- restrictions settings. For tasking to be allowed, No_Tasking
- -- must be False, and Max_Tasks must not be set to zero.
+ -- restrictions settings. For tasking to be allowed, No_Tasking must
+ -- be False, and Max_Tasks must not be set to zero.
end System.Restrictions;
generic
with procedure Action (Item : Node_Id);
procedure Walk_Library_Items;
- -- Primarily for use by SofCheck Inspector. Must be called after semantic
- -- analysis (and expansion) are complete. Walks each relevant library item,
- -- calling Action for each, in an order such that one will not run across
- -- forward references. Each Item passed to Action is the declaration or
- -- body of a library unit, including generics and renamings. The first item
- -- is the N_Package_Declaration node for package Standard. Bodies are not
+ -- Primarily for use by CodePeer. Must be called after semantic analysis
+ -- (and expansion) are complete. Walks each relevant library item, calling
+ -- Action for each, in an order such that one will not run across forward
+ -- references. Each Item passed to Action is the declaration or body of
+ -- a library unit, including generics and renamings. The first item is
+ -- the N_Package_Declaration node for package Standard. Bodies are not
-- included, except for the main unit itself, which always comes last.
--
-- Item is never a subunit
-- Item is never an instantiation. Instead, the instance declaration is
-- passed, and (if the instantiation is the main unit), the instance body.
- -- Debugging:
+ ------------------------
+ -- Debugging Routines --
+ ------------------------
function ss (Index : Int) return Scope_Stack_Entry;
pragma Export (Ada, ss);
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Uname; use Uname;
with Urealp; use Urealp;
package body Sem_Attr is
begin
Check_E0;
- if Nkind (P) /= N_Identifier
- or else Chars (P) /= Name_Standard
- then
+ if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then
Error_Attr ("only allowed prefix for % attribute is Standard", P);
end if;
end Check_Standard_Prefix;
Btyp : Entity_Id;
In_Shared_Var_Procs : Boolean;
- -- True when compiling the body of System.Shared_Storage.
- -- Shared_Var_Procs. For this runtime package (always compiled in
- -- GNAT mode), we allow stream attributes references for limited
- -- types for the case where shared passive objects are implemented
- -- using stream attributes, which is the default in GNAT's persistent
- -- storage implementation.
+ -- True when compiling System.Shared_Storage.Shared_Var_Procs body.
+ -- For this runtime package (always compiled in GNAT mode), we allow
+ -- stream attributes references for limited types for the case where
+ -- shared passive objects are implemented using stream attributes,
+ -- which is the default in GNAT's persistent storage implementation.
begin
Validate_Non_Static_Attribute_Function_Call;
-- some attributes for which we do not analyze the prefix, since the
-- prefix is not a normal name, or else needs special handling.
- if Aname /= Name_Elab_Body
- and then
- Aname /= Name_Elab_Spec
- and then
- Aname /= Name_Elab_Subp_Body
- and then
- Aname /= Name_UET_Address
- and then
- Aname /= Name_Enabled
- and then
+ if Aname /= Name_Elab_Body and then
+ Aname /= Name_Elab_Spec and then
+ Aname /= Name_Elab_Subp_Body and then
+ Aname /= Name_UET_Address and then
+ Aname /= Name_Enabled and then
Aname /= Name_Old
then
Analyze (P);
else
E1 := First (Exprs);
- Analyze (E1);
- -- Check for missing/bad expression (result of previous error)
+ -- Skip analysis for case of Restriction_Set, we do not expect
+ -- the argument to be analyzed in this case.
- if No (E1) or else Etype (E1) = Any_Type then
- raise Bad_Attribute;
+ if Aname /= Name_Restriction_Set then
+ Analyze (E1);
+
+ -- Check for missing/bad expression (result of previous error)
+
+ if No (E1) or else Etype (E1) = Any_Type then
+ raise Bad_Attribute;
+ end if;
end if;
E2 := Next (E1);
Resolve (E1, P_Base_Type);
Resolve (E2, P_Base_Type);
+ ---------------------
+ -- Restriction_Set --
+ ---------------------
+
+ when Attribute_Restriction_Set => Restriction_Set : declare
+ R : Restriction_Id;
+ U : Node_Id;
+ Unam : Unit_Name_Type;
+
+ procedure Set_Result (B : Boolean);
+ -- Replace restriction node by static constant False or True,
+ -- depending on the value of B.
+
+ ----------------
+ -- Set_Result --
+ ----------------
+
+ procedure Set_Result (B : Boolean) is
+ begin
+ if B then
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ end if;
+
+ Set_Is_Static_Expression (N);
+ end Set_Result;
+
+ -- Start of processing for Restriction_Set
+
+ begin
+ Check_E1;
+ Analyze (P);
+
+ if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
+ Set_Result (False);
+ Error_Attr_P ("prefix of % attribute must be System");
+ end if;
+
+ -- No_Dependence case
+
+ if Nkind (E1) = N_Parameter_Association then
+ pragma Assert (Chars (Selector_Name (E1)) = Name_No_Dependence);
+ U := Explicit_Actual_Parameter (E1);
+
+ if not OK_No_Dependence_Unit_Name (U) then
+ Set_Result (False);
+ Error_Attr;
+ end if;
+
+ -- See if there is an entry already in the table. That's the
+ -- case in which we can return True.
+
+ for J in No_Dependences.First .. No_Dependences.Last loop
+ if Designate_Same_Unit (U, No_Dependences.Table (J).Unit)
+ and then No_Dependences.Table (J).Warn = False
+ then
+ Set_Result (True);
+ return;
+ end if;
+ end loop;
+
+ -- If not in the No_Dependence table, result is False
+
+ Set_Result (False);
+
+ -- In this case, we must ensure that the binder will reject any
+ -- other unit in the partition that sets No_Dependence for this
+ -- unit. We do that by making an entry in the special table kept
+ -- for this purpose (if the entry is not there already).
+
+ Unam := Get_Spec_Name (Get_Unit_Name (U));
+
+ for J in Restriction_Set_Dependences.First ..
+ Restriction_Set_Dependences.Last
+ loop
+ if Restriction_Set_Dependences.Table (J) = Unam then
+ return;
+ end if;
+ end loop;
+
+ Restriction_Set_Dependences.Append (Unam);
+
+ -- Normal restriction case
+
+ else
+ if Nkind (E1) /= N_Identifier then
+ Set_Result (False);
+ Error_Attr ("attribute % requires restriction identifier", E1);
+
+ else
+ R := Get_Restriction_Id (Process_Restriction_Synonyms (E1));
+
+ if R = Not_A_Restriction_Id then
+ Set_Result (False);
+ Error_Msg_Node_1 := E1;
+ Error_Attr ("invalid restriction identifier &", E1);
+
+ elsif R not in Partition_Boolean_Restrictions then
+ Set_Result (False);
+ Error_Msg_Node_1 := E1;
+ Error_Attr
+ ("& is not a boolean partition-wide restriction", E1);
+ end if;
+
+ if Restriction_Active (R) then
+ Set_Result (True);
+ else
+ Check_Restriction (R, N);
+ Set_Result (False);
+ end if;
+ end if;
+ end if;
+ end Restriction_Set;
+
-----------
-- Round --
-----------
Check_E1;
Analyze (P);
- if Nkind (P) /= N_Identifier
- or else Chars (P) /= Name_System
- then
+ if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
Error_Attr_P ("prefix of % attribute must be System");
end if;
Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static);
end Remainder;
+ -----------------
+ -- Restriction --
+ -----------------
+
+ when Attribute_Restriction_Set => Restriction_Set : declare
+ begin
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ Set_Is_Static_Expression (N);
+ end Restriction_Set;
+
-----------
-- Round --
-----------
Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True);
- -- If the unit is a package or generic package declaration, a private_
+ -- If the unit is a package or generic package declaration, a private_
-- with_clause on a child unit implies that the implicit with on the
-- parent is also private.
Aspect_Small |
Aspect_Simple_Storage_Pool |
Aspect_Storage_Pool |
- Aspect_Storage_Size |
Aspect_Stream_Size |
Aspect_Value_Size |
Aspect_Variable_Indexing |
Analyze_Aspect_Dimension_System (N, Id, Expr);
goto Continue;
- -- Case 4: Special handling for aspects
+ -- Case 4: Aspects requiring special handling
-- Pre/Post/Test_Case/Contract_Cases whose corresponding
-- pragmas take care of the delay.
else
Aitem := Empty;
end if;
+
+ -- Storage_Size
+
+ -- This is special because for access types we need to generate
+ -- an attribute definition clause. This also works for single
+ -- task declarations, but it does not work for task type
+ -- declarations, because we have the case where the expression
+ -- references a discriminant of the task type. That can't use
+ -- an attribute definition clause because we would not have
+ -- visibility on the discriminant. For that case we must
+ -- generate a pragma in the task definition.
+
+ when Aspect_Storage_Size =>
+
+ -- Task type case
+
+ if Ekind (E) = E_Task_Type then
+ declare
+ Decl : constant Node_Id := Declaration_Node (E);
+
+ begin
+ pragma Assert (Nkind (Decl) = N_Task_Type_Declaration);
+
+ -- If no task definition, create one
+
+ if No (Task_Definition (Decl)) then
+ Set_Task_Definition (Decl,
+ Make_Task_Definition (Loc,
+ Visible_Declarations => Empty_List,
+ End_Label => Empty));
+ end if;
+
+ -- Create a pragma and put it at the start of the
+ -- task definition for the task type declaration.
+
+ Make_Aitem_Pragma
+ (Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Relocate_Node (Expr))),
+ Pragma_Name => Name_Storage_Size);
+
+ Prepend
+ (Aitem,
+ Visible_Declarations (Task_Definition (Decl)));
+ goto Continue;
+ end;
+
+ -- All other cases, generate attribute definition
+
+ else
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
+ end if;
end case;
-- Attach the corresponding pragma/attribute definition clause to
begin
if Is_Task_Type (U_Ent) then
- Check_Restriction (No_Obsolescent_Features, N);
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("?j?storage size clause for task is an " &
- "obsolescent feature (RM J.9)", N);
- Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
+ -- Check obsolescent (but never obsolescent if from aspect!)
+
+ if not From_Aspect_Specification (N) then
+ Check_Restriction (No_Obsolescent_Features, N);
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("?j?storage size clause for task is an " &
+ "obsolescent feature (RM J.9)", N);
+ Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
+ end if;
end if;
FOnly := True;
Expr : Node_Id;
Val : Uint;
- procedure Check_Unit_Name (N : Node_Id);
- -- Checks unit name parameter for No_Dependence. Returns if it has
- -- an appropriate form, otherwise raises pragma argument error.
-
- ---------------------
- -- Check_Unit_Name --
- ---------------------
-
- procedure Check_Unit_Name (N : Node_Id) is
- begin
- if Nkind (N) = N_Selected_Component then
- Check_Unit_Name (Prefix (N));
- Check_Unit_Name (Selector_Name (N));
-
- elsif Nkind (N) = N_Identifier then
- return;
-
- else
- Error_Pragma_Arg
- ("wrong form for unit name for No_Dependence", N);
- end if;
- end Check_Unit_Name;
-
- -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
-
begin
-- Ignore all Restrictions pragmas in CodePeer mode
-- already made the necessary entry in the No_Dependence table.
elsif Id = Name_No_Dependence then
- Check_Unit_Name (Expr);
+ if not OK_No_Dependence_Unit_Name (Expr) then
+ raise Pragma_Exit;
+ end if;
-- Case of No_Specification_Of_Aspect => Identifier.
-- in rtsfind to indicate implicit dependencies on predefined units. Used
-- to prevent multiple with_clauses for the same unit in a given context.
-- A postorder traversal of the tree whose nodes are units and whose
- -- links are with_clauses defines the order in which Inspector must
+ -- links are with_clauses defines the order in which CodePeer must
-- examine a compiled unit and its full context. This ordering ensures
-- that any subprogram call is examined after the subprogram declaration
-- has been seen.
-- Next_Named_Actual (Node4-Sem)
- -- Present in parameter association node. Set during semantic analysis to
- -- point to the next named parameter, where parameters are ordered by
+ -- Present in parameter association nodes. Set during semantic analysis
+ -- to point to the next named parameter, where parameters are ordered by
-- declaration order (as opposed to the actual order in the call, which
-- may be different due to named associations). Not that this field
-- points to the explicit actual parameter itself, not to the
Name_Range : constant Name_Id := N + $;
Name_Range_Length : constant Name_Id := N + $; -- GNAT
Name_Ref : constant Name_Id := N + $; -- GNAT
+ Name_Restriction_Set : constant Name_Id := N + $; -- GNAT
Name_Result : constant Name_Id := N + $; -- GNAT
Name_Round : constant Name_Id := N + $;
Name_Safe_Emax : constant Name_Id := N + $; -- Ada 83
Attribute_Range,
Attribute_Range_Length,
Attribute_Ref,
+ Attribute_Restriction_Set,
Attribute_Result,
Attribute_Round,
Attribute_Safe_Emax,
projects / thirdparty / gcc.git / commitdiff
