-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- Make an entry in the names table for Nam, and set as Chars field of Id
function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id;
- -- Build entity for standard operator with given name and type.
+ -- Build entity for standard operator with given name and type
function New_Standard_Entity
(New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id;
Binary_Ops : constant array (S_Binary_Ops) of Name_Id :=
-- There is one entry here for each binary operator, except for the
- -- case of concatenation, where there are two entries, one for a
- -- String result, and one for a Wide_String result.
+ -- case of concatenation, where there are three entries, one for a
+ -- String result, one for Wide_String, and one for Wide_Wide_String.
(Name_Op_Add,
Name_Op_And,
Name_Op_Concat,
Name_Op_Concat,
+ Name_Op_Concat,
Name_Op_Divide,
Name_Op_Eq,
Name_Op_Expon,
-- This table has the corresponding result types. The entries are
-- ordered so they correspond to the Binary_Ops array above.
- (Universal_Integer, -- Add
- Standard_Boolean, -- And
- Standard_String, -- Concat (String)
- Standard_Wide_String, -- Concat (Wide_String)
- Universal_Integer, -- Divide
- Standard_Boolean, -- Eq
- Universal_Integer, -- Expon
- Standard_Boolean, -- Ge
- Standard_Boolean, -- Gt
- Standard_Boolean, -- Le
- Standard_Boolean, -- Lt
- Universal_Integer, -- Mod
- Universal_Integer, -- Multiply
- Standard_Boolean, -- Ne
- Standard_Boolean, -- Or
- Universal_Integer, -- Rem
- Universal_Integer, -- Subtract
- Standard_Boolean); -- Xor
+ (Universal_Integer, -- Add
+ Standard_Boolean, -- And
+ Standard_String, -- Concat (String)
+ Standard_Wide_String, -- Concat (Wide_String)
+ Standard_Wide_Wide_String, -- Concat (Wide_Wide_String)
+ Universal_Integer, -- Divide
+ Standard_Boolean, -- Eq
+ Universal_Integer, -- Expon
+ Standard_Boolean, -- Ge
+ Standard_Boolean, -- Gt
+ Standard_Boolean, -- Le
+ Standard_Boolean, -- Lt
+ Universal_Integer, -- Mod
+ Universal_Integer, -- Multiply
+ Standard_Boolean, -- Ne
+ Standard_Boolean, -- Or
+ Universal_Integer, -- Rem
+ Universal_Integer, -- Subtract
+ Standard_Boolean); -- Xor
Unary_Ops : constant array (S_Unary_Ops) of Name_Id :=
-- For concatenation, we create a separate operator for each
-- array type. This simplifies the resolution of the component-
-- component concatenation operation. In Standard, we set the types
- -- of the formals for string and wide string concatenation.
+ -- of the formals for string, wide [wide]_string, concatenations.
Set_Etype (First_Entity (Standard_Op_Concat), Standard_String);
Set_Etype (Last_Entity (Standard_Op_Concat), Standard_String);
Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String);
Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String);
+
+ Set_Etype (First_Entity (Standard_Op_Concatww),
+ Standard_Wide_Wide_String);
+
+ Set_Etype (Last_Entity (Standard_Op_Concatww),
+ Standard_Wide_Wide_String);
+
end Create_Operators;
---------------------
Set_Is_Pure (Standard_Standard);
Set_Is_Compilation_Unit (Standard_Standard);
- -- Create type declaration nodes for standard types
+ -- Create type/subtype declaration nodes for standard types
for S in S_Types loop
- Decl := New_Node (N_Full_Type_Declaration, Stloc);
- Set_Defining_Identifier (Decl, Standard_Entity (S));
+
+ -- Subtype declaration case
+
+ if S = S_Natural or else S = S_Positive then
+ Decl := New_Node (N_Subtype_Declaration, Stloc);
+ Set_Subtype_Indication (Decl,
+ New_Occurrence_Of (Standard_Integer, Stloc));
+
+ -- Full type declaration case
+
+ else
+ Decl := New_Node (N_Full_Type_Declaration, Stloc);
+ end if;
+
Set_Is_Frozen (Standard_Entity (S));
Set_Is_Public (Standard_Entity (S));
+ Set_Defining_Identifier (Decl, Standard_Entity (S));
Append (Decl, Decl_S);
end loop;
-- range False .. True
-- where the occurrences of the literals must point to the
- -- corresponding definition.
+ -- corresponding definition.
R_Node := New_Node (N_Range, Stloc);
B_Node := New_Node (N_Identifier, Stloc);
Set_Is_Known_Valid (Standard_Character);
Set_Size_Known_At_Compile_Time (Standard_Character);
- -- Create the bounds for type Character.
+ -- Create the bounds for type Character
R_Node := New_Node (N_Range, Stloc);
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
Set_Chars (B_Node, No_Name);
- Set_Char_Literal_Value (B_Node, 16#00#);
- Set_Entity (B_Node, Empty);
+ Set_Char_Literal_Value (B_Node, Uint_0);
+ Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Character);
Set_Low_Bound (R_Node, B_Node);
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
Set_Chars (B_Node, No_Name);
- Set_Char_Literal_Value (B_Node, 16#FF#);
- Set_Entity (B_Node, Empty);
+ Set_Char_Literal_Value (B_Node, UI_From_Int (16#FF#));
+ Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Character);
Set_High_Bound (R_Node, B_Node);
Set_Is_Known_Valid (Standard_Wide_Character);
Set_Size_Known_At_Compile_Time (Standard_Wide_Character);
- -- Create the bounds for type Wide_Character.
+ -- Create the bounds for type Wide_Character
R_Node := New_Node (N_Range, Stloc);
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
Set_Chars (B_Node, No_Name); -- ???
- Set_Char_Literal_Value (B_Node, 16#0000#);
- Set_Entity (B_Node, Empty);
+ Set_Char_Literal_Value (B_Node, Uint_0);
+ Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Wide_Character);
Set_Low_Bound (R_Node, B_Node);
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
Set_Chars (B_Node, No_Name); -- ???
- Set_Char_Literal_Value (B_Node, 16#FFFF#);
- Set_Entity (B_Node, Empty);
+ Set_Char_Literal_Value (B_Node, UI_From_Int (16#FFFF#));
+ Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Wide_Character);
Set_High_Bound (R_Node, B_Node);
Set_Etype (R_Node, Standard_Wide_Character);
Set_Parent (R_Node, Standard_Wide_Character);
+ -- Create type definition for type Wide_Wide_Character. Note that we
+ -- do not set the Literals field, since type Wide_Wide_Character is
+ -- handled with special routines that do not need a literal list.
+
+ Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
+ Set_Type_Definition (Parent (Standard_Wide_Wide_Character), Tdef_Node);
+
+ Set_Ekind (Standard_Wide_Wide_Character, E_Enumeration_Type);
+ Set_Etype (Standard_Wide_Wide_Character,
+ Standard_Wide_Wide_Character);
+ Init_Size (Standard_Wide_Wide_Character,
+ Standard_Wide_Wide_Character_Size);
+
+ Set_Elem_Alignment (Standard_Wide_Wide_Character);
+ Set_Is_Unsigned_Type (Standard_Wide_Wide_Character);
+ Set_Is_Character_Type (Standard_Wide_Wide_Character);
+ Set_Is_Known_Valid (Standard_Wide_Wide_Character);
+ Set_Size_Known_At_Compile_Time (Standard_Wide_Wide_Character);
+ Set_Is_Ada_2005_Only (Standard_Wide_Wide_Character);
+
+ -- Create the bounds for type Wide_Wide_Character
+
+ R_Node := New_Node (N_Range, Stloc);
+
+ -- Low bound for type Wide_Wide_Character
+
+ B_Node := New_Node (N_Character_Literal, Stloc);
+ Set_Is_Static_Expression (B_Node);
+ Set_Chars (B_Node, No_Name); -- ???
+ Set_Char_Literal_Value (B_Node, Uint_0);
+ Set_Entity (B_Node, Empty);
+ Set_Etype (B_Node, Standard_Wide_Wide_Character);
+ Set_Low_Bound (R_Node, B_Node);
+
+ -- High bound for type Wide_Wide_Character
+
+ B_Node := New_Node (N_Character_Literal, Stloc);
+ Set_Is_Static_Expression (B_Node);
+ Set_Chars (B_Node, No_Name); -- ???
+ Set_Char_Literal_Value (B_Node, UI_From_Int (16#7FFF_FFFF#));
+ Set_Entity (B_Node, Empty);
+ Set_Etype (B_Node, Standard_Wide_Wide_Character);
+ Set_High_Bound (R_Node, B_Node);
+
+ Set_Scalar_Range (Standard_Wide_Wide_Character, R_Node);
+ Set_Etype (R_Node, Standard_Wide_Wide_Character);
+ Set_Parent (R_Node, Standard_Wide_Wide_Character);
+
-- Create type definition node for type String
Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
CompDef_Node : Node_Id;
begin
CompDef_Node := New_Node (N_Component_Definition, Stloc);
- Set_Aliased_Present (CompDef_Node, False);
- Set_Access_Definition (CompDef_Node, Empty);
- Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character));
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node, Empty);
+ Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character));
Set_Component_Definition (Tdef_Node, CompDef_Node);
end;
Init_Size_Align (Standard_String);
Set_Alignment (Standard_String, Uint_1);
+ -- On targets where a storage unit is larger than a byte (such as AAMP),
+ -- pragma Pack has a real effect on the representation of type String,
+ -- and the type must be marked as having a nonstandard representation.
+
+ if System_Storage_Unit > Uint_8 then
+ Set_Has_Non_Standard_Rep (Standard_String);
+ Set_Has_Pragma_Pack (Standard_String);
+ end if;
+
-- Set index type of String
E_Id := First
-- Create type definition node for type Wide_String
Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
+
declare
CompDef_Node : Node_Id;
begin
Identifier_For (S_Wide_Character));
Set_Component_Definition (Tdef_Node, CompDef_Node);
end;
+
Set_Subtype_Marks (Tdef_Node, New_List);
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node);
Set_Entity (E_Id, Standard_Positive);
Set_Etype (E_Id, Standard_Positive);
- -- Create subtype declaration for Natural
+ -- Create type definition node for type Wide_Wide_String
- Decl := New_Node (N_Subtype_Declaration, Stloc);
- Set_Defining_Identifier (Decl, Standard_Natural);
- Set_Subtype_Indication (Decl,
- New_Occurrence_Of (Standard_Integer, Stloc));
- Append (Decl, Decl_S);
+ Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
+
+ declare
+ CompDef_Node : Node_Id;
+ begin
+ CompDef_Node := New_Node (N_Component_Definition, Stloc);
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node, Empty);
+ Set_Subtype_Indication (CompDef_Node,
+ Identifier_For (S_Wide_Wide_Character));
+ Set_Component_Definition (Tdef_Node, CompDef_Node);
+ end;
+
+ Set_Subtype_Marks (Tdef_Node, New_List);
+ Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
+ Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node);
+
+ Set_Ekind (Standard_Wide_Wide_String, E_String_Type);
+ Set_Etype (Standard_Wide_Wide_String,
+ Standard_Wide_Wide_String);
+ Set_Component_Type (Standard_Wide_Wide_String,
+ Standard_Wide_Wide_Character);
+ Set_Component_Size (Standard_Wide_Wide_String, Uint_32);
+ Init_Size_Align (Standard_Wide_Wide_String);
+ Set_Is_Ada_2005_Only (Standard_Wide_Wide_String);
+
+ -- Set index type of Wide_Wide_String
+
+ E_Id := First
+ (Subtype_Marks (Type_Definition (Parent (Standard_Wide_Wide_String))));
+ Set_First_Index (Standard_Wide_Wide_String, E_Id);
+ Set_Entity (E_Id, Standard_Positive);
+ Set_Etype (E_Id, Standard_Positive);
+
+ -- Setup entity for Naturalend Create_Standard;
Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype);
Set_Etype (Standard_Natural, Base_Type (Standard_Integer));
Lb => Uint_0,
Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
Set_Is_Constrained (Standard_Natural);
- Set_Is_Frozen (Standard_Natural);
- Set_Is_Public (Standard_Natural);
-
- -- Create subtype declaration for Positive
- Decl := New_Node (N_Subtype_Declaration, Stloc);
- Set_Defining_Identifier (Decl, Standard_Positive);
- Set_Subtype_Indication (Decl,
- New_Occurrence_Of (Standard_Integer, Stloc));
- Append (Decl, Decl_S);
+ -- Setup entity for Positive
Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype);
Set_Etype (Standard_Positive, Base_Type (Standard_Integer));
Lb => Uint_1,
Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
Set_Is_Constrained (Standard_Positive);
- Set_Is_Frozen (Standard_Positive);
- Set_Is_Public (Standard_Positive);
-- Create declaration for package ASCII
Set_Is_Static_Expression (Expr_Decl);
Set_Chars (Expr_Decl, No_Name);
Set_Etype (Expr_Decl, Standard_Character);
- Set_Char_Literal_Value (Expr_Decl, Ccode);
+ Set_Char_Literal_Value (Expr_Decl, UI_From_Int (Int (Ccode)));
end;
Append (Decl, Decl_A);
Set_Directly_Designated_Type (Standard_A_Char, Standard_Character);
Make_Name (Standard_A_Char, "access_character");
+ -- Standard_Debug_Renaming_Type is used for the special objects created
+ -- to encode the names occurring in renaming declarations for use by the
+ -- debugger (see exp_dbug.adb). The type is a zero-sized subtype of
+ -- Standard.Integer.
+
+ Standard_Debug_Renaming_Type := New_Standard_Entity;
+
+ Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype);
+ Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard);
+ Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer));
+ Init_Esize (Standard_Debug_Renaming_Type, 0);
+ Init_RM_Size (Standard_Debug_Renaming_Type, 0);
+ Set_Size_Known_At_Compile_Time (Standard_Debug_Renaming_Type);
+ Set_Integer_Bounds (Standard_Debug_Renaming_Type,
+ Typ => Base_Type (Standard_Debug_Renaming_Type),
+ Lb => Uint_1,
+ Hb => Uint_0);
+ Set_Is_Constrained (Standard_Debug_Renaming_Type);
+ Set_Has_Size_Clause (Standard_Debug_Renaming_Type);
+
+ Make_Name (Standard_Debug_Renaming_Type, "_renaming_type");
+
-- Note on type names. The type names for the following special types
-- are constructed so that they will look reasonable should they ever
-- appear in error messages etc, although in practice the use of the
Set_Ekind (Any_Id, E_Variable);
Set_Scope (Any_Id, Standard_Standard);
Set_Etype (Any_Id, Any_Type);
- Init_Size_Align (Any_Id);
+ Init_Esize (Any_Id);
+ Init_Alignment (Any_Id);
Make_Name (Any_Id, "any id");
Any_Access := New_Standard_Entity;
Set_Is_Unsigned_Type (Standard_Unsigned);
Set_Size_Known_At_Compile_Time
(Standard_Unsigned);
+ Set_Is_Known_Valid (Standard_Unsigned, True);
R_Node := New_Node (N_Range, Stloc);
Set_Low_Bound (R_Node, Make_Integer (Uint_0));
(Standard_Exception_Type, True);
Make_Name (Standard_Exception_Type, "exception");
- Make_Component (Standard_Exception_Type, Standard_Boolean,
- "Not_Handled_By_Others");
- Make_Component (Standard_Exception_Type, Standard_Character, "Lang");
- Make_Component (Standard_Exception_Type, Standard_Natural,
- "Name_Length");
- Make_Component (Standard_Exception_Type, Standard_A_Char,
- "Full_Name");
- Make_Component (Standard_Exception_Type, Standard_A_Char,
- "HTable_Ptr");
- Make_Component (Standard_Exception_Type, Standard_Unsigned,
- "Import_Code");
- Make_Component (Standard_Exception_Type, Standard_A_Char,
- "Raise_Hook");
- -- Build tree for record declaration, for use by the back-end.
+ Make_Component
+ (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others");
+ Make_Component
+ (Standard_Exception_Type, Standard_Character, "Lang");
+ Make_Component
+ (Standard_Exception_Type, Standard_Natural, "Name_Length");
+ Make_Component
+ (Standard_Exception_Type, Standard_A_Char, "Full_Name");
+ Make_Component
+ (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr");
+ Make_Component
+ (Standard_Exception_Type, Standard_Unsigned, "Import_Code");
+ Make_Component
+ (Standard_Exception_Type, Standard_A_Char, "Raise_Hook");
+
+ -- Build tree for record declaration, for use by the back-end
declare
Comp_List : List_Id;
begin
Comp := First_Entity (Standard_Exception_Type);
Comp_List := New_List;
-
while Present (Comp) loop
Append (
Make_Component_Declaration (Stloc,
function Identifier_For (S : Standard_Entity_Type) return Node_Id is
Ident_Node : Node_Id;
-
begin
Ident_Node := New_Node (N_Identifier, Stloc);
Set_Chars (Ident_Node, Chars (Standard_Entity (S)));
Write_Eol;
P ("package Standard is");
- P ("pragma Pure(Standard);");
+ P ("pragma Pure (Standard);");
Write_Eol;
P (" type Boolean is (False, True);");
P (" -- See RM A.1(36) for details of this type");
Write_Eol;
+ P (" type Wide_Wide_Character is (...)");
+ Write_Str (" for Wide_Wide_Character'Size use ");
+ Write_Int (Standard_Wide_Wide_Character_Size);
+ P (";");
+ P (" -- See RM A.1(36) for details of this type");
+
P (" type String is array (Positive range <>) of Character;");
P (" pragma Pack (String);");
Write_Eol;
P (" pragma Pack (Wide_String);");
Write_Eol;
+ P (" type Wide_Wide_String is array (Positive range <>)" &
+ " of Wide_Wide_Character;");
+ P (" pragma Pack (Wide_Wide_String);");
+ Write_Eol;
+
-- Here it's OK to use the Duration type of the host compiler since
-- the implementation of Duration in GNAT is target independent.