Skip to content

R
riscv-gcc-1
Commit 470cd9e9 by Robert Dewar Committed by Arnaud Charlet
Options

a-ngcoty.adb: New pragma Fast_Math 

2007-12-06  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* a-ngcoty.adb: New pragma Fast_Math

	* opt.adb: New pragma Fast_Math

	* par-prag.adb: 
	Add Implemented_By_Entry to the list of pragmas which do not require any
	special processing.
	(Favor_Top_Level): New pragma.
	New pragma Fast_Math

	* exp_attr.adb: Move Wide_[Wide_]Image routines to Exp_Imgv
	(Expand_N_Attribute_Reference, Displace_Allocator_Pointer,
	Expand_Allocator_Expression): Take into account VM_Target
	(Expand_Attribute, case 'Identity):  Handle properly the case where
	the prefix is a task interface.
	New pragma Fast_Math

	* par.adb (Next_Token_Is): New function
	(P_Pragma): Add Skipping parameter
	(U_Left_Paren): New procedure
	(U_Right_Paren): New procedure
	New pragma Fast_Math

	* par-ch10.adb (P_Subunit): Unconditional msg for missing ) after
	subunit
	New pragma Fast_Math

	* sem_prag.adb: Add significance value to table Sig_Flag for pragma
	Implemented_By_Entry.
	(Analyze_Pragma): Add case for Ada 2005 pragma Implemented_By_Entry.
	(Set_Inline_Flags): Do not try to link pragma Inline onto chain of rep
	items, since it can apply to more than one overloadable entity. Set
	new flag Has_Pragma_Inline_Always for Inline_Always case.
	(Analyze_Pragma, case Complex_Representation): Improve error message.
	(Analyze_Pragma, case Assert): When assertions are disabled build the
	rewritten code with Sloc of expression rather than pragma, so new
	warning about failing is not deleted.
	(Analyze_Pragma): Allow pragma Preelaborable_Initialization to apply to
	protected types and update error message to reflect that. Test whether
	the protected type is allowed for the pragma (an error is issued if the
	type has any entries, or components that do not have preelaborable
	initialization).
	New pragma Fast_Math
	(Analyze_Pragma, case No_Return): Handle generic instance

	* snames.h, snames.ads, snames.adb: 
	Add new predefined name for interface primitive _Disp_Requeue.
	New pragma Fast_Math

	* a-tags.ads, a-tags.adb: New calling sequence for
	String_To_Wide_[Wide_]String
	(Secondary_Tag): New subprogram.

	* exp_imgv.ads, exp_imgv.adb: Move Wide_[Wide_]Image routines here
	from Exp_Attr
	New calling sequence for String_To_Wide_[Wide_]String
	(Expand_Image_Attribute): Major rewrite. New calling sequence avoids
	the use of the secondary stack for image routines.

	* a-except-2005.adb, s-wchstw.ads, s-wchstw.adb, s-wwdenu.adb: New
	calling sequence for String_To_Wide_[Wide_]String

	* par-ch3.adb (P_Declarative_Items): Recognize use of Overriding in
	Ada 95 mode
	(P_Unknown_Discriminant_Part_Opt): Handle missing parens gracefully
	Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List

	* par-ch6.adb (P_Subprogram): Recognize use of Overriding in Ada 95 mode
	(P_Formal_Part): Use Skipping parameter in P_Pragma call
	to improve error recovery

	* par-util.adb (Next_Token_Is): New function
	(Signal_Bad_Attribute): Use new Namet.Is_Bad_Spelling_Of function

	* par-ch2.adb (Skip_Pragma_Semicolon): Do not resynchronize to
	semicolon if missing
	(P_Pragma): Implement new Skipping parameter
	Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List
	Fix location of flag for unrecognized pragma message

	* par-tchk.adb (U_Left_Paren): New procedure
	(U_Right_Paren): New procedure

From-SVN: r130818
parent b917101e
Showing with 484 additions and 268 deletions
gcc/ada/a-except-2005.adb
......@@ -1359,17 +1359,27 @@ package body Ada.Exceptions is
-- Encoding method for source, as exported by binder
function Wide_Exception_Name
(Id : Exception_Id) return Wide_String is
(Id : Exception_Id) return Wide_String
is
S : constant String := Exception_Name (Id);
W : Wide_String (1 .. S'Length);
L : Natural;
begin
return String_To_Wide_String
(Exception_Name (Id), Get_WC_Encoding_Method (WC_Encoding));
String_To_Wide_String
(S, W, L, Get_WC_Encoding_Method (WC_Encoding));
return W (1 .. L);
end Wide_Exception_Name;
function Wide_Exception_Name
(X : Exception_Occurrence) return Wide_String is
(X : Exception_Occurrence) return Wide_String
is
S : constant String := Exception_Name (X);
W : Wide_String (1 .. S'Length);
L : Natural;
begin
return String_To_Wide_String
(Exception_Name (X), Get_WC_Encoding_Method (WC_Encoding));
String_To_Wide_String
(S, W, L, Get_WC_Encoding_Method (WC_Encoding));
return W (1 .. L);
end Wide_Exception_Name;
----------------------------
......@@ -1379,17 +1389,25 @@ package body Ada.Exceptions is
function Wide_Wide_Exception_Name
(Id : Exception_Id) return Wide_Wide_String
is
S : constant String := Exception_Name (Id);
W : Wide_Wide_String (1 .. S'Length);
L : Natural;
begin
return String_To_Wide_Wide_String
(Exception_Name (Id), Get_WC_Encoding_Method (WC_Encoding));
String_To_Wide_Wide_String
(S, W, L, Get_WC_Encoding_Method (WC_Encoding));
return W (1 .. L);
end Wide_Wide_Exception_Name;
function Wide_Wide_Exception_Name
(X : Exception_Occurrence) return Wide_Wide_String
is
S : constant String := Exception_Name (X);
W : Wide_Wide_String (1 .. S'Length);
L : Natural;
begin
return String_To_Wide_Wide_String
(Exception_Name (X), Get_WC_Encoding_Method (WC_Encoding));
String_To_Wide_Wide_String
(S, W, L, Get_WC_Encoding_Method (WC_Encoding));
return W (1 .. L);
end Wide_Wide_Exception_Name;
--------------------------
......
gcc/ada/a-ngcoty.adb
......@@ -52,16 +52,18 @@ package body Ada.Numerics.Generic_Complex_Types is
X := Left.Re * Right.Re - Left.Im * Right.Im;
Y := Left.Re * Right.Im + Left.Im * Right.Re;
-- If either component overflows, try to scale
-- If either component overflows, try to scale (skip in fast math mode)
if abs (X) > R'Last then
X := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Im / 2.0));
end if;
if not Standard'Fast_Math then
if abs (X) > R'Last then
X := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Im / 2.0));
end if;
if abs (Y) > R'Last then
Y := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Re / 2.0));
if abs (Y) > R'Last then
Y := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Re / 2.0));
end if;
end if;
return (X, Y);
......@@ -143,7 +145,6 @@ package body Ada.Numerics.Generic_Complex_Types is
-- 1.0 / infinity, and the closest model number will be zero.
begin
while Exp /= 0 loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
......@@ -156,7 +157,6 @@ package body Ada.Numerics.Generic_Complex_Types is
return R'(1.0) / Result;
exception
when Constraint_Error =>
return (0.0, 0.0);
end;
......
gcc/ada/a-tags.adb
......@@ -318,6 +318,21 @@ package body Ada.Tags is
return This - Offset_To_Top (This);
end Base_Address;
--------------------
-- Descendant_Tag --
--------------------
function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
Int_Tag : constant Tag := Internal_Tag (External);
begin
if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
raise Tag_Error;
end if;
return Int_Tag;
end Descendant_Tag;
--------------
-- Displace --
--------------
......@@ -434,21 +449,6 @@ package body Ada.Tags is
return False;
end IW_Membership;
--------------------
-- Descendant_Tag --
--------------------
function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
Int_Tag : constant Tag := Internal_Tag (External);
begin
if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
raise Tag_Error;
end if;
return Int_Tag;
end Descendant_Tag;
-------------------
-- Expanded_Name --
-------------------
......@@ -846,6 +846,35 @@ package body Ada.Tags is
External_Tag_HTable.Set (T);
end Register_Tag;
-------------------
-- Secondary_Tag --
-------------------
function Secondary_Tag (T, Iface : Tag) return Tag is
Iface_Table : Interface_Data_Ptr;
Obj_DT : Dispatch_Table_Ptr;
begin
if not Is_Primary_DT (T) then
raise Program_Error;
end if;
Obj_DT := DT (T);
Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
return Iface_Table.Ifaces_Table (Id).Secondary_DT;
end if;
end loop;
end if;
-- If the object does not implement the interface we must raise CE
raise Constraint_Error with "invalid interface conversion";
end Secondary_Tag;
---------------------
-- Set_Entry_Index --
---------------------
......@@ -948,9 +977,13 @@ package body Ada.Tags is
-- Encoding method for source, as exported by binder
function Wide_Expanded_Name (T : Tag) return Wide_String is
S : constant String := Expanded_Name (T);
W : Wide_String (1 .. S'Length);
L : Natural;
begin
return String_To_Wide_String
(Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
String_To_Wide_String
(S, W, L, Get_WC_Encoding_Method (WC_Encoding));
return W (1 .. L);
end Wide_Expanded_Name;
-----------------------------
......@@ -958,9 +991,13 @@ package body Ada.Tags is
-----------------------------
function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
S : constant String := Expanded_Name (T);
W : Wide_Wide_String (1 .. S'Length);
L : Natural;
begin
return String_To_Wide_Wide_String
(Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
String_To_Wide_Wide_String
(S, W, L, Get_WC_Encoding_Method (WC_Encoding));
return W (1 .. L);
end Wide_Wide_Expanded_Name;
end Ada.Tags;
gcc/ada/a-tags.ads
......@@ -122,25 +122,23 @@ private
-- Structure of the GNAT Secondary Dispatch Table
-- +-----------------------+
-- | table of |
-- : predefined primitive :
-- | ops pointers |
-- +-----------------------+
-- | Signature |
-- +-----------------------+
-- | Tagged_Kind |
-- +-----------------------+
-- | Offset_To_Top |
-- +-----------------------+
-- | OSD_Ptr |---> Object Specific Data
-- Tag ---> +-----------------------+ +---------------+
-- | table of | | num prim ops |
-- : primitive op : +---------------+
-- | thunk pointers | | table of |
-- +-----------------------+ + primitive |
-- | op offsets |
-- +---------------+
-- +--------------------+
-- | Signature |
-- +--------------------+
-- | Tagged_Kind |
-- +--------------------+ Predef Prims
-- | Predef_Prims -----------------------------> +------------+
-- +--------------------+ | table of |
-- | Offset_To_Top | | predefined |
-- +--------------------+ | primitives |
-- | OSD_Ptr |---> Object Specific Data | thunks |
-- Tag ---> +--------------------+ +---------------+ +------------+
-- | table of | | num prim ops |
-- : primitive op : +---------------+
-- | thunk pointers | | table of |
-- +--------------------+ + primitive |
-- | op offsets |
-- +---------------+
-- The runtime information kept for each tagged type is separated into two
-- objects: the Dispatch Table and the Type Specific Data record.
......@@ -165,12 +163,18 @@ private
Static_Offset_To_Top : Boolean;
Offset_To_Top_Value : SSE.Storage_Offset;
Offset_To_Top_Func : Offset_To_Top_Function_Ptr;
Secondary_DT : Tag;
end record;
-- If some ancestor of the tagged type has discriminants the field
-- Static_Offset_To_Top is False and the field Offset_To_Top_Func
-- is used to store the access to the function generated by the
-- expander which provides this value; otherwise Static_Offset_To_Top
-- is True and such value is stored in the Offset_To_Top_Value field.
-- Secondary_DT references a secondary dispatch table whose contents
-- are pointers to the primitives of the tagged type that cover the
-- interface primitives. Secondary_DT gives support to dispatching
-- calls through interface types associated with Generic Dispatching
-- Constructors.
type Interfaces_Array is array (Natural range <>) of Interface_Data_Element;
......@@ -398,6 +402,11 @@ private
-- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T.
function Secondary_Tag (T, Iface : Tag) return Tag;
-- Ada 2005 (AI-251): Given a primary tag T associated with a tagged type
-- Typ, search for the secondary tag of the interface type Iface covered
-- by Typ.
function DT (T : Tag) return Dispatch_Table_Ptr;
-- Return the pointer to the TSD record associated with T
......@@ -495,11 +504,27 @@ private
-- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD
-- table indexed by Position.
Max_Predef_Prims : constant Positive := 15;
-- Number of reserved slots for predefined ada primitives: Size, Alignment,
-- Read, Write, Input, Output, "=", assignment, deep adjust, deep finalize,
-- async select, conditional select, prim_op kind, task_id, and timed
-- select. The compiler checks that this value is correct.
Max_Predef_Prims : constant Positive := 16;
-- Number of reserved slots for the following predefined ada primitives:
--
-- 1. Size
-- 2. Alignment,
-- 3. Read
-- 4. Write
-- 5. Input
-- 6. Output
-- 7. "="
-- 8. assignment
-- 9. deep adjust
-- 10. deep finalize
-- 11. async select
-- 12. conditional select
-- 13. prim_op kind
-- 14. task_id
-- 15. dispatching requeue
-- 16. timed select
--
-- The compiler checks that the value here is correct
subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims);
type Predef_Prims_Table_Ptr is access Predef_Prims_Table;
......@@ -507,4 +532,5 @@ private
type Addr_Ptr is access System.Address;
pragma No_Strict_Aliasing (Addr_Ptr);
-- Why is this needed ???
end Ada.Tags;
gcc/ada/exp_attr.adb
......@@ -129,7 +129,7 @@ package body Exp_Attr is
-- operand with overflow checking required.
function Get_Index_Subtype (N : Node_Id) return Entity_Id;
-- Used for Last, Last, and Length, when the prefix is an array type,
-- Used for Last, Last, and Length, when the prefix is an array type.
-- Obtains the corresponding index subtype.
procedure Find_Fat_Info
......@@ -838,8 +838,12 @@ package body Exp_Attr is
-- generate a call to a run-time subprogram that returns the base
-- address of the object.
-- This processing is not needed in the VM case, where dispatching
-- issues are taken care of by the virtual machine.
elsif Is_Class_Wide_Type (Etype (Pref))
and then Is_Interface (Etype (Pref))
and then VM_Target = No_VM
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
then
......@@ -1923,8 +1927,27 @@ package body Exp_Attr is
else
Id_Kind := RTE (RO_AT_Task_Id);
Rewrite (N,
Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
-- If the prefix is a task interface, the Task_Id is obtained
-- dynamically through a dispatching call, as for other task
-- attributes applied to interfaces.
if Ada_Version >= Ada_05
and then Ekind (Etype (Pref)) = E_Class_Wide_Type
and then Is_Interface (Etype (Pref))
and then Is_Task_Interface (Etype (Pref))
then
Rewrite (N,
Unchecked_Convert_To (Id_Kind,
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
else
Rewrite (N,
Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
end if;
end if;
Analyze_And_Resolve (N, Id_Kind);
......@@ -4052,13 +4075,17 @@ package body Exp_Attr is
-- Note that Prefix'Address is recursively expanded into a call
-- to Base_Address (Obj.Tag)
Rewrite (N,
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Pref),
Attribute_Name => Name_Address))));
Analyze_And_Resolve (N, RTE (RE_Tag));
-- Not needed for VM targets, since all handled by the VM
if VM_Target = No_VM then
Rewrite (N,
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Pref),
Attribute_Name => Name_Address))));
Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
else
Rewrite (N,
......@@ -4581,66 +4608,19 @@ package body Exp_Attr is
-- Wide_Image --
----------------
-- We expand typ'Wide_Image (X) into
-- String_To_Wide_String
-- (typ'Image (X), Wide_Character_Encoding_Method)
-- Wide_Image attribute is handled in separate unit Exp_Imgv
-- This works in all cases because String_To_Wide_String converts any
-- wide character escape sequences resulting from the Image call to the
-- proper Wide_Character equivalent
-- not quite right for typ = Wide_Character ???
when Attribute_Wide_Image => Wide_Image :
begin
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Pref,
Attribute_Name => Name_Image,
Expressions => Exprs),
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)))));
Analyze_And_Resolve (N, Standard_Wide_String);
end Wide_Image;
when Attribute_Wide_Image =>
Exp_Imgv.Expand_Wide_Image_Attribute (N);
---------------------
-- Wide_Wide_Image --
---------------------
-- We expand typ'Wide_Wide_Image (X) into
-- String_To_Wide_Wide_String
-- (typ'Image (X), Wide_Character_Encoding_Method)
-- This works in all cases because String_To_Wide_Wide_String converts
-- any wide character escape sequences resulting from the Image call to
-- the proper Wide_Character equivalent
-- not quite right for typ = Wide_Wide_Character ???
when Attribute_Wide_Wide_Image => Wide_Wide_Image :
begin
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To
(RTE (RE_String_To_Wide_Wide_String), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Pref,
Attribute_Name => Name_Image,
Expressions => Exprs),
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)))));
-- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
Analyze_And_Resolve (N, Standard_Wide_Wide_String);
end Wide_Wide_Image;
when Attribute_Wide_Wide_Image =>
Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
----------------
-- Wide_Value --
......@@ -4935,6 +4915,7 @@ package body Exp_Attr is
Attribute_Emax |
Attribute_Enabled |
Attribute_Epsilon |
Attribute_Fast_Math |
Attribute_Has_Access_Values |
Attribute_Has_Discriminants |
Attribute_Large |
......
gcc/ada/exp_imgv.ads
......@@ -73,6 +73,14 @@ package Exp_Imgv is
-- This procedure is called from Exp_Attr to expand an occurrence
-- of the attribute Image.
procedure Expand_Wide_Image_Attribute (N : Node_Id);
-- This procedure is called from Exp_Attr to expand an occurrence
-- of the attribute Wide_Image.
procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id);
-- This procedure is called from Exp_Attr to expand an occurrence
-- of the attribute Wide_Wide_Image.
procedure Expand_Value_Attribute (N : Node_Id);
-- This procedure is called from Exp_Attr to expand an occurrence
-- of the attribute Value.
......
gcc/ada/opt.adb
......@@ -55,6 +55,7 @@ package body Opt is
Extensions_Allowed_Config := Extensions_Allowed;
External_Name_Exp_Casing_Config := External_Name_Exp_Casing;
External_Name_Imp_Casing_Config := External_Name_Imp_Casing;
Fast_Math_Config := Fast_Math;
Persistent_BSS_Mode_Config := Persistent_BSS_Mode;
Polling_Required_Config := Polling_Required;
Use_VADS_Size_Config := Use_VADS_Size;
......@@ -75,6 +76,7 @@ package body Opt is
Extensions_Allowed := Save.Extensions_Allowed;
External_Name_Exp_Casing := Save.External_Name_Exp_Casing;
External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
Fast_Math := Save.Fast_Math;
Persistent_BSS_Mode := Save.Persistent_BSS_Mode;
Polling_Required := Save.Polling_Required;
Use_VADS_Size := Save.Use_VADS_Size;
......@@ -95,6 +97,7 @@ package body Opt is
Save.Extensions_Allowed := Extensions_Allowed;
Save.External_Name_Exp_Casing := External_Name_Exp_Casing;
Save.External_Name_Imp_Casing := External_Name_Imp_Casing;
Save.Fast_Math := Fast_Math;
Save.Persistent_BSS_Mode := Persistent_BSS_Mode;
Save.Polling_Required := Polling_Required;
Save.Use_VADS_Size := Use_VADS_Size;
......@@ -147,11 +150,13 @@ package body Opt is
Extensions_Allowed := Extensions_Allowed_Config;
External_Name_Exp_Casing := External_Name_Exp_Casing_Config;
External_Name_Imp_Casing := External_Name_Imp_Casing_Config;
Fast_Math := Fast_Math_Config;
Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
Use_VADS_Size := Use_VADS_Size_Config;
end if;
Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config;
Fast_Math := Fast_Math_Config;
Polling_Required := Polling_Required_Config;
end Set_Opt_Config_Switches;
......
gcc/ada/par-ch10.adb
......@@ -180,7 +180,7 @@ package body Ch10 is
Item := P_Pragma;
if Item = Error
or else Chars (Item) > Last_Configuration_Pragma_Name
or else not Is_Configuration_Pragma_Name (Chars (Item))
then
Restore_Scan_State (Scan_State);
exit;
......@@ -587,19 +587,17 @@ package body Ch10 is
while Token = Tok_Pragma loop
Save_Scan_State (Scan_State);
-- If we are in syntax scan mode allowing multiple units, then
-- start the next unit if we encounter a configuration pragma,
-- or a source reference pragma. We take care not to actually
-- scan the pragma in this case since we don't want it to take
-- effect for the current unit.
-- If we are in syntax scan mode allowing multiple units, then start
-- the next unit if we encounter a configuration pragma, or a source
-- reference pragma. We take care not to actually scan the pragma in
-- this case (we don't want it to take effect for the current unit).
if Operating_Mode = Check_Syntax then
Scan; -- past Pragma
if Token = Tok_Identifier
and then
(Token_Name in
First_Pragma_Name .. Last_Configuration_Pragma_Name
(Is_Configuration_Pragma_Name (Token_Name)
or else Token_Name = Name_Source_Reference)
then
Restore_Scan_State (Scan_State); -- to Pragma
......@@ -1022,9 +1020,9 @@ package body Ch10 is
Body_Node := Error; -- in case no good body found
Scan; -- past SEPARATE;
T_Left_Paren;
U_Left_Paren;
Set_Name (Subunit_Node, P_Qualified_Simple_Name);
T_Right_Paren;
U_Right_Paren;
if Token = Tok_Semicolon then
Error_Msg_SC ("unexpected semicolon ignored");
......
gcc/ada/par-ch2.adb
......@@ -227,8 +227,7 @@ package body Ch2 is
-- will think there are missing bodies, and try to change ; to IS, when
-- in fact the bodies ARE present, supplied by these pragmas.
function P_Pragma return Node_Id is
function P_Pragma (Skipping : Boolean := False) return Node_Id is
Interface_Check_Required : Boolean := False;
-- Set True if check of pragma INTERFACE is required
......@@ -259,10 +258,22 @@ package body Ch2 is
procedure Skip_Pragma_Semicolon is
begin
if Token /= Tok_Semicolon then
T_Semicolon;
Resync_Past_Semicolon;
-- If skipping the pragma, ignore a missing semicolon
if Skipping then
null;
-- Otherwise demand a semicolon
else
T_Semicolon;
end if;
-- Scan past semicolon if present
else
Scan; -- past semicolon
Scan;
end if;
end Skip_Pragma_Semicolon;
......@@ -284,14 +295,14 @@ package body Ch2 is
and then Token = Tok_Interface
then
Pragma_Name := Name_Interface;
Ident_Node := Token_Node;
Ident_Node := Make_Identifier (Token_Ptr, Name_Interface);
Scan; -- past INTERFACE
else
Ident_Node := P_Identifier;
Delete_Node (Ident_Node);
end if;
Set_Chars (Pragma_Node, Pragma_Name);
Set_Pragma_Identifier (Pragma_Node, Ident_Node);
-- See if special INTERFACE/IMPORT check is required
......@@ -336,10 +347,10 @@ package body Ch2 is
Scan; -- past comma
end loop;
-- If we have := for pragma Debug, it is worth special casing
-- the error message (it is easy to think of pragma Debug as
-- taking a statement, and an assignment statement is the most
-- likely candidate for this error)
-- If we have := for pragma Debug, it is worth special casing the
-- error message (it is easy to think of pragma Debug as taking a
-- statement, and an assignment statement is the most likely
-- candidate for this error)
if Token = Tok_Colon_Equal and then Pragma_Name = Name_Debug then
Error_Msg_SC ("argument for pragma Debug must be procedure call");
......@@ -394,7 +405,7 @@ package body Ch2 is
begin
while Token = Tok_Pragma loop
Error_Msg_SC ("pragma not allowed here");
Discard_Junk_Node (P_Pragma);
Discard_Junk_Node (P_Pragma (Skipping => True));
end loop;
end P_Pragmas_Misplaced;
......@@ -469,7 +480,6 @@ package body Ch2 is
Identifier_Seen := True;
Scan; -- past arrow
Set_Chars (Association, Chars (Identifier_Node));
Delete_Node (Identifier_Node);
-- Case of argument with no identifier
......
gcc/ada/par-ch3.adb
......@@ -174,7 +174,9 @@ package body Ch3 is
if Token = Tok_Identifier then
-- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
-- OVERRIDING, and SYNCHRONIZED are new reserved words.
-- OVERRIDING, and SYNCHRONIZED are new reserved words. Note that
-- in the case where these keywords are misused in Ada 95 mode,
-- this routine will generally not be called at all.
if Ada_Version = Ada_95
and then Warn_On_Ada_2005_Compatibility
......@@ -1128,7 +1130,6 @@ package body Ch3 is
Make_Attribute_Reference (Prev_Token_Ptr,
Prefix => Prefix,
Attribute_Name => Token_Name);
Delete_Node (Token_Node);
Scan; -- past type attribute identifier
end if;
......@@ -1279,6 +1280,10 @@ package body Ch3 is
-- returns True, otherwise returns False. Includes checking for some
-- common error cases.
-------------
-- No_List --
-------------
procedure No_List is
begin
if Num_Idents > 1 then
......@@ -1289,6 +1294,10 @@ package body Ch3 is
List_OK := False;
end No_List;
----------------------
-- Token_Is_Renames --
----------------------
function Token_Is_Renames return Boolean is
At_Colon : Saved_Scan_State;
......@@ -1922,7 +1931,6 @@ package body Ch3 is
Abstract_Present => Abstract_Present (Typedef_Node),
Interface_List => Interface_List (Typedef_Node));
Delete_Node (Typedef_Node);
return Typedecl_Node;
-- Derived type definition with record extension part
......@@ -2715,27 +2723,37 @@ package body Ch3 is
Scan_State : Saved_Scan_State;
begin
if Token /= Tok_Left_Paren then
-- If <> right now, then this is missing left paren
if Token = Tok_Box then
U_Left_Paren;
-- If not <> or left paren, then definitely no box
elsif Token /= Tok_Left_Paren then
return False;
-- Left paren, so might be a box after it
else
Save_Scan_State (Scan_State);
Scan; -- past the left paren
if Token = Tok_Box then
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
end if;
Scan; -- past the box
T_Right_Paren; -- must be followed by right paren
return True;
else
if Token /= Tok_Box then
Restore_Scan_State (Scan_State);
return False;
end if;
end if;
-- We are now pointing to the box
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
end if;
Scan; -- past the box
U_Right_Paren; -- must be followed by right paren
return True;
end P_Unknown_Discriminant_Part_Opt;
----------------------------------
......@@ -4039,11 +4057,28 @@ package body Ch3 is
when Tok_Identifier =>
Check_Bad_Layout;
P_Identifier_Declarations (Decls, Done, In_Spec);
-- Special check for misuse of overriding not in Ada 2005 mode
if Token_Name = Name_Overriding
and then not Next_Token_Is (Tok_Colon)
then
Error_Msg_SC ("overriding indicator is an Ada 2005 extension");
Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
Token := Tok_Overriding;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Done := False;
-- Normal case, no overriding, or overriding followed by colon
else
P_Identifier_Declarations (Decls, Done, In_Spec);
end if;
-- Ada2005: A subprogram declaration can start with "not" or
-- "overriding". In older versions, "overriding" is handled
-- like an identifier, with the appropriate warning.
-- like an identifier, with the appropriate messages.
when Tok_Not =>
Check_Bad_Layout;
......
gcc/ada/par-ch6.adb
......@@ -176,7 +176,7 @@ package body Ch6 is
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Lreq := False;
-- Ada2005: scan leading overriding indicator
-- Ada2005: scan leading NOT OVERRIDING indicator
if Token = Tok_Not then
Scan; -- past NOT
......@@ -184,24 +184,41 @@ package body Ch6 is
if Token = Tok_Overriding then
Scan; -- past OVERRIDING
Not_Overriding := True;
-- Overriding keyword used in non Ada 2005 mode
elsif Token = Tok_Identifier
and then Token_Name = Name_Overriding
then
Error_Msg_SC ("overriding indicator is an Ada 2005 extension");
Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
Scan; -- past Overriding
Not_Overriding := True;
else
Error_Msg_SC ("OVERRIDING expected!");
end if;
-- Ada 2005: scan leading OVERRIDING indicator
-- Note: in the case of OVERRIDING keyword used in Ada 95 mode, the
-- declaration circuit already gave an error message and changed the
-- tokem to Tok_Overriding.
elsif Token = Tok_Overriding then
Scan; -- past OVERRIDING
Is_Overriding := True;
end if;
if (Is_Overriding or else Not_Overriding) then
if Ada_Version < Ada_05 then
Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
-- Note that if we are not in Ada_05 mode, error messages have
-- already been given, so no need to give another message here.
-- An overriding indicator is allowed for subprogram declarations,
-- bodies, renamings, stubs, and instantiations.
elsif Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub then
if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub then
Error_Msg_SC ("overriding indicator not allowed here!");
elsif Token /= Tok_Function
......@@ -1000,7 +1017,8 @@ package body Ch6 is
Specification_Loop : loop
begin
if Token = Tok_Pragma then
P_Pragmas_Misplaced;
Error_Msg_SC ("pragma not allowed in formal part");
Discard_Junk_Node (P_Pragma (Skipping => True));
end if;
Ignore (Tok_Left_Paren);
......
gcc/ada/par-prag.adb
......@@ -1028,7 +1028,7 @@ begin
end;
else
raise Constraint_Error;
raise Constraint_Error;
end if;
exception
......@@ -1089,9 +1089,12 @@ begin
Pragma_Extend_System |
Pragma_External |
Pragma_External_Name_Casing |
Pragma_Favor_Top_Level |
Pragma_Fast_Math |
Pragma_Finalize_Storage_Only |
Pragma_Float_Representation |
Pragma_Ident |
Pragma_Implemented_By_Entry |
Pragma_Implicit_Packing |
Pragma_Import |
Pragma_Import_Exception |
......
gcc/ada/par-tchk.adb
......@@ -790,6 +790,32 @@ package body Tchk is
end if;
end TF_Use;
------------------
-- U_Left_Paren --
------------------
procedure U_Left_Paren is
begin
if Token = Tok_Left_Paren then
Scan;
else
Error_Msg_AP ("missing ""(""!");
end if;
end U_Left_Paren;
-------------------
-- U_Right_Paren --
-------------------
procedure U_Right_Paren is
begin
if Token = Tok_Right_Paren then
Scan;
else
Error_Msg_AP ("missing "")""!");
end if;
end U_Right_Paren;
-----------------
-- Wrong_Token --
-----------------
......
gcc/ada/par-util.adb
......@@ -23,9 +23,10 @@
-- --
------------------------------------------------------------------------------
with Csets; use Csets;
with Stylesw; use Stylesw;
with Uintp; use Uintp;
with Csets; use Csets;
with Namet.Sp; use Namet.Sp;
with Stylesw; use Stylesw;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
......@@ -587,6 +588,21 @@ package body Util is
end Merge_Identifier;
-------------------
-- Next_Token_Is --
-------------------
function Next_Token_Is (Tok : Token_Type) return Boolean is
Scan_State : Saved_Scan_State;
Result : Boolean;
begin
Save_Scan_State (Scan_State);
Scan;
Result := (Token = Tok);
Restore_Scan_State (Scan_State);
return Result;
end Next_Token_Is;
-------------------
-- No_Constraint --
-------------------
......@@ -677,27 +693,15 @@ package body Util is
-- Check for possible misspelling
Get_Name_String (Token_Name);
declare
AN : constant String := Name_Buffer (1 .. Name_Len);
begin
Error_Msg_Name_1 := First_Attribute_Name;
while Error_Msg_Name_1 <= Last_Attribute_Name loop
Get_Name_String (Error_Msg_Name_1);
if Is_Bad_Spelling_Of
(AN, Name_Buffer (1 .. Name_Len))
then
Error_Msg_N
("\possible misspelling of %", Token_Node);
exit;
end if;
Error_Msg_Name_1 := First_Attribute_Name;
while Error_Msg_Name_1 <= Last_Attribute_Name loop
if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then
Error_Msg_N ("\possible misspelling of %", Token_Node);
exit;
end if;
Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
end loop;
end;
Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
end loop;
end Signal_Bad_Attribute;
-----------------------------
......
gcc/ada/par.adb
......@@ -530,7 +530,10 @@ is
-------------
package Ch2 is
function P_Pragma return Node_Id;
function P_Pragma (Skipping : Boolean := False) return Node_Id;
-- Scan out a pragma. If Skipping is True, then the caller is skipping
-- the pragma in the context of illegal placement (this is used to avoid
-- some junk cascaded messages).
function P_Identifier (C : Id_Check := None) return Node_Id;
-- Scans out an identifier. The parameter C determines the treatment
......@@ -965,7 +968,7 @@ is
procedure T_When;
procedure T_With;
-- Procedures have names of the form TF_xxx, where Tok_xxx is a token
-- Procedures having names of the form TF_xxx, where Tok_xxx is a token
-- name check that the current token matches the required token, and
-- if so, scan past it. If not, an error message is issued indicating
-- that the required token is not present (xxx expected).
......@@ -987,6 +990,13 @@ is
procedure TF_Semicolon;
procedure TF_Then;
procedure TF_Use;
-- Procedures with names of the form U_xxx, where Tok_xxx is a token
-- name, are just like the corresponding T_xxx procedures except that
-- an error message, if given, is unconditional.
procedure U_Left_Paren;
procedure U_Right_Paren;
end Tchk;
--------------
......@@ -1085,6 +1095,10 @@ is
-- conditions are met, an error message is issued, and the merge is
-- carried out, modifying the Chars field of Prev.
function Next_Token_Is (Tok : Token_Type) return Boolean;
-- Looks at token after current one and returns True if the token type
-- matches Tok. The scan is unconditionally restored on return.
procedure No_Constraint;
-- Called in a place where no constraint is allowed, but one might
-- appear due to a common error (e.g. after the type mark in a procedure
......@@ -1242,7 +1256,7 @@ begin
-- Give error if bad pragma
if Chars (P_Node) > Last_Configuration_Pragma_Name
if not Is_Configuration_Pragma_Name (Chars (P_Node))
and then Chars (P_Node) /= Name_Source_Reference
then
if Is_Pragma_Name (Chars (P_Node)) then
......
gcc/ada/s-wchstw.adb
......@@ -121,18 +121,20 @@ package body System.WCh_StW is
-- String_To_Wide_String --
---------------------------
function String_To_Wide_String
procedure String_To_Wide_String
(S : String;
EM : WC_Encoding_Method) return Wide_String
R : out Wide_String;
L : out Natural;
EM : System.WCh_Con.WC_Encoding_Method)
is
R : Wide_String (1 .. S'Length);
RP : Natural;
SP : Natural;
V : UTF_32_Code;
begin
pragma Assert (S'First = 1);
SP := S'First;
RP := 0;
L := 0;
while SP <= S'Last loop
Get_Next_Code (S, SP, V, EM);
......@@ -141,36 +143,34 @@ package body System.WCh_StW is
with "out of range value for wide character";
end if;
RP := RP + 1;
R (RP) := Wide_Character'Val (V);
L := L + 1;
R (L) := Wide_Character'Val (V);
end loop;
return R (1 .. RP);
end String_To_Wide_String;
--------------------------------
-- String_To_Wide_Wide_String --
--------------------------------
function String_To_Wide_Wide_String
procedure String_To_Wide_Wide_String
(S : String;
EM : WC_Encoding_Method) return Wide_Wide_String
R : out Wide_Wide_String;
L : out Natural;
EM : System.WCh_Con.WC_Encoding_Method)
is
R : Wide_Wide_String (1 .. S'Length);
RP : Natural;
pragma Assert (S'First = 1);
SP : Natural;
V : UTF_32_Code;
begin
SP := S'First;
RP := 0;
L := 0;
while SP <= S'Last loop
Get_Next_Code (S, SP, V, EM);
RP := RP + 1;
R (RP) := Wide_Wide_Character'Val (V);
L := L + 1;
R (L) := Wide_Wide_Character'Val (V);
end loop;
return R (1 .. RP);
end String_To_Wide_Wide_String;
end System.WCh_StW;
gcc/ada/s-wchstw.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -32,33 +32,39 @@
------------------------------------------------------------------------------
-- This package contains the routine used to convert strings to wide (wide)
-- strings for use by wide (wide) character attributes (value, image etc.)
-- strings for use by wide (wide) image attribute.
with System.WCh_Con;
package System.WCh_StW is
pragma Pure;
function String_To_Wide_String
procedure String_To_Wide_String
(S : String;
EM : System.WCh_Con.WC_Encoding_Method) return Wide_String;
R : out Wide_String;
L : out Natural;
EM : System.WCh_Con.WC_Encoding_Method);
-- This routine simply takes its argument and converts it to wide string
-- format. In the context of the Wide_Image attribute, the argument is
-- the corresponding 'Image attribute. Any wide character escape sequences
-- in the string are converted to the corresponding wide character value.
-- No syntax checks are made, it is assumed that any such sequences are
-- validly formed (this must be assured by the caller), and results from
-- the fact that Wide_Image is only used on strings that have been built
-- by the compiler, such as images of enumeration literals. If the method
-- for encoding is a shift-in, shift-out convention, then it is assumed
-- that normal (non-wide character) mode holds at the start and end of
-- the argument string. EM indicates the wide character encoding method.
-- format, storing the result in R (1 .. L), with L being set appropriately
-- on return. The caller guarantees that R is long enough to accomodate the
-- result. This is used in the context of the Wide_Image attribute, where
-- the argument is the corresponding 'Image attribute. Any wide character
-- escape sequences in the string are converted to the corresponding wide
-- character value. No syntax checks are made, it is assumed that any such
-- sequences are validly formed (this must be assured by the caller), and
-- results from the fact that Wide_Image is only used on strings that have
-- been built by the compiler, such as images of enumeration literals. If
-- the method for encoding is a shift-in, shift-out convention, then it is
-- assumed that normal (non-wide character) mode holds at the start and end
-- of the argument string. EM indicates the wide character encoding method.
-- Note: in the WCEM_Brackets case, the brackets escape sequence is used
-- only for codes greater than 16#FF#.
function String_To_Wide_Wide_String
procedure String_To_Wide_Wide_String
(S : String;
EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_String;
R : out Wide_Wide_String;
L : out Natural;
EM : System.WCh_Con.WC_Encoding_Method);
-- Same function with Wide_Wide_String output
end System.WCh_StW;
gcc/ada/s-wwdenu.adb
......@@ -63,12 +63,14 @@ package body System.WWd_Enum is
W := 0;
for J in Lo .. Hi loop
declare
WS : constant Wide_Wide_String :=
String_To_Wide_Wide_String
(Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1), EM);
S : constant String :=
Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1);
WS : Wide_Wide_String (1 .. S'Length);
L : Natural;
begin
W := Natural'Max (W, WS'Length);
String_To_Wide_Wide_String (S, WS, L, EM);
W := Natural'Max (W, L);
end;
end loop;
......@@ -100,12 +102,14 @@ package body System.WWd_Enum is
W := 0;
for J in Lo .. Hi loop
declare
WS : constant Wide_Wide_String :=
String_To_Wide_Wide_String
(Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1), EM);
S : constant String :=
Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1);
WS : Wide_Wide_String (1 .. S'Length);
L : Natural;
begin
W := Natural'Max (W, WS'Length);
String_To_Wide_Wide_String (S, WS, L, EM);
W := Natural'Max (W, L);
end;
end loop;
......@@ -137,12 +141,14 @@ package body System.WWd_Enum is
W := 0;
for J in Lo .. Hi loop
declare
WS : constant Wide_Wide_String :=
String_To_Wide_Wide_String
(Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1), EM);
S : constant String :=
Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1);
WS : Wide_Wide_String (1 .. S'Length);
L : Natural;
begin
W := Natural'Max (W, WS'Length);
String_To_Wide_Wide_String (S, WS, L, EM);
W := Natural'Max (W, L);
end;
end loop;
......@@ -174,12 +180,14 @@ package body System.WWd_Enum is
W := 0;
for J in Lo .. Hi loop
declare
WS : constant Wide_String :=
String_To_Wide_String
(Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1), EM);
S : constant String :=
Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1);
WS : Wide_String (1 .. S'Length);
L : Natural;
begin
W := Natural'Max (W, WS'Length);
String_To_Wide_String (S, WS, L, EM);
W := Natural'Max (W, L);
end;
end loop;
......@@ -211,12 +219,14 @@ package body System.WWd_Enum is
W := 0;
for J in Lo .. Hi loop
declare
WS : constant Wide_String :=
String_To_Wide_String
(Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1), EM);
S : constant String :=
Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1);
WS : Wide_String (1 .. S'Length);
L : Natural;
begin
W := Natural'Max (W, WS'Length);
String_To_Wide_String (S, WS, L, EM);
W := Natural'Max (W, L);
end;
end loop;
......@@ -248,12 +258,14 @@ package body System.WWd_Enum is
W := 0;
for J in Lo .. Hi loop
declare
WS : constant Wide_String :=
String_To_Wide_String
(Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1), EM);
S : constant String :=
Names (Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1);
WS : Wide_String (1 .. S'Length);
L : Natural;
begin
W := Natural'Max (W, WS'Length);
String_To_Wide_String (S, WS, L, EM);
W := Natural'Max (W, L);
end;
end loop;
......
gcc/ada/snames.adb
......@@ -93,8 +93,9 @@ package body Snames is
"_disp_asynchronous_select#" &
"_disp_conditional_select#" &
"_disp_get_prim_op_kind#" &
"_disp_timed_select#" &
"_disp_get_task_id#" &
"_disp_requeue#" &
"_disp_timed_select#" &
"initialize#" &
"adjust#" &
"finalize#" &
......@@ -194,6 +195,7 @@ package body Snames is
"extend_system#" &
"extensions_allowed#" &
"external_name_casing#" &
"favor_top_level#" &
"float_representation#" &
"implicit_packing#" &
"initialize_scalars#" &
......@@ -261,6 +263,7 @@ package body Snames is
"external#" &
"finalize_storage_only#" &
"ident#" &
"implemented_by_entry#" &
"import#" &
"import_exception#" &
"import_function#" &
......@@ -456,6 +459,7 @@ package body Snames is
"epsilon#" &
"exponent#" &
"external_tag#" &
"fast_math#" &
"first#" &
"first_bit#" &
"fixed_value#" &
......@@ -569,7 +573,6 @@ package body Snames is
"priority_queuing#" &
"edf_across_priorities#" &
"fifo_within_priorities#" &
"non_preemptive_within_priorities#" &
"round_robin_within_priorities#" &
"access_check#" &
"accessibility_check#" &
......@@ -927,6 +930,8 @@ package body Snames is
begin
if N = Name_AST_Entry then
return Pragma_AST_Entry;
elsif N = Name_Fast_Math then
return Pragma_Fast_Math;
elsif N = Name_Interface then
return Pragma_Interface;
elsif N = Name_Priority then
......@@ -955,8 +960,9 @@ package body Snames is
-- Get_Task_Dispatching_Policy_Id --
------------------------------------
function Get_Task_Dispatching_Policy_Id (N : Name_Id)
return Task_Dispatching_Policy_Id is
function Get_Task_Dispatching_Policy_Id
(N : Name_Id) return Task_Dispatching_Policy_Id
is
begin
return Task_Dispatching_Policy_Id'Val
(N - First_Task_Dispatching_Policy_Name);
......@@ -972,10 +978,8 @@ package body Snames is
begin
P_Index := Preset_Names'First;
loop
Name_Len := 0;
while Preset_Names (P_Index) /= '#' loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Preset_Names (P_Index);
......@@ -1024,6 +1028,16 @@ package body Snames is
return N in First_Attribute_Name .. Last_Attribute_Name;
end Is_Attribute_Name;
----------------------------------
-- Is_Configuration_Pragma_Name --
----------------------------------
function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
begin
return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
or else N = Name_Fast_Math;
end Is_Configuration_Pragma_Name;
------------------------
-- Is_Convention_Name --
------------------------
......@@ -1109,6 +1123,7 @@ package body Snames is
begin
return N in First_Pragma_Name .. Last_Pragma_Name
or else N = Name_AST_Entry
or else N = Name_Fast_Math
or else N = Name_Interface
or else N = Name_Priority
or else N = Name_Storage_Size
......
gcc/ada/snames.ads
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment