This implements the support for the new C_Variadic_n conventions,
n ranging from 0 to 16, in all versions of the language since the AI is
a binding interpretation.
These new conventions are meant to be used in conjunction with the
Import aspect/pragma to call variadic C functions with the special
calling conventions attached to them, depending on the ABI. But a
warning is issued for C_Variadic_0 since it cannot actually be used.
The typical example is calling the printf function of the C library.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-09 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* exp_ch6.adb (Freeze_Subprogram): Deal with convention C_Family.
* freeze.adb (Freeze_Profile): Likewise. Add missing guard.
* sem_mech.adb (Set_Mechanisms): Likewise.
* lib-xref.adb (Output_Import_Export_Info): Ditto for C_Variadic.
* repinfo.adb (List_Subprogram_Info): Likewise.
* sem_prag.adb (Set_Convention_From_Pragma): Move main checks for
Stdcall to...
(Process_Convention): ...here. Add checks for C_Variadic.
* snames.ads-tmpl: Add Name_C_Variadic_0 .. Name_C_Variadic_16.
Use consistent format for subtype declarations.
(Convention_Id): Add Convention_C_Variadic_0 .. C_Variadic_16
and move Convention_CPP up.
(Convention_C_Family): New subtype of Convention_Id.
(Convention_C_Variadic): Likewise.
(Foreign_Convention): Use explicit upper bound.
Add pragma Inline for Is_Configuration_Pragma_Name,
Is_Function_Attribute_Name, Is_Internal_Attribute_Name
and Is_Procedure_Attribute_Name.
* snames.adb-tmpl (Get_Convention_Id): Deal with Name_Variadic_n.
(Get_Convention_Name): Deal with Convention_Variadic_n.
* types.h (Convention_Id): New typedef.
* xsnamest.adb (Name2): New variable.
(Is_Conv): New pattern.
(Get_Subt1): Likewise.
(Get_Subt2): Likewise.
Output subtypes of Convention_Id into the C header file.--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -7716,8 +7716,7 @@ package body Exp_Ch6 is
-- Build_Inherit_Prims takes care of initializing these slots.
elsif Is_Imported (Subp)
- and then (Convention (Subp) = Convention_CPP
- or else Convention (Subp) = Convention_C)
+ and then Convention (Subp) in Convention_C_Family
then
null;
--- gcc/ada/freeze.adb
+++ gcc/ada/freeze.adb
@@ -3674,9 +3674,7 @@ package body Freeze is
if Warn_On_Export_Import
and then Comes_From_Source (E)
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
+ and then Convention (E) in Convention_C_Family
and then (Is_Imported (E) or else Is_Exported (E))
and then Convention (E) /= Convention (Formal)
and then not Has_Warnings_Off (E)
@@ -3823,9 +3821,8 @@ package body Freeze is
-- Check suspicious return type for C function
if Warn_On_Export_Import
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
+ and then Comes_From_Source (E)
+ and then Convention (E) in Convention_C_Family
and then (Is_Imported (E) or else Is_Exported (E))
then
-- Check suspicious return of fat C pointer
--- gcc/ada/lib-xref.adb
+++ gcc/ada/lib-xref.adb
@@ -1652,7 +1652,7 @@ package body Lib.Xref is
begin
-- Generate language name from convention
- if Conv = Convention_C then
+ if Conv = Convention_C or else Conv in Convention_C_Variadic then
Language_Name := Name_C;
elsif Conv = Convention_CPP then
--- gcc/ada/repinfo.adb
+++ gcc/ada/repinfo.adb
@@ -1935,6 +1935,21 @@ package body Repinfo is
when Convention_C =>
Write_Str ("C");
+ when Convention_C_Variadic =>
+ declare
+ N : Nat :=
+ Convention_Id'Pos (Convention (Ent)) -
+ Convention_Id'Pos (Convention_C_Variadic_0);
+ begin
+ Write_Str ("C_Variadic_");
+ if N >= 10 then
+ Write_Char ('1');
+ N := N - 10;
+ end if;
+ pragma Assert (N < 10);
+ Write_Char (Character'Val (Character'Pos ('0') + N));
+ end;
+
when Convention_COBOL =>
Write_Str ("COBOL");
--- gcc/ada/sem_mech.adb
+++ gcc/ada/sem_mech.adb
@@ -181,11 +181,10 @@ package body Sem_Mech is
-- C --
-------
- -- Note: Assembler, C++, Stdcall also use C conventions
+ -- Note: Assembler and Stdcall also use C conventions
when Convention_Assembler
- | Convention_C
- | Convention_CPP
+ | Convention_C_Family
| Convention_Stdcall
=>
-- The following values are passed by copy
--- gcc/ada/sem_prag.adb
+++ gcc/ada/sem_prag.adb
@@ -7957,59 +7957,24 @@ package body Sem_Prag is
Error_Pragma_Arg
("cannot change convention for overridden dispatching "
& "operation", Arg1);
- end if;
-
- -- Special checks for Convention_Stdcall
-
- if C = Convention_Stdcall then
-
- -- A dispatching call is not allowed. A dispatching subprogram
- -- cannot be used to interface to the Win32 API, so in fact
- -- this check does not impose any effective restriction.
-
- if Is_Dispatching_Operation (E) then
- Error_Msg_Sloc := Sloc (E);
-
- -- Note: make this unconditional so that if there is more
- -- than one call to which the pragma applies, we get a
- -- message for each call. Also don't use Error_Pragma,
- -- so that we get multiple messages.
-
- Error_Msg_N
- ("dispatching subprogram# cannot use Stdcall convention!",
- Arg1);
-
- -- Several allowed cases
-
- elsif Is_Subprogram_Or_Generic_Subprogram (E)
- -- A variable is OK
+ -- Special check for convention Stdcall: a dispatching call is not
+ -- allowed. A dispatching subprogram cannot be used to interface
+ -- to the Win32 API, so this check actually does not impose any
+ -- effective restriction.
- or else Ekind (E) = E_Variable
-
- -- A component as well. The entity does not have its Ekind
- -- set until the enclosing record declaration is fully
- -- analyzed.
-
- or else Nkind (Parent (E)) = N_Component_Declaration
-
- -- An access to subprogram is also allowed
-
- or else
- (Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
-
- -- Allow internal call to set convention of subprogram type
-
- or else Ekind (E) = E_Subprogram_Type
- then
- null;
+ elsif Is_Dispatching_Operation (E)
+ and then C = Convention_Stdcall
+ then
+ -- Note: make this unconditional so that if there is more
+ -- than one call to which the pragma applies, we get a
+ -- message for each call. Also don't use Error_Pragma,
+ -- so that we get multiple messages.
- else
- Error_Pragma_Arg
- ("second argument of pragma% must be subprogram (type)",
- Arg2);
- end if;
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N
+ ("dispatching subprogram# cannot use Stdcall convention!",
+ Get_Pragma_Arg (Arg1));
end if;
-- Set the convention
@@ -8113,6 +8078,7 @@ package body Sem_Prag is
E : Entity_Id;
E1 : Entity_Id;
Id : Node_Id;
+ Subp : Entity_Id;
-- Start of processing for Process_Convention
@@ -8284,13 +8250,114 @@ package body Sem_Prag is
Error_Pragma_Arg
("second argument of pragma% must be a subprogram", Arg2);
end if;
+
+ -- Special checks for C_Variadic_n
+
+ elsif C in Convention_C_Variadic then
+
+ -- Several allowed cases
+
+ if Is_Subprogram_Or_Generic_Subprogram (E) then
+ Subp := E;
+
+ -- An access to subprogram is also allowed
+
+ elsif Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type
+ then
+ Subp := Designated_Type (E);
+
+ -- Allow internal call to set convention of subprogram type
+
+ elsif Ekind (E) = E_Subprogram_Type then
+ Subp := E;
+
+ else
+ Error_Pragma_Arg
+ ("argument of pragma% must be subprogram or access type",
+ Arg2);
+ Subp := Empty;
+ end if;
+
+ -- ISO C requires a named parameter before the ellipsis, so a
+ -- variadic C function taking 0 fixed parameter cannot exist.
+
+ if C = Convention_C_Variadic_0 then
+
+ Error_Msg_N
+ ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
+ Get_Pragma_Arg (Arg2));
+
+ -- Now check the number of parameters of the subprogram
+
+ elsif Present (Subp) then
+ declare
+ Minimum : constant Nat :=
+ Convention_Id'Pos (C) -
+ Convention_Id'Pos (Convention_C_Variadic_0);
+
+ Count : Nat;
+ Formal : Entity_Id;
+
+ begin
+ Count := 0;
+ Formal := First_Formal (Subp);
+ while Present (Formal) loop
+ Count := Count + 1;
+ Next_Formal (Formal);
+ end loop;
+
+ if Count < Minimum then
+ Error_Msg_Uint_1 := UI_From_Int (Minimum);
+ Error_Pragma_Arg
+ ("argument of pragma% must have at least"
+ & "^ parameters", Arg2);
+ end if;
+ end;
+ end if;
+
+ -- Special checks for Stdcall
+
+ elsif C = Convention_Stdcall then
+
+ -- Several allowed cases
+
+ if Is_Subprogram_Or_Generic_Subprogram (E)
+
+ -- A variable is OK
+
+ or else Ekind (E) = E_Variable
+
+ -- A component as well. The entity does not have its Ekind
+ -- set until the enclosing record declaration is fully
+ -- analyzed.
+
+ or else Nkind (Parent (E)) = N_Component_Declaration
+
+ -- An access to subprogram is also allowed
+
+ or else
+ (Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+
+ -- Allow internal call to set convention of subprogram type
+
+ or else Ekind (E) = E_Subprogram_Type
+ then
+ null;
+
+ else
+ Error_Pragma_Arg
+ ("argument of pragma% must be subprogram or access type",
+ Arg2);
+ end if;
end if;
+ Set_Convention_From_Pragma (E);
+
-- Deal with non-subprogram cases
if not Is_Subprogram_Or_Generic_Subprogram (E) then
- Set_Convention_From_Pragma (E);
-
if Is_Type (E) then
-- The pragma must apply to a first subtype, but it can also
@@ -8318,9 +8385,6 @@ package body Sem_Prag is
-- compilation unit.
else
- Comp_Unit := Get_Source_Unit (E);
- Set_Convention_From_Pragma (E);
-
-- Treat a pragma Import as an implicit body, and pragma import
-- as implicit reference (for navigation in GNAT Studio).
@@ -8365,6 +8429,7 @@ package body Sem_Prag is
-- Otherwise Loop through the homonyms of the pragma argument's
-- entity, an apply convention to those in the current scope.
+ Comp_Unit := Get_Source_Unit (E);
E1 := Ent;
loop
--- gcc/ada/snames.adb-tmpl
+++ gcc/ada/snames.adb-tmpl
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, 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- --
@@ -155,6 +155,23 @@ package body Snames is
Convention_Ada_Pass_By_Reference;
when Name_Assembler => return Convention_Assembler;
when Name_C => return Convention_C;
+ when Name_C_Variadic_0 => return Convention_C_Variadic_0;
+ when Name_C_Variadic_1 => return Convention_C_Variadic_1;
+ when Name_C_Variadic_2 => return Convention_C_Variadic_2;
+ when Name_C_Variadic_3 => return Convention_C_Variadic_3;
+ when Name_C_Variadic_4 => return Convention_C_Variadic_4;
+ when Name_C_Variadic_5 => return Convention_C_Variadic_5;
+ when Name_C_Variadic_6 => return Convention_C_Variadic_6;
+ when Name_C_Variadic_7 => return Convention_C_Variadic_7;
+ when Name_C_Variadic_8 => return Convention_C_Variadic_8;
+ when Name_C_Variadic_9 => return Convention_C_Variadic_9;
+ when Name_C_Variadic_10 => return Convention_C_Variadic_10;
+ when Name_C_Variadic_11 => return Convention_C_Variadic_11;
+ when Name_C_Variadic_12 => return Convention_C_Variadic_12;
+ when Name_C_Variadic_13 => return Convention_C_Variadic_13;
+ when Name_C_Variadic_14 => return Convention_C_Variadic_14;
+ when Name_C_Variadic_15 => return Convention_C_Variadic_15;
+ when Name_C_Variadic_16 => return Convention_C_Variadic_16;
when Name_COBOL => return Convention_COBOL;
when Name_CPP => return Convention_CPP;
when Name_Fortran => return Convention_Fortran;
@@ -189,6 +206,23 @@ package body Snames is
return Name_Ada_Pass_By_Reference;
when Convention_Assembler => return Name_Assembler;
when Convention_C => return Name_C;
+ when Convention_C_Variadic_0 => return Name_C_Variadic_0;
+ when Convention_C_Variadic_1 => return Name_C_Variadic_1;
+ when Convention_C_Variadic_2 => return Name_C_Variadic_2;
+ when Convention_C_Variadic_3 => return Name_C_Variadic_3;
+ when Convention_C_Variadic_4 => return Name_C_Variadic_4;
+ when Convention_C_Variadic_5 => return Name_C_Variadic_5;
+ when Convention_C_Variadic_6 => return Name_C_Variadic_6;
+ when Convention_C_Variadic_7 => return Name_C_Variadic_7;
+ when Convention_C_Variadic_8 => return Name_C_Variadic_8;
+ when Convention_C_Variadic_9 => return Name_C_Variadic_9;
+ when Convention_C_Variadic_10 => return Name_C_Variadic_10;
+ when Convention_C_Variadic_11 => return Name_C_Variadic_11;
+ when Convention_C_Variadic_12 => return Name_C_Variadic_12;
+ when Convention_C_Variadic_13 => return Name_C_Variadic_13;
+ when Convention_C_Variadic_14 => return Name_C_Variadic_14;
+ when Convention_C_Variadic_15 => return Name_C_Variadic_15;
+ when Convention_C_Variadic_16 => return Name_C_Variadic_16;
when Convention_COBOL => return Name_COBOL;
when Convention_CPP => return Name_CPP;
when Convention_Entry => return Name_Entry;
@@ -425,9 +459,9 @@ package body Snames is
return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
end Is_Locking_Policy_Name;
- -------------------------------------
- -- Is_Partition_Elaboration_Policy --
- -------------------------------------
+ ------------------------------------------
+ -- Is_Partition_Elaboration_Policy_Name --
+ ------------------------------------------
function Is_Partition_Elaboration_Policy_Name
(N : Name_Id) return Boolean
--- gcc/ada/snames.ads-tmpl
+++ gcc/ada/snames.ads-tmpl
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, 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- --
@@ -705,6 +705,23 @@ package Snames is
Name_Ada_Pass_By_Copy : constant Name_Id := N + $;
Name_Ada_Pass_By_Reference : constant Name_Id := N + $;
Name_Assembler : constant Name_Id := N + $;
+ Name_C_Variadic_0 : constant Name_Id := N + $;
+ Name_C_Variadic_1 : constant Name_Id := N + $;
+ Name_C_Variadic_2 : constant Name_Id := N + $;
+ Name_C_Variadic_3 : constant Name_Id := N + $;
+ Name_C_Variadic_4 : constant Name_Id := N + $;
+ Name_C_Variadic_5 : constant Name_Id := N + $;
+ Name_C_Variadic_6 : constant Name_Id := N + $;
+ Name_C_Variadic_7 : constant Name_Id := N + $;
+ Name_C_Variadic_8 : constant Name_Id := N + $;
+ Name_C_Variadic_9 : constant Name_Id := N + $;
+ Name_C_Variadic_10 : constant Name_Id := N + $;
+ Name_C_Variadic_11 : constant Name_Id := N + $;
+ Name_C_Variadic_12 : constant Name_Id := N + $;
+ Name_C_Variadic_13 : constant Name_Id := N + $;
+ Name_C_Variadic_14 : constant Name_Id := N + $;
+ Name_C_Variadic_15 : constant Name_Id := N + $;
+ Name_C_Variadic_16 : constant Name_Id := N + $;
Name_COBOL : constant Name_Id := N + $;
Name_CPP : constant Name_Id := N + $;
Name_Fortran : constant Name_Id := N + $;
@@ -713,6 +730,9 @@ package Snames is
Name_Stubbed : constant Name_Id := N + $;
Last_Convention_Name : constant Name_Id := N + $;
+ subtype Name_C_Variadic is Name_Id
+ range Name_C_Variadic_0 .. Name_C_Variadic_16;
+
-- The following names are preset as synonyms for Assembler
Name_Asm : constant Name_Id := N + $;
@@ -1166,14 +1186,14 @@ package Snames is
Name_Unsigned_32 : constant Name_Id := N + $; -- GNAT
Name_Unsigned_64 : constant Name_Id := N + $; -- GNAT
- subtype Scalar_Id is Name_Id range
- Name_Short_Float .. Name_Unsigned_64;
+ subtype Scalar_Id is Name_Id
+ range Name_Short_Float .. Name_Unsigned_64;
- subtype Float_Scalar_Id is Name_Id range
- Name_Short_Float .. Name_Long_Long_Float;
+ subtype Float_Scalar_Id is Name_Id
+ range Name_Short_Float .. Name_Long_Long_Float;
- subtype Integer_Scalar_Id is Name_Id range
- Name_Signed_8 .. Name_Unsigned_64;
+ subtype Integer_Scalar_Id is Name_Id
+ range Name_Signed_8 .. Name_Unsigned_64;
-- Names of recognized checks for pragma Suppress
@@ -1314,8 +1334,8 @@ package Snames is
Name_Tagged : constant Name_Id := N + $;
Last_95_Reserved_Word : constant Name_Id := N + $;
- subtype Ada_95_Reserved_Words is
- Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
+ subtype Ada_95_Reserved_Words is Name_Id
+ range First_95_Reserved_Word .. Last_95_Reserved_Word;
-- Miscellaneous names used in semantic checking
@@ -1526,8 +1546,8 @@ package Snames is
Name_Synchronized : constant Name_Id := N + $;
Last_2005_Reserved_Word : constant Name_Id := N + $;
- subtype Ada_2005_Reserved_Words is
- Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
+ subtype Ada_2005_Reserved_Words is Name_Id
+ range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
-- Ada 2012 reserved words
@@ -1535,8 +1555,8 @@ package Snames is
Name_Some : constant Name_Id := N + $;
Last_2012_Reserved_Word : constant Name_Id := N + $;
- subtype Ada_2012_Reserved_Words is
- Name_Id range First_2012_Reserved_Word .. Last_2012_Reserved_Word;
+ subtype Ada_2012_Reserved_Words is Name_Id
+ range First_2012_Reserved_Word .. Last_2012_Reserved_Word;
-- Mark last defined name for consistency check in Snames body
@@ -1546,11 +1566,11 @@ package Snames is
-- Subtypes Defining Name Categories --
---------------------------------------
- subtype Any_Operator_Name is Name_Id range
- First_Operator_Name .. Last_Operator_Name;
+ subtype Any_Operator_Name is Name_Id
+ range First_Operator_Name .. Last_Operator_Name;
- subtype Configuration_Pragma_Names is Name_Id range
- First_Pragma_Name .. Last_Configuration_Pragma_Name;
+ subtype Configuration_Pragma_Names is Name_Id
+ range First_Pragma_Name .. Last_Configuration_Pragma_Name;
------------------------------
-- Attribute ID Definitions --
@@ -1755,8 +1775,8 @@ package Snames is
Attribute_Dispatching_Domain,
Attribute_Interrupt_Priority);
- subtype Internal_Attribute_Id is Attribute_Id range
- Attribute_CPU .. Attribute_Interrupt_Priority;
+ subtype Internal_Attribute_Id is Attribute_Id
+ range Attribute_CPU .. Attribute_Interrupt_Priority;
type Attribute_Class_Array is array (Attribute_Id) of Boolean;
-- Type used to build attribute classification flag arrays
@@ -1784,12 +1804,29 @@ package Snames is
-- The remaining conventions are foreign language conventions
- Convention_Assembler, -- also Asm, Assembly
- Convention_C, -- also Default, External
- Convention_COBOL,
+ Convention_Assembler, -- also Asm, Assembly
+ Convention_C, -- also Default, External
+ Convention_C_Variadic_0,
+ Convention_C_Variadic_1,
+ Convention_C_Variadic_2,
+ Convention_C_Variadic_3,
+ Convention_C_Variadic_4,
+ Convention_C_Variadic_5,
+ Convention_C_Variadic_6,
+ Convention_C_Variadic_7,
+ Convention_C_Variadic_8,
+ Convention_C_Variadic_9,
+ Convention_C_Variadic_10,
+ Convention_C_Variadic_11,
+ Convention_C_Variadic_12,
+ Convention_C_Variadic_13,
+ Convention_C_Variadic_14,
+ Convention_C_Variadic_15,
+ Convention_C_Variadic_16,
Convention_CPP,
+ Convention_COBOL,
Convention_Fortran,
- Convention_Stdcall); -- also DLL, Win32
+ Convention_Stdcall); -- also DLL, Win32
-- Note: Convention C_Pass_By_Copy is allowed only for record types
-- (where it is treated like C except that the appropriate flag is set
@@ -1799,8 +1836,14 @@ package Snames is
for Convention_Id'Size use 8;
-- Plenty of space for expansion
- subtype Foreign_Convention is
- Convention_Id range Convention_Assembler .. Convention_Id'Last;
+ subtype Convention_C_Family is Convention_Id
+ range Convention_C .. Convention_CPP;
+
+ subtype Convention_C_Variadic is Convention_Id
+ range Convention_C_Variadic_0 .. Convention_C_Variadic_16;
+
+ subtype Foreign_Convention is Convention_Id
+ range Convention_Assembler .. Convention_Stdcall;
-----------------------------------
-- Locking Policy ID Definitions --
@@ -2226,13 +2269,17 @@ package Snames is
private
pragma Inline (Is_Attribute_Name);
+ pragma Inline (Is_Configuration_Pragma_Name);
pragma Inline (Is_Entity_Attribute_Name);
- pragma Inline (Is_Type_Attribute_Name);
+ pragma Inline (Is_Function_Attribute_Name);
+ pragma Inline (Is_Internal_Attribute_Name);
pragma Inline (Is_Locking_Policy_Name);
pragma Inline (Is_Partition_Elaboration_Policy_Name);
pragma Inline (Is_Operator_Symbol_Name);
- pragma Inline (Is_Queuing_Policy_Name);
pragma Inline (Is_Pragma_Name);
+ pragma Inline (Is_Procedure_Attribute_Name);
+ pragma Inline (Is_Queuing_Policy_Name);
pragma Inline (Is_Task_Dispatching_Policy_Name);
+ pragma Inline (Is_Type_Attribute_Name);
end Snames;
--- gcc/ada/types.h
+++ gcc/ada/types.h
@@ -139,10 +139,13 @@ typedef Text_Ptr Source_Ptr;
/* Used for Sloc in all nodes in the representation of package Standard. */
#define Standard_Location -2
-/* Instance identifiers */
+/* Convention identifiers. */
+typedef Byte Convention_Id;
+
+/* Instance identifiers. */
typedef Nat Instance_Id;
-/* Type used for union of all possible ID values covering all ranges */
+/* Type used for union of all possible ID values covering all ranges. */
typedef int Union_Id;
/* Range definitions for Tree Data: */
--- gcc/ada/xsnamest.adb
+++ gcc/ada/xsnamest.adb
@@ -58,6 +58,7 @@ procedure XSnamesT is
Line : VString := Nul;
Name0 : VString := Nul;
Name1 : VString := Nul;
+ Name2 : VString := Nul;
Oval : VString := Nul;
Restl : VString := Nul;
@@ -69,6 +70,7 @@ procedure XSnamesT is
Get_Name : constant Pattern := "Name_" & Rest * Name1;
Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
Findu : constant Pattern := Span ('u') * A;
+ Is_Conv : constant Pattern := "Convention_" & Rest;
Val : Natural;
@@ -98,12 +100,18 @@ procedure XSnamesT is
-- Patterns used in the spec file
- Get_Attr : constant Pattern := Span (' ') & "Attribute_"
- & Break (",)") * Name1;
- Get_Conv : constant Pattern := Span (' ') & "Convention_"
- & Break (",)") * Name1;
- Get_Prag : constant Pattern := Span (' ') & "Pragma_"
- & Break (",)") * Name1;
+ Get_Attr : constant Pattern := Span (' ') & "Attribute_"
+ & Break (",)") * Name1;
+ Get_Conv : constant Pattern := Span (' ') & "Convention_"
+ & Break (",)") * Name1;
+ Get_Prag : constant Pattern := Span (' ') & "Pragma_"
+ & Break (",)") * Name1;
+ Get_Subt1 : constant Pattern := Span (' ') & "subtype "
+ & Break (' ') * Name1
+ & " is " & Rest * Name2;
+ Get_Subt2 : constant Pattern := Span (' ') & "range "
+ & Break (' ') * Name1
+ & " .. " & Break (";") * Name2;
type Header_Symbol_Counter is array (Header_Symbol) of Natural;
Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0);
@@ -143,7 +151,6 @@ procedure XSnamesT is
if Header_Current_Symbol /= S then
declare
- Name2 : VString;
Pat : constant Pattern := "#define "
& Header_Prefix (S).all
& Break (' ') * Name2;
@@ -227,6 +234,11 @@ begin
Output_Header_Line (Conv);
elsif Match (Line, Get_Prag) then
Output_Header_Line (Prag);
+ elsif Match (Line, Get_Subt1) and then Match (Name2, Is_Conv) then
+ New_Line (OutH);
+ Put_Line (OutH, "SUBTYPE (" & Name1 & ", " & Name2 & ", ");
+ elsif Match (Line, Get_Subt2) and then Match (Name1, Is_Conv) then
+ Put_Line (OutH, " " & Name1 & ", " & Name2 & ')');
end if;
else
