+2015-05-26 Robert Dewar <dewar@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Defend against
+ bad bounds.
+ * debug.adb: Document -gnatd.k.
+ * erroutc.adb (Set_Msg_Insertion_Line_Number): Implement -gnatd.k.
+
+2015-05-26 Robert Dewar <dewar@adacore.com>
+
+ * gnat1drv.adb (Gnat1drv): Provide new arguments for
+ Get_Target_Parameters.
+ * restrict.adb (Set_Restriction_No_Specification_Of_Aspect):
+ new procedure.
+ (Set_Restriction_No_Use_Of_Attribute): new procedure.
+ * restrict.ads (Set_Restriction_No_Specification_Of_Aspect):
+ new procedure.
+ (Set_Restriction_No_Use_Of_Attribute): new procedure.
+ * s-rident.ads (Integer_Parameter_Restrictions): New subtype.
+ * targparm.adb (Get_Target_Parameters): Allow new restriction
+ pragmas No_Specification_Of_Aspect No_Use_Of_Attribute
+ No_Use_Of_Pragma.
+ * targparm.ads: New parameters for Get_Target_Parameters.
+ * tbuild.adb (Set_NOD): New name for Set_RND.
+ (Set_NSA): New procedure.
+ (Set_NUA): New procedure.
+ (Set_NUP): New procedure.
+ * tbuild.ads (Make_SC): Minor reformatting.
+ (Set_NOD): New name for Set_RND.
+ (Set_NSA, Set_NUA, Set_NUP): New procedure.
+
+2015-05-26 Ed Schonberg <schonberg@adacore.com>
+
+ * a-stwise.adb (Find_Token): If source'first is not positive,
+ an exception must be raised, as specified by RM 2005 A.4.3
+ (68/1). This must be checked explicitly, given that run-time
+ files are normally compiled without constraint checks.
+ * a-stzsea.adb (Find_Token): Ditto.
+
+2015-05-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.ads sem_util.adb (Is_Current_Instance): New predicate
+ to fully implement RM 8.6 (17/3). which earlier only applied
+ to synchronized types. Used to preanalyze aspects that include
+ current instances of types, such as Predicate and Invariant.
+ * sem_res.adb (Resolve_Entity_Name): Use Is_Current_Instance.
+ * sem_ch13.adb (Add_Predicates): In ASIS mode, preserve original
+ expression of aspect and analyze it to provide proper type
+ information.
+
+2015-05-26 Robert Dewar <dewar@adacore.com>
+
+ * rtsfind.ads: Add entries for RE_Exn[_Long]_Float.
+ * s-exnllf.adb (Exn_Float): New function.
+ (Exn_Long_Float): New function.
+ (Exn_Long_Long_Float): Rewritten interface.
+ (Exp): New name for what used to be Exn_Long_Long_Float.
+ * s-exnllf.ads (Exn_Float): New function.
+ (Exn_Long_Float): New function.
+
+2015-05-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Find_Selected_Component): Do not emit an error
+ on a selected component when the prefix is a type name that is
+ a Current_Instance.
+ * einfo.ads: Minor grammar fix.
+
+2015-05-26 Doug Rupp <rupp@adacore.com>
+
+ * init.c [vxworks] (sysLib.h): Only for x86.
+
2015-05-26 Doug Rupp <rupp@adacore.com>
* init-vxsim.c (CPU): define as __VXSIM_CPU__
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- Here if no token found
- First := Source'First;
- Last := 0;
+ -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if
+ -- Source'First is not positive and is assigned to First. Formulation
+ -- is slightly different in RM 2012, but the intent seems similar, so
+ -- we check explicitly for that condition.
+
+ if Source'First not in Positive then
+ raise Constraint_Error;
+
+ else
+ First := Source'First;
+ Last := 0;
+ end if;
end Find_Token;
-----------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- Here if no token found
- First := Source'First;
- Last := 0;
+ -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if
+ -- Source'First is not positive and is assigned to First. Formulation
+ -- is slightly different in RM 2012, but the intent seems similar, so
+ -- we check explicitly for that condition.
+
+ if Source'First not in Positive then
+ raise Constraint_Error;
+
+ else
+ First := Source'First;
+ Last := 0;
+ end if;
end Find_Token;
-----------
-- d.h Minimize the creation of public internal symbols for concatenation
-- d.i Ignore Warnings pragmas
-- d.j Generate listing of frontend inlined calls
- -- d.k
+ -- d.k Kill referenced run-time library unit line numbers
-- d.l Use Ada 95 semantics for limited function returns
-- d.m For -gnatl, print full source only for main unit
-- d.n Print source file names
-- be used in particular to disable Warnings (Off) to check if any of
-- these statements are inappropriate.
+ -- d.k If an error message contains a reference to a location in an
+ -- internal unit, then suppress the line number in this reference.
+
-- d.j Generate listing of frontend inlined calls and inline calls passed
-- to the backend. This is useful to locate skipped calls that must be
-- inlined by the frontend.
-- end and zero is a legitimate value for a type with one value.
-- Root_Type (synthesized)
--- Applies to all type entities. For class-wide types, return the root
+-- Applies to all type entities. For class-wide types, returns the root
-- type of the class covered by the CW type, otherwise returns the
-- ultimate derivation ancestor of the given type. This function
-- preserves the view, i.e. the Root_Type of a partial view is the
with Csets; use Csets;
with Debug; use Debug;
with Err_Vars; use Err_Vars;
+with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
Sindex_Loc : Source_File_Index;
Sindex_Flag : Source_File_Index;
+ Fname : File_Name_Type;
+ Int_File : Boolean;
procedure Set_At;
-- Outputs "at " unless last characters in buffer are " from ". Certain
if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
Set_At;
- Get_Name_String
- (Reference_Name (Get_Source_File_Index (Loc)));
+ Fname := Reference_Name (Get_Source_File_Index (Loc));
+ Int_File := Is_Internal_File_Name (Fname);
+ Get_Name_String (Fname);
Set_Msg_Name_Buffer;
- Set_Msg_Char (':');
+
+ if not (Int_File and Debug_Flag_Dot_K) then
+ Set_Msg_Char (':');
+ Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
+ end if;
-- If in current file, add text "at line "
else
Set_At;
Set_Msg_Str ("line ");
+ Int_File := False;
+ Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
end if;
- -- Output line number for reference
-
- Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
-
-- Deal with the instantiation case. We may have a reference to,
-- e.g. a type, that is declared within a generic template, and
-- what we are really referring to is the occurrence in an instance.
System_Source_File_Index := S;
end if;
+ -- Call to get target parameters. Note that the actual interface
+ -- routines in Tbuild here. They can't be in this procedure
+ -- because of accessibility issues.
+
Targparm.Get_Target_Parameters
(System_Text => Source_Text (S),
Source_First => Source_First (S),
Source_Last => Source_Last (S),
Make_Id => Tbuild.Make_Id'Access,
Make_SC => Tbuild.Make_SC'Access,
- Set_RND => Tbuild.Set_RND'Access);
+ Set_NOD => Tbuild.Set_NOD'Access,
+ Set_NSA => Tbuild.Set_NSA'Access,
+ Set_NUA => Tbuild.Set_NUA'Access,
+ Set_NUP => Tbuild.Set_NUP'Access);
-- Acquire configuration pragma information from Targparm
__gnat_handler_installed = 1;
}
-/*******************/
-/* VxWorks Section */
-/*******************/
+/*************************************/
+/* VxWorks Section (including Vx653) */
+/*************************************/
#elif defined(__vxworks)
#include <signal.h>
#include <taskLib.h>
+#if defined (i386) || defined (__i386__)
#include <sysLib.h>
+#endif
#ifndef __RTP__
#include <intLib.h>
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Einfo; use Einfo;
with Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
-with Snames; use Snames;
with Stand; use Stand;
with Uname; use Uname;
No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr :=
(others => No_Location);
+ -- Source location of pragma No_Use_Of_Pragma for given pragma, a value
+ -- of Sysstem_Location indicates occurrence in system.ads.
No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean :=
(others => False);
No_Specification_Of_Aspect_Set := True;
end Set_Restriction_No_Specification_Of_Aspect;
+ procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
+ begin
+ No_Specification_Of_Aspects (A_Id) := System_Location;
+ No_Specification_Of_Aspect_Warning (A_Id) := False;
+ No_Specification_Of_Aspect_Set := True;
+ end Set_Restriction_No_Specification_Of_Aspect;
+
-----------------------------------------
-- Set_Restriction_No_Use_Of_Attribute --
-----------------------------------------
end if;
end Set_Restriction_No_Use_Of_Attribute;
+ procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
+ begin
+ No_Use_Of_Attribute_Set := True;
+ No_Use_Of_Attribute (A_Id) := System_Location;
+ No_Use_Of_Attribute_Warning (A_Id) := False;
+ end Set_Restriction_No_Use_Of_Attribute;
+
--------------------------------------
-- Set_Restriction_No_Use_Of_Pragma --
--------------------------------------
end if;
end Set_Restriction_No_Use_Of_Pragma;
+ procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
+ begin
+ No_Use_Of_Pragma_Set := True;
+ No_Use_Of_Pragma_Warning (A_Id) := False;
+ No_Use_Of_Pragma (A_Id) := System_Location;
+ end Set_Restriction_No_Use_Of_Pragma;
+
--------------------------------
-- Check_SPARK_05_Restriction --
--------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- This package deals with the implementation of the Restrictions pragma
-with Namet; use Namet;
-with Rident; use Rident;
+with Aspects; use Aspects;
+with Namet; use Namet;
+with Rident; use Rident;
+with Snames; use Snames;
with Table;
-with Types; use Types;
-with Uintp; use Uintp;
+with Types; use Types;
+with Uintp; use Uintp;
package Restrict is
-- case of a Restriction_Warnings pragma specifying this restriction and
-- False for a Restrictions pragma specifying this restriction.
+ procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id);
+ -- Version used by Get_Target_Parameters (via Tbuild)
+
procedure Set_Restriction_No_Use_Of_Attribute
(N : Node_Id;
Warning : Boolean);
-- No_Use_Of_Attribute. Caller has verified that this is a valid attribute
-- designator.
+ procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id);
+ -- Version used by Get_Target_Parameters (via Tbuild)
+
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
Warn : Boolean;
-- N is the node id for the identifier in a pragma Restrictions for
-- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id.
+ procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id);
+ -- Version used in call from Get_Target_Parameters (via Tbuild).
+
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests if tasking operations are allowed by the current restrictions
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
RE_Exn_Integer, -- System.Exn_Int
+ RE_Exn_Float, -- System.Exn_LLF
+ RE_Exn_Long_Float, -- System.Exn_LLF
RE_Exn_Long_Long_Float, -- System.Exn_LLF
RE_Exn_Long_Long_Integer, -- System.Exn_LLI
RE_Exn_Integer => System_Exn_Int,
+ RE_Exn_Float => System_Exn_LLF,
+ RE_Exn_Long_Float => System_Exn_LLF,
RE_Exn_Long_Long_Float => System_Exn_LLF,
RE_Exn_Long_Long_Integer => System_Exn_LLI,
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- --
------------------------------------------------------------------------------
+-- Note: the reason for treating exponents in the range 0 .. 4 specially is
+-- to ensure identical results to the static inline expansion in the case of
+-- a compile time known exponent in this range. The use of Float'Machine and
+-- Long_Float'Machine is to avoid unwanted extra precision in the results.
+
package body System.Exn_LLF is
+ function Exp
+ (Left : Long_Long_Float;
+ Right : Integer) return Long_Long_Float;
+ -- Common routine used if Right not in 0 .. 4
+
+ ---------------
+ -- Exn_Float --
+ ---------------
+
+ function Exn_Float
+ (Left : Float;
+ Right : Integer) return Float
+ is
+ Temp : Float;
+ begin
+ case Right is
+ when 0 =>
+ return 1.0;
+ when 1 =>
+ return Left;
+ when 2 =>
+ return Float'Machine (Left * Left);
+ when 3 =>
+ return Float'Machine (Left * Left * Left);
+ when 4 =>
+ Temp := Float'Machine (Left * Left);
+ return Float'Machine (Temp * Temp);
+ when others =>
+ return
+ Float'Machine
+ (Float (Exp (Long_Long_Float (Left), Right)));
+ end case;
+ end Exn_Float;
+
+ --------------------
+ -- Exn_Long_Float --
+ --------------------
+
+ function Exn_Long_Float
+ (Left : Long_Float;
+ Right : Integer) return Long_Float
+ is
+ Temp : Long_Float;
+ begin
+ case Right is
+ when 0 =>
+ return 1.0;
+ when 1 =>
+ return Left;
+ when 2 =>
+ return Long_Float'Machine (Left * Left);
+ when 3 =>
+ return Long_Float'Machine (Left * Left * Left);
+ when 4 =>
+ Temp := Long_Float'Machine (Left * Left);
+ return Long_Float'Machine (Temp * Temp);
+ when others =>
+ return
+ Long_Float'Machine
+ (Long_Float (Exp (Long_Long_Float (Left), Right)));
+ end case;
+ end Exn_Long_Float;
+
-------------------------
-- Exn_Long_Long_Float --
-------------------------
(Left : Long_Long_Float;
Right : Integer) return Long_Long_Float
is
+ Temp : Long_Long_Float;
+ begin
+ case Right is
+ when 0 =>
+ return 1.0;
+ when 1 =>
+ return Left;
+ when 2 =>
+ return Left * Left;
+ when 3 =>
+ return Left * Left * Left;
+ when 4 =>
+ Temp := Left * Left;
+ return Temp * Temp;
+ when others =>
+ return Exp (Left, Right);
+ end case;
+ end Exn_Long_Long_Float;
+
+ ---------
+ -- Exp --
+ ---------
+
+ function Exp
+ (Left : Long_Long_Float;
+ Right : Integer) return Long_Long_Float
+ is
Result : Long_Long_Float := 1.0;
Factor : Long_Long_Float := Left;
Exp : Integer := Right;
return 1.0 / Result;
end;
end if;
- end Exn_Long_Long_Float;
+ end Exp;
end System.Exn_LLF;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- --
------------------------------------------------------------------------------
--- Long_Long_Float exponentiation (checks off)
+-- [Long_[Long_]]Float exponentiation (checks off)
package System.Exn_LLF is
pragma Pure;
+ function Exn_Float
+ (Left : Float;
+ Right : Integer) return Float;
+
+ function Exn_Long_Float
+ (Left : Long_Float;
+ Right : Integer) return Long_Float;
+
function Exn_Long_Long_Float
(Left : Long_Long_Float;
Right : Integer) return Long_Long_Float;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
No_Specification_Of_Aspect .. Max_Storage_At_Blocking;
-- All restrictions that take a parameter
+ subtype Integer_Parameter_Restrictions is
+ Restriction_Id range
+ Max_Protected_Entries .. Max_Storage_At_Blocking;
+ -- All restrictions taking an integer parameter
+
subtype Checked_Parameter_Restrictions is
All_Parameter_Restrictions range
Max_Protected_Entries .. Max_Entry_Queue_Length;
if Others_Present then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+ -- Abandon processing if either bound is already signalled as
+ -- an error (prevents junk cascaded messages and blow ups).
+
+ if Nkind (Aggr_Low) = N_Error
+ or else
+ Nkind (Aggr_High) = N_Error
+ then
+ return False;
+ end if;
+
-- No others clause present
else
if Others_Allowed then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+ -- Abandon processing if either bound is already signalled
+ -- as an error (stop junk cascaded messages and blow ups).
+
+ if Nkind (Aggr_Low) = N_Error
+ or else
+ Nkind (Aggr_High) = N_Error
+ then
+ return False;
+ end if;
+
-- If others allowed, and no others present, then the array
-- should cover all index values. If it does not, we will
-- get a length check warning, but there is two cases where
begin
Ritem := First_Rep_Item (Typ);
+
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
then
- -- Acquire arguments
+ -- Acquire arguments. The expression itself is copied for use
+ -- in the predicate function, to preserve the orignal version
+ -- for ASIS use.
Arg1 := First (Pragma_Argument_Associations (Ritem));
Arg2 := Next (Arg1);
Arg1 := Get_Pragma_Arg (Arg1);
- Arg2 := Get_Pragma_Arg (Arg2);
+ Arg2 := New_Copy_Tree (Get_Pragma_Arg (Arg2));
-- See if this predicate pragma is for the current type or for
-- its full view. A predicate on a private completion is placed
if From_Aspect_Specification (Ritem) then
declare
- Aitem : Node_Id;
+ Aitem : Node_Id;
+ Orig_Expr : constant Node_Id :=
+ Expression (Corresponding_Aspect (Ritem));
begin
+
+ -- For ASIS use, perform semantic analysis of the
+ -- original predicate expression, which is otherwise
+ -- not utilized.
+
+ if ASIS_Mode then
+ Preanalyze_And_Resolve (Orig_Expr);
+ end if;
+
-- Loop to find corresponding aspect, note that this
-- must be present given the pragma is marked delayed.
if P_Name = Any_Id then
null;
+ -- It is not an error if the prefix is the current instance of
+ -- type name, e.g. the expression of a type aspect, when it is
+ -- analyzed for ASIS use.
+
+ elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then
+ null;
+
elsif Ekind (P_Name) = E_Void then
Premature_Usage (P);
Set_Entity_With_Checks (N, E);
Eval_Entity_Name (N);
- -- Case of subtype name appearing as an operand in expression
+ -- Case of (sub)type name appearing in a context where an expression
+ -- is expected. This is legal if occurrence is a current instance.
+ -- See RM 8.6 (17/3).
elsif Is_Type (E) then
-
- -- Allow use of subtype if it is a concurrent type where we are
- -- currently inside the body. This will eventually be expanded into a
- -- call to Self (for tasks) or _object (for protected objects). Any
- -- other use of a subtype is invalid.
-
- if Is_Concurrent_Type (E)
- and then In_Open_Scopes (E)
- then
+ if Is_Current_Instance (N) then
null;
-- Any other use is an error
and then Is_Imported (Entity (Name (N)));
end Is_CPP_Constructor_Call;
+ -------------------------
+ -- Is_Current_Instance --
+ -------------------------
+
+ function Is_Current_Instance (N : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Entity (N);
+ P : Node_Id;
+
+ begin
+ -- Simplest case : entity is a concurrent type and we are currently
+ -- inside the body. This will eventually be expanded into a
+ -- call to Self (for tasks) or _object (for protected objects).
+
+ if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
+ return True;
+
+ else
+ -- Check whether the context is a (sub)type declaration for the
+ -- type entity.
+
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind_In (P, N_Full_Type_Declaration,
+ N_Private_Type_Declaration,
+ N_Subtype_Declaration)
+ and then Comes_From_Source (P)
+ and then Defining_Entity (P) = Typ
+ then
+ return True;
+ end if;
+
+ P := Parent (P);
+ end loop;
+ end if;
+
+ -- In any other context this is not a current occurence
+
+ return False;
+ end Is_Current_Instance;
+
--------------------
-- Is_Declaration --
--------------------
-- First determine whether type T is an interface and then check whether
-- it is of protected, synchronized or task kind.
+ function Is_Current_Instance (N : Node_Id) return Boolean;
+ -- Predicate is true if N legally denotes a type name within its own
+ -- declaration. Prior to Ada 2012 this covered only synchronized type
+ -- declarations. In Ada2012 it also covers type and subtype declarations
+ -- with aspects: Invariant, Predicate, and Default_Initial_Condition.
+
function Is_Declaration (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a declaration
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null)
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null)
is
Text : Source_Buffer_Ptr;
Hi : Source_Ptr;
Source_Last => Hi,
Make_Id => Make_Id,
Make_SC => Make_SC,
- Set_RND => Set_RND);
+ Set_NOD => Set_NOD,
+ Set_NSA => Set_NSA,
+ Set_NUA => Set_NUA,
+ Set_NUP => Set_NUP);
end Get_Target_Parameters;
-- Version where caller supplies system.ads text
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null)
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null)
is
P : Source_Ptr;
-- Scans source buffer containing source of system.ads
Result : Boolean;
-- Records boolean from system line
+ OK : Boolean;
+ -- Status result from Set_NUP/NSA/NUA call
+
+ PR_Start : Source_Ptr;
+ -- Pointer to ( following pragma Restrictions
+
+ procedure Collect_Name;
+ -- Scan a name starting at System_Text (P), and put Name in Name_Buffer,
+ -- with Name_Len being length, folded to lower case. On return P points
+ -- just past the last character (which should be a right paren).
+
+ ------------------
+ -- Collect_Name --
+ ------------------
+
+ procedure Collect_Name is
+ begin
+ Name_Len := 0;
+ loop
+ if System_Text (P) in 'a' .. 'z'
+ or else
+ System_Text (P) = '_'
+ or else
+ System_Text (P) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 1) := System_Text (P);
+
+ elsif System_Text (P) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 1) :=
+ Character'Val (Character'Pos (System_Text (P)) + 32);
+
+ else
+ exit;
+ end if;
+
+ P := P + 1;
+ Name_Len := Name_Len + 1;
+ end loop;
+ end Collect_Name;
+
+ -- Start of processing for Get_Target_Parameters
+
begin
if Parameters_Obtained then
return;
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
+ PR_Start := P - 1;
+
+ -- Boolean restrictions
Rloop : for K in All_Boolean_Restrictions loop
declare
null;
end loop Rloop;
- Ploop : for K in All_Parameter_Restrictions loop
+ -- Restrictions taking integer parameter
+
+ Ploop : for K in Integer_Parameter_Restrictions loop
declare
Rname : constant String :=
All_Parameter_Restrictions'Image (K);
P := P + 1;
end loop;
- Set_RND (Unit);
+ Set_NOD (Unit);
goto Line_Loop_Continue;
end;
+
+ -- No_Specification_Of_Aspect case
+
+ elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => "
+ then
+ P := P + 30;
+
+ -- Skip this processing (and simply ignore the pragma), if
+ -- caller did not supply the subprogram we need to process
+ -- such lines.
+
+ if Set_NSA = null then
+ goto Line_Loop_Continue;
+ end if;
+
+ -- We have scanned
+ -- "pragma Restrictions (No_Specification_Of_Aspect =>"
+
+ Collect_Name;
+
+ if System_Text (P) /= ')' then
+ goto Bad_Restrictions_Pragma;
+
+ else
+ Set_NSA (Name_Find, OK);
+
+ if OK then
+ goto Line_Loop_Continue;
+ else
+ goto Bad_Restrictions_Pragma;
+ end if;
+ end if;
+
+ -- No_Use_Of_Attribute case
+
+ elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then
+ P := P + 23;
+
+ -- Skip this processing (and simply ignore No_Use_Of_Attribute
+ -- lines) if caller did not supply the subprogram we need to
+ -- process such lines.
+
+ if Set_NUA = null then
+ goto Line_Loop_Continue;
+ end if;
+
+ -- We have scanned
+ -- "pragma Restrictions (No_Use_Of_Attribute =>"
+
+ Collect_Name;
+
+ if System_Text (P) /= ')' then
+ goto Bad_Restrictions_Pragma;
+
+ else
+ Set_NUA (Name_Find, OK);
+
+ if OK then
+ goto Line_Loop_Continue;
+ else
+ goto Bad_Restrictions_Pragma;
+ end if;
+ end if;
+
+ -- No_Use_Of_Pragma case
+
+ elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then
+ P := P + 20;
+
+ -- Skip this processing (and simply ignore No_Use_Of_Pragma
+ -- lines) if caller did not supply the subprogram we need to
+ -- process such lines.
+
+ if Set_NUP = null then
+ goto Line_Loop_Continue;
+ end if;
+
+ -- We have scanned
+ -- "pragma Restrictions (No_Use_Of_Pragma =>"
+
+ Collect_Name;
+
+ if System_Text (P) /= ')' then
+ goto Bad_Restrictions_Pragma;
+
+ else
+ Set_NUP (Name_Find, OK);
+
+ if OK then
+ goto Line_Loop_Continue;
+ else
+ goto Bad_Restrictions_Pragma;
+ end if;
+ end if;
end if;
-- Here if unrecognizable restrictions pragma form
+ <<Bad_Restrictions_Pragma>>
+
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
Write_Str ("unrecognized or incorrect restrictions pragma: ");
- while System_Text (P) /= ')'
- and then
- System_Text (P) /= ASCII.LF
+ P := PR_Start;
loop
+ exit when System_Text (P) = ASCII.LF;
Write_Char (System_Text (P));
+ exit when System_Text (P) = ')';
P := P + 1;
end loop;
-- selected component with Sloc value System_Location and given Prefix
-- (Pre) and Selector (Sel) values.
- type Set_RND_Type is access procedure (Unit : Node_Id);
+ type Set_NOD_Type is access procedure (Unit : Node_Id);
-- Parameter type for Get_Target_Parameters that records a Restriction
-- No_Dependence for the given unit (identifier or selected component).
+ type Set_NSA_Type is access procedure (Asp : Name_Id; OK : out Boolean);
+ -- Parameter type for Get_Target_Parameters that records a Restriction
+ -- No_Specificaztion_Of_Aspect. Asp is the pragma name. OK is set True
+ -- if this is an OK aspect name, and False if it is not an aspect name.
+
+ type Set_NUA_Type is access procedure (Attr : Name_Id; OK : out Boolean);
+ -- Parameter type for Get_Target_Parameters that records a Restriction
+ -- No_Use_Of_Attribute. Prag is the attribute name. OK is set True if
+ -- this is an OK attribute name, and False if it is not an attribute name.
+
+ type Set_NUP_Type is access procedure (Prag : Name_Id; OK : out Boolean);
+ -- Parameter type for Get_Target_Parameters that records a Restriction
+ -- No_Use_Of_Pragma. Prag is the pragma name. OK is set True if this is
+ -- an OK pragma name, and False if it is not a recognized pragma name.
+
procedure Get_Target_Parameters
(System_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null);
- -- Called at the start of execution to obtain target parameters from
- -- the source of package System. The parameters provide the source
- -- text to be scanned (in System_Text (Source_First .. Source_Last)).
- -- if the three subprograms are left at their default value of null,
- -- Get_Target_Parameters will ignore pragma Restrictions No_Dependence
- -- lines, otherwise it will use these three subprograms to record them.
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null);
+ -- Called at the start of execution to obtain target parameters from the
+ -- source of package System. The parameters provide the source text to be
+ -- scanned (in System_Text (Source_First .. Source_Last)). if the three
+ -- subprograms Make_Id, Make_SC, and Set_NOD are left at their default
+ -- value of null, Get_Target_Parameters will ignore pragma Restrictions
+ -- No_Dependence lines, otherwise it will use these three subprograms to
+ -- record them. Similarly if Set_NUP is left at its default value of null,
+ -- then any occurrences of pragma Restrictions (No_Use_Of_Pragma => XXX)
+ -- will be ignored, otherwise it will use this procedure to record the
+ -- pragma. Similarly for the NSA and NUA cases.
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null);
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null);
-- This version reads in system.ads using Osint. The idea is that the
-- caller uses the first version if they have to read system.ads anyway
-- (e.g. the compiler) and uses this simpler interface if system.ads is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
------------------------------------------------------------------------------
with Atree; use Atree;
+with Aspects; use Aspects;
with Csets; use Csets;
with Einfo; use Einfo;
with Elists; use Elists;
end OK_Convert_To;
-------------
- -- Set_RND --
+ -- Set_NOD --
-------------
- procedure Set_RND (Unit : Node_Id) is
+ procedure Set_NOD (Unit : Node_Id) is
begin
Set_Restriction_No_Dependence (Unit, Warn => False);
- end Set_RND;
+ end Set_NOD;
+
+ -------------
+ -- Set_NSA --
+ -------------
+
+ procedure Set_NSA (Asp : Name_Id; OK : out Boolean) is
+ Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
+ begin
+ if Asp_Id = No_Aspect then
+ OK := False;
+ else
+ OK := True;
+ Set_Restriction_No_Specification_Of_Aspect (Asp_Id);
+ end if;
+ end Set_NSA;
+
+ -------------
+ -- Set_NUA --
+ -------------
+
+ procedure Set_NUA (Attr : Name_Id; OK : out Boolean) is
+ begin
+ if Is_Attribute_Name (Attr) then
+ OK := True;
+ Set_Restriction_No_Use_Of_Attribute (Get_Attribute_Id (Attr));
+ else
+ OK := False;
+ end if;
+ end Set_NUA;
+
+ -------------
+ -- Set_NUP --
+ -------------
+
+ procedure Set_NUP (Prag : Name_Id; OK : out Boolean) is
+ begin
+ if Is_Pragma_Name (Prag) then
+ OK := True;
+ Set_Restriction_No_Use_Of_Pragma (Get_Pragma_Id (Prag));
+ else
+ OK := False;
+ end if;
+ end Set_NUP;
--------------------------
-- Unchecked_Convert_To --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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 Make_Id (Str : Text_Buffer) return Node_Id;
function Make_SC (Pre, Sel : Node_Id) return Node_Id;
- procedure Set_RND (Unit : Node_Id);
+ procedure Set_NOD (Unit : Node_Id);
+ procedure Set_NSA (Asp : Name_Id; OK : out Boolean);
+ procedure Set_NUA (Attr : Name_Id; OK : out Boolean);
+ procedure Set_NUP (Prag : Name_Id; OK : out Boolean);
-- Subprograms for call to Get_Target_Parameters in Gnat1drv, see spec
- -- of package Targparm for full description of these three subprograms.
+ -- of package Targparm for full description of these four subprograms.
-- These have to be declared at the top level of a package (accessibility
-- issues), and Gnat1drv is a procedure, so they can't go there.
projects / platform / upstream / gcc.git / commitdiff